trans-array.cc source code [gcc/fortran/trans-array.cc]

1	/ Array translation routines*
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-array.cc-- Various array related code, including scalarization,*
23	allocation, initialization and other support routines. /*
24
25	/ How the scalarizer works.*
26	In gfortran, array expressions use the same core routines as scalar
27	expressions.
28	First, a Scalarization State (SS) chain is built. This is done by walking
29	the expression tree, and building a linear list of the terms in the
30	expression. As the tree is walked, scalar subexpressions are translated.
31
32	The scalarization parameters are stored in a gfc_loopinfo structure.
33	First the start and stride of each term is calculated by
34	gfc_conv_ss_startstride. During this process the expressions for the array
35	descriptors and data pointers are also translated.
36
37	If the expression is an assignment, we must then resolve any dependencies.
38	In Fortran all the rhs values of an assignment must be evaluated before
39	any assignments take place. This can require a temporary array to store the
40	values. We also require a temporary when we are passing array expressions
41	or vector subscripts as procedure parameters.
42
43	Array sections are passed without copying to a temporary. These use the
44	scalarizer to determine the shape of the section. The flag
45	loop->array_parameter tells the scalarizer that the actual values and loop
46	variables will not be required.
47
48	The function gfc_conv_loop_setup generates the scalarization setup code.
49	It determines the range of the scalarizing loop variables. If a temporary
50	is required, this is created and initialized. Code for scalar expressions
51	taken outside the loop is also generated at this time. Next the offset and
52	scaling required to translate from loop variables to array indices for each
53	term is calculated.
54
55	A call to gfc_start_scalarized_body marks the start of the scalarized
56	expression. This creates a scope and declares the loop variables. Before
57	calling this gfc_make_ss_chain_used must be used to indicate which terms
58	will be used inside this loop.
59
60	The scalar gfc_conv_ functions are then used to build the main body of the*
61	scalarization loop. Scalarization loop variables and precalculated scalar
62	values are automatically substituted. Note that gfc_advance_se_ss_chain
63	must be used, rather than changing the se->ss directly.
64
65	For assignment expressions requiring a temporary two sub loops are
66	generated. The first stores the result of the expression in the temporary,
67	the second copies it to the result. A call to
68	gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
69	the start of the copying loop. The temporary may be less than full rank.
70
71	Finally gfc_trans_scalarizing_loops is called to generate the implicit do
72	loops. The loops are added to the pre chain of the loopinfo. The post
73	chain may still contain cleanup code.
74
75	After the loop code has been added into its parent scope gfc_cleanup_loop
76	is called to free all the SS allocated by the scalarizer. /*
77
78	#include "config.h"
79	#include "system.h"
80	#include "coretypes.h"
81	#include "options.h"
82	#include "tree.h"
83	#include "gfortran.h"
84	#include "gimple-expr.h"
85	#include "tree-iterator.h"
86	#include "stringpool.h" /* Required by "attribs.h". */
87	#include "attribs.h" /* For lookup_attribute. */
88	#include "trans.h"
89	#include "fold-const.h"
90	#include "constructor.h"
91	#include "trans-types.h"
92	#include "trans-array.h"
93	#include "trans-const.h"
94	#include "dependency.h"
95
96	static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
97
98	/ The contents of this structure aren't actually used, just the address. /
99	static gfc_ss gfc_ss_terminator_var;
100	gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
101
102
103	static tree
104	gfc_array_dataptr_type (tree desc)
105	{
106	return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
107	}
108
109	/ Build expressions to access members of the CFI descriptor. /
110	#define CFI_FIELD_BASE_ADDR 0
111	#define CFI_FIELD_ELEM_LEN 1
112	#define CFI_FIELD_VERSION 2
113	#define CFI_FIELD_RANK 3
114	#define CFI_FIELD_ATTRIBUTE 4
115	#define CFI_FIELD_TYPE 5
116	#define CFI_FIELD_DIM 6
117
118	#define CFI_DIM_FIELD_LOWER_BOUND 0
119	#define CFI_DIM_FIELD_EXTENT 1
120	#define CFI_DIM_FIELD_SM 2
121
122	static tree
123	gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
124	{
125	tree type = TREE_TYPE (desc);
126	gcc_assert (TREE_CODE (type) == RECORD_TYPE
127	&& TYPE_FIELDS (type)
128	&& (strcmp ("base_addr",
129	IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
130	== `0`));
131	tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
132	gcc_assert (field != NULL_TREE);
133
134	return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
135	desc, field, NULL_TREE);
136	}
137
138	tree
139	gfc_get_cfi_desc_base_addr (tree desc)
140	{
141	return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
142	}
143
144	tree
145	gfc_get_cfi_desc_elem_len (tree desc)
146	{
147	return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
148	}
149
150	tree
151	gfc_get_cfi_desc_version (tree desc)
152	{
153	return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
154	}
155
156	tree
157	gfc_get_cfi_desc_rank (tree desc)
158	{
159	return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
160	}
161
162	tree
163	gfc_get_cfi_desc_type (tree desc)
164	{
165	return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
166	}
167
168	tree
169	gfc_get_cfi_desc_attribute (tree desc)
170	{
171	return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
172	}
173
174	static tree
175	gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
176	{
177	tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
178	tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, non_negative_offset: true);
179	tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
180	gcc_assert (field != NULL_TREE);
181	return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
182	tmp, field, NULL_TREE);
183	}
184
185	tree
186	gfc_get_cfi_dim_lbound (tree desc, tree idx)
187	{
188	return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
189	}
190
191	tree
192	gfc_get_cfi_dim_extent (tree desc, tree idx)
193	{
194	return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
195	}
196
197	tree
198	gfc_get_cfi_dim_sm (tree desc, tree idx)
199	{
200	return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
201	}
202
203	#undef CFI_FIELD_BASE_ADDR
204	#undef CFI_FIELD_ELEM_LEN
205	#undef CFI_FIELD_VERSION
206	#undef CFI_FIELD_RANK
207	#undef CFI_FIELD_ATTRIBUTE
208	#undef CFI_FIELD_TYPE
209	#undef CFI_FIELD_DIM
210
211	#undef CFI_DIM_FIELD_LOWER_BOUND
212	#undef CFI_DIM_FIELD_EXTENT
213	#undef CFI_DIM_FIELD_SM
214
215	/ Build expressions to access the members of an array descriptor.*
216	It's surprisingly easy to mess up here, so never access
217	an array descriptor by "brute force", always use these
218	functions. This also avoids problems if we change the format
219	of an array descriptor.
220
221	To understand these magic numbers, look at the comments
222	before gfc_build_array_type() in trans-types.cc.
223
224	The code within these defines should be the only code which knows the format
225	of an array descriptor.
226
227	Any code just needing to read obtain the bounds of an array should use
228	gfc_conv_array_ rather than the following functions as these will return*
229	know constant values, and work with arrays which do not have descriptors.
230
231	Don't forget to #undef these! /*
232
233	#define DATA_FIELD 0
234	#define OFFSET_FIELD 1
235	#define DTYPE_FIELD 2
236	#define SPAN_FIELD 3
237	#define DIMENSION_FIELD 4
238	#define CAF_TOKEN_FIELD 5
239
240	#define STRIDE_SUBFIELD 0
241	#define LBOUND_SUBFIELD 1
242	#define UBOUND_SUBFIELD 2
243
244	static tree
245	gfc_get_descriptor_field (tree desc, unsigned field_idx)
246	{
247	tree type = TREE_TYPE (desc);
248	gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
249
250	tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
251	gcc_assert (field != NULL_TREE);
252
253	return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
254	desc, field, NULL_TREE);
255	}
256
257	/ This provides READ-ONLY access to the data field. The field itself*
258	doesn't have the proper type. /*
259
260	tree
261	gfc_conv_descriptor_data_get (tree desc)
262	{
263	tree type = TREE_TYPE (desc);
264	if (TREE_CODE (type) == REFERENCE_TYPE)
265	gcc_unreachable ();
266
267	tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
268	return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
269	}
270
271	/ This provides WRITE access to the data field.*
272
273	TUPLES_P is true if we are generating tuples.
274
275	This function gets called through the following macros:
276	gfc_conv_descriptor_data_set
277	gfc_conv_descriptor_data_set. /*
278
279	void
280	gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
281	{
282	tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
283	gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
284	}
285
286
287	/ This provides address access to the data field. This should only be*
288	used by array allocation, passing this on to the runtime. /*
289
290	tree
291	gfc_conv_descriptor_data_addr (tree desc)
292	{
293	tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
294	return gfc_build_addr_expr (NULL_TREE, field);
295	}
296
297	static tree
298	gfc_conv_descriptor_offset (tree desc)
299	{
300	tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
301	gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
302	return field;
303	}
304
305	tree
306	gfc_conv_descriptor_offset_get (tree desc)
307	{
308	return gfc_conv_descriptor_offset (desc);
309	}
310
311	void
312	gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
313	tree value)
314	{
315	tree t = gfc_conv_descriptor_offset (desc);
316	gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
317	}
318
319
320	tree
321	gfc_conv_descriptor_dtype (tree desc)
322	{
323	tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
324	gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
325	return field;
326	}
327
328	static tree
329	gfc_conv_descriptor_span (tree desc)
330	{
331	tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
332	gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
333	return field;
334	}
335
336	tree
337	gfc_conv_descriptor_span_get (tree desc)
338	{
339	return gfc_conv_descriptor_span (desc);
340	}
341
342	void
343	gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
344	tree value)
345	{
346	tree t = gfc_conv_descriptor_span (desc);
347	gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
348	}
349
350
351	tree
352	gfc_conv_descriptor_rank (tree desc)
353	{
354	tree tmp;
355	tree dtype;
356
357	dtype = gfc_conv_descriptor_dtype (desc);
358	tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
359	gcc_assert (tmp != NULL_TREE
360	&& TREE_TYPE (tmp) == signed_char_type_node);
361	return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
362	dtype, tmp, NULL_TREE);
363	}
364
365
366	/ Return the element length from the descriptor dtype field. /
367
368	tree
369	gfc_conv_descriptor_elem_len (tree desc)
370	{
371	tree tmp;
372	tree dtype;
373
374	dtype = gfc_conv_descriptor_dtype (desc);
375	tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
376	GFC_DTYPE_ELEM_LEN);
377	gcc_assert (tmp != NULL_TREE
378	&& TREE_TYPE (tmp) == size_type_node);
379	return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
380	dtype, tmp, NULL_TREE);
381	}
382
383
384	tree
385	gfc_conv_descriptor_attribute (tree desc)
386	{
387	tree tmp;
388	tree dtype;
389
390	dtype = gfc_conv_descriptor_dtype (desc);
391	tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
392	GFC_DTYPE_ATTRIBUTE);
393	gcc_assert (tmp!= NULL_TREE
394	&& TREE_TYPE (tmp) == short_integer_type_node);
395	return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
396	dtype, tmp, NULL_TREE);
397	}
398
399	tree
400	gfc_conv_descriptor_type (tree desc)
401	{
402	tree tmp;
403	tree dtype;
404
405	dtype = gfc_conv_descriptor_dtype (desc);
406	tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
407	gcc_assert (tmp!= NULL_TREE
408	&& TREE_TYPE (tmp) == signed_char_type_node);
409	return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
410	dtype, tmp, NULL_TREE);
411	}
412
413	tree
414	gfc_get_descriptor_dimension (tree desc)
415	{
416	tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
417	gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
418	&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
419	return field;
420	}
421
422
423	static tree
424	gfc_conv_descriptor_dimension (tree desc, tree dim)
425	{
426	tree tmp;
427
428	tmp = gfc_get_descriptor_dimension (desc);
429
430	return gfc_build_array_ref (tmp, dim, NULL_TREE, non_negative_offset: true);
431	}
432
433
434	tree
435	gfc_conv_descriptor_token (tree desc)
436	{
437	gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
438	tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
439	/ Should be a restricted pointer - except in the finalization wrapper. /
440	gcc_assert (TREE_TYPE (field) == prvoid_type_node
441	\|\| TREE_TYPE (field) == pvoid_type_node);
442	return field;
443	}
444
445	static tree
446	gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
447	{
448	tree tmp = gfc_conv_descriptor_dimension (desc, dim);
449	tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
450	gcc_assert (field != NULL_TREE);
451
452	return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
453	tmp, field, NULL_TREE);
454	}
455
456	static tree
457	gfc_conv_descriptor_stride (tree desc, tree dim)
458	{
459	tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
460	gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
461	return field;
462	}
463
464	tree
465	gfc_conv_descriptor_stride_get (tree desc, tree dim)
466	{
467	tree type = TREE_TYPE (desc);
468	gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
469	if (integer_zerop (dim)
470	&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
471	\|\|GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
472	\|\|GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
473	\|\|GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
474	return gfc_index_one_node;
475
476	return gfc_conv_descriptor_stride (desc, dim);
477	}
478
479	void
480	gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
481	tree dim, tree value)
482	{
483	tree t = gfc_conv_descriptor_stride (desc, dim);
484	gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
485	}
486
487	static tree
488	gfc_conv_descriptor_lbound (tree desc, tree dim)
489	{
490	tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
491	gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
492	return field;
493	}
494
495	tree
496	gfc_conv_descriptor_lbound_get (tree desc, tree dim)
497	{
498	return gfc_conv_descriptor_lbound (desc, dim);
499	}
500
501	void
502	gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
503	tree dim, tree value)
504	{
505	tree t = gfc_conv_descriptor_lbound (desc, dim);
506	gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
507	}
508
509	static tree
510	gfc_conv_descriptor_ubound (tree desc, tree dim)
511	{
512	tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
513	gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
514	return field;
515	}
516
517	tree
518	gfc_conv_descriptor_ubound_get (tree desc, tree dim)
519	{
520	return gfc_conv_descriptor_ubound (desc, dim);
521	}
522
523	void
524	gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
525	tree dim, tree value)
526	{
527	tree t = gfc_conv_descriptor_ubound (desc, dim);
528	gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
529	}
530
531	/ Build a null array descriptor constructor. /
532
533	tree
534	gfc_build_null_descriptor (tree type)
535	{
536	tree field;
537	tree tmp;
538
539	gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
540	gcc_assert (DATA_FIELD == `0`);
541	field = TYPE_FIELDS (type);
542
543	/ Set a NULL data pointer. /
544	tmp = build_constructor_single (type, field, null_pointer_node);
545	TREE_CONSTANT (tmp) = `1`;
546	/ All other fields are ignored. /
547
548	return tmp;
549	}
550
551
552	/ Modify a descriptor such that the lbound of a given dimension is the value*
553	specified. This also updates ubound and offset accordingly. /*
554
555	void
556	gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
557	int dim, tree new_lbound)
558	{
559	tree offs, ubound, lbound, stride;
560	tree diff, offs_diff;
561
562	new_lbound = fold_convert (gfc_array_index_type, new_lbound);
563
564	offs = gfc_conv_descriptor_offset_get (desc);
565	lbound = gfc_conv_descriptor_lbound_get (desc, dim: gfc_rank_cst[dim]);
566	ubound = gfc_conv_descriptor_ubound_get (desc, dim: gfc_rank_cst[dim]);
567	stride = gfc_conv_descriptor_stride_get (desc, dim: gfc_rank_cst[dim]);
568
569	/ Get difference (new - old) by which to shift stuff. /
570	diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
571	new_lbound, lbound);
572
573	/ Shift ubound and offset accordingly. This has to be done before*
574	updating the lbound, as they depend on the lbound expression! /*
575	ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
576	ubound, diff);
577	gfc_conv_descriptor_ubound_set (block, desc, dim: gfc_rank_cst[dim], value: ubound);
578	offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
579	diff, stride);
580	offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
581	offs, offs_diff);
582	gfc_conv_descriptor_offset_set (block, desc, value: offs);
583
584	/ Finally set lbound to value we want. /
585	gfc_conv_descriptor_lbound_set (block, desc, dim: gfc_rank_cst[dim], value: new_lbound);
586	}
587
588
589	/ Obtain offsets for trans-types.cc(gfc_get_array_descr_info). /
590
591	void
592	gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
593	tree dtype_off, tree span_off,
594	tree dim_off, tree dim_size,
595	tree stride_suboff, tree lower_suboff,
596	tree *upper_suboff)
597	{
598	tree field;
599	tree type;
600
601	type = TYPE_MAIN_VARIANT (desc_type);
602	field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
603	*data_off = byte_position (field);
604	field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
605	*dtype_off = byte_position (field);
606	field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
607	*span_off = byte_position (field);
608	field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
609	*dim_off = byte_position (field);
610	type = TREE_TYPE (TREE_TYPE (field));
611	*dim_size = TYPE_SIZE_UNIT (type);
612	field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
613	*stride_suboff = byte_position (field);
614	field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
615	*lower_suboff = byte_position (field);
616	field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
617	*upper_suboff = byte_position (field);
618	}
619
620
621	/ Cleanup those #defines. /
622
623	#undef DATA_FIELD
624	#undef OFFSET_FIELD
625	#undef DTYPE_FIELD
626	#undef SPAN_FIELD
627	#undef DIMENSION_FIELD
628	#undef CAF_TOKEN_FIELD
629	#undef STRIDE_SUBFIELD
630	#undef LBOUND_SUBFIELD
631	#undef UBOUND_SUBFIELD
632
633
634	/ Mark a SS chain as used. Flags specifies in which loops the SS is used.*
635	flags & 1 = Main loop body.
636	flags & 2 = temp copy loop. /*
637
638	void
639	gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
640	{
641	for (; ss != gfc_ss_terminator; ss = ss->next)
642	ss->info->useflags = flags;
643	}
644
645
646	/ Free a gfc_ss chain. /
647
648	void
649	gfc_free_ss_chain (gfc_ss * ss)
650	{
651	gfc_ss *next;
652
653	while (ss != gfc_ss_terminator)
654	{
655	gcc_assert (ss != NULL);
656	next = ss->next;
657	gfc_free_ss (ss);
658	ss = next;
659	}
660	}
661
662
663	static void
664	free_ss_info (gfc_ss_info *ss_info)
665	{
666	int n;
667
668	ss_info->refcount--;
669	if (ss_info->refcount > `0`)
670	return;
671
672	gcc_assert (ss_info->refcount == `0`);
673
674	switch (ss_info->type)
675	{
676	case GFC_SS_SECTION:
677	for (n = `0`; n < GFC_MAX_DIMENSIONS; n++)
678	if (ss_info->data.array.subscript[n])
679	gfc_free_ss_chain (ss: ss_info->data.array.subscript[n]);
680	break;
681
682	default:
683	break;
684	}
685
686	free (ptr: ss_info);
687	}
688
689
690	/ Free a SS. /
691
692	void
693	gfc_free_ss (gfc_ss * ss)
694	{
695	free_ss_info (ss_info: ss->info);
696	free (ptr: ss);
697	}
698
699
700	/ Creates and initializes an array type gfc_ss struct. /
701
702	gfc_ss *
703	gfc_get_array_ss (gfc_ss next, gfc_expr expr, int dimen, gfc_ss_type type)
704	{
705	gfc_ss *ss;
706	gfc_ss_info *ss_info;
707	int i;
708
709	ss_info = gfc_get_ss_info ();
710	ss_info->refcount++;
711	ss_info->type = type;
712	ss_info->expr = expr;
713
714	ss = gfc_get_ss ();
715	ss->info = ss_info;
716	ss->next = next;
717	ss->dimen = dimen;
718	for (i = `0`; i < ss->dimen; i++)
719	ss->dim[i] = i;
720
721	return ss;
722	}
723
724
725	/ Creates and initializes a temporary type gfc_ss struct. /
726
727	gfc_ss *
728	gfc_get_temp_ss (tree type, tree string_length, int dimen)
729	{
730	gfc_ss *ss;
731	gfc_ss_info *ss_info;
732	int i;
733
734	ss_info = gfc_get_ss_info ();
735	ss_info->refcount++;
736	ss_info->type = GFC_SS_TEMP;
737	ss_info->string_length = string_length;
738	ss_info->data.temp.type = type;
739
740	ss = gfc_get_ss ();
741	ss->info = ss_info;
742	ss->next = gfc_ss_terminator;
743	ss->dimen = dimen;
744	for (i = `0`; i < ss->dimen; i++)
745	ss->dim[i] = i;
746
747	return ss;
748	}
749
750
751	/ Creates and initializes a scalar type gfc_ss struct. /
752
753	gfc_ss *
754	gfc_get_scalar_ss (gfc_ss next, gfc_expr expr)
755	{
756	gfc_ss *ss;
757	gfc_ss_info *ss_info;
758
759	ss_info = gfc_get_ss_info ();
760	ss_info->refcount++;
761	ss_info->type = GFC_SS_SCALAR;
762	ss_info->expr = expr;
763
764	ss = gfc_get_ss ();
765	ss->info = ss_info;
766	ss->next = next;
767
768	return ss;
769	}
770
771
772	/ Free all the SS associated with a loop. /
773
774	void
775	gfc_cleanup_loop (gfc_loopinfo * loop)
776	{
777	gfc_loopinfo loop_next, *ploop;
778	gfc_ss *ss;
779	gfc_ss *next;
780
781	ss = loop->ss;
782	while (ss != gfc_ss_terminator)
783	{
784	gcc_assert (ss != NULL);
785	next = ss->loop_chain;
786	gfc_free_ss (ss);
787	ss = next;
788	}
789
790	/ Remove reference to self in the parent loop. /
791	if (loop->parent)
792	for (ploop = &loop->parent->nested; ploop; ploop = &(ploop)->next)
793	if (*ploop == loop)
794	{
795	*ploop = loop->next;
796	break;
797	}
798
799	/ Free non-freed nested loops. /
800	for (loop = loop->nested; loop; loop = loop_next)
801	{
802	loop_next = loop->next;
803	gfc_cleanup_loop (loop);
804	free (ptr: loop);
805	}
806	}
807
808
809	static void
810	set_ss_loop (gfc_ss ss, gfc_loopinfo loop)
811	{
812	int n;
813
814	for (; ss != gfc_ss_terminator; ss = ss->next)
815	{
816	ss->loop = loop;
817
818	if (ss->info->type == GFC_SS_SCALAR
819	\|\| ss->info->type == GFC_SS_REFERENCE
820	\|\| ss->info->type == GFC_SS_TEMP)
821	continue;
822
823	for (n = `0`; n < GFC_MAX_DIMENSIONS; n++)
824	if (ss->info->data.array.subscript[n] != NULL)
825	set_ss_loop (ss: ss->info->data.array.subscript[n], loop);
826	}
827	}
828
829
830	/ Associate a SS chain with a loop. /
831
832	void
833	gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
834	{
835	gfc_ss *ss;
836	gfc_loopinfo *nested_loop;
837
838	if (head == gfc_ss_terminator)
839	return;
840
841	set_ss_loop (ss: head, loop);
842
843	ss = head;
844	for (; ss && ss != gfc_ss_terminator; ss = ss->next)
845	{
846	if (ss->nested_ss)
847	{
848	nested_loop = ss->nested_ss->loop;
849
850	/ More than one ss can belong to the same loop. Hence, we add the*
851	loop to the chain only if it is different from the previously
852	added one, to avoid duplicate nested loops. /*
853	if (nested_loop != loop->nested)
854	{
855	gcc_assert (nested_loop->parent == NULL);
856	nested_loop->parent = loop;
857
858	gcc_assert (nested_loop->next == NULL);
859	nested_loop->next = loop->nested;
860	loop->nested = nested_loop;
861	}
862	else
863	gcc_assert (nested_loop->parent == loop);
864	}
865
866	if (ss->next == gfc_ss_terminator)
867	ss->loop_chain = loop->ss;
868	else
869	ss->loop_chain = ss->next;
870	}
871	gcc_assert (ss == gfc_ss_terminator);
872	loop->ss = head;
873	}
874
875
876	/ Returns true if the expression is an array pointer. /
877
878	static bool
879	is_pointer_array (tree expr)
880	{
881	if (expr == NULL_TREE
882	\|\| !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
883	\|\| GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
884	return false;
885
886	if (VAR_P (expr)
887	&& GFC_DECL_PTR_ARRAY_P (expr))
888	return true;
889
890	if (TREE_CODE (expr) == PARM_DECL
891	&& GFC_DECL_PTR_ARRAY_P (expr))
892	return true;
893
894	if (INDIRECT_REF_P (expr)
895	&& GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, `0`)))
896	return true;
897
898	/ The field declaration is marked as an pointer array. /
899	if (TREE_CODE (expr) == COMPONENT_REF
900	&& GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, `1`))
901	&& !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, `1`))))
902	return true;
903
904	return false;
905	}
906
907
908	/ If the symbol or expression reference a CFI descriptor, return the*
909	pointer to the converted gfc descriptor. If an array reference is
910	present as the last argument, check that it is the one applied to
911	the CFI descriptor in the expression. Note that the CFI object is
912	always the symbol in the expression! /*
913
914	static bool
915	get_CFI_desc (gfc_symbol sym, gfc_expr expr,
916	tree desc, gfc_array_ref ar)
917	{
918	tree tmp;
919
920	if (!is_CFI_desc (sym, expr))
921	return false;
922
923	if (expr && ar)
924	{
925	if (!(expr->ref && expr->ref->type == REF_ARRAY)
926	\|\| (&expr->ref->u.ar != ar))
927	return false;
928	}
929
930	if (sym == NULL)
931	tmp = expr->symtree->n.sym->backend_decl;
932	else
933	tmp = sym->backend_decl;
934
935	if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
936	tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
937
938	*desc = tmp;
939	return true;
940	}
941
942
943	/ Return the span of an array. /
944
945	tree
946	gfc_get_array_span (tree desc, gfc_expr *expr)
947	{
948	tree tmp;
949
950	if (is_pointer_array (expr: desc)
951	\|\| (get_CFI_desc (NULL, expr, desc: &desc, NULL)
952	&& (POINTER_TYPE_P (TREE_TYPE (desc))
953	? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
954	: GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
955	{
956	if (POINTER_TYPE_P (TREE_TYPE (desc)))
957	desc = build_fold_indirect_ref_loc (input_location, desc);
958
959	/ This will have the span field set. /
960	tmp = gfc_conv_descriptor_span_get (desc);
961	}
962	else if (expr->ts.type == BT_ASSUMED)
963	{
964	if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
965	desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
966	if (POINTER_TYPE_P (TREE_TYPE (desc)))
967	desc = build_fold_indirect_ref_loc (input_location, desc);
968	tmp = gfc_conv_descriptor_span_get (desc);
969	}
970	else if (TREE_CODE (desc) == COMPONENT_REF
971	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
972	&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, `0`))))
973	{
974	/ The descriptor is a class _data field and so use the vtable*
975	size for the receiving span field. /*
976	tmp = gfc_get_vptr_from_expr (desc);
977	tmp = gfc_vptr_size_get (tmp);
978	}
979	else if (expr && expr->expr_type == EXPR_VARIABLE
980	&& expr->symtree->n.sym->ts.type == BT_CLASS
981	&& expr->ref->type == REF_COMPONENT
982	&& expr->ref->next->type == REF_ARRAY
983	&& expr->ref->next->next == NULL
984	&& CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
985	{
986	/ Dummys come in sometimes with the descriptor detached from*
987	the class field or declaration. /*
988	tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
989	tmp = gfc_vptr_size_get (tmp);
990	}
991	else
992	{
993	/ If none of the fancy stuff works, the span is the element*
994	size of the array. Attempt to deal with unbounded character
995	types if possible. Otherwise, return NULL_TREE. /*
996	tmp = gfc_get_element_type (TREE_TYPE (desc));
997	if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
998	{
999	gcc_assert (expr->ts.type == BT_CHARACTER);
1000
1001	tmp = gfc_get_character_len_in_bytes (tmp);
1002
1003	if (tmp == NULL_TREE \|\| integer_zerop (tmp))
1004	{
1005	tree bs;
1006
1007	tmp = gfc_get_expr_charlen (expr);
1008	tmp = fold_convert (gfc_array_index_type, tmp);
1009	bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
1010	tmp = fold_build2_loc (input_location, MULT_EXPR,
1011	gfc_array_index_type, tmp, bs);
1012	}
1013
1014	tmp = (tmp && !integer_zerop (tmp))
1015	? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
1016	}
1017	else
1018	tmp = fold_convert (gfc_array_index_type,
1019	size_in_bytes (tmp));
1020	}
1021	return tmp;
1022	}
1023
1024
1025	/ Generate an initializer for a static pointer or allocatable array. /
1026
1027	void
1028	gfc_trans_static_array_pointer (gfc_symbol * sym)
1029	{
1030	tree type;
1031
1032	gcc_assert (TREE_STATIC (sym->backend_decl));
1033	/ Just zero the data member. /
1034	type = TREE_TYPE (sym->backend_decl);
1035	DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
1036	}
1037
1038
1039	/ If the bounds of SE's loop have not yet been set, see if they can be*
1040	determined from array spec AS, which is the array spec of a called
1041	function. MAPPING maps the callee's dummy arguments to the values
1042	that the caller is passing. Add any initialization and finalization
1043	code to SE. /*
1044
1045	void
1046	gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
1047	gfc_se * se, gfc_array_spec * as)
1048	{
1049	int n, dim, total_dim;
1050	gfc_se tmpse;
1051	gfc_ss *ss;
1052	tree lower;
1053	tree upper;
1054	tree tmp;
1055
1056	total_dim = `0`;
1057
1058	if (!as \|\| as->type != AS_EXPLICIT)
1059	return;
1060
1061	for (ss = se->ss; ss; ss = ss->parent)
1062	{
1063	total_dim += ss->loop->dimen;
1064	for (n = `0`; n < ss->loop->dimen; n++)
1065	{
1066	/ The bound is known, nothing to do. /
1067	if (ss->loop->to[n] != NULL_TREE)
1068	continue;
1069
1070	dim = ss->dim[n];
1071	gcc_assert (dim < as->rank);
1072	gcc_assert (ss->loop->dimen <= as->rank);
1073
1074	/ Evaluate the lower bound. /
1075	gfc_init_se (&tmpse, NULL);
1076	gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
1077	gfc_add_block_to_block (&se->pre, &tmpse.pre);
1078	gfc_add_block_to_block (&se->post, &tmpse.post);
1079	lower = fold_convert (gfc_array_index_type, tmpse.expr);
1080
1081	/ ...and the upper bound. /
1082	gfc_init_se (&tmpse, NULL);
1083	gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
1084	gfc_add_block_to_block (&se->pre, &tmpse.pre);
1085	gfc_add_block_to_block (&se->post, &tmpse.post);
1086	upper = fold_convert (gfc_array_index_type, tmpse.expr);
1087
1088	/ Set the upper bound of the loop to UPPER - LOWER. /
1089	tmp = fold_build2_loc (input_location, MINUS_EXPR,
1090	gfc_array_index_type, upper, lower);
1091	tmp = gfc_evaluate_now (tmp, &se->pre);
1092	ss->loop->to[n] = tmp;
1093	}
1094	}
1095
1096	gcc_assert (total_dim == as->rank);
1097	}
1098
1099
1100	/ Generate code to allocate an array temporary, or create a variable to*
1101	hold the data. If size is NULL, zero the descriptor so that the
1102	callee will allocate the array. If DEALLOC is true, also generate code to
1103	free the array afterwards.
1104
1105	If INITIAL is not NULL, it is packed using internal_pack and the result used
1106	as data instead of allocating a fresh, unitialized area of memory.
1107
1108	Initialization code is added to PRE and finalization code to POST.
1109	DYNAMIC is true if the caller may want to extend the array later
1110	using realloc. This prevents us from putting the array on the stack. /*
1111
1112	static void
1113	gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
1114	gfc_array_info * info, tree size, tree nelem,
1115	tree initial, bool dynamic, bool dealloc)
1116	{
1117	tree tmp;
1118	tree desc;
1119	bool onstack;
1120
1121	desc = info->descriptor;
1122	info->offset = gfc_index_zero_node;
1123	if (size == NULL_TREE \|\| (dynamic && integer_zerop (size)))
1124	{
1125	/ A callee allocated array. /
1126	gfc_conv_descriptor_data_set (block: pre, desc, null_pointer_node);
1127	onstack = false;
1128	}
1129	else
1130	{
1131	/ Allocate the temporary. /
1132	onstack = !dynamic && initial == NULL_TREE
1133	&& (flag_stack_arrays
1134	\|\| gfc_can_put_var_on_stack (size));
1135
1136	if (onstack)
1137	{
1138	/ Make a temporary variable to hold the data. /
1139	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
1140	nelem, gfc_index_one_node);
1141	tmp = gfc_evaluate_now (tmp, pre);
1142	tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
1143	tmp);
1144	tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
1145	tmp);
1146	tmp = gfc_create_var (tmp, "A");
1147	/ If we're here only because of -fstack-arrays we have to*
1148	emit a DECL_EXPR to make the gimplifier emit alloca calls. /*
1149	if (!gfc_can_put_var_on_stack (size))
1150	gfc_add_expr_to_block (pre,
1151	fold_build1_loc (input_location,
1152	DECL_EXPR, TREE_TYPE (tmp),
1153	tmp));
1154	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1155	gfc_conv_descriptor_data_set (block: pre, desc, value: tmp);
1156	}
1157	else
1158	{
1159	/ Allocate memory to hold the data or call internal_pack. /
1160	if (initial == NULL_TREE)
1161	{
1162	tmp = gfc_call_malloc (pre, NULL, size);
1163	tmp = gfc_evaluate_now (tmp, pre);
1164	}
1165	else
1166	{
1167	tree packed;
1168	tree source_data;
1169	tree was_packed;
1170	stmtblock_t do_copying;
1171
1172	tmp = TREE_TYPE (initial); / Pointer to descriptor. /
1173	gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
1174	tmp = TREE_TYPE (tmp); / The descriptor itself. /
1175	tmp = gfc_get_element_type (tmp);
1176	packed = gfc_create_var (build_pointer_type (tmp), "data");
1177
1178	tmp = build_call_expr_loc (input_location,
1179	gfor_fndecl_in_pack, `1`, initial);
1180	tmp = fold_convert (TREE_TYPE (packed), tmp);
1181	gfc_add_modify (pre, packed, tmp);
1182
1183	tmp = build_fold_indirect_ref_loc (input_location,
1184	initial);
1185	source_data = gfc_conv_descriptor_data_get (desc: tmp);
1186
1187	/ internal_pack may return source->data without any allocation*
1188	or copying if it is already packed. If that's the case, we
1189	need to allocate and copy manually. /*
1190
1191	gfc_start_block (&do_copying);
1192	tmp = gfc_call_malloc (&do_copying, NULL, size);
1193	tmp = fold_convert (TREE_TYPE (packed), tmp);
1194	gfc_add_modify (&do_copying, packed, tmp);
1195	tmp = gfc_build_memcpy_call (packed, source_data, size);
1196	gfc_add_expr_to_block (&do_copying, tmp);
1197
1198	was_packed = fold_build2_loc (input_location, EQ_EXPR,
1199	logical_type_node, packed,
1200	source_data);
1201	tmp = gfc_finish_block (&do_copying);
1202	tmp = build3_v (COND_EXPR, was_packed, tmp,
1203	build_empty_stmt (input_location));
1204	gfc_add_expr_to_block (pre, tmp);
1205
1206	tmp = fold_convert (pvoid_type_node, packed);
1207	}
1208
1209	gfc_conv_descriptor_data_set (block: pre, desc, value: tmp);
1210	}
1211	}
1212	info->data = gfc_conv_descriptor_data_get (desc);
1213
1214	/ The offset is zero because we create temporaries with a zero*
1215	lower bound. /*
1216	gfc_conv_descriptor_offset_set (block: pre, desc, gfc_index_zero_node);
1217
1218	if (dealloc && !onstack)
1219	{
1220	/ Free the temporary. /
1221	tmp = gfc_conv_descriptor_data_get (desc);
1222	tmp = gfc_call_free (tmp);
1223	gfc_add_expr_to_block (post, tmp);
1224	}
1225	}
1226
1227
1228	/ Get the scalarizer array dimension corresponding to actual array dimension*
1229	given by ARRAY_DIM.
1230
1231	For example, if SS represents the array ref a(1,:,:,1), it is a
1232	bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
1233	and 1 for ARRAY_DIM=2.
1234	If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
1235	scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
1236	ARRAY_DIM=3.
1237	If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
1238	array. If called on the inner ss, the result would be respectively 0,1,2 for
1239	ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
1240	for ARRAY_DIM=1,2. /*
1241
1242	static int
1243	get_scalarizer_dim_for_array_dim (gfc_ss ss, int* array_dim)
1244	{
1245	int array_ref_dim;
1246	int n;
1247
1248	array_ref_dim = `0`;
1249
1250	for (; ss; ss = ss->parent)
1251	for (n = `0`; n < ss->dimen; n++)
1252	if (ss->dim[n] < array_dim)
1253	array_ref_dim++;
1254
1255	return array_ref_dim;
1256	}
1257
1258
1259	static gfc_ss *
1260	innermost_ss (gfc_ss *ss)
1261	{
1262	while (ss->nested_ss != NULL)
1263	ss = ss->nested_ss;
1264
1265	return ss;
1266	}
1267
1268
1269
1270	/ Get the array reference dimension corresponding to the given loop dimension.*
1271	It is different from the true array dimension given by the dim array in
1272	the case of a partial array reference (i.e. a(:,:,1,:) for example)
1273	It is different from the loop dimension in the case of a transposed array.
1274	*/
1275
1276	static int
1277	get_array_ref_dim_for_loop_dim (gfc_ss ss, int* loop_dim)
1278	{
1279	return get_scalarizer_dim_for_array_dim (ss: innermost_ss (ss),
1280	array_dim: ss->dim[loop_dim]);
1281	}
1282
1283
1284	/ Use the information in the ss to obtain the required information about*
1285	the type and size of an array temporary, when the lhs in an assignment
1286	is a class expression. /*
1287
1288	static tree
1289	get_class_info_from_ss (stmtblock_t * pre, gfc_ss ss, tree eltype)
1290	{
1291	gfc_ss *lhs_ss;
1292	gfc_ss *rhs_ss;
1293	tree tmp;
1294	tree tmp2;
1295	tree vptr;
1296	tree rhs_class_expr = NULL_TREE;
1297	tree lhs_class_expr = NULL_TREE;
1298	bool unlimited_rhs = false;
1299	bool unlimited_lhs = false;
1300	bool rhs_function = false;
1301	gfc_symbol *vtab;
1302
1303	/ The second element in the loop chain contains the source for the*
1304	temporary; ie. the rhs of the assignment. /*
1305	rhs_ss = ss->loop->ss->loop_chain;
1306
1307	if (rhs_ss != gfc_ss_terminator
1308	&& rhs_ss->info
1309	&& rhs_ss->info->expr
1310	&& rhs_ss->info->expr->ts.type == BT_CLASS
1311	&& rhs_ss->info->data.array.descriptor)
1312	{
1313	if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
1314	rhs_class_expr
1315	= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
1316	else
1317	rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
1318	unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
1319	if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
1320	rhs_function = true;
1321	}
1322
1323	/ For an assignment the lhs is the next element in the loop chain.*
1324	If we have a class rhs, this had better be a class variable
1325	expression! /*
1326	lhs_ss = rhs_ss->loop_chain;
1327	if (lhs_ss != gfc_ss_terminator
1328	&& lhs_ss->info
1329	&& lhs_ss->info->expr
1330	&& lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
1331	&& lhs_ss->info->expr->ts.type == BT_CLASS)
1332	{
1333	tmp = lhs_ss->info->data.array.descriptor;
1334	unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
1335	}
1336	else
1337	tmp = NULL_TREE;
1338
1339	/ Get the lhs class expression. /
1340	if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
1341	lhs_class_expr = gfc_get_class_from_expr (tmp);
1342	else
1343	return rhs_class_expr;
1344
1345	gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
1346
1347	/ Set the lhs vptr and, if necessary, the _len field. /
1348	if (rhs_class_expr)
1349	{
1350	/ Both lhs and rhs are class expressions. /
1351	tmp = gfc_class_vptr_get (lhs_class_expr);
1352	gfc_add_modify (pre, tmp,
1353	fold_convert (TREE_TYPE (tmp),
1354	gfc_class_vptr_get (rhs_class_expr)));
1355	if (unlimited_lhs)
1356	{
1357	tmp = gfc_class_len_get (lhs_class_expr);
1358	if (unlimited_rhs)
1359	tmp2 = gfc_class_len_get (rhs_class_expr);
1360	else
1361	tmp2 = build_int_cst (TREE_TYPE (tmp), `0`);
1362	gfc_add_modify (pre, tmp, tmp2);
1363	}
1364
1365	if (rhs_function)
1366	{
1367	tmp = gfc_class_data_get (rhs_class_expr);
1368	gfc_conv_descriptor_offset_set (block: pre, desc: tmp, gfc_index_zero_node);
1369	}
1370	}
1371	else
1372	{
1373	/ lhs is class and rhs is intrinsic or derived type. /
1374	*eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
1375	eltype = gfc_get_element_type (eltype);
1376	vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
1377	vptr = vtab->backend_decl;
1378	if (vptr == NULL_TREE)
1379	vptr = gfc_get_symbol_decl (vtab);
1380	vptr = gfc_build_addr_expr (NULL_TREE, vptr);
1381	tmp = gfc_class_vptr_get (lhs_class_expr);
1382	gfc_add_modify (pre, tmp,
1383	fold_convert (TREE_TYPE (tmp), vptr));
1384
1385	if (unlimited_lhs)
1386	{
1387	tmp = gfc_class_len_get (lhs_class_expr);
1388	if (rhs_ss->info
1389	&& rhs_ss->info->expr
1390	&& rhs_ss->info->expr->ts.type == BT_CHARACTER)
1391	tmp2 = build_int_cst (TREE_TYPE (tmp),
1392	rhs_ss->info->expr->ts.kind);
1393	else
1394	tmp2 = build_int_cst (TREE_TYPE (tmp), `0`);
1395	gfc_add_modify (pre, tmp, tmp2);
1396	}
1397	}
1398
1399	return rhs_class_expr;
1400	}
1401
1402
1403
1404	/ Generate code to create and initialize the descriptor for a temporary*
1405	array. This is used for both temporaries needed by the scalarizer, and
1406	functions returning arrays. Adjusts the loop variables to be
1407	zero-based, and calculates the loop bounds for callee allocated arrays.
1408	Allocate the array unless it's callee allocated (we have a callee
1409	allocated array if 'callee_alloc' is true, or if loop->to[n] is
1410	NULL_TREE for any n). Also fills in the descriptor, data and offset
1411	fields of info if known. Returns the size of the array, or NULL for a
1412	callee allocated array.
1413
1414	'eltype' == NULL signals that the temporary should be a class object.
1415	The 'initial' expression is used to obtain the size of the dynamic
1416	type; otherwise the allocation and initialization proceeds as for any
1417	other expression
1418
1419	PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
1420	gfc_trans_allocate_array_storage. /*
1421
1422	tree
1423	gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
1424	tree eltype, tree initial, bool dynamic,
1425	bool dealloc, bool callee_alloc, locus * where)
1426	{
1427	gfc_loopinfo *loop;
1428	gfc_ss *s;
1429	gfc_array_info *info;
1430	tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
1431	tree type;
1432	tree desc;
1433	tree tmp;
1434	tree size;
1435	tree nelem;
1436	tree cond;
1437	tree or_expr;
1438	tree elemsize;
1439	tree class_expr = NULL_TREE;
1440	int n, dim, tmp_dim;
1441	int total_dim = `0`;
1442
1443	/ This signals a class array for which we need the size of the*
1444	dynamic type. Generate an eltype and then the class expression. /*
1445	if (eltype == NULL_TREE && initial)
1446	{
1447	gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
1448	class_expr = build_fold_indirect_ref_loc (input_location, initial);
1449	/ Obtain the structure (class) expression. /
1450	class_expr = gfc_get_class_from_expr (class_expr);
1451	gcc_assert (class_expr);
1452	}
1453
1454	/ Otherwise, some expressions, such as class functions, arising from*
1455	dependency checking in assignments come here with class element type.
1456	The descriptor can be obtained from the ss->info and then converted
1457	to the class object. /*
1458	if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
1459	class_expr = get_class_info_from_ss (pre, ss, eltype: &eltype);
1460
1461	/ If the dynamic type is not available, use the declared type. /
1462	if (eltype && GFC_CLASS_TYPE_P (eltype))
1463	eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
1464
1465	if (class_expr == NULL_TREE)
1466	elemsize = fold_convert (gfc_array_index_type,
1467	TYPE_SIZE_UNIT (eltype));
1468	else
1469	{
1470	/ Unlimited polymorphic entities are initialised with NULL vptr. They*
1471	can be tested for by checking if the len field is present. If so
1472	test the vptr before using the vtable size. /*
1473	tmp = gfc_class_vptr_get (class_expr);
1474	tmp = fold_build2_loc (input_location, NE_EXPR,
1475	logical_type_node,
1476	tmp, build_int_cst (TREE_TYPE (tmp), `0`));
1477	elemsize = fold_build3_loc (input_location, COND_EXPR,
1478	gfc_array_index_type,
1479	tmp,
1480	gfc_class_vtab_size_get (class_expr),
1481	gfc_index_zero_node);
1482	elemsize = gfc_evaluate_now (elemsize, pre);
1483	elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
1484	/ Casting the data as a character of the dynamic length ensures that*
1485	assignment of elements works when needed. /*
1486	eltype = gfc_get_character_type_len (`1`, elemsize);
1487	}
1488
1489	memset (s: from, c: `0`, n: sizeof (from));
1490	memset (s: to, c: `0`, n: sizeof (to));
1491
1492	info = &ss->info->data.array;
1493
1494	gcc_assert (ss->dimen > `0`);
1495	gcc_assert (ss->loop->dimen == ss->dimen);
1496
1497	if (warn_array_temporaries && where)
1498	gfc_warning (opt: OPT_Warray_temporaries,
1499	"Creating array temporary at %L", where);
1500
1501	/ Set the lower bound to zero. /
1502	for (s = ss; s; s = s->parent)
1503	{
1504	loop = s->loop;
1505
1506	total_dim += loop->dimen;
1507	for (n = `0`; n < loop->dimen; n++)
1508	{
1509	dim = s->dim[n];
1510
1511	/ Callee allocated arrays may not have a known bound yet. /
1512	if (loop->to[n])
1513	loop->to[n] = gfc_evaluate_now (
1514	fold_build2_loc (input_location, MINUS_EXPR,
1515	gfc_array_index_type,
1516	loop->to[n], loop->from[n]),
1517	pre);
1518	loop->from[n] = gfc_index_zero_node;
1519
1520	/ We have just changed the loop bounds, we must clear the*
1521	corresponding specloop, so that delta calculation is not skipped
1522	later in gfc_set_delta. /*
1523	loop->specloop[n] = NULL;
1524
1525	/ We are constructing the temporary's descriptor based on the loop*
1526	dimensions. As the dimensions may be accessed in arbitrary order
1527	(think of transpose) the size taken from the n'th loop may not map
1528	to the n'th dimension of the array. We need to reconstruct loop
1529	infos in the right order before using it to set the descriptor
1530	bounds. /*
1531	tmp_dim = get_scalarizer_dim_for_array_dim (ss, array_dim: dim);
1532	from[tmp_dim] = loop->from[n];
1533	to[tmp_dim] = loop->to[n];
1534
1535	info->delta[dim] = gfc_index_zero_node;
1536	info->start[dim] = gfc_index_zero_node;
1537	info->end[dim] = gfc_index_zero_node;
1538	info->stride[dim] = gfc_index_one_node;
1539	}
1540	}
1541
1542	/ Initialize the descriptor. /
1543	type =
1544	gfc_get_array_type_bounds (eltype, total_dim, `0`, from, to, `1`,
1545	GFC_ARRAY_UNKNOWN, true);
1546	desc = gfc_create_var (type, "atmp");
1547	GFC_DECL_PACKED_ARRAY (desc) = `1`;
1548
1549	/ Emit a DECL_EXPR for the variable sized array type in*
1550	GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
1551	sizes works correctly. /*
1552	tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
1553	if (! TYPE_NAME (arraytype))
1554	TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
1555	NULL_TREE, arraytype);
1556	gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
1557	arraytype, TYPE_NAME (arraytype)));
1558
1559	if (class_expr != NULL_TREE)
1560	{
1561	tree class_data;
1562	tree dtype;
1563
1564	/ Create a class temporary. /
1565	tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
1566	gfc_add_modify (pre, tmp, class_expr);
1567
1568	/ Assign the new descriptor to the _data field. This allows the*
1569	vptr _copy to be used for scalarized assignment since the class
1570	temporary can be found from the descriptor. /*
1571	class_data = gfc_class_data_get (tmp);
1572	tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1573	TREE_TYPE (desc), desc);
1574	gfc_add_modify (pre, class_data, tmp);
1575
1576	/ Take the dtype from the class expression. /
1577	dtype = gfc_conv_descriptor_dtype (desc: gfc_class_data_get (class_expr));
1578	tmp = gfc_conv_descriptor_dtype (desc: class_data);
1579	gfc_add_modify (pre, tmp, dtype);
1580
1581	/ Point desc to the class _data field. /
1582	desc = class_data;
1583	}
1584	else
1585	{
1586	/ Fill in the array dtype. /
1587	tmp = gfc_conv_descriptor_dtype (desc);
1588	gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
1589	}
1590
1591	info->descriptor = desc;
1592	size = gfc_index_one_node;
1593
1594	/*
1595	Fill in the bounds and stride. This is a packed array, so:
1596
1597	size = 1;
1598	for (n = 0; n < rank; n++)
1599	{
1600	stride[n] = size
1601	delta = ubound[n] + 1 - lbound[n];
1602	size = size delta;*
1603	}
1604	size = size sizeof(element);*
1605	*/
1606
1607	or_expr = NULL_TREE;
1608
1609	/ If there is at least one null loop->to[n], it is a callee allocated*
1610	array. /*
1611	for (n = `0`; n < total_dim; n++)
1612	if (to[n] == NULL_TREE)
1613	{
1614	size = NULL_TREE;
1615	break;
1616	}
1617
1618	if (size == NULL_TREE)
1619	for (s = ss; s; s = s->parent)
1620	for (n = `0`; n < s->loop->dimen; n++)
1621	{
1622	dim = get_scalarizer_dim_for_array_dim (ss, array_dim: s->dim[n]);
1623
1624	/ For a callee allocated array express the loop bounds in terms*
1625	of the descriptor fields. /*
1626	tmp = fold_build2_loc (input_location,
1627	MINUS_EXPR, gfc_array_index_type,
1628	gfc_conv_descriptor_ubound_get (desc, dim: gfc_rank_cst[dim]),
1629	gfc_conv_descriptor_lbound_get (desc, dim: gfc_rank_cst[dim]));
1630	s->loop->to[n] = tmp;
1631	}
1632	else
1633	{
1634	for (n = `0`; n < total_dim; n++)
1635	{
1636	/ Store the stride and bound components in the descriptor. /
1637	gfc_conv_descriptor_stride_set (block: pre, desc, dim: gfc_rank_cst[n], value: size);
1638
1639	gfc_conv_descriptor_lbound_set (block: pre, desc, dim: gfc_rank_cst[n],
1640	gfc_index_zero_node);
1641
1642	gfc_conv_descriptor_ubound_set (block: pre, desc, dim: gfc_rank_cst[n], value: to[n]);
1643
1644	tmp = fold_build2_loc (input_location, PLUS_EXPR,
1645	gfc_array_index_type,
1646	to[n], gfc_index_one_node);
1647
1648	/ Check whether the size for this dimension is negative. /
1649	cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1650	tmp, gfc_index_zero_node);
1651	cond = gfc_evaluate_now (cond, pre);
1652
1653	if (n == `0`)
1654	or_expr = cond;
1655	else
1656	or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1657	logical_type_node, or_expr, cond);
1658
1659	size = fold_build2_loc (input_location, MULT_EXPR,
1660	gfc_array_index_type, size, tmp);
1661	size = gfc_evaluate_now (size, pre);
1662	}
1663	}
1664
1665	/ Get the size of the array. /
1666	if (size && !callee_alloc)
1667	{
1668	/ If or_expr is true, then the extent in at least one*
1669	dimension is zero and the size is set to zero. /*
1670	size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
1671	or_expr, gfc_index_zero_node, size);
1672
1673	nelem = size;
1674	size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
1675	size, elemsize);
1676	}
1677	else
1678	{
1679	nelem = size;
1680	size = NULL_TREE;
1681	}
1682
1683	/ Set the span. /
1684	tmp = fold_convert (gfc_array_index_type, elemsize);
1685	gfc_conv_descriptor_span_set (block: pre, desc, value: tmp);
1686
1687	gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
1688	dynamic, dealloc);
1689
1690	while (ss->parent)
1691	ss = ss->parent;
1692
1693	if (ss->dimen > ss->loop->temp_dim)
1694	ss->loop->temp_dim = ss->dimen;
1695
1696	return size;
1697	}
1698
1699
1700	/ Return the number of iterations in a loop that starts at START,*
1701	ends at END, and has step STEP. /*
1702
1703	static tree
1704	gfc_get_iteration_count (tree start, tree end, tree step)
1705	{
1706	tree tmp;
1707	tree type;
1708
1709	type = TREE_TYPE (step);
1710	tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
1711	tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
1712	tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
1713	build_int_cst (type, `1`));
1714	tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
1715	build_int_cst (type, `0`));
1716	return fold_convert (gfc_array_index_type, tmp);
1717	}
1718
1719
1720	/ Extend the data in array DESC by EXTRA elements. /
1721
1722	static void
1723	gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
1724	{
1725	tree arg0, arg1;
1726	tree tmp;
1727	tree size;
1728	tree ubound;
1729
1730	if (integer_zerop (extra))
1731	return;
1732
1733	ubound = gfc_conv_descriptor_ubound_get (desc, dim: gfc_rank_cst[`0`]);
1734
1735	/ Add EXTRA to the upper bound. /
1736	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1737	ubound, extra);
1738	gfc_conv_descriptor_ubound_set (block: pblock, desc, dim: gfc_rank_cst[`0`], value: tmp);
1739
1740	/ Get the value of the current data pointer. /
1741	arg0 = gfc_conv_descriptor_data_get (desc);
1742
1743	/ Calculate the new array size. /
1744	size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
1745	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1746	ubound, gfc_index_one_node);
1747	arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
1748	fold_convert (size_type_node, tmp),
1749	fold_convert (size_type_node, size));
1750
1751	/ Call the realloc() function. /
1752	tmp = gfc_call_realloc (pblock, arg0, arg1);
1753	gfc_conv_descriptor_data_set (block: pblock, desc, value: tmp);
1754	}
1755
1756
1757	/ Return true if the bounds of iterator I can only be determined*
1758	at run time. /*
1759
1760	static inline bool
1761	gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
1762	{
1763	return (i->start->expr_type != EXPR_CONSTANT
1764	\|\| i->end->expr_type != EXPR_CONSTANT
1765	\|\| i->step->expr_type != EXPR_CONSTANT);
1766	}
1767
1768
1769	/ Split the size of constructor element EXPR into the sum of two terms,*
1770	one of which can be determined at compile time and one of which must
1771	be calculated at run time. Set SIZE to the former and return true*
1772	if the latter might be nonzero. /*
1773
1774	static bool
1775	gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
1776	{
1777	if (expr->expr_type == EXPR_ARRAY)
1778	return gfc_get_array_constructor_size (size, expr->value.constructor);
1779	else if (expr->rank > `0`)
1780	{
1781	/ Calculate everything at run time. /
1782	mpz_set_ui (*size, `0`);
1783	return true;
1784	}
1785	else
1786	{
1787	/ A single element. /
1788	mpz_set_ui (*size, `1`);
1789	return false;
1790	}
1791	}
1792
1793
1794	/ Like gfc_get_array_constructor_element_size, but applied to the whole*
1795	of array constructor C. /*
1796
1797	static bool
1798	gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
1799	{
1800	gfc_constructor *c;
1801	gfc_iterator *i;
1802	mpz_t val;
1803	mpz_t len;
1804	bool dynamic;
1805
1806	mpz_set_ui (*size, `0`);
1807	mpz_init (len);
1808	mpz_init (val);
1809
1810	dynamic = false;
1811	for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (ctor: c))
1812	{
1813	i = c->iterator;
1814	if (i && gfc_iterator_has_dynamic_bounds (i))
1815	dynamic = true;
1816	else
1817	{
1818	dynamic \|= gfc_get_array_constructor_element_size (size: &len, expr: c->expr);
1819	if (i)
1820	{
1821	/ Multiply the static part of the element size by the*
1822	number of iterations. /*
1823	mpz_sub (val, i->end->value.integer, i->start->value.integer);
1824	mpz_fdiv_q (val, val, i->step->value.integer);
1825	mpz_add_ui (val, val, `1`);
1826	if (mpz_sgn (val) > `0`)
1827	mpz_mul (len, len, val);
1828	else
1829	mpz_set_ui (len, `0`);
1830	}
1831	mpz_add (size, size, len);
1832	}
1833	}
1834	mpz_clear (len);
1835	mpz_clear (val);
1836	return dynamic;
1837	}
1838
1839
1840	/ Make sure offset is a variable. /
1841
1842	static void
1843	gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
1844	tree * offsetvar)
1845	{
1846	/ We should have already created the offset variable. We cannot*
1847	create it here because we may be in an inner scope. /*
1848	gcc_assert (*offsetvar != NULL_TREE);
1849	gfc_add_modify (pblock, offsetvar, poffset);
1850	poffset = offsetvar;
1851	TREE_USED (*offsetvar) = `1`;
1852	}
1853
1854
1855	/ Variables needed for bounds-checking. /
1856	static bool first_len;
1857	static tree first_len_val;
1858	static bool typespec_chararray_ctor;
1859
1860	static void
1861	gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
1862	tree offset, gfc_se * se, gfc_expr * expr)
1863	{
1864	tree tmp;
1865
1866	gfc_conv_expr (se, expr);
1867
1868	/ Store the value. /
1869	tmp = build_fold_indirect_ref_loc (input_location,
1870	gfc_conv_descriptor_data_get (desc));
1871	tmp = gfc_build_array_ref (tmp, offset, NULL);
1872
1873	if (expr->ts.type == BT_CHARACTER)
1874	{
1875	int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
1876	tree esize;
1877
1878	esize = size_in_bytes (t: gfc_get_element_type (TREE_TYPE (desc)));
1879	esize = fold_convert (gfc_charlen_type_node, esize);
1880	esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1881	TREE_TYPE (esize), esize,
1882	build_int_cst (TREE_TYPE (esize),
1883	gfc_character_kinds[i].bit_size / `8`));
1884
1885	gfc_conv_string_parameter (se);
1886	if (POINTER_TYPE_P (TREE_TYPE (tmp)))
1887	{
1888	/ The temporary is an array of pointers. /
1889	se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1890	gfc_add_modify (&se->pre, tmp, se->expr);
1891	}
1892	else
1893	{
1894	/ The temporary is an array of string values. /
1895	tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
1896	/ We know the temporary and the value will be the same length,*
1897	so can use memcpy. /*
1898	gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
1899	se->string_length, se->expr, expr->ts.kind);
1900	}
1901	if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
1902	{
1903	if (first_len)
1904	{
1905	gfc_add_modify (&se->pre, first_len_val,
1906	fold_convert (TREE_TYPE (first_len_val),
1907	se->string_length));
1908	first_len = false;
1909	}
1910	else
1911	{
1912	/ Verify that all constructor elements are of the same*
1913	length. /*
1914	tree rhs = fold_convert (TREE_TYPE (first_len_val),
1915	se->string_length);
1916	tree cond = fold_build2_loc (input_location, NE_EXPR,
1917	logical_type_node, first_len_val,
1918	rhs);
1919	gfc_trans_runtime_check
1920	(true, false, cond, &se->pre, &expr->where,
1921	"Different CHARACTER lengths (%ld/%ld) in array constructor",
1922	fold_convert (long_integer_type_node, first_len_val),
1923	fold_convert (long_integer_type_node, se->string_length));
1924	}
1925	}
1926	}
1927	else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
1928	&& !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
1929	{
1930	/ Assignment of a CLASS array constructor to a derived type array. /
1931	if (expr->expr_type == EXPR_FUNCTION)
1932	se->expr = gfc_evaluate_now (se->expr, pblock);
1933	se->expr = gfc_class_data_get (se->expr);
1934	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
1935	se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1936	gfc_add_modify (&se->pre, tmp, se->expr);
1937	}
1938	else
1939	{
1940	/ TODO: Should the frontend already have done this conversion? /
1941	se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
1942	gfc_add_modify (&se->pre, tmp, se->expr);
1943	}
1944
1945	gfc_add_block_to_block (pblock, &se->pre);
1946	gfc_add_block_to_block (pblock, &se->post);
1947	}
1948
1949
1950	/ Add the contents of an array to the constructor. DYNAMIC is as for*
1951	gfc_trans_array_constructor_value. /*
1952
1953	static void
1954	gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
1955	tree type ATTRIBUTE_UNUSED,
1956	tree desc, gfc_expr * expr,
1957	tree * poffset, tree * offsetvar,
1958	bool dynamic)
1959	{
1960	gfc_se se;
1961	gfc_ss *ss;
1962	gfc_loopinfo loop;
1963	stmtblock_t body;
1964	tree tmp;
1965	tree size;
1966	int n;
1967
1968	/ We need this to be a variable so we can increment it. /
1969	gfc_put_offset_into_var (pblock, poffset, offsetvar);
1970
1971	gfc_init_se (&se, NULL);
1972
1973	/ Walk the array expression. /
1974	ss = gfc_walk_expr (expr);
1975	gcc_assert (ss != gfc_ss_terminator);
1976
1977	/ Initialize the scalarizer. /
1978	gfc_init_loopinfo (&loop);
1979	gfc_add_ss_to_loop (loop: &loop, head: ss);
1980
1981	/ Initialize the loop. /
1982	gfc_conv_ss_startstride (&loop);
1983	gfc_conv_loop_setup (&loop, &expr->where);
1984
1985	/ Make sure the constructed array has room for the new data. /
1986	if (dynamic)
1987	{
1988	/ Set SIZE to the total number of elements in the subarray. /
1989	size = gfc_index_one_node;
1990	for (n = `0`; n < loop.dimen; n++)
1991	{
1992	tmp = gfc_get_iteration_count (start: loop.from[n], end: loop.to[n],
1993	gfc_index_one_node);
1994	size = fold_build2_loc (input_location, MULT_EXPR,
1995	gfc_array_index_type, size, tmp);
1996	}
1997
1998	/ Grow the constructed array by SIZE elements. /
1999	gfc_grow_array (pblock: &loop.pre, desc, extra: size);
2000	}
2001
2002	/ Make the loop body. /
2003	gfc_mark_ss_chain_used (ss, flags: `1`);
2004	gfc_start_scalarized_body (&loop, &body);
2005	gfc_copy_loopinfo_to_se (&se, &loop);
2006	se.ss = ss;
2007
2008	gfc_trans_array_ctor_element (pblock: &body, desc, offset: *poffset, se: &se, expr);
2009	gcc_assert (se.ss == gfc_ss_terminator);
2010
2011	/ Increment the offset. /
2012	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2013	*poffset, gfc_index_one_node);
2014	gfc_add_modify (&body, *poffset, tmp);
2015
2016	/ Finish the loop. /
2017	gfc_trans_scalarizing_loops (&loop, &body);
2018	gfc_add_block_to_block (&loop.pre, &loop.post);
2019	tmp = gfc_finish_block (&loop.pre);
2020	gfc_add_expr_to_block (pblock, tmp);
2021
2022	gfc_cleanup_loop (loop: &loop);
2023	}
2024
2025
2026	/ Assign the values to the elements of an array constructor. DYNAMIC*
2027	is true if descriptor DESC only contains enough data for the static
2028	size calculated by gfc_get_array_constructor_size. When true, memory
2029	for the dynamic parts must be allocated using realloc. /*
2030
2031	static void
2032	gfc_trans_array_constructor_value (stmtblock_t * pblock,
2033	stmtblock_t * finalblock,
2034	tree type, tree desc,
2035	gfc_constructor_base base, tree * poffset,
2036	tree * offsetvar, bool dynamic)
2037	{
2038	tree tmp;
2039	tree start = NULL_TREE;
2040	tree end = NULL_TREE;
2041	tree step = NULL_TREE;
2042	stmtblock_t body;
2043	gfc_se se;
2044	mpz_t size;
2045	gfc_constructor *c;
2046	gfc_typespec ts;
2047	int ctr = `0`;
2048
2049	tree shadow_loopvar = NULL_TREE;
2050	gfc_saved_var saved_loopvar;
2051
2052	ts.type = BT_UNKNOWN;
2053	mpz_init (size);
2054	for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (ctor: c))
2055	{
2056	ctr++;
2057	/ If this is an iterator or an array, the offset must be a variable. /
2058	if ((c->iterator \|\| c->expr->rank > `0`) && INTEGER_CST_P (*poffset))
2059	gfc_put_offset_into_var (pblock, poffset, offsetvar);
2060
2061	/ Shadowing the iterator avoids changing its value and saves us from*
2062	keeping track of it. Further, it makes sure that there's always a
2063	backend-decl for the symbol, even if there wasn't one before,
2064	e.g. in the case of an iterator that appears in a specification
2065	expression in an interface mapping. /*
2066	if (c->iterator)
2067	{
2068	gfc_symbol *sym;
2069	tree type;
2070
2071	/ Evaluate loop bounds before substituting the loop variable*
2072	in case they depend on it. Such a case is invalid, but it is
2073	not more expensive to do the right thing here.
2074	See PR 44354. /*
2075	gfc_init_se (&se, NULL);
2076	gfc_conv_expr_val (se: &se, expr: c->iterator->start);
2077	gfc_add_block_to_block (pblock, &se.pre);
2078	start = gfc_evaluate_now (se.expr, pblock);
2079
2080	gfc_init_se (&se, NULL);
2081	gfc_conv_expr_val (se: &se, expr: c->iterator->end);
2082	gfc_add_block_to_block (pblock, &se.pre);
2083	end = gfc_evaluate_now (se.expr, pblock);
2084
2085	gfc_init_se (&se, NULL);
2086	gfc_conv_expr_val (se: &se, expr: c->iterator->step);
2087	gfc_add_block_to_block (pblock, &se.pre);
2088	step = gfc_evaluate_now (se.expr, pblock);
2089
2090	sym = c->iterator->var->symtree->n.sym;
2091	type = gfc_typenode_for_spec (&sym->ts);
2092
2093	shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
2094	gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
2095	}
2096
2097	gfc_start_block (&body);
2098
2099	if (c->expr->expr_type == EXPR_ARRAY)
2100	{
2101	/ Array constructors can be nested. /
2102	gfc_trans_array_constructor_value (pblock: &body, finalblock, type,
2103	desc, base: c->expr->value.constructor,
2104	poffset, offsetvar, dynamic);
2105	}
2106	else if (c->expr->rank > `0`)
2107	{
2108	gfc_trans_array_constructor_subarray (pblock: &body, type, desc, expr: c->expr,
2109	poffset, offsetvar, dynamic);
2110	}
2111	else
2112	{
2113	/ This code really upsets the gimplifier so don't bother for now. /
2114	gfc_constructor *p;
2115	HOST_WIDE_INT n;
2116	HOST_WIDE_INT size;
2117
2118	p = c;
2119	n = `0`;
2120	while (p && !(p->iterator \|\| p->expr->expr_type != EXPR_CONSTANT))
2121	{
2122	p = gfc_constructor_next (ctor: p);
2123	n++;
2124	}
2125	if (n < `4`)
2126	{
2127	/ Scalar values. /
2128	gfc_init_se (&se, NULL);
2129	gfc_trans_array_ctor_element (pblock: &body, desc, offset: *poffset,
2130	se: &se, expr: c->expr);
2131
2132	*poffset = fold_build2_loc (input_location, PLUS_EXPR,
2133	gfc_array_index_type,
2134	*poffset, gfc_index_one_node);
2135	}
2136	else
2137	{
2138	/ Collect multiple scalar constants into a constructor. /
2139	vec<constructor_elt, va_gc> *v = NULL;
2140	tree init;
2141	tree bound;
2142	tree tmptype;
2143	HOST_WIDE_INT idx = `0`;
2144
2145	p = c;
2146	/ Count the number of consecutive scalar constants. /
2147	while (p && !(p->iterator
2148	\|\| p->expr->expr_type != EXPR_CONSTANT))
2149	{
2150	gfc_init_se (&se, NULL);
2151	gfc_conv_constant (&se, p->expr);
2152
2153	if (c->expr->ts.type != BT_CHARACTER)
2154	se.expr = fold_convert (type, se.expr);
2155	/ For constant character array constructors we build*
2156	an array of pointers. /*
2157	else if (POINTER_TYPE_P (type))
2158	se.expr = gfc_build_addr_expr
2159	(gfc_get_pchar_type (p->expr->ts.kind),
2160	se.expr);
2161
2162	CONSTRUCTOR_APPEND_ELT (v,
2163	build_int_cst (gfc_array_index_type,
2164	idx++),
2165	se.expr);
2166	c = p;
2167	p = gfc_constructor_next (ctor: p);
2168	}
2169
2170	bound = size_int (n - `1`);
2171	/ Create an array type to hold them. /
2172	tmptype = build_range_type (gfc_array_index_type,
2173	gfc_index_zero_node, bound);
2174	tmptype = build_array_type (type, tmptype);
2175
2176	init = build_constructor (tmptype, v);
2177	TREE_CONSTANT (init) = `1`;
2178	TREE_STATIC (init) = `1`;
2179	/ Create a static variable to hold the data. /
2180	tmp = gfc_create_var (tmptype, "data");
2181	TREE_STATIC (tmp) = `1`;
2182	TREE_CONSTANT (tmp) = `1`;
2183	TREE_READONLY (tmp) = `1`;
2184	DECL_INITIAL (tmp) = init;
2185	init = tmp;
2186
2187	/ Use BUILTIN_MEMCPY to assign the values. /
2188	tmp = gfc_conv_descriptor_data_get (desc);
2189	tmp = build_fold_indirect_ref_loc (input_location,
2190	tmp);
2191	tmp = gfc_build_array_ref (tmp, *poffset, NULL);
2192	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2193	init = gfc_build_addr_expr (NULL_TREE, init);
2194
2195	size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
2196	bound = build_int_cst (size_type_node, n * size);
2197	tmp = build_call_expr_loc (input_location,
2198	builtin_decl_explicit (fncode: BUILT_IN_MEMCPY),
2199	`3`, tmp, init, bound);
2200	gfc_add_expr_to_block (&body, tmp);
2201
2202	*poffset = fold_build2_loc (input_location, PLUS_EXPR,
2203	gfc_array_index_type, *poffset,
2204	build_int_cst (gfc_array_index_type, n));
2205	}
2206	if (!INTEGER_CST_P (*poffset))
2207	{
2208	gfc_add_modify (&body, offsetvar, poffset);
2209	poffset = offsetvar;
2210	}
2211
2212	if (!c->iterator)
2213	ts = c->expr->ts;
2214	}
2215
2216	/ The frontend should already have done any expansions*
2217	at compile-time. /*
2218	if (!c->iterator)
2219	{
2220	/ Pass the code as is. /
2221	tmp = gfc_finish_block (&body);
2222	gfc_add_expr_to_block (pblock, tmp);
2223	}
2224	else
2225	{
2226	/ Build the implied do-loop. /
2227	stmtblock_t implied_do_block;
2228	tree cond;
2229	tree exit_label;
2230	tree loopbody;
2231	tree tmp2;
2232
2233	loopbody = gfc_finish_block (&body);
2234
2235	/ Create a new block that holds the implied-do loop. A temporary*
2236	loop-variable is used. /*
2237	gfc_start_block(&implied_do_block);
2238
2239	/ Initialize the loop. /
2240	gfc_add_modify (&implied_do_block, shadow_loopvar, start);
2241
2242	/ If this array expands dynamically, and the number of iterations*
2243	is not constant, we won't have allocated space for the static
2244	part of C->EXPR's size. Do that now. /*
2245	if (dynamic && gfc_iterator_has_dynamic_bounds (i: c->iterator))
2246	{
2247	/ Get the number of iterations. /
2248	tmp = gfc_get_iteration_count (start: shadow_loopvar, end, step);
2249
2250	/ Get the static part of C->EXPR's size. /
2251	gfc_get_array_constructor_element_size (size: &size, expr: c->expr);
2252	tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2253
2254	/ Grow the array by TMP * TMP2 elements. /
2255	tmp = fold_build2_loc (input_location, MULT_EXPR,
2256	gfc_array_index_type, tmp, tmp2);
2257	gfc_grow_array (pblock: &implied_do_block, desc, extra: tmp);
2258	}
2259
2260	/ Generate the loop body. /
2261	exit_label = gfc_build_label_decl (NULL_TREE);
2262	gfc_start_block (&body);
2263
2264	/ Generate the exit condition. Depending on the sign of*
2265	the step variable we have to generate the correct
2266	comparison. /*
2267	tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2268	step, build_int_cst (TREE_TYPE (step), `0`));
2269	cond = fold_build3_loc (input_location, COND_EXPR,
2270	logical_type_node, tmp,
2271	fold_build2_loc (input_location, GT_EXPR,
2272	logical_type_node, shadow_loopvar, end),
2273	fold_build2_loc (input_location, LT_EXPR,
2274	logical_type_node, shadow_loopvar, end));
2275	tmp = build1_v (GOTO_EXPR, exit_label);
2276	TREE_USED (exit_label) = `1`;
2277	tmp = build3_v (COND_EXPR, cond, tmp,
2278	build_empty_stmt (input_location));
2279	gfc_add_expr_to_block (&body, tmp);
2280
2281	/ The main loop body. /
2282	gfc_add_expr_to_block (&body, loopbody);
2283
2284	/ Increase loop variable by step. /
2285	tmp = fold_build2_loc (input_location, PLUS_EXPR,
2286	TREE_TYPE (shadow_loopvar), shadow_loopvar,
2287	step);
2288	gfc_add_modify (&body, shadow_loopvar, tmp);
2289
2290	/ Finish the loop. /
2291	tmp = gfc_finish_block (&body);
2292	tmp = build1_v (LOOP_EXPR, tmp);
2293	gfc_add_expr_to_block (&implied_do_block, tmp);
2294
2295	/ Add the exit label. /
2296	tmp = build1_v (LABEL_EXPR, exit_label);
2297	gfc_add_expr_to_block (&implied_do_block, tmp);
2298
2299	/ Finish the implied-do loop. /
2300	tmp = gfc_finish_block(&implied_do_block);
2301	gfc_add_expr_to_block(pblock, tmp);
2302
2303	gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
2304	}
2305	}
2306
2307	/ F2008 4.5.6.3 para 5: If an executable construct references a structure*
2308	constructor or array constructor, the entity created by the constructor is
2309	finalized after execution of the innermost executable construct containing
2310	the reference. This, in fact, was later deleted by the Combined Techical
2311	Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
2312
2313	Transmit finalization of this constructor through 'finalblock'. /*
2314	if (!gfc_notification_std (GFC_STD_F2018_DEL) && finalblock != NULL
2315	&& gfc_may_be_finalized (ts)
2316	&& ctr > `0` && desc != NULL_TREE
2317	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2318	{
2319	symbol_attribute attr;
2320	gfc_se fse;
2321	gfc_warning (opt: `0`, "The structure constructor at %C has been"
2322	" finalized. This feature was removed by f08/0011."
2323	" Use -std=f2018 or -std=gnu to eliminate the"
2324	" finalization.");
2325	attr.pointer = attr.allocatable = `0`;
2326	gfc_init_se (&fse, NULL);
2327	fse.expr = desc;
2328	gfc_finalize_tree_expr (&fse, ts.u.derived, attr, `1`);
2329	gfc_add_block_to_block (finalblock, &fse.pre);
2330	gfc_add_block_to_block (finalblock, &fse.finalblock);
2331	gfc_add_block_to_block (finalblock, &fse.post);
2332	}
2333
2334	mpz_clear (size);
2335	}
2336
2337
2338	/ The array constructor code can create a string length with an operand*
2339	in the form of a temporary variable. This variable will retain its
2340	context (current_function_decl). If we store this length tree in a
2341	gfc_charlen structure which is shared by a variable in another
2342	context, the resulting gfc_charlen structure with a variable in a
2343	different context, we could trip the assertion in expand_expr_real_1
2344	when it sees that a variable has been created in one context and
2345	referenced in another.
2346
2347	If this might be the case, we create a new gfc_charlen structure and
2348	link it into the current namespace. /*
2349
2350	static void
2351	store_backend_decl (gfc_charlen *clp, tree len, bool* force_new_cl)
2352	{
2353	if (force_new_cl)
2354	{
2355	gfc_charlen new_cl = gfc_new_charlen (gfc_current_ns, clp);
2356	*clp = new_cl;
2357	}
2358	(*clp)->backend_decl = len;
2359	}
2360
2361	/ A catch-all to obtain the string length for anything that is not*
2362	a substring of non-constant length, a constant, array or variable. /*
2363
2364	static void
2365	get_array_ctor_all_strlen (stmtblock_t block, gfc_expr e, tree *len)
2366	{
2367	gfc_se se;
2368
2369	/ Don't bother if we already know the length is a constant. /
2370	if (len && INTEGER_CST_P (len))
2371	return;
2372
2373	if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
2374	&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2375	{
2376	/ This is easy. /
2377	gfc_conv_const_charlen (e->ts.u.cl);
2378	*len = e->ts.u.cl->backend_decl;
2379	}
2380	else
2381	{
2382	/ Otherwise, be brutal even if inefficient. /
2383	gfc_init_se (&se, NULL);
2384
2385	/ No function call, in case of side effects. /
2386	se.no_function_call = `1`;
2387	if (e->rank == `0`)
2388	gfc_conv_expr (se: &se, expr: e);
2389	else
2390	gfc_conv_expr_descriptor (&se, e);
2391
2392	/ Fix the value. /
2393	*len = gfc_evaluate_now (se.string_length, &se.pre);
2394
2395	gfc_add_block_to_block (block, &se.pre);
2396	gfc_add_block_to_block (block, &se.post);
2397
2398	store_backend_decl (clp: &e->ts.u.cl, len: len, force_new_cl: true*);
2399	}
2400	}
2401
2402
2403	/ Figure out the string length of a variable reference expression.*
2404	Used by get_array_ctor_strlen. /*
2405
2406	static void
2407	get_array_ctor_var_strlen (stmtblock_t block, gfc_expr expr, tree * len)
2408	{
2409	gfc_ref *ref;
2410	gfc_typespec *ts;
2411	mpz_t char_len;
2412	gfc_se se;
2413
2414	/ Don't bother if we already know the length is a constant. /
2415	if (len && INTEGER_CST_P (len))
2416	return;
2417
2418	ts = &expr->symtree->n.sym->ts;
2419	for (ref = expr->ref; ref; ref = ref->next)
2420	{
2421	switch (ref->type)
2422	{
2423	case REF_ARRAY:
2424	/ Array references don't change the string length. /
2425	if (ts->deferred)
2426	get_array_ctor_all_strlen (block, e: expr, len);
2427	break;
2428
2429	case REF_COMPONENT:
2430	/ Use the length of the component. /
2431	ts = &ref->u.c.component->ts;
2432	break;
2433
2434	case REF_SUBSTRING:
2435	if (ref->u.ss.end == NULL
2436	\|\| ref->u.ss.start->expr_type != EXPR_CONSTANT
2437	\|\| ref->u.ss.end->expr_type != EXPR_CONSTANT)
2438	{
2439	/ Note that this might evaluate expr. /
2440	get_array_ctor_all_strlen (block, e: expr, len);
2441	return;
2442	}
2443	mpz_init_set_ui (char_len, `1`);
2444	mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
2445	mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
2446	*len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
2447	mpz_clear (char_len);
2448	return;
2449
2450	case REF_INQUIRY:
2451	break;
2452
2453	default:
2454	gcc_unreachable ();
2455	}
2456	}
2457
2458	/ A last ditch attempt that is sometimes needed for deferred characters. /
2459	if (!ts->u.cl->backend_decl)
2460	{
2461	gfc_init_se (&se, NULL);
2462	if (expr->rank)
2463	gfc_conv_expr_descriptor (&se, expr);
2464	else
2465	gfc_conv_expr (se: &se, expr);
2466	gcc_assert (se.string_length != NULL_TREE);
2467	gfc_add_block_to_block (block, &se.pre);
2468	ts->u.cl->backend_decl = se.string_length;
2469	}
2470
2471	*len = ts->u.cl->backend_decl;
2472	}
2473
2474
2475	/ Figure out the string length of a character array constructor.*
2476	If len is NULL, don't calculate the length; this happens for recursive calls
2477	when a sub-array-constructor is an element but not at the first position,
2478	so when we're not interested in the length.
2479	Returns TRUE if all elements are character constants. /*
2480
2481	bool
2482	get_array_ctor_strlen (stmtblock_t block, gfc_constructor_base base, tree len)
2483	{
2484	gfc_constructor *c;
2485	bool is_const;
2486
2487	is_const = true;
2488
2489	if (gfc_constructor_first (base) == NULL)
2490	{
2491	if (len)
2492	*len = build_int_cstu (type: gfc_charlen_type_node, `0`);
2493	return is_const;
2494	}
2495
2496	/ Loop over all constructor elements to find out is_const, but in len we*
2497	want to store the length of the first, not the last, element. We can
2498	of course exit the loop as soon as is_const is found to be false. /*
2499	for (c = gfc_constructor_first (base);
2500	c && is_const; c = gfc_constructor_next (ctor: c))
2501	{
2502	switch (c->expr->expr_type)
2503	{
2504	case EXPR_CONSTANT:
2505	if (len && !(len && INTEGER_CST_P (len)))
2506	*len = build_int_cstu (type: gfc_charlen_type_node,
2507	c->expr->value.character.length);
2508	break;
2509
2510	case EXPR_ARRAY:
2511	if (!get_array_ctor_strlen (block, base: c->expr->value.constructor, len))
2512	is_const = false;
2513	break;
2514
2515	case EXPR_VARIABLE:
2516	is_const = false;
2517	if (len)
2518	get_array_ctor_var_strlen (block, expr: c->expr, len);
2519	break;
2520
2521	default:
2522	is_const = false;
2523	if (len)
2524	get_array_ctor_all_strlen (block, e: c->expr, len);
2525	break;
2526	}
2527
2528	/ After the first iteration, we don't want the length modified. /
2529	len = NULL;
2530	}
2531
2532	return is_const;
2533	}
2534
2535	/ Check whether the array constructor C consists entirely of constant*
2536	elements, and if so returns the number of those elements, otherwise
2537	return zero. Note, an empty or NULL array constructor returns zero. /*
2538
2539	unsigned HOST_WIDE_INT
2540	gfc_constant_array_constructor_p (gfc_constructor_base base)
2541	{
2542	unsigned HOST_WIDE_INT nelem = `0`;
2543
2544	gfc_constructor *c = gfc_constructor_first (base);
2545	while (c)
2546	{
2547	if (c->iterator
2548	\|\| c->expr->rank > `0`
2549	\|\| c->expr->expr_type != EXPR_CONSTANT)
2550	return `0`;
2551	c = gfc_constructor_next (ctor: c);
2552	nelem++;
2553	}
2554	return nelem;
2555	}
2556
2557
2558	/ Given EXPR, the constant array constructor specified by an EXPR_ARRAY,*
2559	and the tree type of it's elements, TYPE, return a static constant
2560	variable that is compile-time initialized. /*
2561
2562	tree
2563	gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
2564	{
2565	tree tmptype, init, tmp;
2566	HOST_WIDE_INT nelem;
2567	gfc_constructor *c;
2568	gfc_array_spec as;
2569	gfc_se se;
2570	int i;
2571	vec<constructor_elt, va_gc> *v = NULL;
2572
2573	/ First traverse the constructor list, converting the constants*
2574	to tree to build an initializer. /*
2575	nelem = `0`;
2576	c = gfc_constructor_first (base: expr->value.constructor);
2577	while (c)
2578	{
2579	gfc_init_se (&se, NULL);
2580	gfc_conv_constant (&se, c->expr);
2581	if (c->expr->ts.type != BT_CHARACTER)
2582	se.expr = fold_convert (type, se.expr);
2583	else if (POINTER_TYPE_P (type))
2584	se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
2585	se.expr);
2586	CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
2587	se.expr);
2588	c = gfc_constructor_next (ctor: c);
2589	nelem++;
2590	}
2591
2592	/ Next determine the tree type for the array. We use the gfortran*
2593	front-end's gfc_get_nodesc_array_type in order to create a suitable
2594	GFC_ARRAY_TYPE_P that may be used by the scalarizer. /*
2595
2596	memset (s: &as, c: `0`, n: sizeof (gfc_array_spec));
2597
2598	as.rank = expr->rank;
2599	as.type = AS_EXPLICIT;
2600	if (!expr->shape)
2601	{
2602	as.lower[`0`] = gfc_get_int_expr (gfc_default_integer_kind, NULL, `0`);
2603	as.upper[`0`] = gfc_get_int_expr (gfc_default_integer_kind,
2604	NULL, nelem - `1`);
2605	}
2606	else
2607	for (i = `0`; i < expr->rank; i++)
2608	{
2609	int tmp = (int) mpz_get_si (expr->shape[i]);
2610	as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, `0`);
2611	as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
2612	NULL, tmp - `1`);
2613	}
2614
2615	tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
2616
2617	/ as is not needed anymore. /
2618	for (i = `0`; i < as.rank + as.corank; i++)
2619	{
2620	gfc_free_expr (as.lower[i]);
2621	gfc_free_expr (as.upper[i]);
2622	}
2623
2624	init = build_constructor (tmptype, v);
2625
2626	TREE_CONSTANT (init) = `1`;
2627	TREE_STATIC (init) = `1`;
2628
2629	tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
2630	tmptype);
2631	DECL_ARTIFICIAL (tmp) = `1`;
2632	DECL_IGNORED_P (tmp) = `1`;
2633	TREE_STATIC (tmp) = `1`;
2634	TREE_CONSTANT (tmp) = `1`;
2635	TREE_READONLY (tmp) = `1`;
2636	DECL_INITIAL (tmp) = init;
2637	pushdecl (tmp);
2638
2639	return tmp;
2640	}
2641
2642
2643	/ Translate a constant EXPR_ARRAY array constructor for the scalarizer.*
2644	This mostly initializes the scalarizer state info structure with the
2645	appropriate values to directly use the array created by the function
2646	gfc_build_constant_array_constructor. /*
2647
2648	static void
2649	trans_constant_array_constructor (gfc_ss * ss, tree type)
2650	{
2651	gfc_array_info *info;
2652	tree tmp;
2653	int i;
2654
2655	tmp = gfc_build_constant_array_constructor (expr: ss->info->expr, type);
2656
2657	info = &ss->info->data.array;
2658
2659	info->descriptor = tmp;
2660	info->data = gfc_build_addr_expr (NULL_TREE, tmp);
2661	info->offset = gfc_index_zero_node;
2662
2663	for (i = `0`; i < ss->dimen; i++)
2664	{
2665	info->delta[i] = gfc_index_zero_node;
2666	info->start[i] = gfc_index_zero_node;
2667	info->end[i] = gfc_index_zero_node;
2668	info->stride[i] = gfc_index_one_node;
2669	}
2670	}
2671
2672
2673	static int
2674	get_rank (gfc_loopinfo *loop)
2675	{
2676	int rank;
2677
2678	rank = `0`;
2679	for (; loop; loop = loop->parent)
2680	rank += loop->dimen;
2681
2682	return rank;
2683	}
2684
2685
2686	/ Helper routine of gfc_trans_array_constructor to determine if the*
2687	bounds of the loop specified by LOOP are constant and simple enough
2688	to use with trans_constant_array_constructor. Returns the
2689	iteration count of the loop if suitable, and NULL_TREE otherwise. /*
2690
2691	static tree
2692	constant_array_constructor_loop_size (gfc_loopinfo * l)
2693	{
2694	gfc_loopinfo *loop;
2695	tree size = gfc_index_one_node;
2696	tree tmp;
2697	int i, total_dim;
2698
2699	total_dim = get_rank (loop: l);
2700
2701	for (loop = l; loop; loop = loop->parent)
2702	{
2703	for (i = `0`; i < loop->dimen; i++)
2704	{
2705	/ If the bounds aren't constant, return NULL_TREE. /
2706	if (!INTEGER_CST_P (loop->from[i]) \|\| !INTEGER_CST_P (loop->to[i]))
2707	return NULL_TREE;
2708	if (!integer_zerop (loop->from[i]))
2709	{
2710	/ Only allow nonzero "from" in one-dimensional arrays. /
2711	if (total_dim != `1`)
2712	return NULL_TREE;
2713	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2714	gfc_array_index_type,
2715	loop->to[i], loop->from[i]);
2716	}
2717	else
2718	tmp = loop->to[i];
2719	tmp = fold_build2_loc (input_location, PLUS_EXPR,
2720	gfc_array_index_type, tmp, gfc_index_one_node);
2721	size = fold_build2_loc (input_location, MULT_EXPR,
2722	gfc_array_index_type, size, tmp);
2723	}
2724	}
2725
2726	return size;
2727	}
2728
2729
2730	static tree *
2731	get_loop_upper_bound_for_array (gfc_ss array, int* array_dim)
2732	{
2733	gfc_ss *ss;
2734	int n;
2735
2736	gcc_assert (array->nested_ss == NULL);
2737
2738	for (ss = array; ss; ss = ss->parent)
2739	for (n = `0`; n < ss->loop->dimen; n++)
2740	if (array_dim == get_array_ref_dim_for_loop_dim (ss, loop_dim: n))
2741	return &(ss->loop->to[n]);
2742
2743	gcc_unreachable ();
2744	}
2745
2746
2747	static gfc_loopinfo *
2748	outermost_loop (gfc_loopinfo * loop)
2749	{
2750	while (loop->parent != NULL)
2751	loop = loop->parent;
2752
2753	return loop;
2754	}
2755
2756
2757	/ Array constructors are handled by constructing a temporary, then using that*
2758	within the scalarization loop. This is not optimal, but seems by far the
2759	simplest method. /*
2760
2761	static void
2762	trans_array_constructor (gfc_ss * ss, locus * where)
2763	{
2764	gfc_constructor_base c;
2765	tree offset;
2766	tree offsetvar;
2767	tree desc;
2768	tree type;
2769	tree tmp;
2770	tree *loop_ubound0;
2771	bool dynamic;
2772	bool old_first_len, old_typespec_chararray_ctor;
2773	tree old_first_len_val;
2774	gfc_loopinfo loop, outer_loop;
2775	gfc_ss_info *ss_info;
2776	gfc_expr *expr;
2777	gfc_ss *s;
2778	tree neg_len;
2779	char *msg;
2780	stmtblock_t finalblock;
2781
2782	/ Save the old values for nested checking. /
2783	old_first_len = first_len;
2784	old_first_len_val = first_len_val;
2785	old_typespec_chararray_ctor = typespec_chararray_ctor;
2786
2787	loop = ss->loop;
2788	outer_loop = outermost_loop (loop);
2789	ss_info = ss->info;
2790	expr = ss_info->expr;
2791
2792	/ Do bounds-checking here and in gfc_trans_array_ctor_element only if no*
2793	typespec was given for the array constructor. /*
2794	typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
2795	&& expr->ts.u.cl
2796	&& expr->ts.u.cl->length_from_typespec);
2797
2798	if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2799	&& expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
2800	{
2801	first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
2802	first_len = true;
2803	}
2804
2805	gcc_assert (ss->dimen == ss->loop->dimen);
2806
2807	c = expr->value.constructor;
2808	if (expr->ts.type == BT_CHARACTER)
2809	{
2810	bool const_string;
2811	bool force_new_cl = false;
2812
2813	/ get_array_ctor_strlen walks the elements of the constructor, if a*
2814	typespec was given, we already know the string length and want the one
2815	specified there. /*
2816	if (typespec_chararray_ctor && expr->ts.u.cl->length
2817	&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2818	{
2819	gfc_se length_se;
2820
2821	const_string = false;
2822	gfc_init_se (&length_se, NULL);
2823	gfc_conv_expr_type (se: &length_se, expr->ts.u.cl->length,
2824	gfc_charlen_type_node);
2825	ss_info->string_length = length_se.expr;
2826
2827	/ Check if the character length is negative. If it is, then*
2828	set LEN = 0. /*
2829	neg_len = fold_build2_loc (input_location, LT_EXPR,
2830	logical_type_node, ss_info->string_length,
2831	build_zero_cst (TREE_TYPE
2832	(ss_info->string_length)));
2833	/ Print a warning if bounds checking is enabled. /
2834	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2835	{
2836	msg = xasprintf ("Negative character length treated as LEN = 0");
2837	gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
2838	where, msg);
2839	free (ptr: msg);
2840	}
2841
2842	ss_info->string_length
2843	= fold_build3_loc (input_location, COND_EXPR,
2844	gfc_charlen_type_node, neg_len,
2845	build_zero_cst
2846	(TREE_TYPE (ss_info->string_length)),
2847	ss_info->string_length);
2848	ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2849	&length_se.pre);
2850	gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2851	gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2852	}
2853	else
2854	{
2855	const_string = get_array_ctor_strlen (block: &outer_loop->pre, base: c,
2856	len: &ss_info->string_length);
2857	force_new_cl = true;
2858
2859	/ Initialize "len" with string length for bounds checking. /
2860	if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2861	&& !typespec_chararray_ctor
2862	&& ss_info->string_length)
2863	{
2864	gfc_se length_se;
2865
2866	gfc_init_se (&length_se, NULL);
2867	gfc_add_modify (&length_se.pre, first_len_val,
2868	fold_convert (TREE_TYPE (first_len_val),
2869	ss_info->string_length));
2870	ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
2871	&length_se.pre);
2872	gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
2873	gfc_add_block_to_block (&outer_loop->post, &length_se.post);
2874	}
2875	}
2876
2877	/ Complex character array constructors should have been taken care of*
2878	and not end up here. /*
2879	gcc_assert (ss_info->string_length);
2880
2881	store_backend_decl (clp: &expr->ts.u.cl, len: ss_info->string_length, force_new_cl);
2882
2883	type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
2884	if (const_string)
2885	type = build_pointer_type (type);
2886	}
2887	else
2888	type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
2889	? &CLASS_DATA (expr)->ts : &expr->ts);
2890
2891	/ See if the constructor determines the loop bounds. /
2892	dynamic = false;
2893
2894	loop_ubound0 = get_loop_upper_bound_for_array (array: ss, array_dim: `0`);
2895
2896	if (expr->shape && get_rank (loop) > `1` && *loop_ubound0 == NULL_TREE)
2897	{
2898	/ We have a multidimensional parameter. /
2899	for (s = ss; s; s = s->parent)
2900	{
2901	int n;
2902	for (n = `0`; n < s->loop->dimen; n++)
2903	{
2904	s->loop->from[n] = gfc_index_zero_node;
2905	s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
2906	gfc_index_integer_kind);
2907	s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
2908	gfc_array_index_type,
2909	s->loop->to[n],
2910	gfc_index_one_node);
2911	}
2912	}
2913	}
2914
2915	if (*loop_ubound0 == NULL_TREE)
2916	{
2917	mpz_t size;
2918
2919	/ We should have a 1-dimensional, zero-based loop. /
2920	gcc_assert (loop->parent == NULL && loop->nested == NULL);
2921	gcc_assert (loop->dimen == `1`);
2922	gcc_assert (integer_zerop (loop->from[`0`]));
2923
2924	/ Split the constructor size into a static part and a dynamic part.*
2925	Allocate the static size up-front and record whether the dynamic
2926	size might be nonzero. /*
2927	mpz_init (size);
2928	dynamic = gfc_get_array_constructor_size (size: &size, base: c);
2929	mpz_sub_ui (size, size, `1`);
2930	loop->to[`0`] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
2931	mpz_clear (size);
2932	}
2933
2934	/ Special case constant array constructors. /
2935	if (!dynamic)
2936	{
2937	unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (base: c);
2938	if (nelem > `0`)
2939	{
2940	tree size = constant_array_constructor_loop_size (l: loop);
2941	if (size && compare_tree_int (size, nelem) == `0`)
2942	{
2943	trans_constant_array_constructor (ss, type);
2944	goto finish;
2945	}
2946	}
2947	}
2948
2949	gfc_trans_create_temp_array (pre: &outer_loop->pre, post: &outer_loop->post, ss, eltype: type,
2950	NULL_TREE, dynamic, dealloc: true, callee_alloc: false, where);
2951
2952	desc = ss_info->data.array.descriptor;
2953	offset = gfc_index_zero_node;
2954	offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
2955	suppress_warning (offsetvar);
2956	TREE_USED (offsetvar) = `0`;
2957
2958	gfc_init_block (&finalblock);
2959	gfc_trans_array_constructor_value (pblock: &outer_loop->pre,
2960	finalblock: expr->must_finalize ? &finalblock : NULL,
2961	type, desc, base: c, poffset: &offset, offsetvar: &offsetvar,
2962	dynamic);
2963
2964	/ If the array grows dynamically, the upper bound of the loop variable*
2965	is determined by the array's final upper bound. /*
2966	if (dynamic)
2967	{
2968	tmp = fold_build2_loc (input_location, MINUS_EXPR,
2969	gfc_array_index_type,
2970	offsetvar, gfc_index_one_node);
2971	tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
2972	gfc_conv_descriptor_ubound_set (block: &loop->pre, desc, dim: gfc_rank_cst[`0`], value: tmp);
2973	if (loop_ubound0 && VAR_P (loop_ubound0))
2974	gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
2975	else
2976	*loop_ubound0 = tmp;
2977	}
2978
2979	if (TREE_USED (offsetvar))
2980	pushdecl (offsetvar);
2981	else
2982	gcc_assert (INTEGER_CST_P (offset));
2983
2984	#if 0
2985	/ Disable bound checking for now because it's probably broken. /
2986	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2987	{
2988	gcc_unreachable ();
2989	}
2990	#endif
2991
2992	finish:
2993	/ Restore old values of globals. /
2994	first_len = old_first_len;
2995	first_len_val = old_first_len_val;
2996	typespec_chararray_ctor = old_typespec_chararray_ctor;
2997
2998	/ F2008 4.5.6.3 para 5: If an executable construct references a structure*
2999	constructor or array constructor, the entity created by the constructor is
3000	finalized after execution of the innermost executable construct containing
3001	the reference. /*
3002	if ((expr->ts.type == BT_DERIVED \|\| expr->ts.type == BT_CLASS)
3003	&& finalblock.head != NULL_TREE)
3004	gfc_add_block_to_block (&loop->post, &finalblock);
3005
3006	}
3007
3008
3009	/ INFO describes a GFC_SS_SECTION in loop LOOP, and this function is*
3010	called after evaluating all of INFO's vector dimensions. Go through
3011	each such vector dimension and see if we can now fill in any missing
3012	loop bounds. /*
3013
3014	static void
3015	set_vector_loop_bounds (gfc_ss * ss)
3016	{
3017	gfc_loopinfo loop, outer_loop;
3018	gfc_array_info *info;
3019	gfc_se se;
3020	tree tmp;
3021	tree desc;
3022	tree zero;
3023	int n;
3024	int dim;
3025
3026	outer_loop = outermost_loop (loop: ss->loop);
3027
3028	info = &ss->info->data.array;
3029
3030	for (; ss; ss = ss->parent)
3031	{
3032	loop = ss->loop;
3033
3034	for (n = `0`; n < loop->dimen; n++)
3035	{
3036	dim = ss->dim[n];
3037	if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
3038	\|\| loop->to[n] != NULL)
3039	continue;
3040
3041	/ Loop variable N indexes vector dimension DIM, and we don't*
3042	yet know the upper bound of loop variable N. Set it to the
3043	difference between the vector's upper and lower bounds. /*
3044	gcc_assert (loop->from[n] == gfc_index_zero_node);
3045	gcc_assert (info->subscript[dim]
3046	&& info->subscript[dim]->info->type == GFC_SS_VECTOR);
3047
3048	gfc_init_se (&se, NULL);
3049	desc = info->subscript[dim]->info->data.array.descriptor;
3050	zero = gfc_rank_cst[`0`];
3051	tmp = fold_build2_loc (input_location, MINUS_EXPR,
3052	gfc_array_index_type,
3053	gfc_conv_descriptor_ubound_get (desc, dim: zero),
3054	gfc_conv_descriptor_lbound_get (desc, dim: zero));
3055	tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
3056	loop->to[n] = tmp;
3057	}
3058	}
3059	}
3060
3061
3062	/ Tells whether a scalar argument to an elemental procedure is saved out*
3063	of a scalarization loop as a value or as a reference. /*
3064
3065	bool
3066	gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
3067	{
3068	if (ss_info->type != GFC_SS_REFERENCE)
3069	return false;
3070
3071	if (ss_info->data.scalar.needs_temporary)
3072	return false;
3073
3074	/ If the actual argument can be absent (in other words, it can*
3075	be a NULL reference), don't try to evaluate it; pass instead
3076	the reference directly. /*
3077	if (ss_info->can_be_null_ref)
3078	return true;
3079
3080	/ If the expression is of polymorphic type, it's actual size is not known,*
3081	so we avoid copying it anywhere. /*
3082	if (ss_info->data.scalar.dummy_arg
3083	&& gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
3084	== BT_CLASS
3085	&& ss_info->expr->ts.type == BT_CLASS)
3086	return true;
3087
3088	/ If the expression is a data reference of aggregate type,*
3089	and the data reference is not used on the left hand side,
3090	avoid a copy by saving a reference to the content. /*
3091	if (!ss_info->data.scalar.needs_temporary
3092	&& (ss_info->expr->ts.type == BT_DERIVED
3093	\|\| ss_info->expr->ts.type == BT_CLASS)
3094	&& gfc_expr_is_variable (ss_info->expr))
3095	return true;
3096
3097	/ Otherwise the expression is evaluated to a temporary variable before the*
3098	scalarization loop. /*
3099	return false;
3100	}
3101
3102
3103	/ Add the pre and post chains for all the scalar expressions in a SS chain*
3104	to loop. This is called after the loop parameters have been calculated,
3105	but before the actual scalarizing loops. /*
3106
3107	static void
3108	gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
3109	locus * where)
3110	{
3111	gfc_loopinfo nested_loop, outer_loop;
3112	gfc_se se;
3113	gfc_ss_info *ss_info;
3114	gfc_array_info *info;
3115	gfc_expr *expr;
3116	int n;
3117
3118	/ Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,*
3119	arguments could get evaluated multiple times. /*
3120	if (ss->is_alloc_lhs)
3121	return;
3122
3123	outer_loop = outermost_loop (loop);
3124
3125	/ TODO: This can generate bad code if there are ordering dependencies,*
3126	e.g., a callee allocated function and an unknown size constructor. /*
3127	gcc_assert (ss != NULL);
3128
3129	for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
3130	{
3131	gcc_assert (ss);
3132
3133	/ Cross loop arrays are handled from within the most nested loop. /
3134	if (ss->nested_ss != NULL)
3135	continue;
3136
3137	ss_info = ss->info;
3138	expr = ss_info->expr;
3139	info = &ss_info->data.array;
3140
3141	switch (ss_info->type)
3142	{
3143	case GFC_SS_SCALAR:
3144	/ Scalar expression. Evaluate this now. This includes elemental*
3145	dimension indices, but not array section bounds. /*
3146	gfc_init_se (&se, NULL);
3147	gfc_conv_expr (se: &se, expr);
3148	gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3149
3150	if (expr->ts.type != BT_CHARACTER
3151	&& !gfc_is_alloc_class_scalar_function (expr))
3152	{
3153	/ Move the evaluation of scalar expressions outside the*
3154	scalarization loop, except for WHERE assignments. /*
3155	if (subscript)
3156	se.expr = convert(gfc_array_index_type, se.expr);
3157	if (!ss_info->where)
3158	se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
3159	gfc_add_block_to_block (&outer_loop->pre, &se.post);
3160	}
3161	else
3162	gfc_add_block_to_block (&outer_loop->post, &se.post);
3163
3164	ss_info->data.scalar.value = se.expr;
3165	ss_info->string_length = se.string_length;
3166	break;
3167
3168	case GFC_SS_REFERENCE:
3169	/ Scalar argument to elemental procedure. /
3170	gfc_init_se (&se, NULL);
3171	if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
3172	gfc_conv_expr_reference (se: &se, expr);
3173	else
3174	{
3175	/ Evaluate the argument outside the loop and pass*
3176	a reference to the value. /*
3177	gfc_conv_expr (se: &se, expr);
3178	}
3179
3180	/ Ensure that a pointer to the string is stored. /
3181	if (expr->ts.type == BT_CHARACTER)
3182	gfc_conv_string_parameter (se: &se);
3183
3184	gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3185	gfc_add_block_to_block (&outer_loop->post, &se.post);
3186	if (gfc_is_class_scalar_expr (expr))
3187	/ This is necessary because the dynamic type will always be*
3188	large than the declared type. In consequence, assigning
3189	the value to a temporary could segfault.
3190	OOP-TODO: see if this is generally correct or is the value
3191	has to be written to an allocated temporary, whose address
3192	is passed via ss_info. /*
3193	ss_info->data.scalar.value = se.expr;
3194	else
3195	ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
3196	&outer_loop->pre);
3197
3198	ss_info->string_length = se.string_length;
3199	break;
3200
3201	case GFC_SS_SECTION:
3202	/ Add the expressions for scalar and vector subscripts. /
3203	for (n = `0`; n < GFC_MAX_DIMENSIONS; n++)
3204	if (info->subscript[n])
3205	gfc_add_loop_ss_code (loop, ss: info->subscript[n], subscript: true, where);
3206
3207	set_vector_loop_bounds (ss);
3208	break;
3209
3210	case GFC_SS_VECTOR:
3211	/ Get the vector's descriptor and store it in SS. /
3212	gfc_init_se (&se, NULL);
3213	gfc_conv_expr_descriptor (&se, expr);
3214	gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3215	gfc_add_block_to_block (&outer_loop->post, &se.post);
3216	info->descriptor = se.expr;
3217	break;
3218
3219	case GFC_SS_INTRINSIC:
3220	gfc_add_intrinsic_ss_code (loop, ss);
3221	break;
3222
3223	case GFC_SS_FUNCTION:
3224	/ Array function return value. We call the function and save its*
3225	result in a temporary for use inside the loop. /*
3226	gfc_init_se (&se, NULL);
3227	se.loop = loop;
3228	se.ss = ss;
3229	if (gfc_is_class_array_function (expr))
3230	expr->must_finalize = `1`;
3231	gfc_conv_expr (se: &se, expr);
3232	gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3233	gfc_add_block_to_block (&outer_loop->post, &se.post);
3234	gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
3235	ss_info->string_length = se.string_length;
3236	break;
3237
3238	case GFC_SS_CONSTRUCTOR:
3239	if (expr->ts.type == BT_CHARACTER
3240	&& ss_info->string_length == NULL
3241	&& expr->ts.u.cl
3242	&& expr->ts.u.cl->length
3243	&& expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
3244	{
3245	gfc_init_se (&se, NULL);
3246	gfc_conv_expr_type (se: &se, expr->ts.u.cl->length,
3247	gfc_charlen_type_node);
3248	ss_info->string_length = se.expr;
3249	gfc_add_block_to_block (&outer_loop->pre, &se.pre);
3250	gfc_add_block_to_block (&outer_loop->post, &se.post);
3251	}
3252	trans_array_constructor (ss, where);
3253	break;
3254
3255	case GFC_SS_TEMP:
3256	case GFC_SS_COMPONENT:
3257	/ Do nothing. These are handled elsewhere. /
3258	break;
3259
3260	default:
3261	gcc_unreachable ();
3262	}
3263	}
3264
3265	if (!subscript)
3266	for (nested_loop = loop->nested; nested_loop;
3267	nested_loop = nested_loop->next)
3268	gfc_add_loop_ss_code (loop: nested_loop, ss: nested_loop->ss, subscript, where);
3269	}
3270
3271
3272	/ Translate expressions for the descriptor and data pointer of a SS. /
3273	/GCC ARRAYS/
3274
3275	static void
3276	gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
3277	{
3278	gfc_se se;
3279	gfc_ss_info *ss_info;
3280	gfc_array_info *info;
3281	tree tmp;
3282
3283	ss_info = ss->info;
3284	info = &ss_info->data.array;
3285
3286	/ Get the descriptor for the array to be scalarized. /
3287	gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE);
3288	gfc_init_se (&se, NULL);
3289	se.descriptor_only = `1`;
3290	gfc_conv_expr_lhs (se: &se, expr: ss_info->expr);
3291	gfc_add_block_to_block (block, &se.pre);
3292	info->descriptor = se.expr;
3293	ss_info->string_length = se.string_length;
3294	ss_info->class_container = se.class_container;
3295
3296	if (base)
3297	{
3298	if (ss_info->expr->ts.type == BT_CHARACTER && !ss_info->expr->ts.deferred
3299	&& ss_info->expr->ts.u.cl->length == NULL)
3300	{
3301	/ Emit a DECL_EXPR for the variable sized array type in*
3302	GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
3303	sizes works correctly. /*
3304	tree arraytype = TREE_TYPE (
3305	GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (info->descriptor)));
3306	if (! TYPE_NAME (arraytype))
3307	TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
3308	NULL_TREE, arraytype);
3309	gfc_add_expr_to_block (block, build1 (DECL_EXPR, arraytype,
3310	TYPE_NAME (arraytype)));
3311	}
3312	/ Also the data pointer. /
3313	tmp = gfc_conv_array_data (se.expr);
3314	/ If this is a variable or address or a class array, use it directly.*
3315	Otherwise we must evaluate it now to avoid breaking dependency
3316	analysis by pulling the expressions for elemental array indices
3317	inside the loop. /*
3318	if (!(DECL_P (tmp)
3319	\|\| (TREE_CODE (tmp) == ADDR_EXPR
3320	&& DECL_P (TREE_OPERAND (tmp, `0`)))
3321	\|\| (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
3322	&& TREE_CODE (se.expr) == COMPONENT_REF
3323	&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, `0`))))))
3324	tmp = gfc_evaluate_now (tmp, block);
3325	info->data = tmp;
3326
3327	tmp = gfc_conv_array_offset (se.expr);
3328	info->offset = gfc_evaluate_now (tmp, block);
3329
3330	/ Make absolutely sure that the saved_offset is indeed saved*
3331	so that the variable is still accessible after the loops
3332	are translated. /*
3333	info->saved_offset = info->offset;
3334	}
3335	}
3336
3337
3338	/ Initialize a gfc_loopinfo structure. /
3339
3340	void
3341	gfc_init_loopinfo (gfc_loopinfo * loop)
3342	{
3343	int n;
3344
3345	memset (s: loop, c: `0`, n: sizeof (gfc_loopinfo));
3346	gfc_init_block (&loop->pre);
3347	gfc_init_block (&loop->post);
3348
3349	/ Initially scalarize in order and default to no loop reversal. /
3350	for (n = `0`; n < GFC_MAX_DIMENSIONS; n++)
3351	{
3352	loop->order[n] = n;
3353	loop->reverse[n] = GFC_INHIBIT_REVERSE;
3354	}
3355
3356	loop->ss = gfc_ss_terminator;
3357	}
3358
3359
3360	/ Copies the loop variable info to a gfc_se structure. Does not copy the SS*
3361	chain. /*
3362
3363	void
3364	gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
3365	{
3366	se->loop = loop;
3367	}
3368
3369
3370	/ Return an expression for the data pointer of an array. /
3371
3372	tree
3373	gfc_conv_array_data (tree descriptor)
3374	{
3375	tree type;
3376
3377	type = TREE_TYPE (descriptor);
3378	if (GFC_ARRAY_TYPE_P (type))
3379	{
3380	if (TREE_CODE (type) == POINTER_TYPE)
3381	return descriptor;
3382	else
3383	{
3384	/ Descriptorless arrays. /
3385	return gfc_build_addr_expr (NULL_TREE, descriptor);
3386	}
3387	}
3388	else
3389	return gfc_conv_descriptor_data_get (desc: descriptor);
3390	}
3391
3392
3393	/ Return an expression for the base offset of an array. /
3394
3395	tree
3396	gfc_conv_array_offset (tree descriptor)
3397	{
3398	tree type;
3399
3400	type = TREE_TYPE (descriptor);
3401	if (GFC_ARRAY_TYPE_P (type))
3402	return GFC_TYPE_ARRAY_OFFSET (type);
3403	else
3404	return gfc_conv_descriptor_offset_get (desc: descriptor);
3405	}
3406
3407
3408	/ Get an expression for the array stride. /
3409
3410	tree
3411	gfc_conv_array_stride (tree descriptor, int dim)
3412	{
3413	tree tmp;
3414	tree type;
3415
3416	type = TREE_TYPE (descriptor);
3417
3418	/ For descriptorless arrays use the array size. /
3419	tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
3420	if (tmp != NULL_TREE)
3421	return tmp;
3422
3423	tmp = gfc_conv_descriptor_stride_get (desc: descriptor, dim: gfc_rank_cst[dim]);
3424	return tmp;
3425	}
3426
3427
3428	/ Like gfc_conv_array_stride, but for the lower bound. /
3429
3430	tree
3431	gfc_conv_array_lbound (tree descriptor, int dim)
3432	{
3433	tree tmp;
3434	tree type;
3435
3436	type = TREE_TYPE (descriptor);
3437
3438	tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
3439	if (tmp != NULL_TREE)
3440	return tmp;
3441
3442	tmp = gfc_conv_descriptor_lbound_get (desc: descriptor, dim: gfc_rank_cst[dim]);
3443	return tmp;
3444	}
3445
3446
3447	/ Like gfc_conv_array_stride, but for the upper bound. /
3448
3449	tree
3450	gfc_conv_array_ubound (tree descriptor, int dim)
3451	{
3452	tree tmp;
3453	tree type;
3454
3455	type = TREE_TYPE (descriptor);
3456
3457	tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
3458	if (tmp != NULL_TREE)
3459	return tmp;
3460
3461	/ This should only ever happen when passing an assumed shape array*
3462	as an actual parameter. The value will never be used. /*
3463	if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
3464	return gfc_index_zero_node;
3465
3466	tmp = gfc_conv_descriptor_ubound_get (desc: descriptor, dim: gfc_rank_cst[dim]);
3467	return tmp;
3468	}
3469
3470
3471	/ Generate code to perform an array index bound check. /
3472
3473	static tree
3474	trans_array_bound_check (gfc_se * se, gfc_ss ss, tree index, int* n,
3475	locus * where, bool check_upper,
3476	const char *compname = NULL)
3477	{
3478	tree fault;
3479	tree tmp_lo, tmp_up;
3480	tree descriptor;
3481	char *msg;
3482	const char * name = NULL;
3483
3484	if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
3485	return index;
3486
3487	descriptor = ss->info->data.array.descriptor;
3488
3489	index = gfc_evaluate_now (index, &se->pre);
3490
3491	/ We find a name for the error message. /
3492	name = ss->info->expr->symtree->n.sym->name;
3493	gcc_assert (name != NULL);
3494
3495	if (VAR_P (descriptor))
3496	name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
3497
3498	/ Use given (array component) name. /
3499	if (compname)
3500	name = compname;
3501
3502	/ If upper bound is present, include both bounds in the error message. /
3503	if (check_upper)
3504	{
3505	tmp_lo = gfc_conv_array_lbound (descriptor, dim: n);
3506	tmp_up = gfc_conv_array_ubound (descriptor, dim: n);
3507
3508	if (name)
3509	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3510	"outside of expected range (%%ld:%%ld)", n+`1`, name);
3511	else
3512	msg = xasprintf ("Index '%%ld' of dimension %d "
3513	"outside of expected range (%%ld:%%ld)", n+`1`);
3514
3515	fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3516	index, tmp_lo);
3517	gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3518	fold_convert (long_integer_type_node, index),
3519	fold_convert (long_integer_type_node, tmp_lo),
3520	fold_convert (long_integer_type_node, tmp_up));
3521	fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3522	index, tmp_up);
3523	gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3524	fold_convert (long_integer_type_node, index),
3525	fold_convert (long_integer_type_node, tmp_lo),
3526	fold_convert (long_integer_type_node, tmp_up));
3527	free (ptr: msg);
3528	}
3529	else
3530	{
3531	tmp_lo = gfc_conv_array_lbound (descriptor, dim: n);
3532
3533	if (name)
3534	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
3535	"below lower bound of %%ld", n+`1`, name);
3536	else
3537	msg = xasprintf ("Index '%%ld' of dimension %d "
3538	"below lower bound of %%ld", n+`1`);
3539
3540	fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
3541	index, tmp_lo);
3542	gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
3543	fold_convert (long_integer_type_node, index),
3544	fold_convert (long_integer_type_node, tmp_lo));
3545	free (ptr: msg);
3546	}
3547
3548	return index;
3549	}
3550
3551
3552	/ Generate code for bounds checking for elemental dimensions. /
3553
3554	static void
3555	array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
3556	{
3557	gfc_array_ref *ar;
3558	gfc_ref *ref;
3559	gfc_symbol *sym;
3560	char *var_name = NULL;
3561	size_t len;
3562	int dim;
3563
3564	if (expr->expr_type == EXPR_VARIABLE)
3565	{
3566	sym = expr->symtree->n.sym;
3567	len = strlen (s: sym->name) + `1`;
3568
3569	for (ref = expr->ref; ref; ref = ref->next)
3570	if (ref->type == REF_COMPONENT)
3571	len += `2` + strlen (s: ref->u.c.component->name);
3572
3573	var_name = XALLOCAVEC (char, len);
3574	strcpy (dest: var_name, src: sym->name);
3575
3576	for (ref = expr->ref; ref; ref = ref->next)
3577	{
3578	/ Append component name. /
3579	if (ref->type == REF_COMPONENT)
3580	{
3581	strcat (dest: var_name, src: "%%");
3582	strcat (dest: var_name, src: ref->u.c.component->name);
3583	continue;
3584	}
3585
3586	if (ref->type == REF_ARRAY && ref->u.ar.dimen > `0`)
3587	{
3588	ar = &ref->u.ar;
3589	for (dim = `0`; dim < ar->dimen; dim++)
3590	{
3591	if (ar->dimen_type[dim] == DIMEN_ELEMENT)
3592	{
3593	gfc_se indexse;
3594	gfc_init_se (&indexse, NULL);
3595	gfc_conv_expr_type (se: &indexse, ar->start[dim],
3596	gfc_array_index_type);
3597	trans_array_bound_check (se, ss, index: indexse.expr, n: dim,
3598	where: &ar->where,
3599	check_upper: ar->as->type != AS_ASSUMED_SIZE
3600	\|\| dim < ar->dimen - `1`,
3601	compname: var_name);
3602	}
3603	}
3604	}
3605	}
3606	}
3607	}
3608
3609
3610	/ Return the offset for an index. Performs bound checking for elemental*
3611	dimensions. Single element references are processed separately.
3612	DIM is the array dimension, I is the loop dimension. /*
3613
3614	static tree
3615	conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
3616	gfc_array_ref * ar, tree stride)
3617	{
3618	gfc_array_info *info;
3619	tree index;
3620	tree desc;
3621	tree data;
3622
3623	info = &ss->info->data.array;
3624
3625	/ Get the index into the array for this dimension. /
3626	if (ar)
3627	{
3628	gcc_assert (ar->type != AR_ELEMENT);
3629	switch (ar->dimen_type[dim])
3630	{
3631	case DIMEN_THIS_IMAGE:
3632	gcc_unreachable ();
3633	break;
3634	case DIMEN_ELEMENT:
3635	/ Elemental dimension. /
3636	gcc_assert (info->subscript[dim]
3637	&& info->subscript[dim]->info->type == GFC_SS_SCALAR);
3638	/ We've already translated this value outside the loop. /
3639	index = info->subscript[dim]->info->data.scalar.value;
3640
3641	index = trans_array_bound_check (se, ss, index, n: dim, where: &ar->where,
3642	check_upper: ar->as->type != AS_ASSUMED_SIZE
3643	\|\| dim < ar->dimen - `1`);
3644	break;
3645
3646	case DIMEN_VECTOR:
3647	gcc_assert (info && se->loop);
3648	gcc_assert (info->subscript[dim]
3649	&& info->subscript[dim]->info->type == GFC_SS_VECTOR);
3650	desc = info->subscript[dim]->info->data.array.descriptor;
3651
3652	/ Get a zero-based index into the vector. /
3653	index = fold_build2_loc (input_location, MINUS_EXPR,
3654	gfc_array_index_type,
3655	se->loop->loopvar[i], se->loop->from[i]);
3656
3657	/ Multiply the index by the stride. /
3658	index = fold_build2_loc (input_location, MULT_EXPR,
3659	gfc_array_index_type,
3660	index, gfc_conv_array_stride (descriptor: desc, dim: `0`));
3661
3662	/ Read the vector to get an index into info->descriptor. /
3663	data = build_fold_indirect_ref_loc (input_location,
3664	gfc_conv_array_data (descriptor: desc));
3665	index = gfc_build_array_ref (data, index, NULL);
3666	index = gfc_evaluate_now (index, &se->pre);
3667	index = fold_convert (gfc_array_index_type, index);
3668
3669	/ Do any bounds checking on the final info->descriptor index. /
3670	index = trans_array_bound_check (se, ss, index, n: dim, where: &ar->where,
3671	check_upper: ar->as->type != AS_ASSUMED_SIZE
3672	\|\| dim < ar->dimen - `1`);
3673	break;
3674
3675	case DIMEN_RANGE:
3676	/ Scalarized dimension. /
3677	gcc_assert (info && se->loop);
3678
3679	/ Multiply the loop variable by the stride and delta. /
3680	index = se->loop->loopvar[i];
3681	if (!integer_onep (info->stride[dim]))
3682	index = fold_build2_loc (input_location, MULT_EXPR,
3683	gfc_array_index_type, index,
3684	info->stride[dim]);
3685	if (!integer_zerop (info->delta[dim]))
3686	index = fold_build2_loc (input_location, PLUS_EXPR,
3687	gfc_array_index_type, index,
3688	info->delta[dim]);
3689	break;
3690
3691	default:
3692	gcc_unreachable ();
3693	}
3694	}
3695	else
3696	{
3697	/ Temporary array or derived type component. /
3698	gcc_assert (se->loop);
3699	index = se->loop->loopvar[se->loop->order[i]];
3700
3701	/ Pointer functions can have stride[0] different from unity.*
3702	Use the stride returned by the function call and stored in
3703	the descriptor for the temporary. /*
3704	if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
3705	&& se->ss->info->expr
3706	&& se->ss->info->expr->symtree
3707	&& se->ss->info->expr->symtree->n.sym->result
3708	&& se->ss->info->expr->symtree->n.sym->result->attr.pointer)
3709	stride = gfc_conv_descriptor_stride_get (desc: info->descriptor,
3710	dim: gfc_rank_cst[dim]);
3711
3712	if (info->delta[dim] && !integer_zerop (info->delta[dim]))
3713	index = fold_build2_loc (input_location, PLUS_EXPR,
3714	gfc_array_index_type, index, info->delta[dim]);
3715	}
3716
3717	/ Multiply by the stride. /
3718	if (stride != NULL && !integer_onep (stride))
3719	index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3720	index, stride);
3721
3722	return index;
3723	}
3724
3725
3726	/ Build a scalarized array reference using the vptr 'size'. /
3727
3728	static bool
3729	build_class_array_ref (gfc_se *se, tree base, tree index)
3730	{
3731	tree size;
3732	tree decl = NULL_TREE;
3733	tree tmp;
3734	gfc_expr *expr = se->ss->info->expr;
3735	gfc_expr *class_expr;
3736	gfc_typespec *ts;
3737	gfc_symbol *sym;
3738
3739	tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
3740
3741	if (tmp != NULL_TREE)
3742	decl = tmp;
3743	else
3744	{
3745	/ The base expression does not contain a class component, either*
3746	because it is a temporary array or array descriptor. Class
3747	array functions are correctly resolved above. /*
3748	if (!expr
3749	\|\| (expr->ts.type != BT_CLASS
3750	&& !gfc_is_class_array_ref (expr, NULL)))
3751	return false;
3752
3753	/ Obtain the expression for the class entity or component that is*
3754	followed by an array reference, which is not an element, so that
3755	the span of the array can be obtained. /*
3756	class_expr = gfc_find_and_cut_at_last_class_ref (expr, is_mold: false, ts: &ts);
3757
3758	if (!ts)
3759	return false;
3760
3761	sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
3762	if (sym && sym->attr.function
3763	&& sym == sym->result
3764	&& sym->backend_decl == current_function_decl)
3765	/ The temporary is the data field of the class data component*
3766	of the current function. /*
3767	decl = gfc_get_fake_result_decl (sym, `0`);
3768	else if (sym)
3769	{
3770	if (decl == NULL_TREE)
3771	decl = expr->symtree->n.sym->backend_decl;
3772	/ For class arrays the tree containing the class is stored in*
3773	GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
3774	For all others it's sym's backend_decl directly. /*
3775	if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
3776	decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
3777	}
3778	else
3779	decl = gfc_get_class_from_gfc_expr (class_expr);
3780
3781	if (POINTER_TYPE_P (TREE_TYPE (decl)))
3782	decl = build_fold_indirect_ref_loc (input_location, decl);
3783
3784	if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
3785	return false;
3786	}
3787
3788	se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
3789
3790	size = gfc_class_vtab_size_get (decl);
3791	/ For unlimited polymorphic entities then _len component needs to be*
3792	multiplied with the size. /*
3793	size = gfc_resize_class_size_with_len (&se->pre, decl, size);
3794	size = fold_convert (TREE_TYPE (index), size);
3795
3796	/ Return the element in the se expression. /
3797	se->expr = gfc_build_spanned_array_ref (base, offset: index, span: size);
3798	return true;
3799	}
3800
3801
3802	/ Indicates that the tree EXPR is a reference to an array that can’t*
3803	have any negative stride. /*
3804
3805	static bool
3806	non_negative_strides_array_p (tree expr)
3807	{
3808	if (expr == NULL_TREE)
3809	return false;
3810
3811	tree type = TREE_TYPE (expr);
3812	if (POINTER_TYPE_P (type))
3813	type = TREE_TYPE (type);
3814
3815	if (TYPE_LANG_SPECIFIC (type))
3816	{
3817	gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
3818
3819	if (array_kind == GFC_ARRAY_ALLOCATABLE
3820	\|\| array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
3821	return true;
3822	}
3823
3824	/ An array with descriptor can have negative strides.*
3825	We try to be conservative and return false by default here
3826	if we don’t recognize a contiguous array instead of
3827	returning false if we can identify a non-contiguous one. /*
3828	if (!GFC_ARRAY_TYPE_P (type))
3829	return false;
3830
3831	/ If the array was originally a dummy with a descriptor, strides can be*
3832	negative. /*
3833	if (DECL_P (expr)
3834	&& DECL_LANG_SPECIFIC (expr)
3835	&& GFC_DECL_SAVED_DESCRIPTOR (expr)
3836	&& GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
3837	return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
3838
3839	return true;
3840	}
3841
3842
3843	/ Build a scalarized reference to an array. /
3844
3845	static void
3846	gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
3847	bool tmp_array = false)
3848	{
3849	gfc_array_info *info;
3850	tree decl = NULL_TREE;
3851	tree index;
3852	tree base;
3853	gfc_ss *ss;
3854	gfc_expr *expr;
3855	int n;
3856
3857	ss = se->ss;
3858	expr = ss->info->expr;
3859	info = &ss->info->data.array;
3860	if (ar)
3861	n = se->loop->order[`0`];
3862	else
3863	n = `0`;
3864
3865	index = conv_array_index_offset (se, ss, dim: ss->dim[n], i: n, ar, stride: info->stride0);
3866	/ Add the offset for this dimension to the stored offset for all other*
3867	dimensions. /*
3868	if (info->offset && !integer_zerop (info->offset))
3869	index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3870	index, info->offset);
3871
3872	base = build_fold_indirect_ref_loc (input_location, info->data);
3873
3874	/ Use the vptr 'size' field to access the element of a class array. /
3875	if (build_class_array_ref (se, base, index))
3876	return;
3877
3878	if (get_CFI_desc (NULL, expr, desc: &decl, ar))
3879	decl = build_fold_indirect_ref_loc (input_location, decl);
3880
3881	/ A pointer array component can be detected from its field decl. Fix*
3882	the descriptor, mark the resulting variable decl and pass it to
3883	gfc_build_array_ref. /*
3884	if (is_pointer_array (expr: info->descriptor)
3885	\|\| (expr && expr->ts.deferred && info->descriptor
3886	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
3887	{
3888	if (TREE_CODE (info->descriptor) == COMPONENT_REF)
3889	decl = info->descriptor;
3890	else if (INDIRECT_REF_P (info->descriptor))
3891	decl = TREE_OPERAND (info->descriptor, `0`);
3892
3893	if (decl == NULL_TREE)
3894	decl = info->descriptor;
3895	}
3896
3897	bool non_negative_stride = tmp_array
3898	\|\| non_negative_strides_array_p (expr: info->descriptor);
3899	se->expr = gfc_build_array_ref (base, index, decl,
3900	non_negative_offset: non_negative_stride);
3901	}
3902
3903
3904	/ Translate access of temporary array. /
3905
3906	void
3907	gfc_conv_tmp_array_ref (gfc_se * se)
3908	{
3909	se->string_length = se->ss->info->string_length;
3910	gfc_conv_scalarized_array_ref (se, NULL, tmp_array: true);
3911	gfc_advance_se_ss_chain (se);
3912	}
3913
3914	/ Add T to the offset pair OFFSET, CST_OFFSET. /
3915
3916	static void
3917	add_to_offset (tree cst_offset, tree offset, tree t)
3918	{
3919	if (TREE_CODE (t) == INTEGER_CST)
3920	cst_offset = int_const_binop (PLUS_EXPR, cst_offset, t);
3921	else
3922	{
3923	if (!integer_zerop (*offset))
3924	*offset = fold_build2_loc (input_location, PLUS_EXPR,
3925	gfc_array_index_type, *offset, t);
3926	else
3927	*offset = t;
3928	}
3929	}
3930
3931
3932	static tree
3933	build_array_ref (tree desc, tree offset, tree decl, tree vptr)
3934	{
3935	tree tmp;
3936	tree type;
3937	tree cdesc;
3938
3939	/ For class arrays the class declaration is stored in the saved*
3940	descriptor. /*
3941	if (INDIRECT_REF_P (desc)
3942	&& DECL_LANG_SPECIFIC (TREE_OPERAND (desc, `0`))
3943	&& GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, `0`)))
3944	cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
3945	TREE_OPERAND (desc, `0`)));
3946	else
3947	cdesc = desc;
3948
3949	/ Class container types do not always have the GFC_CLASS_TYPE_P*
3950	but the canonical type does. /*
3951	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
3952	&& TREE_CODE (cdesc) == COMPONENT_REF)
3953	{
3954	type = TREE_TYPE (TREE_OPERAND (cdesc, `0`));
3955	if (TYPE_CANONICAL (type)
3956	&& GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
3957	vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, `0`));
3958	}
3959
3960	tmp = gfc_conv_array_data (descriptor: desc);
3961	tmp = build_fold_indirect_ref_loc (input_location, tmp);
3962	tmp = gfc_build_array_ref (tmp, offset, decl,
3963	non_negative_offset: non_negative_strides_array_p (expr: desc),
3964	vptr);
3965	return tmp;
3966	}
3967
3968
3969	/ Build an array reference. se->expr already holds the array descriptor.*
3970	This should be either a variable, indirect variable reference or component
3971	reference. For arrays which do not have a descriptor, se->expr will be
3972	the data pointer.
3973	a(i, j, k) = base[offset + i stride[0] + j * stride[1] + k * stride[2]]/
3974
3975	void
3976	gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
3977	locus * where)
3978	{
3979	int n;
3980	tree offset, cst_offset;
3981	tree tmp;
3982	tree stride;
3983	tree decl = NULL_TREE;
3984	gfc_se indexse;
3985	gfc_se tmpse;
3986	gfc_symbol * sym = expr->symtree->n.sym;
3987	char *var_name = NULL;
3988
3989	if (ar->dimen == `0`)
3990	{
3991	gcc_assert (ar->codimen \|\| sym->attr.select_rank_temporary
3992	\|\| (ar->as && ar->as->corank));
3993
3994	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3995	se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
3996	else
3997	{
3998	if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
3999	&& TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
4000	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4001
4002	/ Use the actual tree type and not the wrapped coarray. /
4003	if (!se->want_pointer)
4004	se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
4005	se->expr);
4006	}
4007
4008	return;
4009	}
4010
4011	/ Handle scalarized references separately. /
4012	if (ar->type != AR_ELEMENT)
4013	{
4014	gfc_conv_scalarized_array_ref (se, ar);
4015	gfc_advance_se_ss_chain (se);
4016	return;
4017	}
4018
4019	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4020	{
4021	size_t len;
4022	gfc_ref *ref;
4023
4024	len = strlen (s: sym->name) + `1`;
4025	for (ref = expr->ref; ref; ref = ref->next)
4026	{
4027	if (ref->type == REF_ARRAY && &ref->u.ar == ar)
4028	break;
4029	if (ref->type == REF_COMPONENT)
4030	len += `2` + strlen (s: ref->u.c.component->name);
4031	}
4032
4033	var_name = XALLOCAVEC (char, len);
4034	strcpy (dest: var_name, src: sym->name);
4035
4036	for (ref = expr->ref; ref; ref = ref->next)
4037	{
4038	if (ref->type == REF_ARRAY && &ref->u.ar == ar)
4039	break;
4040	if (ref->type == REF_COMPONENT)
4041	{
4042	strcat (dest: var_name, src: "%%");
4043	strcat (dest: var_name, src: ref->u.c.component->name);
4044	}
4045	}
4046	}
4047
4048	decl = se->expr;
4049	if (IS_CLASS_ARRAY (sym) && sym->attr.dummy && ar->as->type != AS_DEFERRED)
4050	decl = sym->backend_decl;
4051
4052	cst_offset = offset = gfc_index_zero_node;
4053	add_to_offset (cst_offset: &cst_offset, offset: &offset, t: gfc_conv_array_offset (descriptor: decl));
4054
4055	/ Calculate the offsets from all the dimensions. Make sure to associate*
4056	the final offset so that we form a chain of loop invariant summands. /*
4057	for (n = ar->dimen - `1`; n >= `0`; n--)
4058	{
4059	/ Calculate the index for this dimension. /
4060	gfc_init_se (&indexse, se);
4061	gfc_conv_expr_type (se: &indexse, ar->start[n], gfc_array_index_type);
4062	gfc_add_block_to_block (&se->pre, &indexse.pre);
4063
4064	if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && ! expr->no_bounds_check)
4065	{
4066	/ Check array bounds. /
4067	tree cond;
4068	char *msg;
4069
4070	/ Evaluate the indexse.expr only once. /
4071	indexse.expr = save_expr (indexse.expr);
4072
4073	/ Lower bound. /
4074	tmp = gfc_conv_array_lbound (descriptor: decl, dim: n);
4075	if (sym->attr.temporary)
4076	{
4077	gfc_init_se (&tmpse, se);
4078	gfc_conv_expr_type (se: &tmpse, ar->as->lower[n],
4079	gfc_array_index_type);
4080	gfc_add_block_to_block (&se->pre, &tmpse.pre);
4081	tmp = tmpse.expr;
4082	}
4083
4084	cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
4085	indexse.expr, tmp);
4086	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4087	"below lower bound of %%ld", n+`1`, var_name);
4088	gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4089	fold_convert (long_integer_type_node,
4090	indexse.expr),
4091	fold_convert (long_integer_type_node, tmp));
4092	free (ptr: msg);
4093
4094	/ Upper bound, but not for the last dimension of assumed-size*
4095	arrays. /*
4096	if (n < ar->dimen - `1` \|\| ar->as->type != AS_ASSUMED_SIZE)
4097	{
4098	tmp = gfc_conv_array_ubound (descriptor: decl, dim: n);
4099	if (sym->attr.temporary)
4100	{
4101	gfc_init_se (&tmpse, se);
4102	gfc_conv_expr_type (se: &tmpse, ar->as->upper[n],
4103	gfc_array_index_type);
4104	gfc_add_block_to_block (&se->pre, &tmpse.pre);
4105	tmp = tmpse.expr;
4106	}
4107
4108	cond = fold_build2_loc (input_location, GT_EXPR,
4109	logical_type_node, indexse.expr, tmp);
4110	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4111	"above upper bound of %%ld", n+`1`, var_name);
4112	gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
4113	fold_convert (long_integer_type_node,
4114	indexse.expr),
4115	fold_convert (long_integer_type_node, tmp));
4116	free (ptr: msg);
4117	}
4118	}
4119
4120	/ Multiply the index by the stride. /
4121	stride = gfc_conv_array_stride (descriptor: decl, dim: n);
4122	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4123	indexse.expr, stride);
4124
4125	/ And add it to the total. /
4126	add_to_offset (cst_offset: &cst_offset, offset: &offset, t: tmp);
4127	}
4128
4129	if (!integer_zerop (cst_offset))
4130	offset = fold_build2_loc (input_location, PLUS_EXPR,
4131	gfc_array_index_type, offset, cst_offset);
4132
4133	/ A pointer array component can be detected from its field decl. Fix*
4134	the descriptor, mark the resulting variable decl and pass it to
4135	build_array_ref. /*
4136	decl = NULL_TREE;
4137	if (get_CFI_desc (sym, expr, desc: &decl, ar))
4138	decl = build_fold_indirect_ref_loc (input_location, decl);
4139	if (!expr->ts.deferred && !sym->attr.codimension
4140	&& is_pointer_array (expr: se->expr))
4141	{
4142	if (TREE_CODE (se->expr) == COMPONENT_REF)
4143	decl = se->expr;
4144	else if (INDIRECT_REF_P (se->expr))
4145	decl = TREE_OPERAND (se->expr, `0`);
4146	else
4147	decl = se->expr;
4148	}
4149	else if (expr->ts.deferred
4150	\|\| (sym->ts.type == BT_CHARACTER
4151	&& sym->attr.select_type_temporary))
4152	{
4153	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
4154	{
4155	decl = se->expr;
4156	if (INDIRECT_REF_P (decl))
4157	decl = TREE_OPERAND (decl, `0`);
4158	}
4159	else
4160	decl = sym->backend_decl;
4161	}
4162	else if (sym->ts.type == BT_CLASS)
4163	{
4164	if (UNLIMITED_POLY (sym))
4165	{
4166	gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
4167	gfc_init_se (&tmpse, NULL);
4168	gfc_conv_expr (se: &tmpse, expr: class_expr);
4169	if (!se->class_vptr)
4170	se->class_vptr = gfc_class_vptr_get (tmpse.expr);
4171	gfc_free_expr (class_expr);
4172	decl = tmpse.expr;
4173	}
4174	else
4175	decl = NULL_TREE;
4176	}
4177
4178	se->expr = build_array_ref (desc: se->expr, offset, decl, vptr: se->class_vptr);
4179	}
4180
4181
4182	/ Add the offset corresponding to array's ARRAY_DIM dimension and loop's*
4183	LOOP_DIM dimension (if any) to array's offset. /*
4184
4185	static void
4186	add_array_offset (stmtblock_t pblock, gfc_loopinfo loop, gfc_ss *ss,
4187	gfc_array_ref ar, int* array_dim, int loop_dim)
4188	{
4189	gfc_se se;
4190	gfc_array_info *info;
4191	tree stride, index;
4192
4193	info = &ss->info->data.array;
4194
4195	gfc_init_se (&se, NULL);
4196	se.loop = loop;
4197	se.expr = info->descriptor;
4198	stride = gfc_conv_array_stride (descriptor: info->descriptor, dim: array_dim);
4199	index = conv_array_index_offset (se: &se, ss, dim: array_dim, i: loop_dim, ar, stride);
4200	gfc_add_block_to_block (pblock, &se.pre);
4201
4202	info->offset = fold_build2_loc (input_location, PLUS_EXPR,
4203	gfc_array_index_type,
4204	info->offset, index);
4205	info->offset = gfc_evaluate_now (info->offset, pblock);
4206	}
4207
4208
4209	/ Generate the code to be executed immediately before entering a*
4210	scalarization loop. /*
4211
4212	static void
4213	gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
4214	stmtblock_t * pblock)
4215	{
4216	tree stride;
4217	gfc_ss_info *ss_info;
4218	gfc_array_info *info;
4219	gfc_ss_type ss_type;
4220	gfc_ss ss, pss;
4221	gfc_loopinfo *ploop;
4222	gfc_array_ref *ar;
4223	int i;
4224
4225	/ This code will be executed before entering the scalarization loop*
4226	for this dimension. /*
4227	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4228	{
4229	ss_info = ss->info;
4230
4231	if ((ss_info->useflags & flag) == `0`)
4232	continue;
4233
4234	ss_type = ss_info->type;
4235	if (ss_type != GFC_SS_SECTION
4236	&& ss_type != GFC_SS_FUNCTION
4237	&& ss_type != GFC_SS_CONSTRUCTOR
4238	&& ss_type != GFC_SS_COMPONENT)
4239	continue;
4240
4241	info = &ss_info->data.array;
4242
4243	gcc_assert (dim < ss->dimen);
4244	gcc_assert (ss->dimen == loop->dimen);
4245
4246	if (info->ref)
4247	ar = &info->ref->u.ar;
4248	else
4249	ar = NULL;
4250
4251	if (dim == loop->dimen - `1` && loop->parent != NULL)
4252	{
4253	/ If we are in the outermost dimension of this loop, the previous*
4254	dimension shall be in the parent loop. /*
4255	gcc_assert (ss->parent != NULL);
4256
4257	pss = ss->parent;
4258	ploop = loop->parent;
4259
4260	/ ss and ss->parent are about the same array. /
4261	gcc_assert (ss_info == pss->info);
4262	}
4263	else
4264	{
4265	ploop = loop;
4266	pss = ss;
4267	}
4268
4269	if (dim == loop->dimen - `1`)
4270	i = `0`;
4271	else
4272	i = dim + `1`;
4273
4274	/ For the time being, there is no loop reordering. /
4275	gcc_assert (i == ploop->order[i]);
4276	i = ploop->order[i];
4277
4278	if (dim == loop->dimen - `1` && loop->parent == NULL)
4279	{
4280	stride = gfc_conv_array_stride (descriptor: info->descriptor,
4281	dim: innermost_ss (ss)->dim[i]);
4282
4283	/ Calculate the stride of the innermost loop. Hopefully this will*
4284	allow the backend optimizers to do their stuff more effectively.
4285	*/
4286	info->stride0 = gfc_evaluate_now (stride, pblock);
4287
4288	/ For the outermost loop calculate the offset due to any*
4289	elemental dimensions. It will have been initialized with the
4290	base offset of the array. /*
4291	if (info->ref)
4292	{
4293	for (i = `0`; i < ar->dimen; i++)
4294	{
4295	if (ar->dimen_type[i] != DIMEN_ELEMENT)
4296	continue;
4297
4298	add_array_offset (pblock, loop, ss, ar, array_dim: i, / unused / loop_dim: -`1`);
4299	}
4300	}
4301	}
4302	else
4303	/ Add the offset for the previous loop dimension. /
4304	add_array_offset (pblock, loop: ploop, ss, ar, array_dim: pss->dim[i], loop_dim: i);
4305
4306	/ Remember this offset for the second loop. /
4307	if (dim == loop->temp_dim - `1` && loop->parent == NULL)
4308	info->saved_offset = info->offset;
4309	}
4310	}
4311
4312
4313	/ Start a scalarized expression. Creates a scope and declares loop*
4314	variables. /*
4315
4316	void
4317	gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
4318	{
4319	int dim;
4320	int n;
4321	int flags;
4322
4323	gcc_assert (!loop->array_parameter);
4324
4325	for (dim = loop->dimen - `1`; dim >= `0`; dim--)
4326	{
4327	n = loop->order[dim];
4328
4329	gfc_start_block (&loop->code[n]);
4330
4331	/ Create the loop variable. /
4332	loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
4333
4334	if (dim < loop->temp_dim)
4335	flags = `3`;
4336	else
4337	flags = `1`;
4338	/ Calculate values that will be constant within this loop. /
4339	gfc_trans_preloop_setup (loop, dim, flag: flags, pblock: &loop->code[n]);
4340	}
4341	gfc_start_block (pbody);
4342	}
4343
4344
4345	/ Generates the actual loop code for a scalarization loop. /
4346
4347	static void
4348	gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
4349	stmtblock_t * pbody)
4350	{
4351	stmtblock_t block;
4352	tree cond;
4353	tree tmp;
4354	tree loopbody;
4355	tree exit_label;
4356	tree stmt;
4357	tree init;
4358	tree incr;
4359
4360	if ((ompws_flags & (OMPWS_WORKSHARE_FLAG \| OMPWS_SCALARIZER_WS
4361	\| OMPWS_SCALARIZER_BODY))
4362	== (OMPWS_WORKSHARE_FLAG \| OMPWS_SCALARIZER_WS)
4363	&& n == loop->dimen - `1`)
4364	{
4365	/ We create an OMP_FOR construct for the outermost scalarized loop. /
4366	init = make_tree_vec (`1`);
4367	cond = make_tree_vec (`1`);
4368	incr = make_tree_vec (`1`);
4369
4370	/ Cycle statement is implemented with a goto. Exit statement must not*
4371	be present for this loop. /*
4372	exit_label = gfc_build_label_decl (NULL_TREE);
4373	TREE_USED (exit_label) = `1`;
4374
4375	/ Label for cycle statements (if needed). /
4376	tmp = build1_v (LABEL_EXPR, exit_label);
4377	gfc_add_expr_to_block (pbody, tmp);
4378
4379	stmt = make_node (OMP_FOR);
4380
4381	TREE_TYPE (stmt) = void_type_node;
4382	OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
4383
4384	OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
4385	OMP_CLAUSE_SCHEDULE);
4386	OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
4387	= OMP_CLAUSE_SCHEDULE_STATIC;
4388	if (ompws_flags & OMPWS_NOWAIT)
4389	OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
4390	= build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
4391
4392	/ Initialize the loopvar. /
4393	TREE_VEC_ELT (init, `0`) = build2_v (MODIFY_EXPR, loop->loopvar[n],
4394	loop->from[n]);
4395	OMP_FOR_INIT (stmt) = init;
4396	/ The exit condition. /
4397	TREE_VEC_ELT (cond, `0`) = build2_loc (loc: input_location, code: LE_EXPR,
4398	type: logical_type_node,
4399	arg0: loop->loopvar[n], arg1: loop->to[n]);
4400	SET_EXPR_LOCATION (TREE_VEC_ELT (cond, `0`), input_location);
4401	OMP_FOR_COND (stmt) = cond;
4402	/ Increment the loopvar. /
4403	tmp = build2_loc (loc: input_location, code: PLUS_EXPR, type: gfc_array_index_type,
4404	arg0: loop->loopvar[n], gfc_index_one_node);
4405	TREE_VEC_ELT (incr, `0`) = fold_build2_loc (input_location, MODIFY_EXPR,
4406	void_type_node, loop->loopvar[n], tmp);
4407	OMP_FOR_INCR (stmt) = incr;
4408
4409	ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
4410	gfc_add_expr_to_block (&loop->code[n], stmt);
4411	}
4412	else
4413	{
4414	bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET)
4415	&& (loop->temp_ss == NULL);
4416
4417	loopbody = gfc_finish_block (pbody);
4418
4419	if (reverse_loop)
4420	std::swap (a&: loop->from[n], b&: loop->to[n]);
4421
4422	/ Initialize the loopvar. /
4423	if (loop->loopvar[n] != loop->from[n])
4424	gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
4425
4426	exit_label = gfc_build_label_decl (NULL_TREE);
4427
4428	/ Generate the loop body. /
4429	gfc_init_block (&block);
4430
4431	/ The exit condition. /
4432	cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR,
4433	logical_type_node, loop->loopvar[n], loop->to[n]);
4434	tmp = build1_v (GOTO_EXPR, exit_label);
4435	TREE_USED (exit_label) = `1`;
4436	tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4437	gfc_add_expr_to_block (&block, tmp);
4438
4439	/ The main body. /
4440	gfc_add_expr_to_block (&block, loopbody);
4441
4442	/ Increment the loopvar. /
4443	tmp = fold_build2_loc (input_location,
4444	reverse_loop ? MINUS_EXPR : PLUS_EXPR,
4445	gfc_array_index_type, loop->loopvar[n],
4446	gfc_index_one_node);
4447
4448	gfc_add_modify (&block, loop->loopvar[n], tmp);
4449
4450	/ Build the loop. /
4451	tmp = gfc_finish_block (&block);
4452	tmp = build1_v (LOOP_EXPR, tmp);
4453	gfc_add_expr_to_block (&loop->code[n], tmp);
4454
4455	/ Add the exit label. /
4456	tmp = build1_v (LABEL_EXPR, exit_label);
4457	gfc_add_expr_to_block (&loop->code[n], tmp);
4458	}
4459
4460	}
4461
4462
4463	/ Finishes and generates the loops for a scalarized expression. /
4464
4465	void
4466	gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
4467	{
4468	int dim;
4469	int n;
4470	gfc_ss *ss;
4471	stmtblock_t *pblock;
4472	tree tmp;
4473
4474	pblock = body;
4475	/ Generate the loops. /
4476	for (dim = `0`; dim < loop->dimen; dim++)
4477	{
4478	n = loop->order[dim];
4479	gfc_trans_scalarized_loop_end (loop, n, pbody: pblock);
4480	loop->loopvar[n] = NULL_TREE;
4481	pblock = &loop->code[n];
4482	}
4483
4484	tmp = gfc_finish_block (pblock);
4485	gfc_add_expr_to_block (&loop->pre, tmp);
4486
4487	/ Clear all the used flags. /
4488	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4489	if (ss->parent == NULL)
4490	ss->info->useflags = `0`;
4491	}
4492
4493
4494	/ Finish the main body of a scalarized expression, and start the secondary*
4495	copying body. /*
4496
4497	void
4498	gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
4499	{
4500	int dim;
4501	int n;
4502	stmtblock_t *pblock;
4503	gfc_ss *ss;
4504
4505	pblock = body;
4506	/ We finish as many loops as are used by the temporary. /
4507	for (dim = `0`; dim < loop->temp_dim - `1`; dim++)
4508	{
4509	n = loop->order[dim];
4510	gfc_trans_scalarized_loop_end (loop, n, pbody: pblock);
4511	loop->loopvar[n] = NULL_TREE;
4512	pblock = &loop->code[n];
4513	}
4514
4515	/ We don't want to finish the outermost loop entirely. /
4516	n = loop->order[loop->temp_dim - `1`];
4517	gfc_trans_scalarized_loop_end (loop, n, pbody: pblock);
4518
4519	/ Restore the initial offsets. /
4520	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4521	{
4522	gfc_ss_type ss_type;
4523	gfc_ss_info *ss_info;
4524
4525	ss_info = ss->info;
4526
4527	if ((ss_info->useflags & `2`) == `0`)
4528	continue;
4529
4530	ss_type = ss_info->type;
4531	if (ss_type != GFC_SS_SECTION
4532	&& ss_type != GFC_SS_FUNCTION
4533	&& ss_type != GFC_SS_CONSTRUCTOR
4534	&& ss_type != GFC_SS_COMPONENT)
4535	continue;
4536
4537	ss_info->data.array.offset = ss_info->data.array.saved_offset;
4538	}
4539
4540	/ Restart all the inner loops we just finished. /
4541	for (dim = loop->temp_dim - `2`; dim >= `0`; dim--)
4542	{
4543	n = loop->order[dim];
4544
4545	gfc_start_block (&loop->code[n]);
4546
4547	loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
4548
4549	gfc_trans_preloop_setup (loop, dim, flag: `2`, pblock: &loop->code[n]);
4550	}
4551
4552	/ Start a block for the secondary copying code. /
4553	gfc_start_block (body);
4554	}
4555
4556
4557	/ Precalculate (either lower or upper) bound of an array section.*
4558	BLOCK: Block in which the (pre)calculation code will go.
4559	BOUNDS[DIM]: Where the bound value will be stored once evaluated.
4560	VALUES[DIM]: Specified bound (NULL <=> unspecified).
4561	DESC: Array descriptor from which the bound will be picked if unspecified
4562	(either lower or upper bound according to LBOUND). /*
4563
4564	static void
4565	evaluate_bound (stmtblock_t block, tree bounds, gfc_expr ** values,
4566	tree desc, int dim, bool lbound, bool deferred)
4567	{
4568	gfc_se se;
4569	gfc_expr * input_val = values[dim];
4570	tree *output = &bounds[dim];
4571
4572
4573	if (input_val)
4574	{
4575	/ Specified section bound. /
4576	gfc_init_se (&se, NULL);
4577	gfc_conv_expr_type (se: &se, input_val, gfc_array_index_type);
4578	gfc_add_block_to_block (block, &se.pre);
4579	*output = se.expr;
4580	}
4581	else if (deferred && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4582	{
4583	/ The gfc_conv_array_lbound () routine returns a constant zero for*
4584	deferred length arrays, which in the scalarizer wreaks havoc, when
4585	copying to a (newly allocated) one-based array.
4586	Keep returning the actual result in sync for both bounds. /*
4587	*output = lbound ? gfc_conv_descriptor_lbound_get (desc,
4588	dim: gfc_rank_cst[dim]):
4589	gfc_conv_descriptor_ubound_get (desc,
4590	dim: gfc_rank_cst[dim]);
4591	}
4592	else
4593	{
4594	/ No specific bound specified so use the bound of the array. /
4595	*output = lbound ? gfc_conv_array_lbound (descriptor: desc, dim) :
4596	gfc_conv_array_ubound (descriptor: desc, dim);
4597	}
4598	output = gfc_evaluate_now (output, block);
4599	}
4600
4601
4602	/ Calculate the lower bound of an array section. /
4603
4604	static void
4605	gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
4606	{
4607	gfc_expr *stride = NULL;
4608	tree desc;
4609	gfc_se se;
4610	gfc_array_info *info;
4611	gfc_array_ref *ar;
4612
4613	gcc_assert (ss->info->type == GFC_SS_SECTION);
4614
4615	info = &ss->info->data.array;
4616	ar = &info->ref->u.ar;
4617
4618	if (ar->dimen_type[dim] == DIMEN_VECTOR)
4619	{
4620	/ We use a zero-based index to access the vector. /
4621	info->start[dim] = gfc_index_zero_node;
4622	info->end[dim] = NULL;
4623	info->stride[dim] = gfc_index_one_node;
4624	return;
4625	}
4626
4627	gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
4628	\|\| ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
4629	desc = info->descriptor;
4630	stride = ar->stride[dim];
4631
4632
4633	/ Calculate the start of the range. For vector subscripts this will*
4634	be the range of the vector. /*
4635	evaluate_bound (block, bounds: info->start, values: ar->start, desc, dim, lbound: true,
4636	deferred: ar->as->type == AS_DEFERRED);
4637
4638	/ Similarly calculate the end. Although this is not used in the*
4639	scalarizer, it is needed when checking bounds and where the end
4640	is an expression with side-effects. /*
4641	evaluate_bound (block, bounds: info->end, values: ar->end, desc, dim, lbound: false,
4642	deferred: ar->as->type == AS_DEFERRED);
4643
4644
4645	/ Calculate the stride. /
4646	if (stride == NULL)
4647	info->stride[dim] = gfc_index_one_node;
4648	else
4649	{
4650	gfc_init_se (&se, NULL);
4651	gfc_conv_expr_type (se: &se, stride, gfc_array_index_type);
4652	gfc_add_block_to_block (block, &se.pre);
4653	info->stride[dim] = gfc_evaluate_now (se.expr, block);
4654	}
4655	}
4656
4657
4658	/ Calculates the range start and stride for a SS chain. Also gets the*
4659	descriptor and data pointer. The range of vector subscripts is the size
4660	of the vector. Array bounds are also checked. /*
4661
4662	void
4663	gfc_conv_ss_startstride (gfc_loopinfo * loop)
4664	{
4665	int n;
4666	tree tmp;
4667	gfc_ss *ss;
4668	tree desc;
4669
4670	gfc_loopinfo * const outer_loop = outermost_loop (loop);
4671
4672	loop->dimen = `0`;
4673	/ Determine the rank of the loop. /
4674	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4675	{
4676	switch (ss->info->type)
4677	{
4678	case GFC_SS_SECTION:
4679	case GFC_SS_CONSTRUCTOR:
4680	case GFC_SS_FUNCTION:
4681	case GFC_SS_COMPONENT:
4682	loop->dimen = ss->dimen;
4683	goto done;
4684
4685	/ As usual, lbound and ubound are exceptions!. /
4686	case GFC_SS_INTRINSIC:
4687	switch (ss->info->expr->value.function.isym->id)
4688	{
4689	case GFC_ISYM_LBOUND:
4690	case GFC_ISYM_UBOUND:
4691	case GFC_ISYM_LCOBOUND:
4692	case GFC_ISYM_UCOBOUND:
4693	case GFC_ISYM_SHAPE:
4694	case GFC_ISYM_THIS_IMAGE:
4695	loop->dimen = ss->dimen;
4696	goto done;
4697
4698	default:
4699	break;
4700	}
4701
4702	default:
4703	break;
4704	}
4705	}
4706
4707	/ We should have determined the rank of the expression by now. If*
4708	not, that's bad news. /*
4709	gcc_unreachable ();
4710
4711	done:
4712	/ Loop over all the SS in the chain. /
4713	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4714	{
4715	gfc_ss_info *ss_info;
4716	gfc_array_info *info;
4717	gfc_expr *expr;
4718
4719	ss_info = ss->info;
4720	expr = ss_info->expr;
4721	info = &ss_info->data.array;
4722
4723	if (expr && expr->shape && !info->shape)
4724	info->shape = expr->shape;
4725
4726	switch (ss_info->type)
4727	{
4728	case GFC_SS_SECTION:
4729	/ Get the descriptor for the array. If it is a cross loops array,*
4730	we got the descriptor already in the outermost loop. /*
4731	if (ss->parent == NULL)
4732	gfc_conv_ss_descriptor (block: &outer_loop->pre, ss,
4733	base: !loop->array_parameter);
4734
4735	for (n = `0`; n < ss->dimen; n++)
4736	gfc_conv_section_startstride (block: &outer_loop->pre, ss, dim: ss->dim[n]);
4737	break;
4738
4739	case GFC_SS_INTRINSIC:
4740	switch (expr->value.function.isym->id)
4741	{
4742	/ Fall through to supply start and stride. /
4743	case GFC_ISYM_LBOUND:
4744	case GFC_ISYM_UBOUND:
4745	/ This is the variant without DIM=... /
4746	gcc_assert (expr->value.function.actual->next->expr == NULL);
4747	/ Fall through. /
4748
4749	case GFC_ISYM_SHAPE:
4750	{
4751	gfc_expr *arg;
4752
4753	arg = expr->value.function.actual->expr;
4754	if (arg->rank == -`1`)
4755	{
4756	gfc_se se;
4757	tree rank, tmp;
4758
4759	/ The rank (hence the return value's shape) is unknown,*
4760	we have to retrieve it. /*
4761	gfc_init_se (&se, NULL);
4762	se.descriptor_only = `1`;
4763	gfc_conv_expr (se: &se, expr: arg);
4764	/ This is a bare variable, so there is no preliminary*
4765	or cleanup code. /*
4766	gcc_assert (se.pre.head == NULL_TREE
4767	&& se.post.head == NULL_TREE);
4768	rank = gfc_conv_descriptor_rank (desc: se.expr);
4769	tmp = fold_build2_loc (input_location, MINUS_EXPR,
4770	gfc_array_index_type,
4771	fold_convert (gfc_array_index_type,
4772	rank),
4773	gfc_index_one_node);
4774	info->end[`0`] = gfc_evaluate_now (tmp, &outer_loop->pre);
4775	info->start[`0`] = gfc_index_zero_node;
4776	info->stride[`0`] = gfc_index_one_node;
4777	continue;
4778	}
4779	/ Otherwise fall through GFC_SS_FUNCTION. /
4780	gcc_fallthrough ();
4781	}
4782	case GFC_ISYM_LCOBOUND:
4783	case GFC_ISYM_UCOBOUND:
4784	case GFC_ISYM_THIS_IMAGE:
4785	break;
4786
4787	default:
4788	continue;
4789	}
4790
4791	/ FALLTHRU /
4792	case GFC_SS_CONSTRUCTOR:
4793	case GFC_SS_FUNCTION:
4794	for (n = `0`; n < ss->dimen; n++)
4795	{
4796	int dim = ss->dim[n];
4797
4798	info->start[dim] = gfc_index_zero_node;
4799	info->end[dim] = gfc_index_zero_node;
4800	info->stride[dim] = gfc_index_one_node;
4801	}
4802	break;
4803
4804	default:
4805	break;
4806	}
4807	}
4808
4809	/ The rest is just runtime bounds checking. /
4810	if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4811	{
4812	stmtblock_t block;
4813	tree lbound, ubound;
4814	tree end;
4815	tree size[GFC_MAX_DIMENSIONS];
4816	tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
4817	gfc_array_info *info;
4818	char *msg;
4819	int dim;
4820
4821	gfc_start_block (&block);
4822
4823	for (n = `0`; n < loop->dimen; n++)
4824	size[n] = NULL_TREE;
4825
4826	/ If there is a constructor involved, derive size[] from its shape. /
4827	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4828	{
4829	gfc_ss_info *ss_info;
4830
4831	ss_info = ss->info;
4832	info = &ss_info->data.array;
4833
4834	if (ss_info->type == GFC_SS_CONSTRUCTOR && info->shape)
4835	{
4836	for (n = `0`; n < loop->dimen; n++)
4837	{
4838	if (size[n] == NULL)
4839	{
4840	gcc_assert (info->shape[n]);
4841	size[n] = gfc_conv_mpz_to_tree (info->shape[n],
4842	gfc_index_integer_kind);
4843	}
4844	}
4845	break;
4846	}
4847	}
4848
4849	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
4850	{
4851	stmtblock_t inner;
4852	gfc_ss_info *ss_info;
4853	gfc_expr *expr;
4854	locus *expr_loc;
4855	const char *expr_name;
4856
4857	ss_info = ss->info;
4858	if (ss_info->type != GFC_SS_SECTION)
4859	continue;
4860
4861	/ Catch allocatable lhs in f2003. /
4862	if (flag_realloc_lhs && ss->no_bounds_check)
4863	continue;
4864
4865	expr = ss_info->expr;
4866	expr_loc = &expr->where;
4867	expr_name = expr->symtree->name;
4868
4869	gfc_start_block (&inner);
4870
4871	/ TODO: range checking for mapped dimensions. /
4872	info = &ss_info->data.array;
4873
4874	/ This code only checks ranges. Elemental and vector*
4875	dimensions are checked later. /*
4876	for (n = `0`; n < loop->dimen; n++)
4877	{
4878	bool check_upper;
4879
4880	dim = ss->dim[n];
4881	if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
4882	continue;
4883
4884	if (dim == info->ref->u.ar.dimen - `1`
4885	&& info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
4886	check_upper = false;
4887	else
4888	check_upper = true;
4889
4890	/ Zero stride is not allowed. /
4891	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
4892	info->stride[dim], gfc_index_zero_node);
4893	msg = xasprintf ("Zero stride is not allowed, for dimension %d "
4894	"of array '%s'", dim + `1`, expr_name);
4895	gfc_trans_runtime_check (true, false, tmp, &inner,
4896	expr_loc, msg);
4897	free (ptr: msg);
4898
4899	desc = info->descriptor;
4900
4901	/ This is the run-time equivalent of resolve.cc's*
4902	check_dimension(). The logical is more readable there
4903	than it is here, with all the trees. /*
4904	lbound = gfc_conv_array_lbound (descriptor: desc, dim);
4905	end = info->end[dim];
4906	if (check_upper)
4907	ubound = gfc_conv_array_ubound (descriptor: desc, dim);
4908	else
4909	ubound = NULL;
4910
4911	/ non_zerosized is true when the selected range is not*
4912	empty. /*
4913	stride_pos = fold_build2_loc (input_location, GT_EXPR,
4914	logical_type_node, info->stride[dim],
4915	gfc_index_zero_node);
4916	tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4917	info->start[dim], end);
4918	stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4919	logical_type_node, stride_pos, tmp);
4920
4921	stride_neg = fold_build2_loc (input_location, LT_EXPR,
4922	logical_type_node,
4923	info->stride[dim], gfc_index_zero_node);
4924	tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
4925	info->start[dim], end);
4926	stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4927	logical_type_node,
4928	stride_neg, tmp);
4929	non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4930	logical_type_node,
4931	stride_pos, stride_neg);
4932
4933	/ Check the start of the range against the lower and upper*
4934	bounds of the array, if the range is not empty.
4935	If upper bound is present, include both bounds in the
4936	error message. /*
4937	if (check_upper)
4938	{
4939	tmp = fold_build2_loc (input_location, LT_EXPR,
4940	logical_type_node,
4941	info->start[dim], lbound);
4942	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4943	logical_type_node,
4944	non_zerosized, tmp);
4945	tmp2 = fold_build2_loc (input_location, GT_EXPR,
4946	logical_type_node,
4947	info->start[dim], ubound);
4948	tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4949	logical_type_node,
4950	non_zerosized, tmp2);
4951	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4952	"outside of expected range (%%ld:%%ld)",
4953	dim + `1`, expr_name);
4954	gfc_trans_runtime_check (true, false, tmp, &inner,
4955	expr_loc, msg,
4956	fold_convert (long_integer_type_node, info->start[dim]),
4957	fold_convert (long_integer_type_node, lbound),
4958	fold_convert (long_integer_type_node, ubound));
4959	gfc_trans_runtime_check (true, false, tmp2, &inner,
4960	expr_loc, msg,
4961	fold_convert (long_integer_type_node, info->start[dim]),
4962	fold_convert (long_integer_type_node, lbound),
4963	fold_convert (long_integer_type_node, ubound));
4964	free (ptr: msg);
4965	}
4966	else
4967	{
4968	tmp = fold_build2_loc (input_location, LT_EXPR,
4969	logical_type_node,
4970	info->start[dim], lbound);
4971	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4972	logical_type_node, non_zerosized, tmp);
4973	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
4974	"below lower bound of %%ld",
4975	dim + `1`, expr_name);
4976	gfc_trans_runtime_check (true, false, tmp, &inner,
4977	expr_loc, msg,
4978	fold_convert (long_integer_type_node, info->start[dim]),
4979	fold_convert (long_integer_type_node, lbound));
4980	free (ptr: msg);
4981	}
4982
4983	/ Compute the last element of the range, which is not*
4984	necessarily "end" (think 0:5:3, which doesn't contain 5)
4985	and check it against both lower and upper bounds. /*
4986
4987	tmp = fold_build2_loc (input_location, MINUS_EXPR,
4988	gfc_array_index_type, end,
4989	info->start[dim]);
4990	tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
4991	gfc_array_index_type, tmp,
4992	info->stride[dim]);
4993	tmp = fold_build2_loc (input_location, MINUS_EXPR,
4994	gfc_array_index_type, end, tmp);
4995	tmp2 = fold_build2_loc (input_location, LT_EXPR,
4996	logical_type_node, tmp, lbound);
4997	tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4998	logical_type_node, non_zerosized, tmp2);
4999	if (check_upper)
5000	{
5001	tmp3 = fold_build2_loc (input_location, GT_EXPR,
5002	logical_type_node, tmp, ubound);
5003	tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5004	logical_type_node, non_zerosized, tmp3);
5005	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
5006	"outside of expected range (%%ld:%%ld)",
5007	dim + `1`, expr_name);
5008	gfc_trans_runtime_check (true, false, tmp2, &inner,
5009	expr_loc, msg,
5010	fold_convert (long_integer_type_node, tmp),
5011	fold_convert (long_integer_type_node, ubound),
5012	fold_convert (long_integer_type_node, lbound));
5013	gfc_trans_runtime_check (true, false, tmp3, &inner,
5014	expr_loc, msg,
5015	fold_convert (long_integer_type_node, tmp),
5016	fold_convert (long_integer_type_node, ubound),
5017	fold_convert (long_integer_type_node, lbound));
5018	free (ptr: msg);
5019	}
5020	else
5021	{
5022	msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' "
5023	"below lower bound of %%ld",
5024	dim + `1`, expr_name);
5025	gfc_trans_runtime_check (true, false, tmp2, &inner,
5026	expr_loc, msg,
5027	fold_convert (long_integer_type_node, tmp),
5028	fold_convert (long_integer_type_node, lbound));
5029	free (ptr: msg);
5030	}
5031
5032	/ Check the section sizes match. /
5033	tmp = fold_build2_loc (input_location, MINUS_EXPR,
5034	gfc_array_index_type, end,
5035	info->start[dim]);
5036	tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5037	gfc_array_index_type, tmp,
5038	info->stride[dim]);
5039	tmp = fold_build2_loc (input_location, PLUS_EXPR,
5040	gfc_array_index_type,
5041	gfc_index_one_node, tmp);
5042	tmp = fold_build2_loc (input_location, MAX_EXPR,
5043	gfc_array_index_type, tmp,
5044	build_int_cst (gfc_array_index_type, `0`));
5045	/ We remember the size of the first section, and check all the*
5046	others against this. /*
5047	if (size[n])
5048	{
5049	tmp3 = fold_build2_loc (input_location, NE_EXPR,
5050	logical_type_node, tmp, size[n]);
5051	msg = xasprintf ("Array bound mismatch for dimension %d "
5052	"of array '%s' (%%ld/%%ld)",
5053	dim + `1`, expr_name);
5054
5055	gfc_trans_runtime_check (true, false, tmp3, &inner,
5056	expr_loc, msg,
5057	fold_convert (long_integer_type_node, tmp),
5058	fold_convert (long_integer_type_node, size[n]));
5059
5060	free (ptr: msg);
5061	}
5062	else
5063	size[n] = gfc_evaluate_now (tmp, &inner);
5064	}
5065
5066	tmp = gfc_finish_block (&inner);
5067
5068	/ For optional arguments, only check bounds if the argument is*
5069	present. /*
5070	if ((expr->symtree->n.sym->attr.optional
5071	\|\| expr->symtree->n.sym->attr.not_always_present)
5072	&& expr->symtree->n.sym->attr.dummy)
5073	tmp = build3_v (COND_EXPR,
5074	gfc_conv_expr_present (expr->symtree->n.sym),
5075	tmp, build_empty_stmt (input_location));
5076
5077	gfc_add_expr_to_block (&block, tmp);
5078
5079	}
5080
5081	tmp = gfc_finish_block (&block);
5082	gfc_add_expr_to_block (&outer_loop->pre, tmp);
5083	}
5084
5085	for (loop = loop->nested; loop; loop = loop->next)
5086	gfc_conv_ss_startstride (loop);
5087	}
5088
5089	/ Return true if both symbols could refer to the same data object. Does*
5090	not take account of aliasing due to equivalence statements. /*
5091
5092	static bool
5093	symbols_could_alias (gfc_symbol lsym, gfc_symbol rsym, bool lsym_pointer,
5094	bool lsym_target, bool rsym_pointer, bool rsym_target)
5095	{
5096	/ Aliasing isn't possible if the symbols have different base types. /
5097	if (gfc_compare_types (&lsym->ts, &rsym->ts) == `0`)
5098	return `0`;
5099
5100	/ Pointers can point to other pointers and target objects. /
5101
5102	if ((lsym_pointer && (rsym_pointer \|\| rsym_target))
5103	\|\| (rsym_pointer && (lsym_pointer \|\| lsym_target)))
5104	return `1`;
5105
5106	/ Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7*
5107	and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
5108	checked above. /*
5109	if (lsym_target && rsym_target
5110	&& ((lsym->attr.dummy && !lsym->attr.contiguous
5111	&& (!lsym->attr.dimension \|\| lsym->as->type == AS_ASSUMED_SHAPE))
5112	\|\| (rsym->attr.dummy && !rsym->attr.contiguous
5113	&& (!rsym->attr.dimension
5114	\|\| rsym->as->type == AS_ASSUMED_SHAPE))))
5115	return `1`;
5116
5117	return `0`;
5118	}
5119
5120
5121	/ Return true if the two SS could be aliased, i.e. both point to the same data*
5122	object. /*
5123	/ TODO: resolve aliases based on frontend expressions. /
5124
5125	static int
5126	gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
5127	{
5128	gfc_ref *lref;
5129	gfc_ref *rref;
5130	gfc_expr lexpr, rexpr;
5131	gfc_symbol *lsym;
5132	gfc_symbol *rsym;
5133	bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
5134
5135	lexpr = lss->info->expr;
5136	rexpr = rss->info->expr;
5137
5138	lsym = lexpr->symtree->n.sym;
5139	rsym = rexpr->symtree->n.sym;
5140
5141	lsym_pointer = lsym->attr.pointer;
5142	lsym_target = lsym->attr.target;
5143	rsym_pointer = rsym->attr.pointer;
5144	rsym_target = rsym->attr.target;
5145
5146	if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
5147	rsym_pointer, rsym_target))
5148	return `1`;
5149
5150	if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
5151	&& lsym->ts.type != BT_DERIVED && lsym->ts.type != BT_CLASS)
5152	return `0`;
5153
5154	/ For derived types we must check all the component types. We can ignore*
5155	array references as these will have the same base type as the previous
5156	component ref. /*
5157	for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next)
5158	{
5159	if (lref->type != REF_COMPONENT)
5160	continue;
5161
5162	lsym_pointer = lsym_pointer \|\| lref->u.c.sym->attr.pointer;
5163	lsym_target = lsym_target \|\| lref->u.c.sym->attr.target;
5164
5165	if (symbols_could_alias (lsym: lref->u.c.sym, rsym, lsym_pointer, lsym_target,
5166	rsym_pointer, rsym_target))
5167	return `1`;
5168
5169	if ((lsym_pointer && (rsym_pointer \|\| rsym_target))
5170	\|\| (rsym_pointer && (lsym_pointer \|\| lsym_target)))
5171	{
5172	if (gfc_compare_types (&lref->u.c.component->ts,
5173	&rsym->ts))
5174	return `1`;
5175	}
5176
5177	for (rref = rexpr->ref; rref != rss->info->data.array.ref;
5178	rref = rref->next)
5179	{
5180	if (rref->type != REF_COMPONENT)
5181	continue;
5182
5183	rsym_pointer = rsym_pointer \|\| rref->u.c.sym->attr.pointer;
5184	rsym_target = lsym_target \|\| rref->u.c.sym->attr.target;
5185
5186	if (symbols_could_alias (lsym: lref->u.c.sym, rsym: rref->u.c.sym,
5187	lsym_pointer, lsym_target,
5188	rsym_pointer, rsym_target))
5189	return `1`;
5190
5191	if ((lsym_pointer && (rsym_pointer \|\| rsym_target))
5192	\|\| (rsym_pointer && (lsym_pointer \|\| lsym_target)))
5193	{
5194	if (gfc_compare_types (&lref->u.c.component->ts,
5195	&rref->u.c.sym->ts))
5196	return `1`;
5197	if (gfc_compare_types (&lref->u.c.sym->ts,
5198	&rref->u.c.component->ts))
5199	return `1`;
5200	if (gfc_compare_types (&lref->u.c.component->ts,
5201	&rref->u.c.component->ts))
5202	return `1`;
5203	}
5204	}
5205	}
5206
5207	lsym_pointer = lsym->attr.pointer;
5208	lsym_target = lsym->attr.target;
5209
5210	for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next)
5211	{
5212	if (rref->type != REF_COMPONENT)
5213	break;
5214
5215	rsym_pointer = rsym_pointer \|\| rref->u.c.sym->attr.pointer;
5216	rsym_target = lsym_target \|\| rref->u.c.sym->attr.target;
5217
5218	if (symbols_could_alias (lsym: rref->u.c.sym, rsym: lsym,
5219	lsym_pointer, lsym_target,
5220	rsym_pointer, rsym_target))
5221	return `1`;
5222
5223	if ((lsym_pointer && (rsym_pointer \|\| rsym_target))
5224	\|\| (rsym_pointer && (lsym_pointer \|\| lsym_target)))
5225	{
5226	if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
5227	return `1`;
5228	}
5229	}
5230
5231	return `0`;
5232	}
5233
5234
5235	/ Resolve array data dependencies. Creates a temporary if required. /
5236	/ TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to*
5237	dependency.cc. /*
5238
5239	void
5240	gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
5241	gfc_ss * rss)
5242	{
5243	gfc_ss *ss;
5244	gfc_ref *lref;
5245	gfc_ref *rref;
5246	gfc_ss_info *ss_info;
5247	gfc_expr *dest_expr;
5248	gfc_expr *ss_expr;
5249	int nDepend = `0`;
5250	int i, j;
5251
5252	loop->temp_ss = NULL;
5253	dest_expr = dest->info->expr;
5254
5255	for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
5256	{
5257	ss_info = ss->info;
5258	ss_expr = ss_info->expr;
5259
5260	if (ss_info->array_outer_dependency)
5261	{
5262	nDepend = `1`;
5263	break;
5264	}
5265
5266	if (ss_info->type != GFC_SS_SECTION)
5267	{
5268	if (flag_realloc_lhs
5269	&& dest_expr != ss_expr
5270	&& gfc_is_reallocatable_lhs (dest_expr)
5271	&& ss_expr->rank)
5272	nDepend = gfc_check_dependency (dest_expr, ss_expr, true);
5273
5274	/ Check for cases like c(:)(1:2) = c(2)(2:3) /
5275	if (!nDepend && dest_expr->rank > `0`
5276	&& dest_expr->ts.type == BT_CHARACTER
5277	&& ss_expr->expr_type == EXPR_VARIABLE)
5278
5279	nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
5280
5281	if (ss_info->type == GFC_SS_REFERENCE
5282	&& gfc_check_dependency (dest_expr, ss_expr, false))
5283	ss_info->data.scalar.needs_temporary = `1`;
5284
5285	if (nDepend)
5286	break;
5287	else
5288	continue;
5289	}
5290
5291	if (dest_expr->symtree->n.sym != ss_expr->symtree->n.sym)
5292	{
5293	if (gfc_could_be_alias (lss: dest, rss: ss)
5294	\|\| gfc_are_equivalenced_arrays (dest_expr, ss_expr))
5295	{
5296	nDepend = `1`;
5297	break;
5298	}
5299	}
5300	else
5301	{
5302	lref = dest_expr->ref;
5303	rref = ss_expr->ref;
5304
5305	nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[`0`]);
5306
5307	if (nDepend == `1`)
5308	break;
5309
5310	for (i = `0`; i < dest->dimen; i++)
5311	for (j = `0`; j < ss->dimen; j++)
5312	if (i != j
5313	&& dest->dim[i] == ss->dim[j])
5314	{
5315	/ If we don't access array elements in the same order,*
5316	there is a dependency. /*
5317	nDepend = `1`;
5318	goto temporary;
5319	}
5320	#if 0
5321	/ TODO : loop shifting. /
5322	if (nDepend == `1`)
5323	{
5324	/ Mark the dimensions for LOOP SHIFTING /
5325	for (n = `0`; n < loop->dimen; n++)
5326	{
5327	int dim = dest->data.info.dim[n];
5328
5329	if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
5330	depends[n] = `2`;
5331	else if (! gfc_is_same_range (&lref->u.ar,
5332	&rref->u.ar, dim, `0`))
5333	depends[n] = `1`;
5334	}
5335
5336	/ Put all the dimensions with dependencies in the*
5337	innermost loops. /*
5338	dim = `0`;
5339	for (n = `0`; n < loop->dimen; n++)
5340	{
5341	gcc_assert (loop->order[n] == n);
5342	if (depends[n])
5343	loop->order[dim++] = n;
5344	}
5345	for (n = `0`; n < loop->dimen; n++)
5346	{
5347	if (! depends[n])
5348	loop->order[dim++] = n;
5349	}
5350
5351	gcc_assert (dim == loop->dimen);
5352	break;
5353	}
5354	#endif
5355	}
5356	}
5357
5358	temporary:
5359
5360	if (nDepend == `1`)
5361	{
5362	tree base_type = gfc_typenode_for_spec (&dest_expr->ts);
5363	if (GFC_ARRAY_TYPE_P (base_type)
5364	\|\| GFC_DESCRIPTOR_TYPE_P (base_type))
5365	base_type = gfc_get_element_type (base_type);
5366	loop->temp_ss = gfc_get_temp_ss (type: base_type, string_length: dest->info->string_length,
5367	dimen: loop->dimen);
5368	gfc_add_ss_to_loop (loop, head: loop->temp_ss);
5369	}
5370	else
5371	loop->temp_ss = NULL;
5372	}
5373
5374
5375	/ Browse through each array's information from the scalarizer and set the loop*
5376	bounds according to the "best" one (per dimension), i.e. the one which
5377	provides the most information (constant bounds, shape, etc.). /*
5378
5379	static void
5380	set_loop_bounds (gfc_loopinfo *loop)
5381	{
5382	int n, dim, spec_dim;
5383	gfc_array_info *info;
5384	gfc_array_info *specinfo;
5385	gfc_ss *ss;
5386	tree tmp;
5387	gfc_ss **loopspec;
5388	bool dynamic[GFC_MAX_DIMENSIONS];
5389	mpz_t *cshape;
5390	mpz_t i;
5391	bool nonoptional_arr;
5392
5393	gfc_loopinfo * const outer_loop = outermost_loop (loop);
5394
5395	loopspec = loop->specloop;
5396
5397	mpz_init (i);
5398	for (n = `0`; n < loop->dimen; n++)
5399	{
5400	loopspec[n] = NULL;
5401	dynamic[n] = false;
5402
5403	/ If there are both optional and nonoptional array arguments, scalarize*
5404	over the nonoptional; otherwise, it does not matter as then all
5405	(optional) arrays have to be present per F2008, 125.2.12p3(6). /*
5406
5407	nonoptional_arr = false;
5408
5409	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5410	if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
5411	&& ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
5412	{
5413	nonoptional_arr = true;
5414	break;
5415	}
5416
5417	/ We use one SS term, and use that to determine the bounds of the*
5418	loop for this dimension. We try to pick the simplest term. /*
5419	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5420	{
5421	gfc_ss_type ss_type;
5422
5423	ss_type = ss->info->type;
5424	if (ss_type == GFC_SS_SCALAR
5425	\|\| ss_type == GFC_SS_TEMP
5426	\|\| ss_type == GFC_SS_REFERENCE
5427	\|\| (ss->info->can_be_null_ref && nonoptional_arr))
5428	continue;
5429
5430	info = &ss->info->data.array;
5431	dim = ss->dim[n];
5432
5433	if (loopspec[n] != NULL)
5434	{
5435	specinfo = &loopspec[n]->info->data.array;
5436	spec_dim = loopspec[n]->dim[n];
5437	}
5438	else
5439	{
5440	/ Silence uninitialized warnings. /
5441	specinfo = NULL;
5442	spec_dim = `0`;
5443	}
5444
5445	if (info->shape)
5446	{
5447	/ The frontend has worked out the size for us. /
5448	if (!loopspec[n]
5449	\|\| !specinfo->shape
5450	\|\| !integer_zerop (specinfo->start[spec_dim]))
5451	/ Prefer zero-based descriptors if possible. /
5452	loopspec[n] = ss;
5453	continue;
5454	}
5455
5456	if (ss_type == GFC_SS_CONSTRUCTOR)
5457	{
5458	gfc_constructor_base base;
5459	/ An unknown size constructor will always be rank one.*
5460	Higher rank constructors will either have known shape,
5461	or still be wrapped in a call to reshape. /*
5462	gcc_assert (loop->dimen == `1`);
5463
5464	/ Always prefer to use the constructor bounds if the size*
5465	can be determined at compile time. Prefer not to otherwise,
5466	since the general case involves realloc, and it's better to
5467	avoid that overhead if possible. /*
5468	base = ss->info->expr->value.constructor;
5469	dynamic[n] = gfc_get_array_constructor_size (size: &i, base);
5470	if (!dynamic[n] \|\| !loopspec[n])
5471	loopspec[n] = ss;
5472	continue;
5473	}
5474
5475	/ Avoid using an allocatable lhs in an assignment, since*
5476	there might be a reallocation coming. /*
5477	if (loopspec[n] && ss->is_alloc_lhs)
5478	continue;
5479
5480	if (!loopspec[n])
5481	loopspec[n] = ss;
5482	/ Criteria for choosing a loop specifier (most important first):*
5483	doesn't need realloc
5484	stride of one
5485	known stride
5486	known lower bound
5487	known upper bound
5488	*/
5489	else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
5490	loopspec[n] = ss;
5491	else if (integer_onep (info->stride[dim])
5492	&& !integer_onep (specinfo->stride[spec_dim]))
5493	loopspec[n] = ss;
5494	else if (INTEGER_CST_P (info->stride[dim])
5495	&& !INTEGER_CST_P (specinfo->stride[spec_dim]))
5496	loopspec[n] = ss;
5497	else if (INTEGER_CST_P (info->start[dim])
5498	&& !INTEGER_CST_P (specinfo->start[spec_dim])
5499	&& integer_onep (info->stride[dim])
5500	== integer_onep (specinfo->stride[spec_dim])
5501	&& INTEGER_CST_P (info->stride[dim])
5502	== INTEGER_CST_P (specinfo->stride[spec_dim]))
5503	loopspec[n] = ss;
5504	/ We don't work out the upper bound.*
5505	else if (INTEGER_CST_P (info->finish[n])
5506	&& ! INTEGER_CST_P (specinfo->finish[n]))
5507	loopspec[n] = ss; /*
5508	}
5509
5510	/ We should have found the scalarization loop specifier. If not,*
5511	that's bad news. /*
5512	gcc_assert (loopspec[n]);
5513
5514	info = &loopspec[n]->info->data.array;
5515	dim = loopspec[n]->dim[n];
5516
5517	/ Set the extents of this range. /
5518	cshape = info->shape;
5519	if (cshape && INTEGER_CST_P (info->start[dim])
5520	&& INTEGER_CST_P (info->stride[dim]))
5521	{
5522	loop->from[n] = info->start[dim];
5523	mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (ss: loopspec[n], loop_dim: n)]);
5524	mpz_sub_ui (i, i, `1`);
5525	/ To = from + (size - 1) * stride. /
5526	tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
5527	if (!integer_onep (info->stride[dim]))
5528	tmp = fold_build2_loc (input_location, MULT_EXPR,
5529	gfc_array_index_type, tmp,
5530	info->stride[dim]);
5531	loop->to[n] = fold_build2_loc (input_location, PLUS_EXPR,
5532	gfc_array_index_type,
5533	loop->from[n], tmp);
5534	}
5535	else
5536	{
5537	loop->from[n] = info->start[dim];
5538	switch (loopspec[n]->info->type)
5539	{
5540	case GFC_SS_CONSTRUCTOR:
5541	/ The upper bound is calculated when we expand the*
5542	constructor. /*
5543	gcc_assert (loop->to[n] == NULL_TREE);
5544	break;
5545
5546	case GFC_SS_SECTION:
5547	/ Use the end expression if it exists and is not constant,*
5548	so that it is only evaluated once. /*
5549	loop->to[n] = info->end[dim];
5550	break;
5551
5552	case GFC_SS_FUNCTION:
5553	/ The loop bound will be set when we generate the call. /
5554	gcc_assert (loop->to[n] == NULL_TREE);
5555	break;
5556
5557	case GFC_SS_INTRINSIC:
5558	{
5559	gfc_expr *expr = loopspec[n]->info->expr;
5560
5561	/ The {l,u}bound of an assumed rank. /
5562	if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
5563	gcc_assert (expr->value.function.actual->expr->rank == -`1`);
5564	else
5565	gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
5566	\|\| expr->value.function.isym->id == GFC_ISYM_UBOUND)
5567	&& expr->value.function.actual->next->expr == NULL
5568	&& expr->value.function.actual->expr->rank == -`1`);
5569
5570	loop->to[n] = info->end[dim];
5571	break;
5572	}
5573
5574	case GFC_SS_COMPONENT:
5575	{
5576	if (info->end[dim] != NULL_TREE)
5577	{
5578	loop->to[n] = info->end[dim];
5579	break;
5580	}
5581	else
5582	gcc_unreachable ();
5583	}
5584
5585	default:
5586	gcc_unreachable ();
5587	}
5588	}
5589
5590	/ Transform everything so we have a simple incrementing variable. /
5591	if (integer_onep (info->stride[dim]))
5592	info->delta[dim] = gfc_index_zero_node;
5593	else
5594	{
5595	/ Set the delta for this section. /
5596	info->delta[dim] = gfc_evaluate_now (loop->from[n], &outer_loop->pre);
5597	/ Number of iterations is (end - start + step) / step.*
5598	with start = 0, this simplifies to
5599	last = end / step;
5600	for (i = 0; i<=last; i++){...}; /*
5601	tmp = fold_build2_loc (input_location, MINUS_EXPR,
5602	gfc_array_index_type, loop->to[n],
5603	loop->from[n]);
5604	tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR,
5605	gfc_array_index_type, tmp, info->stride[dim]);
5606	tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5607	tmp, build_int_cst (gfc_array_index_type, -`1`));
5608	loop->to[n] = gfc_evaluate_now (tmp, &outer_loop->pre);
5609	/ Make the loop variable start at 0. /
5610	loop->from[n] = gfc_index_zero_node;
5611	}
5612	}
5613	mpz_clear (i);
5614
5615	for (loop = loop->nested; loop; loop = loop->next)
5616	set_loop_bounds (loop);
5617	}
5618
5619
5620	/ Initialize the scalarization loop. Creates the loop variables. Determines*
5621	the range of the loop variables. Creates a temporary if required.
5622	Also generates code for scalar expressions which have been
5623	moved outside the loop. /*
5624
5625	void
5626	gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
5627	{
5628	gfc_ss *tmp_ss;
5629	tree tmp;
5630
5631	set_loop_bounds (loop);
5632
5633	/ Add all the scalar code that can be taken out of the loops.*
5634	This may include calculating the loop bounds, so do it before
5635	allocating the temporary. /*
5636	gfc_add_loop_ss_code (loop, ss: loop->ss, subscript: false, where);
5637
5638	tmp_ss = loop->temp_ss;
5639	/ If we want a temporary then create it. /
5640	if (tmp_ss != NULL)
5641	{
5642	gfc_ss_info *tmp_ss_info;
5643
5644	tmp_ss_info = tmp_ss->info;
5645	gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
5646	gcc_assert (loop->parent == NULL);
5647
5648	/ Make absolutely sure that this is a complete type. /
5649	if (tmp_ss_info->string_length)
5650	tmp_ss_info->data.temp.type
5651	= gfc_get_character_type_len_for_eltype
5652	(TREE_TYPE (tmp_ss_info->data.temp.type),
5653	tmp_ss_info->string_length);
5654
5655	tmp = tmp_ss_info->data.temp.type;
5656	memset (s: &tmp_ss_info->data.array, c: `0`, n: sizeof (gfc_array_info));
5657	tmp_ss_info->type = GFC_SS_SECTION;
5658
5659	gcc_assert (tmp_ss->dimen != `0`);
5660
5661	gfc_trans_create_temp_array (pre: &loop->pre, post: &loop->post, ss: tmp_ss, eltype: tmp,
5662	NULL_TREE, dynamic: false, dealloc: true, callee_alloc: false, where);
5663	}
5664
5665	/ For array parameters we don't have loop variables, so don't calculate the*
5666	translations. /*
5667	if (!loop->array_parameter)
5668	gfc_set_delta (loop);
5669	}
5670
5671
5672	/ Calculates how to transform from loop variables to array indices for each*
5673	array: once loop bounds are chosen, sets the difference (DELTA field) between
5674	loop bounds and array reference bounds, for each array info. /*
5675
5676	void
5677	gfc_set_delta (gfc_loopinfo *loop)
5678	{
5679	gfc_ss ss, *loopspec;
5680	gfc_array_info *info;
5681	tree tmp;
5682	int n, dim;
5683
5684	gfc_loopinfo * const outer_loop = outermost_loop (loop);
5685
5686	loopspec = loop->specloop;
5687
5688	/ Calculate the translation from loop variables to array indices. /
5689	for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
5690	{
5691	gfc_ss_type ss_type;
5692
5693	ss_type = ss->info->type;
5694	if (ss_type != GFC_SS_SECTION
5695	&& ss_type != GFC_SS_COMPONENT
5696	&& ss_type != GFC_SS_CONSTRUCTOR)
5697	continue;
5698
5699	info = &ss->info->data.array;
5700
5701	for (n = `0`; n < ss->dimen; n++)
5702	{
5703	/ If we are specifying the range the delta is already set. /
5704	if (loopspec[n] != ss)
5705	{
5706	dim = ss->dim[n];
5707
5708	/ Calculate the offset relative to the loop variable.*
5709	First multiply by the stride. /*
5710	tmp = loop->from[n];
5711	if (!integer_onep (info->stride[dim]))
5712	tmp = fold_build2_loc (input_location, MULT_EXPR,
5713	gfc_array_index_type,
5714	tmp, info->stride[dim]);
5715
5716	/ Then subtract this from our starting value. /
5717	tmp = fold_build2_loc (input_location, MINUS_EXPR,
5718	gfc_array_index_type,
5719	info->start[dim], tmp);
5720
5721	info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
5722	}
5723	}
5724	}
5725
5726	for (loop = loop->nested; loop; loop = loop->next)
5727	gfc_set_delta (loop);
5728	}
5729
5730
5731	/ Calculate the size of a given array dimension from the bounds. This*
5732	is simply (ubound - lbound + 1) if this expression is positive
5733	or 0 if it is negative (pick either one if it is zero). Optionally
5734	(if or_expr is present) OR the (expression != 0) condition to it. /*
5735
5736	tree
5737	gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
5738	{
5739	tree res;
5740	tree cond;
5741
5742	/ Calculate (ubound - lbound + 1). /
5743	res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5744	ubound, lbound);
5745	res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
5746	gfc_index_one_node);
5747
5748	/ Check whether the size for this dimension is negative. /
5749	cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
5750	gfc_index_zero_node);
5751	res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
5752	gfc_index_zero_node, res);
5753
5754	/ Build OR expression. /
5755	if (or_expr)
5756	*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
5757	logical_type_node, *or_expr, cond);
5758
5759	return res;
5760	}
5761
5762
5763	/ For an array descriptor, get the total number of elements. This is just*
5764	the product of the extents along from_dim to to_dim. /*
5765
5766	static tree
5767	gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
5768	{
5769	tree res;
5770	int dim;
5771
5772	res = gfc_index_one_node;
5773
5774	for (dim = from_dim; dim < to_dim; ++dim)
5775	{
5776	tree lbound;
5777	tree ubound;
5778	tree extent;
5779
5780	lbound = gfc_conv_descriptor_lbound_get (desc, dim: gfc_rank_cst[dim]);
5781	ubound = gfc_conv_descriptor_ubound_get (desc, dim: gfc_rank_cst[dim]);
5782
5783	extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
5784	res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5785	res, extent);
5786	}
5787
5788	return res;
5789	}
5790
5791
5792	/ Full size of an array. /
5793
5794	tree
5795	gfc_conv_descriptor_size (tree desc, int rank)
5796	{
5797	return gfc_conv_descriptor_size_1 (desc, from_dim: `0`, to_dim: rank);
5798	}
5799
5800
5801	/ Size of a coarray for all dimensions but the last. /
5802
5803	tree
5804	gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
5805	{
5806	return gfc_conv_descriptor_size_1 (desc, from_dim: rank, to_dim: rank + corank - `1`);
5807	}
5808
5809
5810	/ Fills in an array descriptor, and returns the size of the array.*
5811	The size will be a simple_val, ie a variable or a constant. Also
5812	calculates the offset of the base. The pointer argument overflow,
5813	which should be of integer type, will increase in value if overflow
5814	occurs during the size calculation. Returns the size of the array.
5815	{
5816	stride = 1;
5817	offset = 0;
5818	for (n = 0; n < rank; n++)
5819	{
5820	a.lbound[n] = specified_lower_bound;
5821	offset = offset + a.lbond[n] stride;*
5822	size = 1 - lbound;
5823	a.ubound[n] = specified_upper_bound;
5824	a.stride[n] = stride;
5825	size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
5826	overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
5827	stride = stride size;*
5828	}
5829	for (n = rank; n < rank+corank; n++)
5830	(Set lcobound/ucobound as above.)
5831	element_size = sizeof (array element);
5832	if (!rank)
5833	return element_size
5834	stride = (size_t) stride;
5835	overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
5836	stride = stride element_size;*
5837	return (stride);
5838	} /*
5839	/GCC ARRAYS/
5840
5841	static tree
5842	gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
5843	gfc_expr lower, gfc_expr upper, stmtblock_t * pblock,
5844	stmtblock_t * descriptor_block, tree * overflow,
5845	tree expr3_elem_size, tree nelems, gfc_expr expr3,
5846	tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
5847	tree *element_size)
5848	{
5849	tree type;
5850	tree tmp;
5851	tree size;
5852	tree offset;
5853	tree stride;
5854	tree or_expr;
5855	tree thencase;
5856	tree elsecase;
5857	tree cond;
5858	tree var;
5859	stmtblock_t thenblock;
5860	stmtblock_t elseblock;
5861	gfc_expr *ubound;
5862	gfc_se se;
5863	int n;
5864
5865	type = TREE_TYPE (descriptor);
5866
5867	stride = gfc_index_one_node;
5868	offset = gfc_index_zero_node;
5869
5870	/ Set the dtype before the alloc, because registration of coarrays needs*
5871	it initialized. /*
5872	if (expr->ts.type == BT_CHARACTER
5873	&& expr->ts.deferred
5874	&& VAR_P (expr->ts.u.cl->backend_decl))
5875	{
5876	type = gfc_typenode_for_spec (&expr->ts);
5877	tmp = gfc_conv_descriptor_dtype (desc: descriptor);
5878	gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
5879	}
5880	else if (expr->ts.type == BT_CHARACTER
5881	&& expr->ts.deferred
5882	&& TREE_CODE (descriptor) == COMPONENT_REF)
5883	{
5884	/ Deferred character components have their string length tucked away*
5885	in a hidden field of the derived type. Obtain that and use it to
5886	set the dtype. The charlen backend decl is zero because the field
5887	type is zero length. /*
5888	gfc_ref *ref;
5889	tmp = NULL_TREE;
5890	for (ref = expr->ref; ref; ref = ref->next)
5891	if (ref->type == REF_COMPONENT
5892	&& gfc_deferred_strlen (ref->u.c.component, &tmp))
5893	break;
5894	gcc_assert (tmp != NULL_TREE);
5895	tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
5896	TREE_OPERAND (descriptor, `0`), tmp, NULL_TREE);
5897	tmp = fold_convert (gfc_charlen_type_node, tmp);
5898	type = gfc_get_character_type_len (expr->ts.kind, tmp);
5899	tmp = gfc_conv_descriptor_dtype (desc: descriptor);
5900	gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
5901	}
5902	else
5903	{
5904	tmp = gfc_conv_descriptor_dtype (desc: descriptor);
5905	gfc_add_modify (pblock, tmp, gfc_get_dtype (type));
5906	}
5907
5908	or_expr = logical_false_node;
5909
5910	for (n = `0`; n < rank; n++)
5911	{
5912	tree conv_lbound;
5913	tree conv_ubound;
5914
5915	/ We have 3 possibilities for determining the size of the array:*
5916	lower == NULL => lbound = 1, ubound = upper[n]
5917	upper[n] = NULL => lbound = 1, ubound = lower[n]
5918	upper[n] != NULL => lbound = lower[n], ubound = upper[n] /*
5919	ubound = upper[n];
5920
5921	/ Set lower bound. /
5922	gfc_init_se (&se, NULL);
5923	if (expr3_desc != NULL_TREE)
5924	{
5925	if (e3_has_nodescriptor)
5926	/ The lbound of nondescriptor arrays like array constructors,*
5927	nonallocatable/nonpointer function results/variables,
5928	start at zero, but when allocating it, the standard expects
5929	the array to start at one. /*
5930	se.expr = gfc_index_one_node;
5931	else
5932	se.expr = gfc_conv_descriptor_lbound_get (desc: expr3_desc,
5933	dim: gfc_rank_cst[n]);
5934	}
5935	else if (lower == NULL)
5936	se.expr = gfc_index_one_node;
5937	else
5938	{
5939	gcc_assert (lower[n]);
5940	if (ubound)
5941	{
5942	gfc_conv_expr_type (se: &se, lower[n], gfc_array_index_type);
5943	gfc_add_block_to_block (pblock, &se.pre);
5944	}
5945	else
5946	{
5947	se.expr = gfc_index_one_node;
5948	ubound = lower[n];
5949	}
5950	}
5951	gfc_conv_descriptor_lbound_set (block: descriptor_block, desc: descriptor,
5952	dim: gfc_rank_cst[n], value: se.expr);
5953	conv_lbound = se.expr;
5954
5955	/ Work out the offset for this component. /
5956	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5957	se.expr, stride);
5958	offset = fold_build2_loc (input_location, MINUS_EXPR,
5959	gfc_array_index_type, offset, tmp);
5960
5961	/ Set upper bound. /
5962	gfc_init_se (&se, NULL);
5963	if (expr3_desc != NULL_TREE)
5964	{
5965	if (e3_has_nodescriptor)
5966	{
5967	/ The lbound of nondescriptor arrays like array constructors,*
5968	nonallocatable/nonpointer function results/variables,
5969	start at zero, but when allocating it, the standard expects
5970	the array to start at one. Therefore fix the upper bound to be
5971	(desc.ubound - desc.lbound) + 1. /*
5972	tmp = fold_build2_loc (input_location, MINUS_EXPR,
5973	gfc_array_index_type,
5974	gfc_conv_descriptor_ubound_get (
5975	desc: expr3_desc, dim: gfc_rank_cst[n]),
5976	gfc_conv_descriptor_lbound_get (
5977	desc: expr3_desc, dim: gfc_rank_cst[n]));
5978	tmp = fold_build2_loc (input_location, PLUS_EXPR,
5979	gfc_array_index_type, tmp,
5980	gfc_index_one_node);
5981	se.expr = gfc_evaluate_now (tmp, pblock);
5982	}
5983	else
5984	se.expr = gfc_conv_descriptor_ubound_get (desc: expr3_desc,
5985	dim: gfc_rank_cst[n]);
5986	}
5987	else
5988	{
5989	gcc_assert (ubound);
5990	gfc_conv_expr_type (se: &se, ubound, gfc_array_index_type);
5991	gfc_add_block_to_block (pblock, &se.pre);
5992	if (ubound->expr_type == EXPR_FUNCTION)
5993	se.expr = gfc_evaluate_now (se.expr, pblock);
5994	}
5995	gfc_conv_descriptor_ubound_set (block: descriptor_block, desc: descriptor,
5996	dim: gfc_rank_cst[n], value: se.expr);
5997	conv_ubound = se.expr;
5998
5999	/ Store the stride. /
6000	gfc_conv_descriptor_stride_set (block: descriptor_block, desc: descriptor,
6001	dim: gfc_rank_cst[n], value: stride);
6002
6003	/ Calculate size and check whether extent is negative. /
6004	size = gfc_conv_array_extent_dim (lbound: conv_lbound, ubound: conv_ubound, or_expr: &or_expr);
6005	size = gfc_evaluate_now (size, pblock);
6006
6007	/ Check whether multiplying the stride by the number of*
6008	elements in this dimension would overflow. We must also check
6009	whether the current dimension has zero size in order to avoid
6010	division by zero.
6011	*/
6012	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6013	gfc_array_index_type,
6014	fold_convert (gfc_array_index_type,
6015	TYPE_MAX_VALUE (gfc_array_index_type)),
6016	size);
6017	cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6018	logical_type_node, tmp, stride),
6019	PRED_FORTRAN_OVERFLOW);
6020	tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6021	integer_one_node, integer_zero_node);
6022	cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6023	logical_type_node, size,
6024	gfc_index_zero_node),
6025	PRED_FORTRAN_SIZE_ZERO);
6026	tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6027	integer_zero_node, tmp);
6028	tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6029	*overflow, tmp);
6030	*overflow = gfc_evaluate_now (tmp, pblock);
6031
6032	/ Multiply the stride by the number of elements in this dimension. /
6033	stride = fold_build2_loc (input_location, MULT_EXPR,
6034	gfc_array_index_type, stride, size);
6035	stride = gfc_evaluate_now (stride, pblock);
6036	}
6037
6038	for (n = rank; n < rank + corank; n++)
6039	{
6040	ubound = upper[n];
6041
6042	/ Set lower bound. /
6043	gfc_init_se (&se, NULL);
6044	if (lower == NULL \|\| lower[n] == NULL)
6045	{
6046	gcc_assert (n == rank + corank - `1`);
6047	se.expr = gfc_index_one_node;
6048	}
6049	else
6050	{
6051	if (ubound \|\| n == rank + corank - `1`)
6052	{
6053	gfc_conv_expr_type (se: &se, lower[n], gfc_array_index_type);
6054	gfc_add_block_to_block (pblock, &se.pre);
6055	}
6056	else
6057	{
6058	se.expr = gfc_index_one_node;
6059	ubound = lower[n];
6060	}
6061	}
6062	gfc_conv_descriptor_lbound_set (block: descriptor_block, desc: descriptor,
6063	dim: gfc_rank_cst[n], value: se.expr);
6064
6065	if (n < rank + corank - `1`)
6066	{
6067	gfc_init_se (&se, NULL);
6068	gcc_assert (ubound);
6069	gfc_conv_expr_type (se: &se, ubound, gfc_array_index_type);
6070	gfc_add_block_to_block (pblock, &se.pre);
6071	gfc_conv_descriptor_ubound_set (block: descriptor_block, desc: descriptor,
6072	dim: gfc_rank_cst[n], value: se.expr);
6073	}
6074	}
6075
6076	/ The stride is the number of elements in the array, so multiply by the*
6077	size of an element to get the total size. Obviously, if there is a
6078	SOURCE expression (expr3) we must use its element size. /*
6079	if (expr3_elem_size != NULL_TREE)
6080	tmp = expr3_elem_size;
6081	else if (expr3 != NULL)
6082	{
6083	if (expr3->ts.type == BT_CLASS)
6084	{
6085	gfc_se se_sz;
6086	gfc_expr *sz = gfc_copy_expr (expr3);
6087	gfc_add_vptr_component (sz);
6088	gfc_add_size_component (sz);
6089	gfc_init_se (&se_sz, NULL);
6090	gfc_conv_expr (se: &se_sz, expr: sz);
6091	gfc_free_expr (sz);
6092	tmp = se_sz.expr;
6093	}
6094	else
6095	{
6096	tmp = gfc_typenode_for_spec (&expr3->ts);
6097	tmp = TYPE_SIZE_UNIT (tmp);
6098	}
6099	}
6100	else
6101	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6102
6103	/ Convert to size_t. /
6104	*element_size = fold_convert (size_type_node, tmp);
6105
6106	if (rank == `0`)
6107	return *element_size;
6108
6109	*nelems = gfc_evaluate_now (stride, pblock);
6110	stride = fold_convert (size_type_node, stride);
6111
6112	/ First check for overflow. Since an array of type character can*
6113	have zero element_size, we must check for that before
6114	dividing. /*
6115	tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6116	size_type_node,
6117	TYPE_MAX_VALUE (size_type_node), *element_size);
6118	cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
6119	logical_type_node, tmp, stride),
6120	PRED_FORTRAN_OVERFLOW);
6121	tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6122	integer_one_node, integer_zero_node);
6123	cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
6124	logical_type_node, *element_size,
6125	build_int_cst (size_type_node, `0`)),
6126	PRED_FORTRAN_SIZE_ZERO);
6127	tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
6128	integer_zero_node, tmp);
6129	tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
6130	*overflow, tmp);
6131	*overflow = gfc_evaluate_now (tmp, pblock);
6132
6133	size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6134	stride, *element_size);
6135
6136	if (poffset != NULL)
6137	{
6138	offset = gfc_evaluate_now (offset, pblock);
6139	*poffset = offset;
6140	}
6141
6142	if (integer_zerop (or_expr))
6143	return size;
6144	if (integer_onep (or_expr))
6145	return build_int_cst (size_type_node, `0`);
6146
6147	var = gfc_create_var (TREE_TYPE (size), "size");
6148	gfc_start_block (&thenblock);
6149	gfc_add_modify (&thenblock, var, build_int_cst (size_type_node, `0`));
6150	thencase = gfc_finish_block (&thenblock);
6151
6152	gfc_start_block (&elseblock);
6153	gfc_add_modify (&elseblock, var, size);
6154	elsecase = gfc_finish_block (&elseblock);
6155
6156	tmp = gfc_evaluate_now (or_expr, pblock);
6157	tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
6158	gfc_add_expr_to_block (pblock, tmp);
6159
6160	return var;
6161	}
6162
6163
6164	/ Retrieve the last ref from the chain. This routine is specific to*
6165	gfc_array_allocate ()'s needs. /*
6166
6167	bool
6168	retrieve_last_ref (gfc_ref ref_in, gfc_ref prev_ref_in)
6169	{
6170	gfc_ref ref, prev_ref;
6171
6172	ref = *ref_in;
6173	/ Prevent warnings for uninitialized variables. /
6174	prev_ref = *prev_ref_in;
6175	while (ref && ref->next != NULL)
6176	{
6177	gcc_assert (ref->type != REF_ARRAY \|\| ref->u.ar.type == AR_ELEMENT
6178	\|\| (ref->u.ar.dimen == `0` && ref->u.ar.codimen > `0`));
6179	prev_ref = ref;
6180	ref = ref->next;
6181	}
6182
6183	if (ref == NULL \|\| ref->type != REF_ARRAY)
6184	return false;
6185
6186	*ref_in = ref;
6187	*prev_ref_in = prev_ref;
6188	return true;
6189	}
6190
6191	/ Initializes the descriptor and generates a call to _gfor_allocate. Does*
6192	the work for an ALLOCATE statement. /*
6193	/GCC ARRAYS/
6194
6195	bool
6196	gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
6197	tree errlen, tree label_finish, tree expr3_elem_size,
6198	tree nelems, gfc_expr expr3, tree e3_arr_desc,
6199	bool e3_has_nodescriptor)
6200	{
6201	tree tmp;
6202	tree pointer;
6203	tree offset = NULL_TREE;
6204	tree token = NULL_TREE;
6205	tree size;
6206	tree msg;
6207	tree error = NULL_TREE;
6208	tree overflow; / Boolean storing whether size calculation overflows. /
6209	tree var_overflow = NULL_TREE;
6210	tree cond;
6211	tree set_descriptor;
6212	tree not_prev_allocated = NULL_TREE;
6213	tree element_size = NULL_TREE;
6214	stmtblock_t set_descriptor_block;
6215	stmtblock_t elseblock;
6216	gfc_expr **lower;
6217	gfc_expr **upper;
6218	gfc_ref ref, prev_ref = NULL, *coref;
6219	bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
6220	non_ulimate_coarray_ptr_comp;
6221
6222	ref = expr->ref;
6223
6224	/ Find the last reference in the chain. /
6225	if (!retrieve_last_ref (ref_in: &ref, prev_ref_in: &prev_ref))
6226	return false;
6227
6228	/ Take the allocatable and coarray properties solely from the expr-ref's*
6229	attributes and not from source=-expression. /*
6230	if (!prev_ref)
6231	{
6232	allocatable = expr->symtree->n.sym->attr.allocatable;
6233	dimension = expr->symtree->n.sym->attr.dimension;
6234	non_ulimate_coarray_ptr_comp = false;
6235	}
6236	else
6237	{
6238	allocatable = prev_ref->u.c.component->attr.allocatable;
6239	/ Pointer components in coarrayed derived types must be treated*
6240	specially in that they are registered without a check if the are
6241	already associated. This does not hold for ultimate coarray
6242	pointers. /*
6243	non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
6244	&& !prev_ref->u.c.component->attr.codimension);
6245	dimension = prev_ref->u.c.component->attr.dimension;
6246	}
6247
6248	/ For allocatable/pointer arrays in derived types, one of the refs has to be*
6249	a coarray. In this case it does not matter whether we are on this_image
6250	or not. /*
6251	coarray = false;
6252	for (coref = expr->ref; coref; coref = coref->next)
6253	if (coref->type == REF_ARRAY && coref->u.ar.codimen > `0`)
6254	{
6255	coarray = true;
6256	break;
6257	}
6258
6259	if (!dimension)
6260	gcc_assert (coarray);
6261
6262	if (ref->u.ar.type == AR_FULL && expr3 != NULL)
6263	{
6264	gfc_ref *old_ref = ref;
6265	/ F08:C633: Array shape from expr3. /
6266	ref = expr3->ref;
6267
6268	/ Find the last reference in the chain. /
6269	if (!retrieve_last_ref (ref_in: &ref, prev_ref_in: &prev_ref))
6270	{
6271	if (expr3->expr_type == EXPR_FUNCTION
6272	&& gfc_expr_attr (expr3).dimension)
6273	ref = old_ref;
6274	else
6275	return false;
6276	}
6277	alloc_w_e3_arr_spec = true;
6278	}
6279
6280	/ Figure out the size of the array. /
6281	switch (ref->u.ar.type)
6282	{
6283	case AR_ELEMENT:
6284	if (!coarray)
6285	{
6286	lower = NULL;
6287	upper = ref->u.ar.start;
6288	break;
6289	}
6290	/ Fall through. /
6291
6292	case AR_SECTION:
6293	lower = ref->u.ar.start;
6294	upper = ref->u.ar.end;
6295	break;
6296
6297	case AR_FULL:
6298	gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
6299	\|\| alloc_w_e3_arr_spec);
6300
6301	lower = ref->u.ar.as->lower;
6302	upper = ref->u.ar.as->upper;
6303	break;
6304
6305	default:
6306	gcc_unreachable ();
6307	break;
6308	}
6309
6310	overflow = integer_zero_node;
6311
6312	if (expr->ts.type == BT_CHARACTER
6313	&& TREE_CODE (se->string_length) == COMPONENT_REF
6314	&& expr->ts.u.cl->backend_decl != se->string_length
6315	&& VAR_P (expr->ts.u.cl->backend_decl))
6316	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
6317	fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
6318	se->string_length));
6319
6320	gfc_init_block (&set_descriptor_block);
6321	/ Take the corank only from the actual ref and not from the coref. The*
6322	later will mislead the generation of the array dimensions for allocatable/
6323	pointer components in derived types. /*
6324	size = gfc_array_init_size (descriptor: se->expr, rank: alloc_w_e3_arr_spec ? expr->rank
6325	: ref->u.ar.as->rank,
6326	corank: coarray ? ref->u.ar.as->corank : `0`,
6327	poffset: &offset, lower, upper,
6328	pblock: &se->pre, descriptor_block: &set_descriptor_block, overflow: &overflow,
6329	expr3_elem_size, nelems, expr3, expr3_desc: e3_arr_desc,
6330	e3_has_nodescriptor, expr, element_size: &element_size);
6331
6332	if (dimension)
6333	{
6334	var_overflow = gfc_create_var (integer_type_node, "overflow");
6335	gfc_add_modify (&se->pre, var_overflow, overflow);
6336
6337	if (status == NULL_TREE)
6338	{
6339	/ Generate the block of code handling overflow. /
6340	msg = gfc_build_addr_expr (pchar_type_node,
6341	gfc_build_localized_cstring_const
6342	("Integer overflow when calculating the amount of "
6343	"memory to allocate"));
6344	error = build_call_expr_loc (input_location,
6345	gfor_fndecl_runtime_error, `1`, msg);
6346	}
6347	else
6348	{
6349	tree status_type = TREE_TYPE (status);
6350	stmtblock_t set_status_block;
6351
6352	gfc_start_block (&set_status_block);
6353	gfc_add_modify (&set_status_block, status,
6354	build_int_cst (status_type, LIBERROR_ALLOCATION));
6355	error = gfc_finish_block (&set_status_block);
6356	}
6357	}
6358
6359	/ Allocate memory to store the data. /
6360	if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
6361	se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6362
6363	if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
6364	{
6365	pointer = non_ulimate_coarray_ptr_comp ? se->expr
6366	: gfc_conv_descriptor_data_get (desc: se->expr);
6367	token = gfc_conv_descriptor_token (desc: se->expr);
6368	token = gfc_build_addr_expr (NULL_TREE, token);
6369	}
6370	else
6371	pointer = gfc_conv_descriptor_data_get (desc: se->expr);
6372	STRIP_NOPS (pointer);
6373
6374	if (allocatable)
6375	{
6376	not_prev_allocated = gfc_create_var (logical_type_node,
6377	"not_prev_allocated");
6378	tmp = fold_build2_loc (input_location, EQ_EXPR,
6379	logical_type_node, pointer,
6380	build_int_cst (TREE_TYPE (pointer), `0`));
6381
6382	gfc_add_modify (&se->pre, not_prev_allocated, tmp);
6383	}
6384
6385	gfc_start_block (&elseblock);
6386
6387	/ The allocatable variant takes the old pointer as first argument. /
6388	if (allocatable)
6389	gfc_allocate_allocatable (&elseblock, pointer, size, token,
6390	status, errmsg, errlen, label_finish, expr,
6391	coref != NULL ? coref->u.ar.as->corank : `0`);
6392	else if (non_ulimate_coarray_ptr_comp && token)
6393	/ The token is set only for GFC_FCOARRAY_LIB mode. /
6394	gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
6395	errmsg, errlen,
6396	GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
6397	else
6398	gfc_allocate_using_malloc (&elseblock, pointer, size, status);
6399
6400	if (dimension)
6401	{
6402	cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
6403	logical_type_node, var_overflow, integer_zero_node),
6404	PRED_FORTRAN_OVERFLOW);
6405	tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6406	error, gfc_finish_block (&elseblock));
6407	}
6408	else
6409	tmp = gfc_finish_block (&elseblock);
6410
6411	gfc_add_expr_to_block (&se->pre, tmp);
6412
6413	/ Update the array descriptor with the offset and the span. /
6414	if (dimension)
6415	{
6416	gfc_conv_descriptor_offset_set (block: &set_descriptor_block, desc: se->expr, value: offset);
6417	tmp = fold_convert (gfc_array_index_type, element_size);
6418	gfc_conv_descriptor_span_set (block: &set_descriptor_block, desc: se->expr, value: tmp);
6419	}
6420
6421	set_descriptor = gfc_finish_block (&set_descriptor_block);
6422	if (status != NULL_TREE)
6423	{
6424	cond = fold_build2_loc (input_location, EQ_EXPR,
6425	logical_type_node, status,
6426	build_int_cst (TREE_TYPE (status), `0`));
6427
6428	if (not_prev_allocated != NULL_TREE)
6429	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
6430	logical_type_node, cond, not_prev_allocated);
6431
6432	gfc_add_expr_to_block (&se->pre,
6433	fold_build3_loc (input_location, COND_EXPR, void_type_node,
6434	cond,
6435	set_descriptor,
6436	build_empty_stmt (input_location)));
6437	}
6438	else
6439	gfc_add_expr_to_block (&se->pre, set_descriptor);
6440
6441	return true;
6442	}
6443
6444
6445	/ Create an array constructor from an initialization expression.*
6446	We assume the frontend already did any expansions and conversions. /*
6447
6448	tree
6449	gfc_conv_array_initializer (tree type, gfc_expr * expr)
6450	{
6451	gfc_constructor *c;
6452	tree tmp;
6453	gfc_se se;
6454	tree index, range;
6455	vec<constructor_elt, va_gc> *v = NULL;
6456
6457	if (expr->expr_type == EXPR_VARIABLE
6458	&& expr->symtree->n.sym->attr.flavor == FL_PARAMETER
6459	&& expr->symtree->n.sym->value)
6460	expr = expr->symtree->n.sym->value;
6461
6462	switch (expr->expr_type)
6463	{
6464	case EXPR_CONSTANT:
6465	case EXPR_STRUCTURE:
6466	/ A single scalar or derived type value. Create an array with all*
6467	elements equal to that value. /*
6468	gfc_init_se (&se, NULL);
6469
6470	if (expr->expr_type == EXPR_CONSTANT)
6471	gfc_conv_constant (&se, expr);
6472	else
6473	gfc_conv_structure (&se, expr, `1`);
6474
6475	if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
6476	TYPE_MIN_VALUE (TYPE_DOMAIN (type))))
6477	break;
6478	else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6479	TYPE_MAX_VALUE (TYPE_DOMAIN (type))))
6480	range = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
6481	else
6482	range = build2 (RANGE_EXPR, gfc_array_index_type,
6483	TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
6484	TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
6485	CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6486	break;
6487
6488	case EXPR_ARRAY:
6489	/ Create a vector of all the elements. /
6490	for (c = gfc_constructor_first (base: expr->value.constructor);
6491	c && c->expr; c = gfc_constructor_next (ctor: c))
6492	{
6493	if (c->iterator)
6494	{
6495	/ Problems occur when we get something like*
6496	integer :: a(lots) = (/(i, i=1, lots)/) /*
6497	gfc_fatal_error ("The number of elements in the array "
6498	"constructor at %L requires an increase of "
6499	"the allowed %d upper limit. See "
6500	"%<-fmax-array-constructor%> option",
6501	&expr->where, flag_max_array_constructor);
6502	return NULL_TREE;
6503	}
6504	if (mpz_cmp_si (c->offset, `0`) != `0`)
6505	index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6506	else
6507	index = NULL_TREE;
6508
6509	if (mpz_cmp_si (c->repeat, `1`) > `0`)
6510	{
6511	tree tmp1, tmp2;
6512	mpz_t maxval;
6513
6514	mpz_init (maxval);
6515	mpz_add (maxval, c->offset, c->repeat);
6516	mpz_sub_ui (maxval, maxval, `1`);
6517	tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6518	if (mpz_cmp_si (c->offset, `0`) != `0`)
6519	{
6520	mpz_add_ui (maxval, c->offset, `1`);
6521	tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
6522	}
6523	else
6524	tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
6525
6526	range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
6527	mpz_clear (maxval);
6528	}
6529	else
6530	range = NULL;
6531
6532	gfc_init_se (&se, NULL);
6533	switch (c->expr->expr_type)
6534	{
6535	case EXPR_CONSTANT:
6536	gfc_conv_constant (&se, c->expr);
6537
6538	/ See gfortran.dg/charlen_15.f90 for instance. /
6539	if (TREE_CODE (se.expr) == STRING_CST
6540	&& TREE_CODE (type) == ARRAY_TYPE)
6541	{
6542	tree atype = type;
6543	while (TREE_CODE (TREE_TYPE (atype)) == ARRAY_TYPE)
6544	atype = TREE_TYPE (atype);
6545	gcc_checking_assert (TREE_CODE (TREE_TYPE (atype))
6546	== INTEGER_TYPE);
6547	gcc_checking_assert (TREE_TYPE (TREE_TYPE (se.expr))
6548	== TREE_TYPE (atype));
6549	if (tree_to_uhwi (TYPE_SIZE_UNIT (TREE_TYPE (se.expr)))
6550	> tree_to_uhwi (TYPE_SIZE_UNIT (atype)))
6551	{
6552	unsigned HOST_WIDE_INT size
6553	= tree_to_uhwi (TYPE_SIZE_UNIT (atype));
6554	const char *p = TREE_STRING_POINTER (se.expr);
6555
6556	se.expr = build_string (size, p);
6557	}
6558	TREE_TYPE (se.expr) = atype;
6559	}
6560	break;
6561
6562	case EXPR_STRUCTURE:
6563	gfc_conv_structure (&se, c->expr, `1`);
6564	break;
6565
6566	default:
6567	/ Catch those occasional beasts that do not simplify*
6568	for one reason or another, assuming that if they are
6569	standard defying the frontend will catch them. /*
6570	gfc_conv_expr (se: &se, expr: c->expr);
6571	break;
6572	}
6573
6574	if (range == NULL_TREE)
6575	CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6576	else
6577	{
6578	if (index != NULL_TREE)
6579	CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
6580	CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
6581	}
6582	}
6583	break;
6584
6585	case EXPR_NULL:
6586	return gfc_build_null_descriptor (type);
6587
6588	default:
6589	gcc_unreachable ();
6590	}
6591
6592	/ Create a constructor from the list of elements. /
6593	tmp = build_constructor (type, v);
6594	TREE_CONSTANT (tmp) = `1`;
6595	return tmp;
6596	}
6597
6598
6599	/ Generate code to evaluate non-constant coarray cobounds. /
6600
6601	void
6602	gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
6603	const gfc_symbol *sym)
6604	{
6605	int dim;
6606	tree ubound;
6607	tree lbound;
6608	gfc_se se;
6609	gfc_array_spec *as;
6610
6611	as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6612
6613	for (dim = as->rank; dim < as->rank + as->corank; dim++)
6614	{
6615	/ Evaluate non-constant array bound expressions.*
6616	F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6617	references a function, the result is finalized before execution of the
6618	executable constructs in the scoping unit.
6619	Adding the finalblocks enables this. /*
6620	lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6621	if (as->lower[dim] && !INTEGER_CST_P (lbound))
6622	{
6623	gfc_init_se (&se, NULL);
6624	gfc_conv_expr_type (se: &se, as->lower[dim], gfc_array_index_type);
6625	gfc_add_block_to_block (pblock, &se.pre);
6626	gfc_add_block_to_block (pblock, &se.finalblock);
6627	gfc_add_modify (pblock, lbound, se.expr);
6628	}
6629	ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6630	if (as->upper[dim] && !INTEGER_CST_P (ubound))
6631	{
6632	gfc_init_se (&se, NULL);
6633	gfc_conv_expr_type (se: &se, as->upper[dim], gfc_array_index_type);
6634	gfc_add_block_to_block (pblock, &se.pre);
6635	gfc_add_block_to_block (pblock, &se.finalblock);
6636	gfc_add_modify (pblock, ubound, se.expr);
6637	}
6638	}
6639	}
6640
6641
6642	/ Generate code to evaluate non-constant array bounds. Sets poffset and
6643	returns the size (in elements) of the array. /*
6644
6645	tree
6646	gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
6647	stmtblock_t * pblock)
6648	{
6649	gfc_array_spec *as;
6650	tree size;
6651	tree stride;
6652	tree offset;
6653	tree ubound;
6654	tree lbound;
6655	tree tmp;
6656	gfc_se se;
6657
6658	int dim;
6659
6660	as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
6661
6662	size = gfc_index_one_node;
6663	offset = gfc_index_zero_node;
6664	for (dim = `0`; dim < as->rank; dim++)
6665	{
6666	/ Evaluate non-constant array bound expressions.*
6667	F2008 4.5.6.3 para 6: If a specification expression in a scoping unit
6668	references a function, the result is finalized before execution of the
6669	executable constructs in the scoping unit.
6670	Adding the finalblocks enables this. /*
6671	lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
6672	if (as->lower[dim] && !INTEGER_CST_P (lbound))
6673	{
6674	gfc_init_se (&se, NULL);
6675	gfc_conv_expr_type (se: &se, as->lower[dim], gfc_array_index_type);
6676	gfc_add_block_to_block (pblock, &se.pre);
6677	gfc_add_block_to_block (pblock, &se.finalblock);
6678	gfc_add_modify (pblock, lbound, se.expr);
6679	}
6680	ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
6681	if (as->upper[dim] && !INTEGER_CST_P (ubound))
6682	{
6683	gfc_init_se (&se, NULL);
6684	gfc_conv_expr_type (se: &se, as->upper[dim], gfc_array_index_type);
6685	gfc_add_block_to_block (pblock, &se.pre);
6686	gfc_add_block_to_block (pblock, &se.finalblock);
6687	gfc_add_modify (pblock, ubound, se.expr);
6688	}
6689	/ The offset of this dimension. offset = offset - lbound * stride. /
6690	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6691	lbound, size);
6692	offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6693	offset, tmp);
6694
6695	/ The size of this dimension, and the stride of the next. /
6696	if (dim + `1` < as->rank)
6697	stride = GFC_TYPE_ARRAY_STRIDE (type, dim + `1`);
6698	else
6699	stride = GFC_TYPE_ARRAY_SIZE (type);
6700
6701	if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
6702	{
6703	/ Calculate stride = size * (ubound + 1 - lbound). /
6704	tmp = fold_build2_loc (input_location, MINUS_EXPR,
6705	gfc_array_index_type,
6706	gfc_index_one_node, lbound);
6707	tmp = fold_build2_loc (input_location, PLUS_EXPR,
6708	gfc_array_index_type, ubound, tmp);
6709	tmp = fold_build2_loc (input_location, MULT_EXPR,
6710	gfc_array_index_type, size, tmp);
6711	if (stride)
6712	gfc_add_modify (pblock, stride, tmp);
6713	else
6714	stride = gfc_evaluate_now (tmp, pblock);
6715
6716	/ Make sure that negative size arrays are translated*
6717	to being zero size. /*
6718	tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
6719	stride, gfc_index_zero_node);
6720	tmp = fold_build3_loc (input_location, COND_EXPR,
6721	gfc_array_index_type, tmp,
6722	stride, gfc_index_zero_node);
6723	gfc_add_modify (pblock, stride, tmp);
6724	}
6725
6726	size = stride;
6727	}
6728
6729	gfc_trans_array_cobounds (type, pblock, sym);
6730	gfc_trans_vla_type_sizes (sym, pblock);
6731
6732	*poffset = offset;
6733	return size;
6734	}
6735
6736
6737	/ Generate code to initialize/allocate an array variable. /
6738
6739	void
6740	gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
6741	gfc_wrapped_block * block)
6742	{
6743	stmtblock_t init;
6744	tree type;
6745	tree tmp = NULL_TREE;
6746	tree size;
6747	tree offset;
6748	tree space;
6749	tree inittree;
6750	bool onstack;
6751
6752	gcc_assert (!(sym->attr.pointer \|\| sym->attr.allocatable));
6753
6754	/ Do nothing for USEd variables. /
6755	if (sym->attr.use_assoc)
6756	return;
6757
6758	type = TREE_TYPE (decl);
6759	gcc_assert (GFC_ARRAY_TYPE_P (type));
6760	onstack = TREE_CODE (type) != POINTER_TYPE;
6761
6762	gfc_init_block (&init);
6763
6764	/ Evaluate character string length. /
6765	if (sym->ts.type == BT_CHARACTER
6766	&& onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6767	{
6768	gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6769
6770	gfc_trans_vla_type_sizes (sym, &init);
6771
6772	/ Emit a DECL_EXPR for this variable, which will cause the*
6773	gimplifier to allocate storage, and all that good stuff. /*
6774	tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
6775	gfc_add_expr_to_block (&init, tmp);
6776	if (sym->attr.omp_allocate)
6777	{
6778	/ Save location of size calculation to ensure GOMP_alloc is placed*
6779	after it. /*
6780	tree omp_alloc = lookup_attribute (attr_name: "omp allocate",
6781	DECL_ATTRIBUTES (decl));
6782	TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
6783	= build_tree_list (NULL_TREE, tsi_stmt (i: tsi_last (t: init.head)));
6784	}
6785	}
6786
6787	if (onstack)
6788	{
6789	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
6790	return;
6791	}
6792
6793	type = TREE_TYPE (type);
6794
6795	gcc_assert (!sym->attr.use_assoc);
6796	gcc_assert (!sym->module);
6797
6798	if (sym->ts.type == BT_CHARACTER
6799	&& !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
6800	gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6801
6802	size = gfc_trans_array_bounds (type, sym, poffset: &offset, pblock: &init);
6803
6804	/ Don't actually allocate space for Cray Pointees. /
6805	if (sym->attr.cray_pointee)
6806	{
6807	if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6808	gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6809
6810	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
6811	return;
6812	}
6813	if (sym->attr.omp_allocate)
6814	{
6815	/ The size is the number of elements in the array, so multiply by the*
6816	size of an element to get the total size. /*
6817	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6818	size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6819	size, fold_convert (gfc_array_index_type, tmp));
6820	size = gfc_evaluate_now (size, &init);
6821
6822	tree omp_alloc = lookup_attribute (attr_name: "omp allocate",
6823	DECL_ATTRIBUTES (decl));
6824	TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
6825	= build_tree_list (size, NULL_TREE);
6826	space = NULL_TREE;
6827	}
6828	else if (flag_stack_arrays)
6829	{
6830	gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
6831	space = build_decl (gfc_get_location (&sym->declared_at),
6832	VAR_DECL, create_tmp_var_name ("A"),
6833	TREE_TYPE (TREE_TYPE (decl)));
6834	gfc_trans_vla_type_sizes (sym, &init);
6835	}
6836	else
6837	{
6838	/ The size is the number of elements in the array, so multiply by the*
6839	size of an element to get the total size. /*
6840	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
6841	size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6842	size, fold_convert (gfc_array_index_type, tmp));
6843
6844	/ Allocate memory to hold the data. /
6845	tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
6846	gfc_add_modify (&init, decl, tmp);
6847
6848	/ Free the temporary. /
6849	tmp = gfc_call_free (decl);
6850	space = NULL_TREE;
6851	}
6852
6853	/ Set offset of the array. /
6854	if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6855	gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6856
6857	/ Automatic arrays should not have initializers. /
6858	gcc_assert (!sym->value);
6859
6860	inittree = gfc_finish_block (&init);
6861
6862	if (space)
6863	{
6864	tree addr;
6865	pushdecl (space);
6866
6867	/ Don't create new scope, emit the DECL_EXPR in exactly the scope*
6868	where also space is located. /*
6869	gfc_init_block (&init);
6870	tmp = fold_build1_loc (input_location, DECL_EXPR,
6871	TREE_TYPE (space), space);
6872	gfc_add_expr_to_block (&init, tmp);
6873	addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
6874	ADDR_EXPR, TREE_TYPE (decl), space);
6875	gfc_add_modify (&init, decl, addr);
6876	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
6877	tmp = NULL_TREE;
6878	}
6879	gfc_add_init_cleanup (block, init: inittree, cleanup: tmp);
6880	}
6881
6882
6883	/ Generate entry and exit code for g77 calling convention arrays. /
6884
6885	void
6886	gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
6887	{
6888	tree parm;
6889	tree type;
6890	locus loc;
6891	tree offset;
6892	tree tmp;
6893	tree stmt;
6894	stmtblock_t init;
6895
6896	gfc_save_backend_locus (&loc);
6897	gfc_set_backend_locus (&sym->declared_at);
6898
6899	/ Descriptor type. /
6900	parm = sym->backend_decl;
6901	type = TREE_TYPE (parm);
6902	gcc_assert (GFC_ARRAY_TYPE_P (type));
6903
6904	gfc_start_block (&init);
6905
6906	if (sym->ts.type == BT_CHARACTER
6907	&& VAR_P (sym->ts.u.cl->backend_decl))
6908	gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
6909
6910	/ Evaluate the bounds of the array. /
6911	gfc_trans_array_bounds (type, sym, poffset: &offset, pblock: &init);
6912
6913	/ Set the offset. /
6914	if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
6915	gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
6916
6917	/ Set the pointer itself if we aren't using the parameter directly. /
6918	if (TREE_CODE (parm) != PARM_DECL)
6919	{
6920	tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
6921	if (sym->ts.type == BT_CLASS)
6922	{
6923	tmp = build_fold_indirect_ref_loc (input_location, tmp);
6924	tmp = gfc_class_data_get (tmp);
6925	tmp = gfc_conv_descriptor_data_get (desc: tmp);
6926	}
6927	tmp = convert (TREE_TYPE (parm), tmp);
6928	gfc_add_modify (&init, parm, tmp);
6929	}
6930	stmt = gfc_finish_block (&init);
6931
6932	gfc_restore_backend_locus (&loc);
6933
6934	/ Add the initialization code to the start of the function. /
6935
6936	if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional)
6937	\|\| sym->attr.optional
6938	\|\| sym->attr.not_always_present)
6939	{
6940	tree nullify;
6941	if (TREE_CODE (parm) != PARM_DECL)
6942	nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6943	parm, null_pointer_node);
6944	else
6945	nullify = build_empty_stmt (input_location);
6946	tmp = gfc_conv_expr_present (sym, use_saved_decl: true);
6947	stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
6948	}
6949
6950	gfc_add_init_cleanup (block, init: stmt, NULL_TREE);
6951	}
6952
6953
6954	/ Modify the descriptor of an array parameter so that it has the*
6955	correct lower bound. Also move the upper bound accordingly.
6956	If the array is not packed, it will be copied into a temporary.
6957	For each dimension we set the new lower and upper bounds. Then we copy the
6958	stride and calculate the offset for this dimension. We also work out
6959	what the stride of a packed array would be, and see it the two match.
6960	If the array need repacking, we set the stride to the values we just
6961	calculated, recalculate the offset and copy the array data.
6962	Code is also added to copy the data back at the end of the function.
6963	*/
6964
6965	void
6966	gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
6967	gfc_wrapped_block * block)
6968	{
6969	tree size;
6970	tree type;
6971	tree offset;
6972	locus loc;
6973	stmtblock_t init;
6974	tree stmtInit, stmtCleanup;
6975	tree lbound;
6976	tree ubound;
6977	tree dubound;
6978	tree dlbound;
6979	tree dumdesc;
6980	tree tmp;
6981	tree stride, stride2;
6982	tree stmt_packed;
6983	tree stmt_unpacked;
6984	tree partial;
6985	gfc_se se;
6986	int n;
6987	int checkparm;
6988	int no_repack;
6989	bool optional_arg;
6990	gfc_array_spec *as;
6991	bool is_classarray = IS_CLASS_ARRAY (sym);
6992
6993	/ Do nothing for pointer and allocatable arrays. /
6994	if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
6995	\|\| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
6996	\|\| sym->attr.allocatable
6997	\|\| (is_classarray && CLASS_DATA (sym)->attr.allocatable))
6998	return;
6999
7000	if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
7001	{
7002	gfc_trans_g77_array (sym, block);
7003	return;
7004	}
7005
7006	loc.nextc = NULL;
7007	gfc_save_backend_locus (&loc);
7008	/ loc.nextc is not set by save_backend_locus but the location routines*
7009	depend on it. /*
7010	if (loc.nextc == NULL)
7011	loc.nextc = loc.lb->line;
7012	gfc_set_backend_locus (&sym->declared_at);
7013
7014	/ Descriptor type. /
7015	type = TREE_TYPE (tmpdesc);
7016	gcc_assert (GFC_ARRAY_TYPE_P (type));
7017	dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7018	if (is_classarray)
7019	/ For a class array the dummy array descriptor is in the _class*
7020	component. /*
7021	dumdesc = gfc_class_data_get (dumdesc);
7022	else
7023	dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
7024	as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
7025	gfc_start_block (&init);
7026
7027	if (sym->ts.type == BT_CHARACTER
7028	&& VAR_P (sym->ts.u.cl->backend_decl))
7029	gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
7030
7031	/ TODO: Fix the exclusion of class arrays from extent checking. /
7032	checkparm = (as->type == AS_EXPLICIT && !is_classarray
7033	&& (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
7034
7035	no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
7036	\|\| GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
7037
7038	if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
7039	{
7040	/ For non-constant shape arrays we only check if the first dimension*
7041	is contiguous. Repacking higher dimensions wouldn't gain us
7042	anything as we still don't know the array stride. /*
7043	partial = gfc_create_var (logical_type_node, "partial");
7044	TREE_USED (partial) = `1`;
7045	tmp = gfc_conv_descriptor_stride_get (desc: dumdesc, dim: gfc_rank_cst[`0`]);
7046	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7047	gfc_index_one_node);
7048	gfc_add_modify (&init, partial, tmp);
7049	}
7050	else
7051	partial = NULL_TREE;
7052
7053	/ The naming of stmt_unpacked and stmt_packed may be counter-intuitive*
7054	here, however I think it does the right thing. /*
7055	if (no_repack)
7056	{
7057	/ Set the first stride. /
7058	stride = gfc_conv_descriptor_stride_get (desc: dumdesc, dim: gfc_rank_cst[`0`]);
7059	stride = gfc_evaluate_now (stride, &init);
7060
7061	tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7062	stride, gfc_index_zero_node);
7063	tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
7064	tmp, gfc_index_one_node, stride);
7065	stride = GFC_TYPE_ARRAY_STRIDE (type, `0`);
7066	gfc_add_modify (&init, stride, tmp);
7067
7068	/ Allow the user to disable array repacking. /
7069	stmt_unpacked = NULL_TREE;
7070	}
7071	else
7072	{
7073	gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, `0`)));
7074	/ A library call to repack the array if necessary. /
7075	tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7076	stmt_unpacked = build_call_expr_loc (input_location,
7077	gfor_fndecl_in_pack, `1`, tmp);
7078
7079	stride = gfc_index_one_node;
7080
7081	if (warn_array_temporaries)
7082	gfc_warning (opt: OPT_Warray_temporaries,
7083	"Creating array temporary at %L", &loc);
7084	}
7085
7086	/ This is for the case where the array data is used directly without*
7087	calling the repack function. /*
7088	if (no_repack \|\| partial != NULL_TREE)
7089	stmt_packed = gfc_conv_descriptor_data_get (desc: dumdesc);
7090	else
7091	stmt_packed = NULL_TREE;
7092
7093	/ Assign the data pointer. /
7094	if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7095	{
7096	/ Don't repack unknown shape arrays when the first stride is 1. /
7097	tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (stmt_packed),
7098	partial, stmt_packed, stmt_unpacked);
7099	}
7100	else
7101	tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
7102	gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp));
7103
7104	offset = gfc_index_zero_node;
7105	size = gfc_index_one_node;
7106
7107	/ Evaluate the bounds of the array. /
7108	for (n = `0`; n < as->rank; n++)
7109	{
7110	if (checkparm \|\| !as->upper[n])
7111	{
7112	/ Get the bounds of the actual parameter. /
7113	dubound = gfc_conv_descriptor_ubound_get (desc: dumdesc, dim: gfc_rank_cst[n]);
7114	dlbound = gfc_conv_descriptor_lbound_get (desc: dumdesc, dim: gfc_rank_cst[n]);
7115	}
7116	else
7117	{
7118	dubound = NULL_TREE;
7119	dlbound = NULL_TREE;
7120	}
7121
7122	lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
7123	if (!INTEGER_CST_P (lbound))
7124	{
7125	gfc_init_se (&se, NULL);
7126	gfc_conv_expr_type (se: &se, as->lower[n],
7127	gfc_array_index_type);
7128	gfc_add_block_to_block (&init, &se.pre);
7129	gfc_add_modify (&init, lbound, se.expr);
7130	}
7131
7132	ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
7133	/ Set the desired upper bound. /
7134	if (as->upper[n])
7135	{
7136	/ We know what we want the upper bound to be. /
7137	if (!INTEGER_CST_P (ubound))
7138	{
7139	gfc_init_se (&se, NULL);
7140	gfc_conv_expr_type (se: &se, as->upper[n],
7141	gfc_array_index_type);
7142	gfc_add_block_to_block (&init, &se.pre);
7143	gfc_add_modify (&init, ubound, se.expr);
7144	}
7145
7146	/ Check the sizes match. /
7147	if (checkparm)
7148	{
7149	/ Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). /
7150	char * msg;
7151	tree temp;
7152
7153	temp = fold_build2_loc (input_location, MINUS_EXPR,
7154	gfc_array_index_type, ubound, lbound);
7155	temp = fold_build2_loc (input_location, PLUS_EXPR,
7156	gfc_array_index_type,
7157	gfc_index_one_node, temp);
7158	stride2 = fold_build2_loc (input_location, MINUS_EXPR,
7159	gfc_array_index_type, dubound,
7160	dlbound);
7161	stride2 = fold_build2_loc (input_location, PLUS_EXPR,
7162	gfc_array_index_type,
7163	gfc_index_one_node, stride2);
7164	tmp = fold_build2_loc (input_location, NE_EXPR,
7165	gfc_array_index_type, temp, stride2);
7166	msg = xasprintf ("Dimension %d of array '%s' has extent "
7167	"%%ld instead of %%ld", n+`1`, sym->name);
7168
7169	gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
7170	fold_convert (long_integer_type_node, temp),
7171	fold_convert (long_integer_type_node, stride2));
7172
7173	free (ptr: msg);
7174	}
7175	}
7176	else
7177	{
7178	/ For assumed shape arrays move the upper bound by the same amount*
7179	as the lower bound. /*
7180	tmp = fold_build2_loc (input_location, MINUS_EXPR,
7181	gfc_array_index_type, dubound, dlbound);
7182	tmp = fold_build2_loc (input_location, PLUS_EXPR,
7183	gfc_array_index_type, tmp, lbound);
7184	gfc_add_modify (&init, ubound, tmp);
7185	}
7186	/ The offset of this dimension. offset = offset - lbound * stride. /
7187	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7188	lbound, stride);
7189	offset = fold_build2_loc (input_location, MINUS_EXPR,
7190	gfc_array_index_type, offset, tmp);
7191
7192	/ The size of this dimension, and the stride of the next. /
7193	if (n + `1` < as->rank)
7194	{
7195	stride = GFC_TYPE_ARRAY_STRIDE (type, n + `1`);
7196
7197	if (no_repack \|\| partial != NULL_TREE)
7198	stmt_unpacked =
7199	gfc_conv_descriptor_stride_get (desc: dumdesc, dim: gfc_rank_cst[n+`1`]);
7200
7201	/ Figure out the stride if not a known constant. /
7202	if (!INTEGER_CST_P (stride))
7203	{
7204	if (no_repack)
7205	stmt_packed = NULL_TREE;
7206	else
7207	{
7208	/ Calculate stride = size * (ubound + 1 - lbound). /
7209	tmp = fold_build2_loc (input_location, MINUS_EXPR,
7210	gfc_array_index_type,
7211	gfc_index_one_node, lbound);
7212	tmp = fold_build2_loc (input_location, PLUS_EXPR,
7213	gfc_array_index_type, ubound, tmp);
7214	size = fold_build2_loc (input_location, MULT_EXPR,
7215	gfc_array_index_type, size, tmp);
7216	stmt_packed = size;
7217	}
7218
7219	/ Assign the stride. /
7220	if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
7221	tmp = fold_build3_loc (input_location, COND_EXPR,
7222	gfc_array_index_type, partial,
7223	stmt_unpacked, stmt_packed);
7224	else
7225	tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
7226	gfc_add_modify (&init, stride, tmp);
7227	}
7228	}
7229	else
7230	{
7231	stride = GFC_TYPE_ARRAY_SIZE (type);
7232
7233	if (stride && !INTEGER_CST_P (stride))
7234	{
7235	/ Calculate size = stride * (ubound + 1 - lbound). /
7236	tmp = fold_build2_loc (input_location, MINUS_EXPR,
7237	gfc_array_index_type,
7238	gfc_index_one_node, lbound);
7239	tmp = fold_build2_loc (input_location, PLUS_EXPR,
7240	gfc_array_index_type,
7241	ubound, tmp);
7242	tmp = fold_build2_loc (input_location, MULT_EXPR,
7243	gfc_array_index_type,
7244	GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
7245	gfc_add_modify (&init, stride, tmp);
7246	}
7247	}
7248	}
7249
7250	gfc_trans_array_cobounds (type, pblock: &init, sym);
7251
7252	/ Set the offset. /
7253	if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
7254	gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
7255
7256	gfc_trans_vla_type_sizes (sym, &init);
7257
7258	stmtInit = gfc_finish_block (&init);
7259
7260	/ Only do the entry/initialization code if the arg is present. /
7261	dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
7262	optional_arg = (sym->attr.optional
7263	\|\| (sym->ns->proc_name->attr.entry_master
7264	&& sym->attr.dummy));
7265	if (optional_arg)
7266	{
7267	tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
7268	zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
7269	tmpdesc, zero_init);
7270	tmp = gfc_conv_expr_present (sym, use_saved_decl: true);
7271	stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
7272	}
7273
7274	/ Cleanup code. /
7275	if (no_repack)
7276	stmtCleanup = NULL_TREE;
7277	else
7278	{
7279	stmtblock_t cleanup;
7280	gfc_start_block (&cleanup);
7281
7282	if (sym->attr.intent != INTENT_IN)
7283	{
7284	/ Copy the data back. /
7285	tmp = build_call_expr_loc (input_location,
7286	gfor_fndecl_in_unpack, `2`, dumdesc, tmpdesc);
7287	gfc_add_expr_to_block (&cleanup, tmp);
7288	}
7289
7290	/ Free the temporary. /
7291	tmp = gfc_call_free (tmpdesc);
7292	gfc_add_expr_to_block (&cleanup, tmp);
7293
7294	stmtCleanup = gfc_finish_block (&cleanup);
7295
7296	/ Only do the cleanup if the array was repacked. /
7297	if (is_classarray)
7298	/ For a class array the dummy array descriptor is in the _class*
7299	component. /*
7300	tmp = gfc_class_data_get (dumdesc);
7301	else
7302	tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
7303	tmp = gfc_conv_descriptor_data_get (desc: tmp);
7304	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7305	tmp, tmpdesc);
7306	stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7307	build_empty_stmt (input_location));
7308
7309	if (optional_arg)
7310	{
7311	tmp = gfc_conv_expr_present (sym);
7312	stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup,
7313	build_empty_stmt (input_location));
7314	}
7315	}
7316
7317	/ We don't need to free any memory allocated by internal_pack as it will*
7318	be freed at the end of the function by pop_context. /*
7319	gfc_add_init_cleanup (block, init: stmtInit, cleanup: stmtCleanup);
7320
7321	gfc_restore_backend_locus (&loc);
7322	}
7323
7324
7325	/ Calculate the overall offset, including subreferences. /
7326	void
7327	gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
7328	bool subref, gfc_expr *expr)
7329	{
7330	tree tmp;
7331	tree field;
7332	tree stride;
7333	tree index;
7334	gfc_ref *ref;
7335	gfc_se start;
7336	int n;
7337
7338	/ If offset is NULL and this is not a subreferenced array, there is*
7339	nothing to do. /*
7340	if (offset == NULL_TREE)
7341	{
7342	if (subref)
7343	offset = gfc_index_zero_node;
7344	else
7345	return;
7346	}
7347
7348	tmp = build_array_ref (desc, offset, NULL, NULL);
7349
7350	/ Offset the data pointer for pointer assignments from arrays with*
7351	subreferences; e.g. my_integer => my_type(:)%integer_component. /*
7352	if (subref)
7353	{
7354	/ Go past the array reference. /
7355	for (ref = expr->ref; ref; ref = ref->next)
7356	if (ref->type == REF_ARRAY &&
7357	ref->u.ar.type != AR_ELEMENT)
7358	{
7359	ref = ref->next;
7360	break;
7361	}
7362
7363	/ Calculate the offset for each subsequent subreference. /
7364	for (; ref; ref = ref->next)
7365	{
7366	switch (ref->type)
7367	{
7368	case REF_COMPONENT:
7369	field = ref->u.c.component->backend_decl;
7370	gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
7371	tmp = fold_build3_loc (input_location, COMPONENT_REF,
7372	TREE_TYPE (field),
7373	tmp, field, NULL_TREE);
7374	break;
7375
7376	case REF_SUBSTRING:
7377	gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
7378	gfc_init_se (&start, NULL);
7379	gfc_conv_expr_type (se: &start, ref->u.ss.start, gfc_charlen_type_node);
7380	gfc_add_block_to_block (block, &start.pre);
7381	tmp = gfc_build_array_ref (tmp, start.expr, NULL);
7382	break;
7383
7384	case REF_ARRAY:
7385	gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
7386	&& ref->u.ar.type == AR_ELEMENT);
7387
7388	/ TODO - Add bounds checking. /
7389	stride = gfc_index_one_node;
7390	index = gfc_index_zero_node;
7391	for (n = `0`; n < ref->u.ar.dimen; n++)
7392	{
7393	tree itmp;
7394	tree jtmp;
7395
7396	/ Update the index. /
7397	gfc_init_se (&start, NULL);
7398	gfc_conv_expr_type (se: &start, ref->u.ar.start[n], gfc_array_index_type);
7399	itmp = gfc_evaluate_now (start.expr, block);
7400	gfc_init_se (&start, NULL);
7401	gfc_conv_expr_type (se: &start, ref->u.ar.as->lower[n], gfc_array_index_type);
7402	jtmp = gfc_evaluate_now (start.expr, block);
7403	itmp = fold_build2_loc (input_location, MINUS_EXPR,
7404	gfc_array_index_type, itmp, jtmp);
7405	itmp = fold_build2_loc (input_location, MULT_EXPR,
7406	gfc_array_index_type, itmp, stride);
7407	index = fold_build2_loc (input_location, PLUS_EXPR,
7408	gfc_array_index_type, itmp, index);
7409	index = gfc_evaluate_now (index, block);
7410
7411	/ Update the stride. /
7412	gfc_init_se (&start, NULL);
7413	gfc_conv_expr_type (se: &start, ref->u.ar.as->upper[n], gfc_array_index_type);
7414	itmp = fold_build2_loc (input_location, MINUS_EXPR,
7415	gfc_array_index_type, start.expr,
7416	jtmp);
7417	itmp = fold_build2_loc (input_location, PLUS_EXPR,
7418	gfc_array_index_type,
7419	gfc_index_one_node, itmp);
7420	stride = fold_build2_loc (input_location, MULT_EXPR,
7421	gfc_array_index_type, stride, itmp);
7422	stride = gfc_evaluate_now (stride, block);
7423	}
7424
7425	/ Apply the index to obtain the array element. /
7426	tmp = gfc_build_array_ref (tmp, index, NULL);
7427	break;
7428
7429	case REF_INQUIRY:
7430	switch (ref->u.i)
7431	{
7432	case INQUIRY_RE:
7433	tmp = fold_build1_loc (input_location, REALPART_EXPR,
7434	TREE_TYPE (TREE_TYPE (tmp)), tmp);
7435	break;
7436
7437	case INQUIRY_IM:
7438	tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
7439	TREE_TYPE (TREE_TYPE (tmp)), tmp);
7440	break;
7441
7442	default:
7443	break;
7444	}
7445	break;
7446
7447	default:
7448	gcc_unreachable ();
7449	break;
7450	}
7451	}
7452	}
7453
7454	/ Set the target data pointer. /
7455	offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
7456	gfc_conv_descriptor_data_set (block, desc: parm, value: offset);
7457	}
7458
7459
7460	/ gfc_conv_expr_descriptor needs the string length an expression*
7461	so that the size of the temporary can be obtained. This is done
7462	by adding up the string lengths of all the elements in the
7463	expression. Function with non-constant expressions have their
7464	string lengths mapped onto the actual arguments using the
7465	interface mapping machinery in trans-expr.cc. /*
7466	static void
7467	get_array_charlen (gfc_expr expr, gfc_se se)
7468	{
7469	gfc_interface_mapping mapping;
7470	gfc_formal_arglist *formal;
7471	gfc_actual_arglist *arg;
7472	gfc_se tse;
7473	gfc_expr *e;
7474
7475	if (expr->ts.u.cl->length
7476	&& gfc_is_constant_expr (expr->ts.u.cl->length))
7477	{
7478	if (!expr->ts.u.cl->backend_decl)
7479	gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7480	return;
7481	}
7482
7483	switch (expr->expr_type)
7484	{
7485	case EXPR_ARRAY:
7486
7487	/ This is somewhat brutal. The expression for the first*
7488	element of the array is evaluated and assigned to a
7489	new string length for the original expression. /*
7490	e = gfc_constructor_first (base: expr->value.constructor)->expr;
7491
7492	gfc_init_se (&tse, NULL);
7493
7494	/ Avoid evaluating trailing array references since all we need is*
7495	the string length. /*
7496	if (e->rank)
7497	tse.descriptor_only = `1`;
7498	if (e->rank && e->expr_type != EXPR_VARIABLE)
7499	gfc_conv_expr_descriptor (&tse, e);
7500	else
7501	gfc_conv_expr (se: &tse, expr: e);
7502
7503	gfc_add_block_to_block (&se->pre, &tse.pre);
7504	gfc_add_block_to_block (&se->post, &tse.post);
7505
7506	if (!expr->ts.u.cl->backend_decl \|\| !VAR_P (expr->ts.u.cl->backend_decl))
7507	{
7508	expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7509	expr->ts.u.cl->backend_decl =
7510	gfc_create_var (gfc_charlen_type_node, "sln");
7511	}
7512
7513	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7514	tse.string_length);
7515
7516	/ Make sure that deferred length components point to the hidden*
7517	string_length component. /*
7518	if (TREE_CODE (tse.expr) == COMPONENT_REF
7519	&& TREE_CODE (tse.string_length) == COMPONENT_REF
7520	&& TREE_OPERAND (tse.expr, `0`) == TREE_OPERAND (tse.string_length, `0`))
7521	e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
7522
7523	return;
7524
7525	case EXPR_OP:
7526	get_array_charlen (expr: expr->value.op.op1, se);
7527
7528	/ For parentheses the expression ts.u.cl should be identical. /
7529	if (expr->value.op.op == INTRINSIC_PARENTHESES)
7530	{
7531	if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
7532	expr->ts.u.cl->backend_decl
7533	= expr->value.op.op1->ts.u.cl->backend_decl;
7534	return;
7535	}
7536
7537	expr->ts.u.cl->backend_decl =
7538	gfc_create_var (gfc_charlen_type_node, "sln");
7539
7540	if (expr->value.op.op2)
7541	{
7542	get_array_charlen (expr: expr->value.op.op2, se);
7543
7544	gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
7545
7546	/ Add the string lengths and assign them to the expression*
7547	string length backend declaration. /*
7548	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7549	fold_build2_loc (input_location, PLUS_EXPR,
7550	gfc_charlen_type_node,
7551	expr->value.op.op1->ts.u.cl->backend_decl,
7552	expr->value.op.op2->ts.u.cl->backend_decl));
7553	}
7554	else
7555	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
7556	expr->value.op.op1->ts.u.cl->backend_decl);
7557	break;
7558
7559	case EXPR_FUNCTION:
7560	if (expr->value.function.esym == NULL
7561	\|\| expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7562	{
7563	gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7564	break;
7565	}
7566
7567	/ Map expressions involving the dummy arguments onto the actual*
7568	argument expressions. /*
7569	gfc_init_interface_mapping (&mapping);
7570	formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
7571	arg = expr->value.function.actual;
7572
7573	/ Set se = NULL in the calls to the interface mapping, to suppress any*
7574	backend stuff. /*
7575	for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
7576	{
7577	if (!arg->expr)
7578	continue;
7579	if (formal->sym)
7580	gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
7581	}
7582
7583	gfc_init_se (&tse, NULL);
7584
7585	/ Build the expression for the character length and convert it. /
7586	gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
7587
7588	gfc_add_block_to_block (&se->pre, &tse.pre);
7589	gfc_add_block_to_block (&se->post, &tse.post);
7590	tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
7591	tse.expr = fold_build2_loc (input_location, MAX_EXPR,
7592	TREE_TYPE (tse.expr), tse.expr,
7593	build_zero_cst (TREE_TYPE (tse.expr)));
7594	expr->ts.u.cl->backend_decl = tse.expr;
7595	gfc_free_interface_mapping (&mapping);
7596	break;
7597
7598	default:
7599	gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
7600	break;
7601	}
7602	}
7603
7604
7605	/ Helper function to check dimensions. /
7606	static bool
7607	transposed_dims (gfc_ss *ss)
7608	{
7609	int n;
7610
7611	for (n = `0`; n < ss->dimen; n++)
7612	if (ss->dim[n] != n)
7613	return true;
7614	return false;
7615	}
7616
7617
7618	/ Convert the last ref of a scalar coarray from an AR_ELEMENT to an*
7619	AR_FULL, suitable for the scalarizer. /*
7620
7621	static gfc_ss *
7622	walk_coarray (gfc_expr *e)
7623	{
7624	gfc_ss *ss;
7625
7626	gcc_assert (gfc_get_corank (e) > `0`);
7627
7628	ss = gfc_walk_expr (e);
7629
7630	/ Fix scalar coarray. /
7631	if (ss == gfc_ss_terminator)
7632	{
7633	gfc_ref *ref;
7634
7635	ref = e->ref;
7636	while (ref)
7637	{
7638	if (ref->type == REF_ARRAY
7639	&& ref->u.ar.codimen > `0`)
7640	break;
7641
7642	ref = ref->next;
7643	}
7644
7645	gcc_assert (ref != NULL);
7646	if (ref->u.ar.type == AR_ELEMENT)
7647	ref->u.ar.type = AR_SECTION;
7648	ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
7649	}
7650
7651	return ss;
7652	}
7653
7654
7655	/ Convert an array for passing as an actual argument. Expressions and*
7656	vector subscripts are evaluated and stored in a temporary, which is then
7657	passed. For whole arrays the descriptor is passed. For array sections
7658	a modified copy of the descriptor is passed, but using the original data.
7659
7660	This function is also used for array pointer assignments, and there
7661	are three cases:
7662
7663	- se->want_pointer && !se->direct_byref
7664	EXPR is an actual argument. On exit, se->expr contains a
7665	pointer to the array descriptor.
7666
7667	- !se->want_pointer && !se->direct_byref
7668	EXPR is an actual argument to an intrinsic function or the
7669	left-hand side of a pointer assignment. On exit, se->expr
7670	contains the descriptor for EXPR.
7671
7672	- !se->want_pointer && se->direct_byref
7673	EXPR is the right-hand side of a pointer assignment and
7674	se->expr is the descriptor for the previously-evaluated
7675	left-hand side. The function creates an assignment from
7676	EXPR to se->expr.
7677
7678
7679	The se->force_tmp flag disables the non-copying descriptor optimization
7680	that is used for transpose. It may be used in cases where there is an
7681	alias between the transpose argument and another argument in the same
7682	function call. /*
7683
7684	void
7685	gfc_conv_expr_descriptor (gfc_se se, gfc_expr expr)
7686	{
7687	gfc_ss *ss;
7688	gfc_ss_type ss_type;
7689	gfc_ss_info *ss_info;
7690	gfc_loopinfo loop;
7691	gfc_array_info *info;
7692	int need_tmp;
7693	int n;
7694	tree tmp;
7695	tree desc;
7696	stmtblock_t block;
7697	tree start;
7698	int full;
7699	bool subref_array_target = false;
7700	bool deferred_array_component = false;
7701	bool substr = false;
7702	gfc_expr arg, ss_expr;
7703
7704	if (se->want_coarray)
7705	ss = walk_coarray (e: expr);
7706	else
7707	ss = gfc_walk_expr (expr);
7708
7709	gcc_assert (ss != NULL);
7710	gcc_assert (ss != gfc_ss_terminator);
7711
7712	ss_info = ss->info;
7713	ss_type = ss_info->type;
7714	ss_expr = ss_info->expr;
7715
7716	/ Special case: TRANSPOSE which needs no temporary. /
7717	while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
7718	&& (arg = gfc_get_noncopying_intrinsic_argument (expr)) != NULL)
7719	{
7720	/ This is a call to transpose which has already been handled by the*
7721	scalarizer, so that we just need to get its argument's descriptor. /*
7722	gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
7723	expr = expr->value.function.actual->expr;
7724	}
7725
7726	if (!se->direct_byref)
7727	se->unlimited_polymorphic = UNLIMITED_POLY (expr);
7728
7729	/ Special case things we know we can pass easily. /
7730	switch (expr->expr_type)
7731	{
7732	case EXPR_VARIABLE:
7733	/ If we have a linear array section, we can pass it directly.*
7734	Otherwise we need to copy it into a temporary. /*
7735
7736	gcc_assert (ss_type == GFC_SS_SECTION);
7737	gcc_assert (ss_expr == expr);
7738	info = &ss_info->data.array;
7739
7740	/ Get the descriptor for the array. /
7741	gfc_conv_ss_descriptor (block: &se->pre, ss, base: `0`);
7742	desc = info->descriptor;
7743
7744	/ The charlen backend decl for deferred character components cannot*
7745	be used because it is fixed at zero. Instead, the hidden string
7746	length component is used. /*
7747	if (expr->ts.type == BT_CHARACTER
7748	&& expr->ts.deferred
7749	&& TREE_CODE (desc) == COMPONENT_REF)
7750	deferred_array_component = true;
7751
7752	substr = info->ref && info->ref->next
7753	&& info->ref->next->type == REF_SUBSTRING;
7754
7755	subref_array_target = (is_subref_array (expr)
7756	&& (se->direct_byref
7757	\|\| expr->ts.type == BT_CHARACTER));
7758	need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
7759	&& !subref_array_target);
7760
7761	if (se->force_tmp)
7762	need_tmp = `1`;
7763	else if (se->force_no_tmp)
7764	need_tmp = `0`;
7765
7766	if (need_tmp)
7767	full = `0`;
7768	else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
7769	{
7770	/ Create a new descriptor if the array doesn't have one. /
7771	full = `0`;
7772	}
7773	else if (info->ref->u.ar.type == AR_FULL \|\| se->descriptor_only)
7774	full = `1`;
7775	else if (se->direct_byref)
7776	full = `0`;
7777	else if (info->ref->u.ar.dimen == `0` && !info->ref->next)
7778	full = `1`;
7779	else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
7780	full = `0`;
7781	else
7782	full = gfc_full_array_ref_p (info->ref, NULL);
7783
7784	if (full && !transposed_dims (ss))
7785	{
7786	if (se->direct_byref && !se->byref_noassign)
7787	{
7788	/ Copy the descriptor for pointer assignments. /
7789	gfc_add_modify (&se->pre, se->expr, desc);
7790
7791	/ Add any offsets from subreferences. /
7792	gfc_get_dataptr_offset (block: &se->pre, parm: se->expr, desc, NULL_TREE,
7793	subref: subref_array_target, expr);
7794
7795	/ ....and set the span field. /
7796	if (ss_info->expr->ts.type == BT_CHARACTER)
7797	tmp = gfc_conv_descriptor_span_get (desc);
7798	else
7799	tmp = gfc_get_array_span (desc, expr);
7800	gfc_conv_descriptor_span_set (block: &se->pre, desc: se->expr, value: tmp);
7801	}
7802	else if (se->want_pointer)
7803	{
7804	/ We pass full arrays directly. This means that pointers and*
7805	allocatable arrays should also work. /*
7806	se->expr = gfc_build_addr_expr (NULL_TREE, desc);
7807	}
7808	else
7809	{
7810	se->expr = desc;
7811	}
7812
7813	if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
7814	se->string_length = gfc_get_expr_charlen (expr);
7815	/ The ss_info string length is returned set to the value of the*
7816	hidden string length component. /*
7817	else if (deferred_array_component)
7818	se->string_length = ss_info->string_length;
7819
7820	se->class_container = ss_info->class_container;
7821
7822	gfc_free_ss_chain (ss);
7823	return;
7824	}
7825	break;
7826
7827	case EXPR_FUNCTION:
7828	/ A transformational function return value will be a temporary*
7829	array descriptor. We still need to go through the scalarizer
7830	to create the descriptor. Elemental functions are handled as
7831	arbitrary expressions, i.e. copy to a temporary. /*
7832
7833	if (se->direct_byref)
7834	{
7835	gcc_assert (ss_type == GFC_SS_FUNCTION && ss_expr == expr);
7836
7837	/ For pointer assignments pass the descriptor directly. /
7838	if (se->ss == NULL)
7839	se->ss = ss;
7840	else
7841	gcc_assert (se->ss == ss);
7842
7843	if (!is_pointer_array (expr: se->expr))
7844	{
7845	tmp = gfc_get_element_type (TREE_TYPE (se->expr));
7846	tmp = fold_convert (gfc_array_index_type,
7847	size_in_bytes (tmp));
7848	gfc_conv_descriptor_span_set (block: &se->pre, desc: se->expr, value: tmp);
7849	}
7850
7851	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
7852	gfc_conv_expr (se, expr);
7853
7854	gfc_free_ss_chain (ss);
7855	return;
7856	}
7857
7858	if (ss_expr != expr \|\| ss_type != GFC_SS_FUNCTION)
7859	{
7860	if (ss_expr != expr)
7861	/ Elemental function. /
7862	gcc_assert ((expr->value.function.esym != NULL
7863	&& expr->value.function.esym->attr.elemental)
7864	\|\| (expr->value.function.isym != NULL
7865	&& expr->value.function.isym->elemental)
7866	\|\| (gfc_expr_attr (expr).proc_pointer
7867	&& gfc_expr_attr (expr).elemental)
7868	\|\| gfc_inline_intrinsic_function_p (expr));
7869
7870	need_tmp = `1`;
7871	if (expr->ts.type == BT_CHARACTER
7872	&& expr->ts.u.cl->length
7873	&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
7874	get_array_charlen (expr, se);
7875
7876	info = NULL;
7877	}
7878	else
7879	{
7880	/ Transformational function. /
7881	info = &ss_info->data.array;
7882	need_tmp = `0`;
7883	}
7884	break;
7885
7886	case EXPR_ARRAY:
7887	/ Constant array constructors don't need a temporary. /
7888	if (ss_type == GFC_SS_CONSTRUCTOR
7889	&& expr->ts.type != BT_CHARACTER
7890	&& gfc_constant_array_constructor_p (base: expr->value.constructor))
7891	{
7892	need_tmp = `0`;
7893	info = &ss_info->data.array;
7894	}
7895	else
7896	{
7897	need_tmp = `1`;
7898	info = NULL;
7899	}
7900	break;
7901
7902	default:
7903	/ Something complicated. Copy it into a temporary. /
7904	need_tmp = `1`;
7905	info = NULL;
7906	break;
7907	}
7908
7909	/ If we are creating a temporary, we don't need to bother about aliases*
7910	anymore. /*
7911	if (need_tmp)
7912	se->force_tmp = `0`;
7913
7914	gfc_init_loopinfo (loop: &loop);
7915
7916	/ Associate the SS with the loop. /
7917	gfc_add_ss_to_loop (loop: &loop, head: ss);
7918
7919	/ Tell the scalarizer not to bother creating loop variables, etc. /
7920	if (!need_tmp)
7921	loop.array_parameter = `1`;
7922	else
7923	/ The right-hand side of a pointer assignment mustn't use a temporary. /
7924	gcc_assert (!se->direct_byref);
7925
7926	/ Do we need bounds checking or not? /
7927	ss->no_bounds_check = expr->no_bounds_check;
7928
7929	/ Setup the scalarizing loops and bounds. /
7930	gfc_conv_ss_startstride (loop: &loop);
7931
7932	/ Add bounds-checking for elemental dimensions. /
7933	if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !expr->no_bounds_check)
7934	array_bound_check_elemental (se, ss, expr);
7935
7936	if (need_tmp)
7937	{
7938	if (expr->ts.type == BT_CHARACTER
7939	&& (!expr->ts.u.cl->backend_decl \|\| expr->expr_type == EXPR_ARRAY))
7940	get_array_charlen (expr, se);
7941
7942	/ Tell the scalarizer to make a temporary. /
7943	loop.temp_ss = gfc_get_temp_ss (type: gfc_typenode_for_spec (&expr->ts),
7944	string_length: ((expr->ts.type == BT_CHARACTER)
7945	? expr->ts.u.cl->backend_decl
7946	: NULL),
7947	dimen: loop.dimen);
7948
7949	se->string_length = loop.temp_ss->info->string_length;
7950	gcc_assert (loop.temp_ss->dimen == loop.dimen);
7951	gfc_add_ss_to_loop (loop: &loop, head: loop.temp_ss);
7952	}
7953
7954	gfc_conv_loop_setup (loop: &loop, where: & expr->where);
7955
7956	if (need_tmp)
7957	{
7958	/ Copy into a temporary and pass that. We don't need to copy the data*
7959	back because expressions and vector subscripts must be INTENT_IN. /*
7960	/ TODO: Optimize passing function return values. /
7961	gfc_se lse;
7962	gfc_se rse;
7963	bool deep_copy;
7964
7965	/ Start the copying loops. /
7966	gfc_mark_ss_chain_used (ss: loop.temp_ss, flags: `1`);
7967	gfc_mark_ss_chain_used (ss, flags: `1`);
7968	gfc_start_scalarized_body (loop: &loop, pbody: &block);
7969
7970	/ Copy each data element. /
7971	gfc_init_se (&lse, NULL);
7972	gfc_copy_loopinfo_to_se (se: &lse, loop: &loop);
7973	gfc_init_se (&rse, NULL);
7974	gfc_copy_loopinfo_to_se (se: &rse, loop: &loop);
7975
7976	lse.ss = loop.temp_ss;
7977	rse.ss = ss;
7978
7979	gfc_conv_tmp_array_ref (se: &lse);
7980	if (expr->ts.type == BT_CHARACTER)
7981	{
7982	gfc_conv_expr (se: &rse, expr);
7983	if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
7984	rse.expr = build_fold_indirect_ref_loc (input_location,
7985	rse.expr);
7986	}
7987	else
7988	gfc_conv_expr_val (se: &rse, expr);
7989
7990	gfc_add_block_to_block (&block, &rse.pre);
7991	gfc_add_block_to_block (&block, &lse.pre);
7992
7993	lse.string_length = rse.string_length;
7994
7995	deep_copy = !se->data_not_needed
7996	&& (expr->expr_type == EXPR_VARIABLE
7997	\|\| expr->expr_type == EXPR_ARRAY);
7998	tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
7999	deep_copy, false);
8000	gfc_add_expr_to_block (&block, tmp);
8001
8002	/ Finish the copying loops. /
8003	gfc_trans_scalarizing_loops (loop: &loop, body: &block);
8004
8005	desc = loop.temp_ss->info->data.array.descriptor;
8006	}
8007	else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss))
8008	{
8009	desc = info->descriptor;
8010	se->string_length = ss_info->string_length;
8011	}
8012	else
8013	{
8014	/ We pass sections without copying to a temporary. Make a new*
8015	descriptor and point it at the section we want. The loop variable
8016	limits will be the limits of the section.
8017	A function may decide to repack the array to speed up access, but
8018	we're not bothered about that here. /*
8019	int dim, ndim, codim;
8020	tree parm;
8021	tree parmtype;
8022	tree dtype;
8023	tree stride;
8024	tree from;
8025	tree to;
8026	tree base;
8027	tree offset;
8028
8029	ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
8030
8031	if (se->want_coarray)
8032	{
8033	gfc_array_ref *ar = &info->ref->u.ar;
8034
8035	codim = gfc_get_corank (expr);
8036	for (n = `0`; n < codim - `1`; n++)
8037	{
8038	/ Make sure we are not lost somehow. /
8039	gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE);
8040
8041	/ Make sure the call to gfc_conv_section_startstride won't*
8042	generate unnecessary code to calculate stride. /*
8043	gcc_assert (ar->stride[n + ndim] == NULL);
8044
8045	gfc_conv_section_startstride (block: &loop.pre, ss, dim: n + ndim);
8046	loop.from[n + loop.dimen] = info->start[n + ndim];
8047	loop.to[n + loop.dimen] = info->end[n + ndim];
8048	}
8049
8050	gcc_assert (n == codim - `1`);
8051	evaluate_bound (block: &loop.pre, bounds: info->start, values: ar->start,
8052	desc: info->descriptor, dim: n + ndim, lbound: true,
8053	deferred: ar->as->type == AS_DEFERRED);
8054	loop.from[n + loop.dimen] = info->start[n + ndim];
8055	}
8056	else
8057	codim = `0`;
8058
8059	/ Set the string_length for a character array. /
8060	if (expr->ts.type == BT_CHARACTER)
8061	{
8062	if (deferred_array_component && !substr)
8063	se->string_length = ss_info->string_length;
8064	else
8065	se->string_length = gfc_get_expr_charlen (expr);
8066
8067	if (VAR_P (se->string_length)
8068	&& expr->ts.u.cl->backend_decl == se->string_length)
8069	tmp = ss_info->string_length;
8070	else
8071	tmp = se->string_length;
8072
8073	if (expr->ts.deferred && expr->ts.u.cl->backend_decl
8074	&& VAR_P (expr->ts.u.cl->backend_decl))
8075	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
8076	else
8077	expr->ts.u.cl->backend_decl = tmp;
8078	}
8079
8080	/ If we have an array section, are assigning or passing an array*
8081	section argument make sure that the lower bound is 1. References
8082	to the full array should otherwise keep the original bounds. /*
8083	if (!info->ref \|\| info->ref->u.ar.type != AR_FULL)
8084	for (dim = `0`; dim < loop.dimen; dim++)
8085	if (!integer_onep (loop.from[dim]))
8086	{
8087	tmp = fold_build2_loc (input_location, MINUS_EXPR,
8088	gfc_array_index_type, gfc_index_one_node,
8089	loop.from[dim]);
8090	loop.to[dim] = fold_build2_loc (input_location, PLUS_EXPR,
8091	gfc_array_index_type,
8092	loop.to[dim], tmp);
8093	loop.from[dim] = gfc_index_one_node;
8094	}
8095
8096	desc = info->descriptor;
8097	if (se->direct_byref && !se->byref_noassign)
8098	{
8099	/ For pointer assignments we fill in the destination. /
8100	parm = se->expr;
8101	parmtype = TREE_TYPE (parm);
8102	}
8103	else
8104	{
8105	/ Otherwise make a new one. /
8106	if (expr->ts.type == BT_CHARACTER)
8107	parmtype = gfc_typenode_for_spec (&expr->ts);
8108	else
8109	parmtype = gfc_get_element_type (TREE_TYPE (desc));
8110
8111	parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
8112	loop.from, loop.to, `0`,
8113	GFC_ARRAY_UNKNOWN, false);
8114	parm = gfc_create_var (parmtype, "parm");
8115
8116	/ When expression is a class object, then add the class' handle to*
8117	the parm_decl. /*
8118	if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
8119	{
8120	gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
8121	gfc_se classse;
8122
8123	/ class_expr can be NULL, when no _class ref is in expr.*
8124	We must not fix this here with a gfc_fix_class_ref (). /*
8125	if (class_expr)
8126	{
8127	gfc_init_se (&classse, NULL);
8128	gfc_conv_expr (se: &classse, expr: class_expr);
8129	gfc_free_expr (class_expr);
8130
8131	gcc_assert (classse.pre.head == NULL_TREE
8132	&& classse.post.head == NULL_TREE);
8133	gfc_allocate_lang_decl (parm);
8134	GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
8135	}
8136	}
8137	}
8138
8139	if (expr->ts.type == BT_CHARACTER
8140	&& VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
8141	{
8142	tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
8143	gfc_add_modify (&loop.pre, elem_len,
8144	fold_convert (TREE_TYPE (elem_len),
8145	gfc_get_array_span (desc, expr)));
8146	}
8147
8148	/ Set the span field. /
8149	tmp = NULL_TREE;
8150	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
8151	tmp = gfc_conv_descriptor_span_get (desc);
8152	else
8153	tmp = gfc_get_array_span (desc, expr);
8154	if (tmp)
8155	gfc_conv_descriptor_span_set (block: &loop.pre, desc: parm, value: tmp);
8156
8157	/ The following can be somewhat confusing. We have two*
8158	descriptors, a new one and the original array.
8159	{parm, parmtype, dim} refer to the new one.
8160	{desc, type, n, loop} refer to the original, which maybe
8161	a descriptorless array.
8162	The bounds of the scalarization are the bounds of the section.
8163	We don't have to worry about numeric overflows when calculating
8164	the offsets because all elements are within the array data. /*
8165
8166	/ Set the dtype. /
8167	tmp = gfc_conv_descriptor_dtype (desc: parm);
8168	if (se->unlimited_polymorphic)
8169	dtype = gfc_get_dtype (TREE_TYPE (desc), rank: &loop.dimen);
8170	else if (expr->ts.type == BT_ASSUMED)
8171	{
8172	tree tmp2 = desc;
8173	if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
8174	tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
8175	if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
8176	tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8177	dtype = gfc_conv_descriptor_dtype (desc: tmp2);
8178	}
8179	else
8180	dtype = gfc_get_dtype (parmtype);
8181	gfc_add_modify (&loop.pre, tmp, dtype);
8182
8183	/ The 1st element in the section. /
8184	base = gfc_index_zero_node;
8185
8186	/ The offset from the 1st element in the section. /
8187	offset = gfc_index_zero_node;
8188
8189	for (n = `0`; n < ndim; n++)
8190	{
8191	stride = gfc_conv_array_stride (descriptor: desc, dim: n);
8192
8193	/ Work out the 1st element in the section. /
8194	if (info->ref
8195	&& info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8196	{
8197	gcc_assert (info->subscript[n]
8198	&& info->subscript[n]->info->type == GFC_SS_SCALAR);
8199	start = info->subscript[n]->info->data.scalar.value;
8200	}
8201	else
8202	{
8203	/ Evaluate and remember the start of the section. /
8204	start = info->start[n];
8205	stride = gfc_evaluate_now (stride, &loop.pre);
8206	}
8207
8208	tmp = gfc_conv_array_lbound (descriptor: desc, dim: n);
8209	tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
8210	start, tmp);
8211	tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
8212	tmp, stride);
8213	base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
8214	base, tmp);
8215
8216	if (info->ref
8217	&& info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
8218	{
8219	/ For elemental dimensions, we only need the 1st*
8220	element in the section. /*
8221	continue;
8222	}
8223
8224	/ Vector subscripts need copying and are handled elsewhere. /
8225	if (info->ref)
8226	gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
8227
8228	/ look for the corresponding scalarizer dimension: dim. /
8229	for (dim = `0`; dim < ndim; dim++)
8230	if (ss->dim[dim] == n)
8231	break;
8232
8233	/ loop exited early: the DIM being looked for has been found. /
8234	gcc_assert (dim < ndim);
8235
8236	/ Set the new lower bound. /
8237	from = loop.from[dim];
8238	to = loop.to[dim];
8239
8240	gfc_conv_descriptor_lbound_set (block: &loop.pre, desc: parm,
8241	dim: gfc_rank_cst[dim], value: from);
8242
8243	/ Set the new upper bound. /
8244	gfc_conv_descriptor_ubound_set (block: &loop.pre, desc: parm,
8245	dim: gfc_rank_cst[dim], value: to);
8246
8247	/ Multiply the stride by the section stride to get the*
8248	total stride. /*
8249	stride = fold_build2_loc (input_location, MULT_EXPR,
8250	gfc_array_index_type,
8251	stride, info->stride[n]);
8252
8253	tmp = fold_build2_loc (input_location, MULT_EXPR,
8254	TREE_TYPE (offset), stride, from);
8255	offset = fold_build2_loc (input_location, MINUS_EXPR,
8256	TREE_TYPE (offset), offset, tmp);
8257
8258	/ Store the new stride. /
8259	gfc_conv_descriptor_stride_set (block: &loop.pre, desc: parm,
8260	dim: gfc_rank_cst[dim], value: stride);
8261	}
8262
8263	for (n = loop.dimen; n < loop.dimen + codim; n++)
8264	{
8265	from = loop.from[n];
8266	to = loop.to[n];
8267	gfc_conv_descriptor_lbound_set (block: &loop.pre, desc: parm,
8268	dim: gfc_rank_cst[n], value: from);
8269	if (n < loop.dimen + codim - `1`)
8270	gfc_conv_descriptor_ubound_set (block: &loop.pre, desc: parm,
8271	dim: gfc_rank_cst[n], value: to);
8272	}
8273
8274	if (se->data_not_needed)
8275	gfc_conv_descriptor_data_set (block: &loop.pre, desc: parm,
8276	gfc_index_zero_node);
8277	else
8278	/ Point the data pointer at the 1st element in the section. /
8279	gfc_get_dataptr_offset (block: &loop.pre, parm, desc, offset: base,
8280	subref: subref_array_target, expr);
8281
8282	gfc_conv_descriptor_offset_set (block: &loop.pre, desc: parm, value: offset);
8283
8284	desc = parm;
8285	}
8286
8287	/ For class arrays add the class tree into the saved descriptor to*
8288	enable getting of _vptr and the like. /*
8289	if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
8290	&& IS_CLASS_ARRAY (expr->symtree->n.sym))
8291	{
8292	gfc_allocate_lang_decl (desc);
8293	GFC_DECL_SAVED_DESCRIPTOR (desc) =
8294	DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
8295	GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
8296	: expr->symtree->n.sym->backend_decl;
8297	}
8298	else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
8299	&& IS_CLASS_ARRAY (expr))
8300	{
8301	tree vtype;
8302	gfc_allocate_lang_decl (desc);
8303	tmp = gfc_create_var (expr->ts.u.derived->backend_decl, "class");
8304	GFC_DECL_SAVED_DESCRIPTOR (desc) = tmp;
8305	vtype = gfc_class_vptr_get (tmp);
8306	gfc_add_modify (&se->pre, vtype,
8307	gfc_build_addr_expr (TREE_TYPE (vtype),
8308	gfc_find_vtab (&expr->ts)->backend_decl));
8309	}
8310	if (!se->direct_byref \|\| se->byref_noassign)
8311	{
8312	/ Get a pointer to the new descriptor. /
8313	if (se->want_pointer)
8314	se->expr = gfc_build_addr_expr (NULL_TREE, desc);
8315	else
8316	se->expr = desc;
8317	}
8318
8319	gfc_add_block_to_block (&se->pre, &loop.pre);
8320	gfc_add_block_to_block (&se->post, &loop.post);
8321
8322	/ Cleanup the scalarizer. /
8323	gfc_cleanup_loop (loop: &loop);
8324	}
8325
8326
8327	/ Calculate the array size (number of elements); if dim != NULL_TREE,*
8328	return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). /*
8329	tree
8330	gfc_tree_array_size (stmtblock_t block, tree desc, gfc_expr expr, tree dim)
8331	{
8332	if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
8333	{
8334	gcc_assert (dim == NULL_TREE);
8335	return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
8336	}
8337	tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
8338	symbol_attribute attr = gfc_expr_attr (expr);
8339	gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
8340	gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
8341	if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
8342	\|\| !dim)
8343	{
8344	if (expr->rank < `0`)
8345	rank = fold_convert (signed_char_type_node,
8346	gfc_conv_descriptor_rank (desc));
8347	else
8348	rank = build_int_cst (signed_char_type_node, expr->rank);
8349	}
8350
8351	if (dim \|\| expr->rank == `1`)
8352	{
8353	if (!dim)
8354	dim = gfc_index_zero_node;
8355	tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
8356	tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
8357
8358	size = fold_build2_loc (input_location, MINUS_EXPR,
8359	gfc_array_index_type, ubound, lbound);
8360	size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8361	size, gfc_index_one_node);
8362	/ if (!allocatable && !pointer && assumed rank)*
8363	size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
8364	else
8365	size = max (0, size); /*
8366	size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
8367	size, gfc_index_zero_node);
8368	if (!attr.pointer && !attr.allocatable
8369	&& as && as->type == AS_ASSUMED_RANK)
8370	{
8371	tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
8372	rank, build_int_cst (signed_char_type_node, `1`));
8373	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8374	fold_convert (signed_char_type_node, dim),
8375	tmp);
8376	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8377	gfc_conv_descriptor_ubound_get (desc, dim),
8378	build_int_cst (gfc_array_index_type, -`1`));
8379	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8380	cond, tmp);
8381	tmp = build_int_cst (gfc_array_index_type, -`1`);
8382	size = build3_loc (loc: input_location, code: COND_EXPR, type: gfc_array_index_type,
8383	arg0: cond, arg1: tmp, arg2: size);
8384	}
8385	return size;
8386	}
8387
8388	/ size = 1. /
8389	size = gfc_create_var (gfc_array_index_type, "size");
8390	gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), `1`));
8391	tree extent = gfc_create_var (gfc_array_index_type, "extent");
8392
8393	stmtblock_t cond_block, loop_body;
8394	gfc_init_block (&cond_block);
8395	gfc_init_block (&loop_body);
8396
8397	/ Loop: for (i = 0; i < rank; ++i). /
8398	tree idx = gfc_create_var (signed_char_type_node, "idx");
8399	/ Loop body. /
8400	/ #if (assumed-rank + !allocatable && !pointer)*
8401	if (idx == rank - 1 && dim[idx].ubound == -1)
8402	extent = -1;
8403	else
8404	#endif
8405	extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
8406	if (extent < 0)
8407	extent = 0
8408	size = extent. /
8409	cond = NULL_TREE;
8410	if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
8411	{
8412	tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
8413	rank, build_int_cst (signed_char_type_node, `1`));
8414	cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8415	idx, tmp);
8416	tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8417	gfc_conv_descriptor_ubound_get (desc, dim: idx),
8418	build_int_cst (gfc_array_index_type, -`1`));
8419	cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
8420	cond, tmp);
8421	}
8422	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8423	gfc_conv_descriptor_ubound_get (desc, dim: idx),
8424	gfc_conv_descriptor_lbound_get (desc, dim: idx));
8425	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8426	tmp, gfc_index_one_node);
8427	gfc_add_modify (&cond_block, extent, tmp);
8428	tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
8429	extent, gfc_index_zero_node);
8430	tmp = build3_v (COND_EXPR, tmp,
8431	fold_build2_loc (input_location, MODIFY_EXPR,
8432	gfc_array_index_type,
8433	extent, gfc_index_zero_node),
8434	build_empty_stmt (input_location));
8435	gfc_add_expr_to_block (&cond_block, tmp);
8436	tmp = gfc_finish_block (&cond_block);
8437	if (cond)
8438	tmp = build3_v (COND_EXPR, cond,
8439	fold_build2_loc (input_location, MODIFY_EXPR,
8440	gfc_array_index_type, extent,
8441	build_int_cst (gfc_array_index_type, -`1`)),
8442	tmp);
8443	gfc_add_expr_to_block (&loop_body, tmp);
8444	/ size = extent. /*
8445	gfc_add_modify (&loop_body, size,
8446	fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8447	size, extent));
8448	/ Generate loop. /
8449	gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), `0`), rank, LT_EXPR,
8450	build_int_cst (TREE_TYPE (idx), `1`),
8451	gfc_finish_block (&loop_body));
8452	return size;
8453	}
8454
8455	/ Helper function for gfc_conv_array_parameter if array size needs to be*
8456	computed. /*
8457
8458	static void
8459	array_parameter_size (stmtblock_t block, tree desc, gfc_expr expr, tree *size)
8460	{
8461	tree elem;
8462	*size = gfc_tree_array_size (block, desc, expr, NULL);
8463	elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
8464	*size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8465	*size, fold_convert (gfc_array_index_type, elem));
8466	}
8467
8468	/ Helper function - return true if the argument is a pointer. /
8469
8470	static bool
8471	is_pointer (gfc_expr *e)
8472	{
8473	gfc_symbol *sym;
8474
8475	if (e->expr_type != EXPR_VARIABLE \|\| e->symtree == NULL)
8476	return false;
8477
8478	sym = e->symtree->n.sym;
8479	if (sym == NULL)
8480	return false;
8481
8482	return sym->attr.pointer \|\| sym->attr.proc_pointer;
8483	}
8484
8485	/ Convert an array for passing as an actual parameter. /
8486
8487	void
8488	gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
8489	const gfc_symbol fsym, const* char *proc_name,
8490	tree *size)
8491	{
8492	tree ptr;
8493	tree desc;
8494	tree tmp = NULL_TREE;
8495	tree stmt;
8496	tree parent = DECL_CONTEXT (current_function_decl);
8497	bool full_array_var;
8498	bool this_array_result;
8499	bool contiguous;
8500	bool no_pack;
8501	bool array_constructor;
8502	bool good_allocatable;
8503	bool ultimate_ptr_comp;
8504	bool ultimate_alloc_comp;
8505	gfc_symbol *sym;
8506	stmtblock_t block;
8507	gfc_ref *ref;
8508
8509	ultimate_ptr_comp = false;
8510	ultimate_alloc_comp = false;
8511
8512	for (ref = expr->ref; ref; ref = ref->next)
8513	{
8514	if (ref->next == NULL)
8515	break;
8516
8517	if (ref->type == REF_COMPONENT)
8518	{
8519	ultimate_ptr_comp = ref->u.c.component->attr.pointer;
8520	ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
8521	}
8522	}
8523
8524	full_array_var = false;
8525	contiguous = false;
8526
8527	if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
8528	full_array_var = gfc_full_array_ref_p (ref, &contiguous);
8529
8530	sym = full_array_var ? expr->symtree->n.sym : NULL;
8531
8532	/ The symbol should have an array specification. /
8533	gcc_assert (!sym \|\| sym->as \|\| ref->u.ar.as);
8534
8535	if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
8536	{
8537	get_array_ctor_strlen (block: &se->pre, base: expr->value.constructor, len: &tmp);
8538	expr->ts.u.cl->backend_decl = tmp;
8539	se->string_length = tmp;
8540	}
8541
8542	/ Is this the result of the enclosing procedure? /
8543	this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
8544	if (this_array_result
8545	&& (sym->backend_decl != current_function_decl)
8546	&& (sym->backend_decl != parent))
8547	this_array_result = false;
8548
8549	/ Passing address of the array if it is not pointer or assumed-shape. /
8550	if (full_array_var && g77 && !this_array_result
8551	&& sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
8552	{
8553	tmp = gfc_get_symbol_decl (sym);
8554
8555	if (sym->ts.type == BT_CHARACTER)
8556	se->string_length = sym->ts.u.cl->backend_decl;
8557
8558	if (!sym->attr.pointer
8559	&& sym->as
8560	&& sym->as->type != AS_ASSUMED_SHAPE
8561	&& sym->as->type != AS_DEFERRED
8562	&& sym->as->type != AS_ASSUMED_RANK
8563	&& !sym->attr.allocatable)
8564	{
8565	/ Some variables are declared directly, others are declared as*
8566	pointers and allocated on the heap. /*
8567	if (sym->attr.dummy \|\| POINTER_TYPE_P (TREE_TYPE (tmp)))
8568	se->expr = tmp;
8569	else
8570	se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
8571	if (size)
8572	array_parameter_size (block: &se->pre, desc: tmp, expr, size);
8573	return;
8574	}
8575
8576	if (sym->attr.allocatable)
8577	{
8578	if (sym->attr.dummy \|\| sym->attr.result)
8579	{
8580	gfc_conv_expr_descriptor (se, expr);
8581	tmp = se->expr;
8582	}
8583	if (size)
8584	array_parameter_size (block: &se->pre, desc: tmp, expr, size);
8585	se->expr = gfc_conv_array_data (descriptor: tmp);
8586	return;
8587	}
8588	}
8589
8590	/ A convenient reduction in scope. /
8591	contiguous = g77 && !this_array_result && contiguous;
8592
8593	/ There is no need to pack and unpack the array, if it is contiguous*
8594	and not a deferred- or assumed-shape array, or if it is simply
8595	contiguous. /*
8596	no_pack = ((sym && sym->as
8597	&& !sym->attr.pointer
8598	&& sym->as->type != AS_DEFERRED
8599	&& sym->as->type != AS_ASSUMED_RANK
8600	&& sym->as->type != AS_ASSUMED_SHAPE)
8601	\|\|
8602	(ref && ref->u.ar.as
8603	&& ref->u.ar.as->type != AS_DEFERRED
8604	&& ref->u.ar.as->type != AS_ASSUMED_RANK
8605	&& ref->u.ar.as->type != AS_ASSUMED_SHAPE)
8606	\|\|
8607	gfc_is_simply_contiguous (expr, false, true));
8608
8609	no_pack = contiguous && no_pack;
8610
8611	/ If we have an EXPR_OP or a function returning an explicit-shaped*
8612	or allocatable array, an array temporary will be generated which
8613	does not need to be packed / unpacked if passed to an
8614	explicit-shape dummy array. /*
8615
8616	if (g77)
8617	{
8618	if (expr->expr_type == EXPR_OP)
8619	no_pack = `1`;
8620	else if (expr->expr_type == EXPR_FUNCTION && expr->value.function.esym)
8621	{
8622	gfc_symbol *result = expr->value.function.esym->result;
8623	if (result->attr.dimension
8624	&& (result->as->type == AS_EXPLICIT
8625	\|\| result->attr.allocatable
8626	\|\| result->attr.contiguous))
8627	no_pack = `1`;
8628	}
8629	}
8630
8631	/ Array constructors are always contiguous and do not need packing. /
8632	array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
8633
8634	/ Same is true of contiguous sections from allocatable variables. /
8635	good_allocatable = contiguous
8636	&& expr->symtree
8637	&& expr->symtree->n.sym->attr.allocatable;
8638
8639	/ Or ultimate allocatable components. /
8640	ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
8641
8642	if (no_pack \|\| array_constructor \|\| good_allocatable \|\| ultimate_alloc_comp)
8643	{
8644	gfc_conv_expr_descriptor (se, expr);
8645	/ Deallocate the allocatable components of structures that are*
8646	not variable. /*
8647	if ((expr->ts.type == BT_DERIVED \|\| expr->ts.type == BT_CLASS)
8648	&& expr->ts.u.derived->attr.alloc_comp
8649	&& expr->expr_type != EXPR_VARIABLE)
8650	{
8651	tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se->expr, expr->rank);
8652
8653	/ The components shall be deallocated before their containing entity. /
8654	gfc_prepend_expr_to_block (&se->post, tmp);
8655	}
8656	if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
8657	se->string_length = expr->ts.u.cl->backend_decl;
8658	if (size)
8659	array_parameter_size (block: &se->pre, desc: se->expr, expr, size);
8660	se->expr = gfc_conv_array_data (descriptor: se->expr);
8661	return;
8662	}
8663
8664	if (this_array_result)
8665	{
8666	/ Result of the enclosing function. /
8667	gfc_conv_expr_descriptor (se, expr);
8668	if (size)
8669	array_parameter_size (block: &se->pre, desc: se->expr, expr, size);
8670	se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8671
8672	if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
8673	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
8674	se->expr = gfc_conv_array_data (descriptor: build_fold_indirect_ref_loc (input_location,
8675	se->expr));
8676
8677	return;
8678	}
8679	else
8680	{
8681	/ Every other type of array. /
8682	se->want_pointer = `1`;
8683	gfc_conv_expr_descriptor (se, expr);
8684
8685	if (size)
8686	array_parameter_size (block: &se->pre,
8687	desc: build_fold_indirect_ref_loc (input_location,
8688	se->expr),
8689	expr, size);
8690	}
8691
8692	/ Deallocate the allocatable components of structures that are*
8693	not variable, for descriptorless arguments.
8694	Arguments with a descriptor are handled in gfc_conv_procedure_call. /*
8695	if (g77 && (expr->ts.type == BT_DERIVED \|\| expr->ts.type == BT_CLASS)
8696	&& expr->ts.u.derived->attr.alloc_comp
8697	&& expr->expr_type != EXPR_VARIABLE)
8698	{
8699	tmp = build_fold_indirect_ref_loc (input_location, se->expr);
8700	tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
8701
8702	/ The components shall be deallocated before their containing entity. /
8703	gfc_prepend_expr_to_block (&se->post, tmp);
8704	}
8705
8706	if (g77 \|\| (fsym && fsym->attr.contiguous
8707	&& !gfc_is_simply_contiguous (expr, false, true)))
8708	{
8709	tree origptr = NULL_TREE;
8710
8711	desc = se->expr;
8712
8713	/ For contiguous arrays, save the original value of the descriptor. /
8714	if (!g77)
8715	{
8716	origptr = gfc_create_var (pvoid_type_node, "origptr");
8717	tmp = build_fold_indirect_ref_loc (input_location, desc);
8718	tmp = gfc_conv_array_data (descriptor: tmp);
8719	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8720	TREE_TYPE (origptr), origptr,
8721	fold_convert (TREE_TYPE (origptr), tmp));
8722	gfc_add_expr_to_block (&se->pre, tmp);
8723	}
8724
8725	/ Repack the array. /
8726	if (warn_array_temporaries)
8727	{
8728	if (fsym)
8729	gfc_warning (opt: OPT_Warray_temporaries,
8730	"Creating array temporary at %L for argument %qs",
8731	&expr->where, fsym->name);
8732	else
8733	gfc_warning (opt: OPT_Warray_temporaries,
8734	"Creating array temporary at %L", &expr->where);
8735	}
8736
8737	/ When optimizing, we can use gfc_conv_subref_array_arg for*
8738	making the packing and unpacking operation visible to the
8739	optimizers. /*
8740
8741	if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
8742	&& !is_pointer (e: expr) && ! gfc_has_dimen_vector_ref (e: expr)
8743	&& !(expr->symtree->n.sym->as
8744	&& expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
8745	&& (fsym == NULL \|\| fsym->ts.type != BT_ASSUMED))
8746	{
8747	gfc_conv_subref_array_arg (se, expr, g77,
8748	fsym ? fsym->attr.intent : INTENT_INOUT,
8749	false, fsym, proc_name, sym, check_contiguous: true);
8750	return;
8751	}
8752
8753	ptr = build_call_expr_loc (input_location,
8754	gfor_fndecl_in_pack, `1`, desc);
8755
8756	if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8757	{
8758	tmp = gfc_conv_expr_present (sym);
8759	ptr = build3_loc (loc: input_location, code: COND_EXPR, TREE_TYPE (se->expr),
8760	arg0: tmp, fold_convert (TREE_TYPE (se->expr), ptr),
8761	fold_convert (TREE_TYPE (se->expr), null_pointer_node));
8762	}
8763
8764	ptr = gfc_evaluate_now (ptr, &se->pre);
8765
8766	/ Use the packed data for the actual argument, except for contiguous arrays,*
8767	where the descriptor's data component is set. /*
8768	if (g77)
8769	se->expr = ptr;
8770	else
8771	{
8772	tmp = build_fold_indirect_ref_loc (input_location, desc);
8773
8774	gfc_ss * ss = gfc_walk_expr (expr);
8775	if (!transposed_dims (ss))
8776	gfc_conv_descriptor_data_set (block: &se->pre, desc: tmp, value: ptr);
8777	else
8778	{
8779	tree old_field, new_field;
8780
8781	/ The original descriptor has transposed dims so we can't reuse*
8782	it directly; we have to create a new one. /*
8783	tree old_desc = tmp;
8784	tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
8785
8786	old_field = gfc_conv_descriptor_dtype (desc: old_desc);
8787	new_field = gfc_conv_descriptor_dtype (desc: new_desc);
8788	gfc_add_modify (&se->pre, new_field, old_field);
8789
8790	old_field = gfc_conv_descriptor_offset (desc: old_desc);
8791	new_field = gfc_conv_descriptor_offset (desc: new_desc);
8792	gfc_add_modify (&se->pre, new_field, old_field);
8793
8794	for (int i = `0`; i < expr->rank; i++)
8795	{
8796	old_field = gfc_conv_descriptor_dimension (desc: old_desc,
8797	dim: gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, loop_dim: i)]);
8798	new_field = gfc_conv_descriptor_dimension (desc: new_desc,
8799	dim: gfc_rank_cst[i]);
8800	gfc_add_modify (&se->pre, new_field, old_field);
8801	}
8802
8803	if (flag_coarray == GFC_FCOARRAY_LIB
8804	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
8805	&& GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
8806	== GFC_ARRAY_ALLOCATABLE)
8807	{
8808	old_field = gfc_conv_descriptor_token (desc: old_desc);
8809	new_field = gfc_conv_descriptor_token (desc: new_desc);
8810	gfc_add_modify (&se->pre, new_field, old_field);
8811	}
8812
8813	gfc_conv_descriptor_data_set (block: &se->pre, desc: new_desc, value: ptr);
8814	se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
8815	}
8816	gfc_free_ss (ss);
8817	}
8818
8819	if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
8820	{
8821	char * msg;
8822
8823	if (fsym && proc_name)
8824	msg = xasprintf ("An array temporary was created for argument "
8825	"'%s' of procedure '%s'", fsym->name, proc_name);
8826	else
8827	msg = xasprintf ("An array temporary was created");
8828
8829	tmp = build_fold_indirect_ref_loc (input_location,
8830	desc);
8831	tmp = gfc_conv_array_data (descriptor: tmp);
8832	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8833	fold_convert (TREE_TYPE (tmp), ptr), tmp);
8834
8835	if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8836	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8837	logical_type_node,
8838	gfc_conv_expr_present (sym), tmp);
8839
8840	gfc_trans_runtime_check (false, true, tmp, &se->pre,
8841	&expr->where, msg);
8842	free (ptr: msg);
8843	}
8844
8845	gfc_start_block (&block);
8846
8847	/ Copy the data back. /
8848	if (fsym == NULL \|\| fsym->attr.intent != INTENT_IN)
8849	{
8850	tmp = build_call_expr_loc (input_location,
8851	gfor_fndecl_in_unpack, `2`, desc, ptr);
8852	gfc_add_expr_to_block (&block, tmp);
8853	}
8854
8855	/ Free the temporary. /
8856	tmp = gfc_call_free (ptr);
8857	gfc_add_expr_to_block (&block, tmp);
8858
8859	stmt = gfc_finish_block (&block);
8860
8861	gfc_init_block (&block);
8862	/ Only if it was repacked. This code needs to be executed before the*
8863	loop cleanup code. /*
8864	tmp = build_fold_indirect_ref_loc (input_location,
8865	desc);
8866	tmp = gfc_conv_array_data (descriptor: tmp);
8867	tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
8868	fold_convert (TREE_TYPE (tmp), ptr), tmp);
8869
8870	if (fsym && fsym->attr.optional && sym && sym->attr.optional)
8871	tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8872	logical_type_node,
8873	gfc_conv_expr_present (sym), tmp);
8874
8875	tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
8876
8877	gfc_add_expr_to_block (&block, tmp);
8878	gfc_add_block_to_block (&block, &se->post);
8879
8880	gfc_init_block (&se->post);
8881
8882	/ Reset the descriptor pointer. /
8883	if (!g77)
8884	{
8885	tmp = build_fold_indirect_ref_loc (input_location, desc);
8886	gfc_conv_descriptor_data_set (block: &se->post, desc: tmp, value: origptr);
8887	}
8888
8889	gfc_add_block_to_block (&se->post, &block);
8890	}
8891	}
8892
8893
8894	/ This helper function calculates the size in words of a full array. /
8895
8896	tree
8897	gfc_full_array_size (stmtblock_t block, tree decl, int* rank)
8898	{
8899	tree idx;
8900	tree nelems;
8901	tree tmp;
8902	idx = gfc_rank_cst[rank - `1`];
8903	nelems = gfc_conv_descriptor_ubound_get (desc: decl, dim: idx);
8904	tmp = gfc_conv_descriptor_lbound_get (desc: decl, dim: idx);
8905	tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8906	nelems, tmp);
8907	tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8908	tmp, gfc_index_one_node);
8909	tmp = gfc_evaluate_now (tmp, block);
8910
8911	nelems = gfc_conv_descriptor_stride_get (desc: decl, dim: idx);
8912	tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8913	nelems, tmp);
8914	return gfc_evaluate_now (tmp, block);
8915	}
8916
8917
8918	/ Allocate dest to the same size as src, and copy src -> dest.*
8919	If no_malloc is set, only the copy is done. /*
8920
8921	static tree
8922	duplicate_allocatable (tree dest, tree src, tree type, int rank,
8923	bool no_malloc, bool no_memcpy, tree str_sz,
8924	tree add_when_allocated)
8925	{
8926	tree tmp;
8927	tree eltype;
8928	tree size;
8929	tree nelems;
8930	tree null_cond;
8931	tree null_data;
8932	stmtblock_t block;
8933
8934	/ If the source is null, set the destination to null. Then,*
8935	allocate memory to the destination. /*
8936	gfc_init_block (&block);
8937
8938	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
8939	{
8940	gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
8941	null_data = gfc_finish_block (&block);
8942
8943	gfc_init_block (&block);
8944	eltype = TREE_TYPE (type);
8945	if (str_sz != NULL_TREE)
8946	size = str_sz;
8947	else
8948	size = TYPE_SIZE_UNIT (eltype);
8949
8950	if (!no_malloc)
8951	{
8952	tmp = gfc_call_malloc (&block, type, size);
8953	gfc_add_modify (&block, dest, fold_convert (type, tmp));
8954	}
8955
8956	if (!no_memcpy)
8957	{
8958	tmp = builtin_decl_explicit (fncode: BUILT_IN_MEMCPY);
8959	tmp = build_call_expr_loc (input_location, tmp, `3`, dest, src,
8960	fold_convert (size_type_node, size));
8961	gfc_add_expr_to_block (&block, tmp);
8962	}
8963	}
8964	else
8965	{
8966	gfc_conv_descriptor_data_set (block: &block, desc: dest, null_pointer_node);
8967	null_data = gfc_finish_block (&block);
8968
8969	gfc_init_block (&block);
8970	if (rank)
8971	nelems = gfc_full_array_size (block: &block, decl: src, rank);
8972	else
8973	nelems = gfc_index_one_node;
8974
8975	/ If type is not the array type, then it is the element type. /
8976	if (GFC_ARRAY_TYPE_P (type) \|\| GFC_DESCRIPTOR_TYPE_P (type))
8977	eltype = gfc_get_element_type (type);
8978	else
8979	eltype = type;
8980
8981	if (str_sz != NULL_TREE)
8982	tmp = fold_convert (gfc_array_index_type, str_sz);
8983	else
8984	tmp = fold_convert (gfc_array_index_type,
8985	TYPE_SIZE_UNIT (eltype));
8986
8987	tmp = gfc_evaluate_now (tmp, &block);
8988	size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8989	nelems, tmp);
8990	if (!no_malloc)
8991	{
8992	tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
8993	tmp = gfc_call_malloc (&block, tmp, size);
8994	gfc_conv_descriptor_data_set (block: &block, desc: dest, value: tmp);
8995	}
8996
8997	/ We know the temporary and the value will be the same length,*
8998	so can use memcpy. /*
8999	if (!no_memcpy)
9000	{
9001	tmp = builtin_decl_explicit (fncode: BUILT_IN_MEMCPY);
9002	tmp = build_call_expr_loc (input_location, tmp, `3`,
9003	gfc_conv_descriptor_data_get (desc: dest),
9004	gfc_conv_descriptor_data_get (desc: src),
9005	fold_convert (size_type_node, size));
9006	gfc_add_expr_to_block (&block, tmp);
9007	}
9008	}
9009
9010	gfc_add_expr_to_block (&block, add_when_allocated);
9011	tmp = gfc_finish_block (&block);
9012
9013	/ Null the destination if the source is null; otherwise do*
9014	the allocate and copy. /*
9015	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9016	null_cond = src;
9017	else
9018	null_cond = gfc_conv_descriptor_data_get (desc: src);
9019
9020	null_cond = convert (pvoid_type_node, null_cond);
9021	null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9022	null_cond, null_pointer_node);
9023	return build3_v (COND_EXPR, null_cond, tmp, null_data);
9024	}
9025
9026
9027	/ Allocate dest to the same size as src, and copy data src -> dest. /
9028
9029	tree
9030	gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
9031	tree add_when_allocated)
9032	{
9033	return duplicate_allocatable (dest, src, type, rank, no_malloc: false, no_memcpy: false,
9034	NULL_TREE, add_when_allocated);
9035	}
9036
9037
9038	/ Copy data src -> dest. /
9039
9040	tree
9041	gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
9042	{
9043	return duplicate_allocatable (dest, src, type, rank, no_malloc: true, no_memcpy: false,
9044	NULL_TREE, NULL_TREE);
9045	}
9046
9047	/ Allocate dest to the same size as src, but don't copy anything. /
9048
9049	tree
9050	gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
9051	{
9052	return duplicate_allocatable (dest, src, type, rank, no_malloc: false, no_memcpy: true,
9053	NULL_TREE, NULL_TREE);
9054	}
9055
9056
9057	static tree
9058	duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
9059	tree type, int rank)
9060	{
9061	tree tmp;
9062	tree size;
9063	tree nelems;
9064	tree null_cond;
9065	tree null_data;
9066	stmtblock_t block, globalblock;
9067
9068	/ If the source is null, set the destination to null. Then,*
9069	allocate memory to the destination. /*
9070	gfc_init_block (&block);
9071	gfc_init_block (&globalblock);
9072
9073	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9074	{
9075	gfc_se se;
9076	symbol_attribute attr;
9077	tree dummy_desc;
9078
9079	gfc_init_se (&se, NULL);
9080	gfc_clear_attr (&attr);
9081	attr.allocatable = `1`;
9082	dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
9083	gfc_add_block_to_block (&globalblock, &se.pre);
9084	size = TYPE_SIZE_UNIT (TREE_TYPE (type));
9085
9086	gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
9087	gfc_allocate_using_caf_lib (&block, dummy_desc, size,
9088	gfc_build_addr_expr (NULL_TREE, dest_tok),
9089	NULL_TREE, NULL_TREE, NULL_TREE,
9090	GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9091	null_data = gfc_finish_block (&block);
9092
9093	gfc_init_block (&block);
9094
9095	gfc_allocate_using_caf_lib (&block, dummy_desc,
9096	fold_convert (size_type_node, size),
9097	gfc_build_addr_expr (NULL_TREE, dest_tok),
9098	NULL_TREE, NULL_TREE, NULL_TREE,
9099	GFC_CAF_COARRAY_ALLOC);
9100
9101	tmp = builtin_decl_explicit (fncode: BUILT_IN_MEMCPY);
9102	tmp = build_call_expr_loc (input_location, tmp, `3`, dest, src,
9103	fold_convert (size_type_node, size));
9104	gfc_add_expr_to_block (&block, tmp);
9105	}
9106	else
9107	{
9108	/ Set the rank or unitialized memory access may be reported. /
9109	tmp = gfc_conv_descriptor_rank (desc: dest);
9110	gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
9111
9112	if (rank)
9113	nelems = gfc_full_array_size (block: &block, decl: src, rank);
9114	else
9115	nelems = integer_one_node;
9116
9117	tmp = fold_convert (size_type_node,
9118	TYPE_SIZE_UNIT (gfc_get_element_type (type)));
9119	size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
9120	fold_convert (size_type_node, nelems), tmp);
9121
9122	gfc_conv_descriptor_data_set (block: &block, desc: dest, null_pointer_node);
9123	gfc_allocate_using_caf_lib (&block, dest, fold_convert (size_type_node,
9124	size),
9125	gfc_build_addr_expr (NULL_TREE, dest_tok),
9126	NULL_TREE, NULL_TREE, NULL_TREE,
9127	GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9128	null_data = gfc_finish_block (&block);
9129
9130	gfc_init_block (&block);
9131	gfc_allocate_using_caf_lib (&block, dest,
9132	fold_convert (size_type_node, size),
9133	gfc_build_addr_expr (NULL_TREE, dest_tok),
9134	NULL_TREE, NULL_TREE, NULL_TREE,
9135	GFC_CAF_COARRAY_ALLOC);
9136
9137	tmp = builtin_decl_explicit (fncode: BUILT_IN_MEMCPY);
9138	tmp = build_call_expr_loc (input_location, tmp, `3`,
9139	gfc_conv_descriptor_data_get (desc: dest),
9140	gfc_conv_descriptor_data_get (desc: src),
9141	fold_convert (size_type_node, size));
9142	gfc_add_expr_to_block (&block, tmp);
9143	}
9144
9145	tmp = gfc_finish_block (&block);
9146
9147	/ Null the destination if the source is null; otherwise do*
9148	the register and copy. /*
9149	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
9150	null_cond = src;
9151	else
9152	null_cond = gfc_conv_descriptor_data_get (desc: src);
9153
9154	null_cond = convert (pvoid_type_node, null_cond);
9155	null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9156	null_cond, null_pointer_node);
9157	gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp,
9158	null_data));
9159	return gfc_finish_block (&globalblock);
9160	}
9161
9162
9163	/ Helper function to abstract whether coarray processing is enabled. /
9164
9165	static bool
9166	caf_enabled (int caf_mode)
9167	{
9168	return (caf_mode & GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY)
9169	== GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY;
9170	}
9171
9172
9173	/ Helper function to abstract whether coarray processing is enabled*
9174	and we are in a derived type coarray. /*
9175
9176	static bool
9177	caf_in_coarray (int caf_mode)
9178	{
9179	static const int pat = GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9180	\| GFC_STRUCTURE_CAF_MODE_IN_COARRAY;
9181	return (caf_mode & pat) == pat;
9182	}
9183
9184
9185	/ Helper function to abstract whether coarray is to deallocate only. /
9186
9187	bool
9188	gfc_caf_is_dealloc_only (int caf_mode)
9189	{
9190	return (caf_mode & GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY)
9191	== GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY;
9192	}
9193
9194
9195	/ Recursively traverse an object of derived type, generating code to*
9196	deallocate, nullify or copy allocatable components. This is the work horse
9197	function for the functions named in this enum. /*
9198
9199	enum {DEALLOCATE_ALLOC_COMP = `1`, NULLIFY_ALLOC_COMP,
9200	COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
9201	ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
9202	BCAST_ALLOC_COMP};
9203
9204	static gfc_actual_arglist *pdt_param_list;
9205
9206	static tree
9207	structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
9208	int rank, int purpose, int caf_mode,
9209	gfc_co_subroutines_args *args,
9210	bool no_finalization = false)
9211	{
9212	gfc_component *c;
9213	gfc_loopinfo loop;
9214	stmtblock_t fnblock;
9215	stmtblock_t loopbody;
9216	stmtblock_t tmpblock;
9217	tree decl_type;
9218	tree tmp;
9219	tree comp;
9220	tree dcmp;
9221	tree nelems;
9222	tree index;
9223	tree var;
9224	tree cdecl;
9225	tree ctype;
9226	tree vref, dref;
9227	tree null_cond = NULL_TREE;
9228	tree add_when_allocated;
9229	tree dealloc_fndecl;
9230	tree caf_token;
9231	gfc_symbol *vtab;
9232	int caf_dereg_mode;
9233	symbol_attribute *attr;
9234	bool deallocate_called;
9235
9236	gfc_init_block (&fnblock);
9237
9238	decl_type = TREE_TYPE (decl);
9239
9240	if ((POINTER_TYPE_P (decl_type))
9241	\|\| (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == `0`))
9242	{
9243	decl = build_fold_indirect_ref_loc (input_location, decl);
9244	/ Deref dest in sync with decl, but only when it is not NULL. /
9245	if (dest)
9246	dest = build_fold_indirect_ref_loc (input_location, dest);
9247
9248	/ Update the decl_type because it got dereferenced. /
9249	decl_type = TREE_TYPE (decl);
9250	}
9251
9252	/ If this is an array of derived types with allocatable components*
9253	build a loop and recursively call this function. /*
9254	if (TREE_CODE (decl_type) == ARRAY_TYPE
9255	\|\| (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != `0`))
9256	{
9257	tmp = gfc_conv_array_data (descriptor: decl);
9258	var = build_fold_indirect_ref_loc (input_location, tmp);
9259
9260	/ Get the number of elements - 1 and set the counter. /
9261	if (GFC_DESCRIPTOR_TYPE_P (decl_type))
9262	{
9263	/ Use the descriptor for an allocatable array. Since this*
9264	is a full array reference, we only need the descriptor
9265	information from dimension = rank. /*
9266	tmp = gfc_full_array_size (block: &fnblock, decl, rank);
9267	tmp = fold_build2_loc (input_location, MINUS_EXPR,
9268	gfc_array_index_type, tmp,
9269	gfc_index_one_node);
9270
9271	null_cond = gfc_conv_descriptor_data_get (desc: decl);
9272	null_cond = fold_build2_loc (input_location, NE_EXPR,
9273	logical_type_node, null_cond,
9274	build_int_cst (TREE_TYPE (null_cond), `0`));
9275	}
9276	else
9277	{
9278	/ Otherwise use the TYPE_DOMAIN information. /
9279	tmp = array_type_nelts (decl_type);
9280	tmp = fold_convert (gfc_array_index_type, tmp);
9281	}
9282
9283	/ Remember that this is, in fact, the no. of elements - 1. /
9284	nelems = gfc_evaluate_now (tmp, &fnblock);
9285	index = gfc_create_var (gfc_array_index_type, "S");
9286
9287	/ Build the body of the loop. /
9288	gfc_init_block (&loopbody);
9289
9290	vref = gfc_build_array_ref (var, index, NULL);
9291
9292	if (purpose == COPY_ALLOC_COMP \|\| purpose == COPY_ONLY_ALLOC_COMP)
9293	{
9294	tmp = build_fold_indirect_ref_loc (input_location,
9295	gfc_conv_array_data (descriptor: dest));
9296	dref = gfc_build_array_ref (tmp, index, NULL);
9297	tmp = structure_alloc_comps (der_type, decl: vref, dest: dref, rank,
9298	purpose: COPY_ALLOC_COMP, caf_mode, args,
9299	no_finalization);
9300	}
9301	else
9302	tmp = structure_alloc_comps (der_type, decl: vref, NULL_TREE, rank, purpose,
9303	caf_mode, args, no_finalization);
9304
9305	gfc_add_expr_to_block (&loopbody, tmp);
9306
9307	/ Build the loop and return. /
9308	gfc_init_loopinfo (loop: &loop);
9309	loop.dimen = `1`;
9310	loop.from[`0`] = gfc_index_zero_node;
9311	loop.loopvar[`0`] = index;
9312	loop.to[`0`] = nelems;
9313	gfc_trans_scalarizing_loops (loop: &loop, body: &loopbody);
9314	gfc_add_block_to_block (&fnblock, &loop.pre);
9315
9316	tmp = gfc_finish_block (&fnblock);
9317	/ When copying allocateable components, the above implements the*
9318	deep copy. Nevertheless is a deep copy only allowed, when the current
9319	component is allocated, for which code will be generated in
9320	gfc_duplicate_allocatable (), where the deep copy code is just added
9321	into the if's body, by adding tmp (the deep copy code) as last
9322	argument to gfc_duplicate_allocatable (). /*
9323	if (purpose == COPY_ALLOC_COMP
9324	&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
9325	tmp = gfc_duplicate_allocatable (dest, src: decl, type: decl_type, rank,
9326	add_when_allocated: tmp);
9327	else if (null_cond != NULL_TREE)
9328	tmp = build3_v (COND_EXPR, null_cond, tmp,
9329	build_empty_stmt (input_location));
9330
9331	return tmp;
9332	}
9333
9334	if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
9335	{
9336	tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9337	purpose: DEALLOCATE_PDT_COMP, caf_mode: `0`, args,
9338	no_finalization);
9339	gfc_add_expr_to_block (&fnblock, tmp);
9340	}
9341	else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
9342	{
9343	tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9344	purpose: NULLIFY_ALLOC_COMP, caf_mode: `0`, args,
9345	no_finalization);
9346	gfc_add_expr_to_block (&fnblock, tmp);
9347	}
9348
9349	/ Still having a descriptor array of rank == 0 here, indicates an*
9350	allocatable coarrays. Dereference it correctly. /*
9351	if (GFC_DESCRIPTOR_TYPE_P (decl_type))
9352	{
9353	decl = build_fold_indirect_ref (gfc_conv_array_data (decl));
9354	}
9355	/ Otherwise, act on the components or recursively call self to*
9356	act on a chain of components. /*
9357	for (c = der_type->components; c; c = c->next)
9358	{
9359	bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED
9360	\|\| c->ts.type == BT_CLASS)
9361	&& c->ts.u.derived->attr.alloc_comp;
9362	bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
9363	\|\| (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
9364
9365	bool is_pdt_type = c->ts.type == BT_DERIVED
9366	&& c->ts.u.derived->attr.pdt_type;
9367
9368	cdecl = c->backend_decl;
9369	ctype = TREE_TYPE (cdecl);
9370
9371	switch (purpose)
9372	{
9373
9374	case BCAST_ALLOC_COMP:
9375
9376	tree ubound;
9377	tree cdesc;
9378	stmtblock_t derived_type_block;
9379
9380	gfc_init_block (&tmpblock);
9381
9382	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9383	decl, cdecl, NULL_TREE);
9384
9385	/ Shortcut to get the attributes of the component. /
9386	if (c->ts.type == BT_CLASS)
9387	{
9388	attr = &CLASS_DATA (c)->attr;
9389	if (attr->class_pointer)
9390	continue;
9391	}
9392	else
9393	{
9394	attr = &c->attr;
9395	if (attr->pointer)
9396	continue;
9397	}
9398
9399	/ Do not broadcast a caf_token. These are local to the image. /
9400	if (attr->caf_token)
9401	continue;
9402
9403	add_when_allocated = NULL_TREE;
9404	if (cmp_has_alloc_comps
9405	&& !c->attr.pointer && !c->attr.proc_pointer)
9406	{
9407	if (c->ts.type == BT_CLASS)
9408	{
9409	rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : `0`;
9410	add_when_allocated
9411	= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
9412	decl: comp, NULL_TREE, rank, purpose,
9413	caf_mode, args, no_finalization);
9414	}
9415	else
9416	{
9417	rank = c->as ? c->as->rank : `0`;
9418	add_when_allocated = structure_alloc_comps (der_type: c->ts.u.derived,
9419	decl: comp, NULL_TREE,
9420	rank, purpose,
9421	caf_mode, args,
9422	no_finalization);
9423	}
9424	}
9425
9426	gfc_init_block (&derived_type_block);
9427	if (add_when_allocated)
9428	gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
9429	tmp = gfc_finish_block (&derived_type_block);
9430	gfc_add_expr_to_block (&tmpblock, tmp);
9431
9432	/ Convert the component into a rank 1 descriptor type. /
9433	if (attr->dimension)
9434	{
9435	tmp = gfc_get_element_type (TREE_TYPE (comp));
9436	if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
9437	ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp));
9438	else
9439	ubound = gfc_full_array_size (block: &tmpblock, decl: comp,
9440	rank: c->ts.type == BT_CLASS
9441	? CLASS_DATA (c)->as->rank
9442	: c->as->rank);
9443	}
9444	else
9445	{
9446	tmp = TREE_TYPE (comp);
9447	ubound = build_int_cst (gfc_array_index_type, `1`);
9448	}
9449
9450	/ Treat strings like arrays. Or the other way around, do not*
9451	* generate an additional array layer for scalar components. */
9452	if (attr->dimension \|\| c->ts.type == BT_CHARACTER)
9453	{
9454	cdesc = gfc_get_array_type_bounds (tmp, `1`, `0`, &gfc_index_one_node,
9455	&ubound, `1`,
9456	GFC_ARRAY_ALLOCATABLE, false);
9457
9458	cdesc = gfc_create_var (cdesc, "cdesc");
9459	DECL_ARTIFICIAL (cdesc) = `1`;
9460
9461	gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (desc: cdesc),
9462	gfc_get_dtype_rank_type (`1`, tmp));
9463	gfc_conv_descriptor_lbound_set (block: &tmpblock, desc: cdesc,
9464	gfc_index_zero_node,
9465	gfc_index_one_node);
9466	gfc_conv_descriptor_stride_set (block: &tmpblock, desc: cdesc,
9467	gfc_index_zero_node,
9468	gfc_index_one_node);
9469	gfc_conv_descriptor_ubound_set (block: &tmpblock, desc: cdesc,
9470	gfc_index_zero_node, value: ubound);
9471	}
9472	else
9473	/ Prevent warning. /
9474	cdesc = NULL_TREE;
9475
9476	if (attr->dimension)
9477	{
9478	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
9479	comp = gfc_conv_descriptor_data_get (desc: comp);
9480	else
9481	comp = gfc_build_addr_expr (NULL_TREE, comp);
9482	}
9483	else
9484	{
9485	gfc_se se;
9486
9487	gfc_init_se (&se, NULL);
9488
9489	comp = gfc_conv_scalar_to_descriptor (&se, comp,
9490	c->ts.type == BT_CLASS
9491	? CLASS_DATA (c)->attr
9492	: c->attr);
9493	if (c->ts.type == BT_CHARACTER)
9494	comp = gfc_build_addr_expr (NULL_TREE, comp);
9495	gfc_add_block_to_block (&tmpblock, &se.pre);
9496	}
9497
9498	if (attr->dimension \|\| c->ts.type == BT_CHARACTER)
9499	gfc_conv_descriptor_data_set (block: &tmpblock, desc: cdesc, value: comp);
9500	else
9501	cdesc = comp;
9502
9503	tree fndecl;
9504
9505	fndecl = build_call_expr_loc (input_location,
9506	gfor_fndecl_co_broadcast, `5`,
9507	gfc_build_addr_expr (pvoid_type_node,cdesc),
9508	args->image_index,
9509	null_pointer_node, null_pointer_node,
9510	null_pointer_node);
9511
9512	gfc_add_expr_to_block (&tmpblock, fndecl);
9513	gfc_add_block_to_block (&fnblock, &tmpblock);
9514
9515	break;
9516
9517	case DEALLOCATE_ALLOC_COMP:
9518
9519	gfc_init_block (&tmpblock);
9520
9521	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9522	decl, cdecl, NULL_TREE);
9523
9524	/ Shortcut to get the attributes of the component. /
9525	if (c->ts.type == BT_CLASS)
9526	{
9527	attr = &CLASS_DATA (c)->attr;
9528	if (attr->class_pointer)
9529	continue;
9530	}
9531	else
9532	{
9533	attr = &c->attr;
9534	if (attr->pointer)
9535	continue;
9536	}
9537
9538	if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
9539	\|\| (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
9540	/ Call the finalizer, which will free the memory and nullify the*
9541	pointer of an array. /*
9542	deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
9543	caf_enabled (caf_mode))
9544	&& attr->dimension;
9545	else
9546	deallocate_called = false;
9547
9548	/ Add the _class ref for classes. /
9549	if (c->ts.type == BT_CLASS && attr->allocatable)
9550	comp = gfc_class_data_get (comp);
9551
9552	add_when_allocated = NULL_TREE;
9553	if (cmp_has_alloc_comps
9554	&& !c->attr.pointer && !c->attr.proc_pointer
9555	&& !same_type
9556	&& !deallocate_called)
9557	{
9558	/ Add checked deallocation of the components. This code is*
9559	obviously added because the finalizer is not trusted to free
9560	all memory. /*
9561	if (c->ts.type == BT_CLASS)
9562	{
9563	rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : `0`;
9564	add_when_allocated
9565	= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
9566	decl: comp, NULL_TREE, rank, purpose,
9567	caf_mode, args, no_finalization);
9568	}
9569	else
9570	{
9571	rank = c->as ? c->as->rank : `0`;
9572	add_when_allocated = structure_alloc_comps (der_type: c->ts.u.derived,
9573	decl: comp, NULL_TREE,
9574	rank, purpose,
9575	caf_mode, args,
9576	no_finalization);
9577	}
9578	}
9579
9580	if (attr->allocatable && !same_type
9581	&& (!attr->codimension \|\| caf_enabled (caf_mode)))
9582	{
9583	/ Handle all types of components besides components of the*
9584	same_type as the current one, because those would create an
9585	endless loop. /*
9586	caf_dereg_mode
9587	= (caf_in_coarray (caf_mode) \|\| attr->codimension)
9588	? (gfc_caf_is_dealloc_only (caf_mode)
9589	? GFC_CAF_COARRAY_DEALLOCATE_ONLY
9590	: GFC_CAF_COARRAY_DEREGISTER)
9591	: GFC_CAF_COARRAY_NOCOARRAY;
9592
9593	caf_token = NULL_TREE;
9594	/ Coarray components are handled directly by*
9595	deallocate_with_status. /*
9596	if (!attr->codimension
9597	&& caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
9598	{
9599	if (c->caf_token)
9600	caf_token = fold_build3_loc (input_location, COMPONENT_REF,
9601	TREE_TYPE (c->caf_token),
9602	decl, c->caf_token, NULL_TREE);
9603	else if (attr->dimension && !attr->proc_pointer)
9604	caf_token = gfc_conv_descriptor_token (desc: comp);
9605	}
9606	if (attr->dimension && !attr->codimension && !attr->proc_pointer)
9607	/ When this is an array but not in conjunction with a coarray*
9608	then add the data-ref. For coarray'ed arrays the data-ref
9609	is added by deallocate_with_status. /*
9610	comp = gfc_conv_descriptor_data_get (desc: comp);
9611
9612	tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
9613	NULL_TREE, NULL_TREE, true,
9614	NULL, caf_dereg_mode, NULL_TREE,
9615	a: add_when_allocated, c: caf_token);
9616
9617	gfc_add_expr_to_block (&tmpblock, tmp);
9618	}
9619	else if (attr->allocatable && !attr->codimension
9620	&& !deallocate_called)
9621	{
9622	/ Case of recursive allocatable derived types. /
9623	tree is_allocated;
9624	tree ubound;
9625	tree cdesc;
9626	stmtblock_t dealloc_block;
9627
9628	gfc_init_block (&dealloc_block);
9629	if (add_when_allocated)
9630	gfc_add_expr_to_block (&dealloc_block, add_when_allocated);
9631
9632	/ Convert the component into a rank 1 descriptor type. /
9633	if (attr->dimension)
9634	{
9635	tmp = gfc_get_element_type (TREE_TYPE (comp));
9636	ubound = gfc_full_array_size (block: &dealloc_block, decl: comp,
9637	rank: c->ts.type == BT_CLASS
9638	? CLASS_DATA (c)->as->rank
9639	: c->as->rank);
9640	}
9641	else
9642	{
9643	tmp = TREE_TYPE (comp);
9644	ubound = build_int_cst (gfc_array_index_type, `1`);
9645	}
9646
9647	cdesc = gfc_get_array_type_bounds (tmp, `1`, `0`, &gfc_index_one_node,
9648	&ubound, `1`,
9649	GFC_ARRAY_ALLOCATABLE, false);
9650
9651	cdesc = gfc_create_var (cdesc, "cdesc");
9652	DECL_ARTIFICIAL (cdesc) = `1`;
9653
9654	gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (desc: cdesc),
9655	gfc_get_dtype_rank_type (`1`, tmp));
9656	gfc_conv_descriptor_lbound_set (block: &dealloc_block, desc: cdesc,
9657	gfc_index_zero_node,
9658	gfc_index_one_node);
9659	gfc_conv_descriptor_stride_set (block: &dealloc_block, desc: cdesc,
9660	gfc_index_zero_node,
9661	gfc_index_one_node);
9662	gfc_conv_descriptor_ubound_set (block: &dealloc_block, desc: cdesc,
9663	gfc_index_zero_node, value: ubound);
9664
9665	if (attr->dimension)
9666	comp = gfc_conv_descriptor_data_get (desc: comp);
9667
9668	gfc_conv_descriptor_data_set (block: &dealloc_block, desc: cdesc, value: comp);
9669
9670	/ Now call the deallocator. /
9671	vtab = gfc_find_vtab (&c->ts);
9672	if (vtab->backend_decl == NULL)
9673	gfc_get_symbol_decl (vtab);
9674	tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
9675	dealloc_fndecl = gfc_vptr_deallocate_get (tmp);
9676	dealloc_fndecl = build_fold_indirect_ref_loc (input_location,
9677	dealloc_fndecl);
9678	tmp = build_int_cst (TREE_TYPE (comp), `0`);
9679	is_allocated = fold_build2_loc (input_location, NE_EXPR,
9680	logical_type_node, tmp,
9681	comp);
9682	cdesc = gfc_build_addr_expr (NULL_TREE, cdesc);
9683
9684	tmp = build_call_expr_loc (input_location,
9685	dealloc_fndecl, `1`,
9686	cdesc);
9687	gfc_add_expr_to_block (&dealloc_block, tmp);
9688
9689	tmp = gfc_finish_block (&dealloc_block);
9690
9691	tmp = fold_build3_loc (input_location, COND_EXPR,
9692	void_type_node, is_allocated, tmp,
9693	build_empty_stmt (input_location));
9694
9695	gfc_add_expr_to_block (&tmpblock, tmp);
9696	}
9697	else if (add_when_allocated)
9698	gfc_add_expr_to_block (&tmpblock, add_when_allocated);
9699
9700	if (c->ts.type == BT_CLASS && attr->allocatable
9701	&& (!attr->codimension \|\| !caf_enabled (caf_mode)))
9702	{
9703	/ Finally, reset the vptr to the declared type vtable and, if*
9704	necessary reset the _len field.
9705
9706	First recover the reference to the component and obtain
9707	the vptr. /*
9708	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9709	decl, cdecl, NULL_TREE);
9710	tmp = gfc_class_vptr_get (comp);
9711
9712	if (UNLIMITED_POLY (c))
9713	{
9714	/ Both vptr and _len field should be nulled. /
9715	gfc_add_modify (&tmpblock, tmp,
9716	build_int_cst (TREE_TYPE (tmp), `0`));
9717	tmp = gfc_class_len_get (comp);
9718	gfc_add_modify (&tmpblock, tmp,
9719	build_int_cst (TREE_TYPE (tmp), `0`));
9720	}
9721	else
9722	{
9723	/ Build the vtable address and set the vptr with it. /
9724	tree vtab;
9725	gfc_symbol *vtable;
9726	vtable = gfc_find_derived_vtab (c->ts.u.derived);
9727	vtab = vtable->backend_decl;
9728	if (vtab == NULL_TREE)
9729	vtab = gfc_get_symbol_decl (vtable);
9730	vtab = gfc_build_addr_expr (NULL, vtab);
9731	vtab = fold_convert (TREE_TYPE (tmp), vtab);
9732	gfc_add_modify (&tmpblock, tmp, vtab);
9733	}
9734	}
9735
9736	/ Now add the deallocation of this component. /
9737	gfc_add_block_to_block (&fnblock, &tmpblock);
9738	break;
9739
9740	case NULLIFY_ALLOC_COMP:
9741	/ Nullify*
9742	- allocatable components (regular or in class)
9743	- components that have allocatable components
9744	- pointer components when in a coarray.
9745	Skip everything else especially proc_pointers, which may come
9746	coupled with the regular pointer attribute. /*
9747	if (c->attr.proc_pointer
9748	\|\| !(c->attr.allocatable \|\| (c->ts.type == BT_CLASS
9749	&& CLASS_DATA (c)->attr.allocatable)
9750	\|\| (cmp_has_alloc_comps
9751	&& ((c->ts.type == BT_DERIVED && !c->attr.pointer)
9752	\|\| (c->ts.type == BT_CLASS
9753	&& !CLASS_DATA (c)->attr.class_pointer)))
9754	\|\| (caf_in_coarray (caf_mode) && c->attr.pointer)))
9755	continue;
9756
9757	/ Process class components first, because they always have the*
9758	pointer-attribute set which would be caught wrong else. /*
9759	if (c->ts.type == BT_CLASS
9760	&& (CLASS_DATA (c)->attr.allocatable
9761	\|\| CLASS_DATA (c)->attr.class_pointer))
9762	{
9763	tree vptr_decl;
9764
9765	/ Allocatable CLASS components. /
9766	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9767	decl, cdecl, NULL_TREE);
9768
9769	vptr_decl = gfc_class_vptr_get (comp);
9770
9771	comp = gfc_class_data_get (comp);
9772	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
9773	gfc_conv_descriptor_data_set (block: &fnblock, desc: comp,
9774	null_pointer_node);
9775	else
9776	{
9777	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9778	void_type_node, comp,
9779	build_int_cst (TREE_TYPE (comp), `0`));
9780	gfc_add_expr_to_block (&fnblock, tmp);
9781	}
9782
9783	/ The dynamic type of a disassociated pointer or unallocated*
9784	allocatable variable is its declared type. An unlimited
9785	polymorphic entity has no declared type. /*
9786	if (!UNLIMITED_POLY (c))
9787	{
9788	vtab = gfc_find_derived_vtab (c->ts.u.derived);
9789	if (!vtab->backend_decl)
9790	gfc_get_symbol_decl (vtab);
9791	tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
9792	}
9793	else
9794	tmp = build_int_cst (TREE_TYPE (vptr_decl), `0`);
9795
9796	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9797	void_type_node, vptr_decl, tmp);
9798	gfc_add_expr_to_block (&fnblock, tmp);
9799
9800	cmp_has_alloc_comps = false;
9801	}
9802	/ Coarrays need the component to be nulled before the api-call*
9803	is made. /*
9804	else if (c->attr.pointer \|\| c->attr.allocatable)
9805	{
9806	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9807	decl, cdecl, NULL_TREE);
9808	if (c->attr.dimension \|\| c->attr.codimension)
9809	gfc_conv_descriptor_data_set (block: &fnblock, desc: comp,
9810	null_pointer_node);
9811	else
9812	gfc_add_modify (&fnblock, comp,
9813	build_int_cst (TREE_TYPE (comp), `0`));
9814	if (gfc_deferred_strlen (c, &comp))
9815	{
9816	comp = fold_build3_loc (input_location, COMPONENT_REF,
9817	TREE_TYPE (comp),
9818	decl, comp, NULL_TREE);
9819	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
9820	TREE_TYPE (comp), comp,
9821	build_int_cst (TREE_TYPE (comp), `0`));
9822	gfc_add_expr_to_block (&fnblock, tmp);
9823	}
9824	cmp_has_alloc_comps = false;
9825	}
9826
9827	if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode))
9828	{
9829	/ Register a component of a derived type coarray with the*
9830	coarray library. Do not register ultimate component
9831	coarrays here. They are treated like regular coarrays and
9832	are either allocated on all images or on none. /*
9833	tree token;
9834
9835	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9836	decl, cdecl, NULL_TREE);
9837	if (c->attr.dimension)
9838	{
9839	/ Set the dtype, because caf_register needs it. /
9840	gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (desc: comp),
9841	gfc_get_dtype (TREE_TYPE (comp)));
9842	tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9843	decl, cdecl, NULL_TREE);
9844	token = gfc_conv_descriptor_token (desc: tmp);
9845	}
9846	else
9847	{
9848	gfc_se se;
9849
9850	gfc_init_se (&se, NULL);
9851	token = fold_build3_loc (input_location, COMPONENT_REF,
9852	pvoid_type_node, decl, c->caf_token,
9853	NULL_TREE);
9854	comp = gfc_conv_scalar_to_descriptor (&se, comp,
9855	c->ts.type == BT_CLASS
9856	? CLASS_DATA (c)->attr
9857	: c->attr);
9858	gfc_add_block_to_block (&fnblock, &se.pre);
9859	}
9860
9861	gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
9862	gfc_build_addr_expr (NULL_TREE,
9863	token),
9864	NULL_TREE, NULL_TREE, NULL_TREE,
9865	GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY);
9866	}
9867
9868	if (cmp_has_alloc_comps)
9869	{
9870	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9871	decl, cdecl, NULL_TREE);
9872	rank = c->as ? c->as->rank : `0`;
9873	tmp = structure_alloc_comps (der_type: c->ts.u.derived, decl: comp, NULL_TREE,
9874	rank, purpose, caf_mode, args,
9875	no_finalization);
9876	gfc_add_expr_to_block (&fnblock, tmp);
9877	}
9878	break;
9879
9880	case REASSIGN_CAF_COMP:
9881	if (caf_enabled (caf_mode)
9882	&& (c->attr.codimension
9883	\|\| (c->ts.type == BT_CLASS
9884	&& (CLASS_DATA (c)->attr.coarray_comp
9885	\|\| caf_in_coarray (caf_mode)))
9886	\|\| (c->ts.type == BT_DERIVED
9887	&& (c->ts.u.derived->attr.coarray_comp
9888	\|\| caf_in_coarray (caf_mode))))
9889	&& !same_type)
9890	{
9891	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9892	decl, cdecl, NULL_TREE);
9893	dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
9894	dest, cdecl, NULL_TREE);
9895
9896	if (c->attr.codimension)
9897	{
9898	if (c->ts.type == BT_CLASS)
9899	{
9900	comp = gfc_class_data_get (comp);
9901	dcmp = gfc_class_data_get (dcmp);
9902	}
9903	gfc_conv_descriptor_data_set (block: &fnblock, desc: dcmp,
9904	value: gfc_conv_descriptor_data_get (desc: comp));
9905	}
9906	else
9907	{
9908	tmp = structure_alloc_comps (der_type: c->ts.u.derived, decl: comp, dest: dcmp,
9909	rank, purpose, caf_mode: caf_mode
9910	\| GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
9911	args, no_finalization);
9912	gfc_add_expr_to_block (&fnblock, tmp);
9913	}
9914	}
9915	break;
9916
9917	case COPY_ALLOC_COMP:
9918	if (c->attr.pointer \|\| c->attr.proc_pointer)
9919	continue;
9920
9921	/ We need source and destination components. /
9922	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl,
9923	cdecl, NULL_TREE);
9924	dcmp = fold_build3_loc (input_location, COMPONENT_REF, ctype, dest,
9925	cdecl, NULL_TREE);
9926	dcmp = fold_convert (TREE_TYPE (comp), dcmp);
9927
9928	if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
9929	{
9930	tree ftn_tree;
9931	tree size;
9932	tree dst_data;
9933	tree src_data;
9934	tree null_data;
9935
9936	dst_data = gfc_class_data_get (dcmp);
9937	src_data = gfc_class_data_get (comp);
9938	size = fold_convert (size_type_node,
9939	gfc_class_vtab_size_get (comp));
9940
9941	if (CLASS_DATA (c)->attr.dimension)
9942	{
9943	nelems = gfc_conv_descriptor_size (desc: src_data,
9944	CLASS_DATA (c)->as->rank);
9945	size = fold_build2_loc (input_location, MULT_EXPR,
9946	size_type_node, size,
9947	fold_convert (size_type_node,
9948	nelems));
9949	}
9950	else
9951	nelems = build_int_cst (size_type_node, `1`);
9952
9953	if (CLASS_DATA (c)->attr.dimension
9954	\|\| CLASS_DATA (c)->attr.codimension)
9955	{
9956	src_data = gfc_conv_descriptor_data_get (desc: src_data);
9957	dst_data = gfc_conv_descriptor_data_get (desc: dst_data);
9958	}
9959
9960	gfc_init_block (&tmpblock);
9961
9962	gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp),
9963	gfc_class_vptr_get (comp));
9964
9965	/ Copy the unlimited '_len' field. If it is greater than zero*
9966	(ie. a character(_len)), multiply it by size and use this
9967	for the malloc call. /*
9968	if (UNLIMITED_POLY (c))
9969	{
9970	gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
9971	gfc_class_len_get (comp));
9972	size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
9973	}
9974
9975	/ Coarray component have to have the same allocation status and*
9976	shape/type-parameter/effective-type on the LHS and RHS of an
9977	intrinsic assignment. Hence, we did not deallocated them - and
9978	do not allocate them here. /*
9979	if (!CLASS_DATA (c)->attr.codimension)
9980	{
9981	ftn_tree = builtin_decl_explicit (fncode: BUILT_IN_MALLOC);
9982	tmp = build_call_expr_loc (input_location, ftn_tree, `1`, size);
9983	gfc_add_modify (&tmpblock, dst_data,
9984	fold_convert (TREE_TYPE (dst_data), tmp));
9985	}
9986
9987	tmp = gfc_copy_class_to_class (comp, dcmp, nelems,
9988	UNLIMITED_POLY (c));
9989	gfc_add_expr_to_block (&tmpblock, tmp);
9990	tmp = gfc_finish_block (&tmpblock);
9991
9992	gfc_init_block (&tmpblock);
9993	gfc_add_modify (&tmpblock, dst_data,
9994	fold_convert (TREE_TYPE (dst_data),
9995	null_pointer_node));
9996	null_data = gfc_finish_block (&tmpblock);
9997
9998	null_cond = fold_build2_loc (input_location, NE_EXPR,
9999	logical_type_node, src_data,
10000	null_pointer_node);
10001
10002	gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
10003	tmp, null_data));
10004	continue;
10005	}
10006
10007	/ To implement guarded deep copy, i.e., deep copy only allocatable*
10008	components that are really allocated, the deep copy code has to
10009	be generated first and then added to the if-block in
10010	gfc_duplicate_allocatable (). /*
10011	if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
10012	{
10013	rank = c->as ? c->as->rank : `0`;
10014	tmp = fold_convert (TREE_TYPE (dcmp), comp);
10015	gfc_add_modify (&fnblock, dcmp, tmp);
10016	add_when_allocated = structure_alloc_comps (der_type: c->ts.u.derived,
10017	decl: comp, dest: dcmp,
10018	rank, purpose,
10019	caf_mode, args,
10020	no_finalization);
10021	}
10022	else
10023	add_when_allocated = NULL_TREE;
10024
10025	if (gfc_deferred_strlen (c, &tmp))
10026	{
10027	tree len, size;
10028	len = tmp;
10029	tmp = fold_build3_loc (input_location, COMPONENT_REF,
10030	TREE_TYPE (len),
10031	decl, len, NULL_TREE);
10032	len = fold_build3_loc (input_location, COMPONENT_REF,
10033	TREE_TYPE (len),
10034	dest, len, NULL_TREE);
10035	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
10036	TREE_TYPE (len), len, tmp);
10037	gfc_add_expr_to_block (&fnblock, tmp);
10038	size = size_of_string_in_bytes (c->ts.kind, len);
10039	/ This component cannot have allocatable components,*
10040	therefore add_when_allocated of duplicate_allocatable ()
10041	is always NULL. /*
10042	rank = c->as ? c->as->rank : `0`;
10043	tmp = duplicate_allocatable (dest: dcmp, src: comp, type: ctype, rank,
10044	no_malloc: false, no_memcpy: false, str_sz: size, NULL_TREE);
10045	gfc_add_expr_to_block (&fnblock, tmp);
10046	}
10047	else if (c->attr.pdt_array)
10048	{
10049	tmp = duplicate_allocatable (dest: dcmp, src: comp, type: ctype,
10050	rank: c->as ? c->as->rank : `0`,
10051	no_malloc: false, no_memcpy: false, NULL_TREE, NULL_TREE);
10052	gfc_add_expr_to_block (&fnblock, tmp);
10053	}
10054	else if ((c->attr.allocatable)
10055	&& !c->attr.proc_pointer && !same_type
10056	&& (!(cmp_has_alloc_comps && c->as) \|\| c->attr.codimension
10057	\|\| caf_in_coarray (caf_mode)))
10058	{
10059	rank = c->as ? c->as->rank : `0`;
10060	if (c->attr.codimension)
10061	tmp = gfc_copy_allocatable_data (dest: dcmp, src: comp, type: ctype, rank);
10062	else if (flag_coarray == GFC_FCOARRAY_LIB
10063	&& caf_in_coarray (caf_mode))
10064	{
10065	tree dst_tok;
10066	if (c->as)
10067	dst_tok = gfc_conv_descriptor_token (desc: dcmp);
10068	else
10069	{
10070	/ For a scalar allocatable component the caf_token is*
10071	the next component. /*
10072	if (!c->caf_token)
10073	c->caf_token = c->next->backend_decl;
10074	dst_tok = fold_build3_loc (input_location,
10075	COMPONENT_REF,
10076	pvoid_type_node, dest,
10077	c->caf_token,
10078	NULL_TREE);
10079	}
10080	tmp = duplicate_allocatable_coarray (dest: dcmp, dest_tok: dst_tok, src: comp,
10081	type: ctype, rank);
10082	}
10083	else
10084	tmp = gfc_duplicate_allocatable (dest: dcmp, src: comp, type: ctype, rank,
10085	add_when_allocated);
10086	gfc_add_expr_to_block (&fnblock, tmp);
10087	}
10088	else
10089	if (cmp_has_alloc_comps \|\| is_pdt_type)
10090	gfc_add_expr_to_block (&fnblock, add_when_allocated);
10091
10092	break;
10093
10094	case ALLOCATE_PDT_COMP:
10095
10096	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10097	decl, cdecl, NULL_TREE);
10098
10099	/ Set the PDT KIND and LEN fields. /
10100	if (c->attr.pdt_kind \|\| c->attr.pdt_len)
10101	{
10102	gfc_se tse;
10103	gfc_expr *c_expr = NULL;
10104	gfc_actual_arglist *param = pdt_param_list;
10105	gfc_init_se (&tse, NULL);
10106	for (; param; param = param->next)
10107	if (param->name && !strcmp (s1: c->name, s2: param->name))
10108	c_expr = param->expr;
10109
10110	if (!c_expr)
10111	c_expr = c->initializer;
10112
10113	if (c_expr)
10114	{
10115	gfc_conv_expr_type (se: &tse, c_expr, TREE_TYPE (comp));
10116	gfc_add_modify (&fnblock, comp, tse.expr);
10117	}
10118	}
10119
10120	if (c->attr.pdt_string)
10121	{
10122	gfc_se tse;
10123	gfc_init_se (&tse, NULL);
10124	tree strlen = NULL_TREE;
10125	gfc_expr *e = gfc_copy_expr (c->ts.u.cl->length);
10126	/ Convert the parameterized string length to its value. The*
10127	string length is stored in a hidden field in the same way as
10128	deferred string lengths. /*
10129	gfc_insert_parameter_exprs (e, pdt_param_list);
10130	if (gfc_deferred_strlen (c, &strlen) && strlen != NULL_TREE)
10131	{
10132	gfc_conv_expr_type (se: &tse, e,
10133	TREE_TYPE (strlen));
10134	strlen = fold_build3_loc (input_location, COMPONENT_REF,
10135	TREE_TYPE (strlen),
10136	decl, strlen, NULL_TREE);
10137	gfc_add_modify (&fnblock, strlen, tse.expr);
10138	c->ts.u.cl->backend_decl = strlen;
10139	}
10140	gfc_free_expr (e);
10141
10142	/ Scalar parameterized strings can be allocated now. /
10143	if (!c->as)
10144	{
10145	tmp = fold_convert (gfc_array_index_type, strlen);
10146	tmp = size_of_string_in_bytes (c->ts.kind, tmp);
10147	tmp = gfc_evaluate_now (tmp, &fnblock);
10148	tmp = gfc_call_malloc (&fnblock, TREE_TYPE (comp), tmp);
10149	gfc_add_modify (&fnblock, comp, tmp);
10150	}
10151	}
10152
10153	/ Allocate parameterized arrays of parameterized derived types. /
10154	if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
10155	&& !((c->ts.type == BT_DERIVED \|\| c->ts.type == BT_CLASS)
10156	&& (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
10157	continue;
10158
10159	if (c->ts.type == BT_CLASS)
10160	comp = gfc_class_data_get (comp);
10161
10162	if (c->attr.pdt_array)
10163	{
10164	gfc_se tse;
10165	int i;
10166	tree size = gfc_index_one_node;
10167	tree offset = gfc_index_zero_node;
10168	tree lower, upper;
10169	gfc_expr *e;
10170
10171	/ This chunk takes the expressions for 'lower' and 'upper'*
10172	in the arrayspec and substitutes in the expressions for
10173	the parameters from 'pdt_param_list'. The descriptor
10174	fields can then be filled from the values so obtained. /*
10175	gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
10176	for (i = `0`; i < c->as->rank; i++)
10177	{
10178	gfc_init_se (&tse, NULL);
10179	e = gfc_copy_expr (c->as->lower[i]);
10180	gfc_insert_parameter_exprs (e, pdt_param_list);
10181	gfc_conv_expr_type (se: &tse, e, gfc_array_index_type);
10182	gfc_free_expr (e);
10183	lower = tse.expr;
10184	gfc_conv_descriptor_lbound_set (block: &fnblock, desc: comp,
10185	dim: gfc_rank_cst[i],
10186	value: lower);
10187	e = gfc_copy_expr (c->as->upper[i]);
10188	gfc_insert_parameter_exprs (e, pdt_param_list);
10189	gfc_conv_expr_type (se: &tse, e, gfc_array_index_type);
10190	gfc_free_expr (e);
10191	upper = tse.expr;
10192	gfc_conv_descriptor_ubound_set (block: &fnblock, desc: comp,
10193	dim: gfc_rank_cst[i],
10194	value: upper);
10195	gfc_conv_descriptor_stride_set (block: &fnblock, desc: comp,
10196	dim: gfc_rank_cst[i],
10197	value: size);
10198	size = gfc_evaluate_now (size, &fnblock);
10199	offset = fold_build2_loc (input_location,
10200	MINUS_EXPR,
10201	gfc_array_index_type,
10202	offset, size);
10203	offset = gfc_evaluate_now (offset, &fnblock);
10204	tmp = fold_build2_loc (input_location, MINUS_EXPR,
10205	gfc_array_index_type,
10206	upper, lower);
10207	tmp = fold_build2_loc (input_location, PLUS_EXPR,
10208	gfc_array_index_type,
10209	tmp, gfc_index_one_node);
10210	size = fold_build2_loc (input_location, MULT_EXPR,
10211	gfc_array_index_type, size, tmp);
10212	}
10213	gfc_conv_descriptor_offset_set (block: &fnblock, desc: comp, value: offset);
10214	if (c->ts.type == BT_CLASS)
10215	{
10216	tmp = gfc_get_vptr_from_expr (comp);
10217	if (POINTER_TYPE_P (TREE_TYPE (tmp)))
10218	tmp = build_fold_indirect_ref_loc (input_location, tmp);
10219	tmp = gfc_vptr_size_get (tmp);
10220	}
10221	else
10222	tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
10223	tmp = fold_convert (gfc_array_index_type, tmp);
10224	size = fold_build2_loc (input_location, MULT_EXPR,
10225	gfc_array_index_type, size, tmp);
10226	size = gfc_evaluate_now (size, &fnblock);
10227	tmp = gfc_call_malloc (&fnblock, NULL, size);
10228	gfc_conv_descriptor_data_set (block: &fnblock, desc: comp, value: tmp);
10229	tmp = gfc_conv_descriptor_dtype (desc: comp);
10230	gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
10231
10232	if (c->initializer && c->initializer->rank)
10233	{
10234	gfc_init_se (&tse, NULL);
10235	e = gfc_copy_expr (c->initializer);
10236	gfc_insert_parameter_exprs (e, pdt_param_list);
10237	gfc_conv_expr_descriptor (se: &tse, expr: e);
10238	gfc_add_block_to_block (&fnblock, &tse.pre);
10239	gfc_free_expr (e);
10240	tmp = builtin_decl_explicit (fncode: BUILT_IN_MEMCPY);
10241	tmp = build_call_expr_loc (input_location, tmp, `3`,
10242	gfc_conv_descriptor_data_get (desc: comp),
10243	gfc_conv_descriptor_data_get (desc: tse.expr),
10244	fold_convert (size_type_node, size));
10245	gfc_add_expr_to_block (&fnblock, tmp);
10246	gfc_add_block_to_block (&fnblock, &tse.post);
10247	}
10248	}
10249
10250	/ Recurse in to PDT components. /
10251	if ((c->ts.type == BT_DERIVED \|\| c->ts.type == BT_CLASS)
10252	&& c->ts.u.derived && c->ts.u.derived->attr.pdt_type
10253	&& !(c->attr.pointer \|\| c->attr.allocatable))
10254	{
10255	bool is_deferred = false;
10256	gfc_actual_arglist *tail = c->param_list;
10257
10258	for (; tail; tail = tail->next)
10259	if (!tail->expr)
10260	is_deferred = true;
10261
10262	tail = is_deferred ? pdt_param_list : c->param_list;
10263	tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
10264	c->as ? c->as->rank : `0`,
10265	tail);
10266	gfc_add_expr_to_block (&fnblock, tmp);
10267	}
10268
10269	break;
10270
10271	case DEALLOCATE_PDT_COMP:
10272	/ Deallocate array or parameterized string length components*
10273	of parameterized derived types. /*
10274	if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
10275	&& !c->attr.pdt_string
10276	&& !((c->ts.type == BT_DERIVED \|\| c->ts.type == BT_CLASS)
10277	&& (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
10278	continue;
10279
10280	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10281	decl, cdecl, NULL_TREE);
10282	if (c->ts.type == BT_CLASS)
10283	comp = gfc_class_data_get (comp);
10284
10285	/ Recurse in to PDT components. /
10286	if ((c->ts.type == BT_DERIVED \|\| c->ts.type == BT_CLASS)
10287	&& c->ts.u.derived && c->ts.u.derived->attr.pdt_type
10288	&& (!c->attr.pointer && !c->attr.allocatable))
10289	{
10290	tmp = gfc_deallocate_pdt_comp (c->ts.u.derived, comp,
10291	c->as ? c->as->rank : `0`);
10292	gfc_add_expr_to_block (&fnblock, tmp);
10293	}
10294
10295	if (c->attr.pdt_array)
10296	{
10297	tmp = gfc_conv_descriptor_data_get (desc: comp);
10298	null_cond = fold_build2_loc (input_location, NE_EXPR,
10299	logical_type_node, tmp,
10300	build_int_cst (TREE_TYPE (tmp), `0`));
10301	tmp = gfc_call_free (tmp);
10302	tmp = build3_v (COND_EXPR, null_cond, tmp,
10303	build_empty_stmt (input_location));
10304	gfc_add_expr_to_block (&fnblock, tmp);
10305	gfc_conv_descriptor_data_set (block: &fnblock, desc: comp, null_pointer_node);
10306	}
10307	else if (c->attr.pdt_string)
10308	{
10309	null_cond = fold_build2_loc (input_location, NE_EXPR,
10310	logical_type_node, comp,
10311	build_int_cst (TREE_TYPE (comp), `0`));
10312	tmp = gfc_call_free (comp);
10313	tmp = build3_v (COND_EXPR, null_cond, tmp,
10314	build_empty_stmt (input_location));
10315	gfc_add_expr_to_block (&fnblock, tmp);
10316	tmp = fold_convert (TREE_TYPE (comp), null_pointer_node);
10317	gfc_add_modify (&fnblock, comp, tmp);
10318	}
10319
10320	break;
10321
10322	case CHECK_PDT_DUMMY:
10323
10324	comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
10325	decl, cdecl, NULL_TREE);
10326	if (c->ts.type == BT_CLASS)
10327	comp = gfc_class_data_get (comp);
10328
10329	/ Recurse in to PDT components. /
10330	if ((c->ts.type == BT_DERIVED \|\| c->ts.type == BT_CLASS)
10331	&& c->ts.u.derived && c->ts.u.derived->attr.pdt_type)
10332	{
10333	tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp,
10334	c->as ? c->as->rank : `0`,
10335	pdt_param_list);
10336	gfc_add_expr_to_block (&fnblock, tmp);
10337	}
10338
10339	if (!c->attr.pdt_len)
10340	continue;
10341	else
10342	{
10343	gfc_se tse;
10344	gfc_expr *c_expr = NULL;
10345	gfc_actual_arglist *param = pdt_param_list;
10346
10347	gfc_init_se (&tse, NULL);
10348	for (; param; param = param->next)
10349	if (!strcmp (s1: c->name, s2: param->name)
10350	&& param->spec_type == SPEC_EXPLICIT)
10351	c_expr = param->expr;
10352
10353	if (c_expr)
10354	{
10355	tree error, cond, cname;
10356	gfc_conv_expr_type (se: &tse, c_expr, TREE_TYPE (comp));
10357	cond = fold_build2_loc (input_location, NE_EXPR,
10358	logical_type_node,
10359	comp, tse.expr);
10360	cname = gfc_build_cstring_const (c->name);
10361	cname = gfc_build_addr_expr (pchar_type_node, cname);
10362	error = gfc_trans_runtime_error (true, NULL,
10363	"The value of the PDT LEN "
10364	"parameter '%s' does not "
10365	"agree with that in the "
10366	"dummy declaration",
10367	cname);
10368	tmp = fold_build3_loc (input_location, COND_EXPR,
10369	void_type_node, cond, error,
10370	build_empty_stmt (input_location));
10371	gfc_add_expr_to_block (&fnblock, tmp);
10372	}
10373	}
10374	break;
10375
10376	default:
10377	gcc_unreachable ();
10378	break;
10379	}
10380	}
10381
10382	return gfc_finish_block (&fnblock);
10383	}
10384
10385	/ Recursively traverse an object of derived type, generating code to*
10386	nullify allocatable components. /*
10387
10388	tree
10389	gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
10390	int caf_mode)
10391	{
10392	return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10393	purpose: NULLIFY_ALLOC_COMP,
10394	caf_mode: GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY \| caf_mode,
10395	NULL);
10396	}
10397
10398
10399	/ Recursively traverse an object of derived type, generating code to*
10400	deallocate allocatable components. /*
10401
10402	tree
10403	gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
10404	int caf_mode)
10405	{
10406	return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10407	purpose: DEALLOCATE_ALLOC_COMP,
10408	caf_mode: GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY \| caf_mode,
10409	NULL);
10410	}
10411
10412	tree
10413	gfc_bcast_alloc_comp (gfc_symbol derived, gfc_expr expr, int rank,
10414	tree image_index, tree stat, tree errmsg,
10415	tree errmsg_len)
10416	{
10417	tree tmp, array;
10418	gfc_se argse;
10419	stmtblock_t block, post_block;
10420	gfc_co_subroutines_args args;
10421
10422	args.image_index = image_index;
10423	args.stat = stat;
10424	args.errmsg = errmsg;
10425	args.errmsg_len = errmsg_len;
10426
10427	if (rank == `0`)
10428	{
10429	gfc_start_block (&block);
10430	gfc_init_block (&post_block);
10431	gfc_init_se (&argse, NULL);
10432	gfc_conv_expr (se: &argse, expr);
10433	gfc_add_block_to_block (&block, &argse.pre);
10434	gfc_add_block_to_block (&post_block, &argse.post);
10435	array = argse.expr;
10436	}
10437	else
10438	{
10439	gfc_init_se (&argse, NULL);
10440	argse.want_pointer = `1`;
10441	gfc_conv_expr_descriptor (se: &argse, expr);
10442	array = argse.expr;
10443	}
10444
10445	tmp = structure_alloc_comps (der_type: derived, decl: array, NULL_TREE, rank,
10446	purpose: BCAST_ALLOC_COMP,
10447	caf_mode: GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
10448	args: &args);
10449	return tmp;
10450	}
10451
10452	/ Recursively traverse an object of derived type, generating code to*
10453	deallocate allocatable components. But do not deallocate coarrays.
10454	To be used for intrinsic assignment, which may not change the allocation
10455	status of coarrays. /*
10456
10457	tree
10458	gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
10459	bool no_finalization)
10460	{
10461	return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10462	purpose: DEALLOCATE_ALLOC_COMP, caf_mode: `0`, NULL,
10463	no_finalization);
10464	}
10465
10466
10467	tree
10468	gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
10469	{
10470	return structure_alloc_comps (der_type, decl, dest, rank: `0`, purpose: REASSIGN_CAF_COMP,
10471	caf_mode: GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
10472	NULL);
10473	}
10474
10475
10476	/ Recursively traverse an object of derived type, generating code to*
10477	copy it and its allocatable components. /*
10478
10479	tree
10480	gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
10481	int caf_mode)
10482	{
10483	return structure_alloc_comps (der_type, decl, dest, rank, purpose: COPY_ALLOC_COMP,
10484	caf_mode, NULL);
10485	}
10486
10487
10488	/ Recursively traverse an object of derived type, generating code to*
10489	copy it and its allocatable components, while suppressing any
10490	finalization that might occur. This is used in the finalization of
10491	function results. /*
10492
10493	tree
10494	gfc_copy_alloc_comp_no_fini (gfc_symbol * der_type, tree decl, tree dest,
10495	int rank, int caf_mode)
10496	{
10497	return structure_alloc_comps (der_type, decl, dest, rank, purpose: COPY_ALLOC_COMP,
10498	caf_mode, NULL, no_finalization: true);
10499	}
10500
10501
10502	/ Recursively traverse an object of derived type, generating code to*
10503	copy only its allocatable components. /*
10504
10505	tree
10506	gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
10507	{
10508	return structure_alloc_comps (der_type, decl, dest, rank,
10509	purpose: COPY_ONLY_ALLOC_COMP, caf_mode: `0`, NULL);
10510	}
10511
10512
10513	/ Recursively traverse an object of parameterized derived type, generating*
10514	code to allocate parameterized components. /*
10515
10516	tree
10517	gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
10518	gfc_actual_arglist *param_list)
10519	{
10520	tree res;
10521	gfc_actual_arglist *old_param_list = pdt_param_list;
10522	pdt_param_list = param_list;
10523	res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10524	purpose: ALLOCATE_PDT_COMP, caf_mode: `0`, NULL);
10525	pdt_param_list = old_param_list;
10526	return res;
10527	}
10528
10529	/ Recursively traverse an object of parameterized derived type, generating*
10530	code to deallocate parameterized components. /*
10531
10532	tree
10533	gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
10534	{
10535	return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10536	purpose: DEALLOCATE_PDT_COMP, caf_mode: `0`, NULL);
10537	}
10538
10539
10540	/ Recursively traverse a dummy of parameterized derived type to check the*
10541	values of LEN parameters. /*
10542
10543	tree
10544	gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
10545	gfc_actual_arglist *param_list)
10546	{
10547	tree res;
10548	gfc_actual_arglist *old_param_list = pdt_param_list;
10549	pdt_param_list = param_list;
10550	res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
10551	purpose: CHECK_PDT_DUMMY, caf_mode: `0`, NULL);
10552	pdt_param_list = old_param_list;
10553	return res;
10554	}
10555
10556
10557	/ Returns the value of LBOUND for an expression. This could be broken out*
10558	from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
10559	called by gfc_alloc_allocatable_for_assignment. /*
10560	static tree
10561	get_std_lbound (gfc_expr expr, tree desc, int* dim, bool assumed_size)
10562	{
10563	tree lbound;
10564	tree ubound;
10565	tree stride;
10566	tree cond, cond1, cond3, cond4;
10567	tree tmp;
10568	gfc_ref *ref;
10569
10570	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
10571	{
10572	tmp = gfc_rank_cst[dim];
10573	lbound = gfc_conv_descriptor_lbound_get (desc, dim: tmp);
10574	ubound = gfc_conv_descriptor_ubound_get (desc, dim: tmp);
10575	stride = gfc_conv_descriptor_stride_get (desc, dim: tmp);
10576	cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10577	ubound, lbound);
10578	cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
10579	stride, gfc_index_zero_node);
10580	cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
10581	logical_type_node, cond3, cond1);
10582	cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10583	stride, gfc_index_zero_node);
10584	if (assumed_size)
10585	cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10586	tmp, build_int_cst (gfc_array_index_type,
10587	expr->rank - `1`));
10588	else
10589	cond = logical_false_node;
10590
10591	cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10592	logical_type_node, cond3, cond4);
10593	cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10594	logical_type_node, cond, cond1);
10595
10596	return fold_build3_loc (input_location, COND_EXPR,
10597	gfc_array_index_type, cond,
10598	lbound, gfc_index_one_node);
10599	}
10600
10601	if (expr->expr_type == EXPR_FUNCTION)
10602	{
10603	/ A conversion function, so use the argument. /
10604	gcc_assert (expr->value.function.isym
10605	&& expr->value.function.isym->conversion);
10606	expr = expr->value.function.actual->expr;
10607	}
10608
10609	if (expr->expr_type == EXPR_VARIABLE)
10610	{
10611	tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
10612	for (ref = expr->ref; ref; ref = ref->next)
10613	{
10614	if (ref->type == REF_COMPONENT
10615	&& ref->u.c.component->as
10616	&& ref->next
10617	&& ref->next->u.ar.type == AR_FULL)
10618	tmp = TREE_TYPE (ref->u.c.component->backend_decl);
10619	}
10620	return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
10621	}
10622
10623	return gfc_index_one_node;
10624	}
10625
10626
10627	/ Returns true if an expression represents an lhs that can be reallocated*
10628	on assignment. /*
10629
10630	bool
10631	gfc_is_reallocatable_lhs (gfc_expr *expr)
10632	{
10633	gfc_ref * ref;
10634	gfc_symbol *sym;
10635
10636	if (!expr->ref)
10637	return false;
10638
10639	sym = expr->symtree->n.sym;
10640
10641	if (sym->attr.associate_var && !expr->ref)
10642	return false;
10643
10644	/ An allocatable class variable with no reference. /
10645	if (sym->ts.type == BT_CLASS
10646	&& (!sym->attr.associate_var \|\| sym->attr.select_rank_temporary)
10647	&& CLASS_DATA (sym)->attr.allocatable
10648	&& expr->ref
10649	&& ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL
10650	&& expr->ref->next == NULL)
10651	\|\| (expr->ref->type == REF_COMPONENT
10652	&& strcmp (s1: expr->ref->u.c.component->name, s2: "_data") == `0`
10653	&& (expr->ref->next == NULL
10654	\|\| (expr->ref->next->type == REF_ARRAY
10655	&& expr->ref->next->u.ar.type == AR_FULL
10656	&& expr->ref->next->next == NULL)))))
10657	return true;
10658
10659	/ An allocatable variable. /
10660	if (sym->attr.allocatable
10661	&& (!sym->attr.associate_var \|\| sym->attr.select_rank_temporary)
10662	&& expr->ref
10663	&& expr->ref->type == REF_ARRAY
10664	&& expr->ref->u.ar.type == AR_FULL)
10665	return true;
10666
10667	/ All that can be left are allocatable components. /
10668	if ((sym->ts.type != BT_DERIVED
10669	&& sym->ts.type != BT_CLASS)
10670	\|\| !sym->ts.u.derived->attr.alloc_comp)
10671	return false;
10672
10673	/ Find a component ref followed by an array reference. /
10674	for (ref = expr->ref; ref; ref = ref->next)
10675	if (ref->next
10676	&& ref->type == REF_COMPONENT
10677	&& ref->next->type == REF_ARRAY
10678	&& !ref->next->next)
10679	break;
10680
10681	if (!ref)
10682	return false;
10683
10684	/ Return true if valid reallocatable lhs. /
10685	if (ref->u.c.component->attr.allocatable
10686	&& ref->next->u.ar.type == AR_FULL)
10687	return true;
10688
10689	return false;
10690	}
10691
10692
10693	static tree
10694	concat_str_length (gfc_expr* expr)
10695	{
10696	tree type;
10697	tree len1;
10698	tree len2;
10699	gfc_se se;
10700
10701	type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
10702	len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
10703	if (len1 == NULL_TREE)
10704	{
10705	if (expr->value.op.op1->expr_type == EXPR_OP)
10706	len1 = concat_str_length (expr: expr->value.op.op1);
10707	else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
10708	len1 = build_int_cst (gfc_charlen_type_node,
10709	expr->value.op.op1->value.character.length);
10710	else if (expr->value.op.op1->ts.u.cl->length)
10711	{
10712	gfc_init_se (&se, NULL);
10713	gfc_conv_expr (se: &se, expr: expr->value.op.op1->ts.u.cl->length);
10714	len1 = se.expr;
10715	}
10716	else
10717	{
10718	/ Last resort! /
10719	gfc_init_se (&se, NULL);
10720	se.want_pointer = `1`;
10721	se.descriptor_only = `1`;
10722	gfc_conv_expr (se: &se, expr: expr->value.op.op1);
10723	len1 = se.string_length;
10724	}
10725	}
10726
10727	type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
10728	len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
10729	if (len2 == NULL_TREE)
10730	{
10731	if (expr->value.op.op2->expr_type == EXPR_OP)
10732	len2 = concat_str_length (expr: expr->value.op.op2);
10733	else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
10734	len2 = build_int_cst (gfc_charlen_type_node,
10735	expr->value.op.op2->value.character.length);
10736	else if (expr->value.op.op2->ts.u.cl->length)
10737	{
10738	gfc_init_se (&se, NULL);
10739	gfc_conv_expr (se: &se, expr: expr->value.op.op2->ts.u.cl->length);
10740	len2 = se.expr;
10741	}
10742	else
10743	{
10744	/ Last resort! /
10745	gfc_init_se (&se, NULL);
10746	se.want_pointer = `1`;
10747	se.descriptor_only = `1`;
10748	gfc_conv_expr (se: &se, expr: expr->value.op.op2);
10749	len2 = se.string_length;
10750	}
10751	}
10752
10753	gcc_assert(len1 && len2);
10754	len1 = fold_convert (gfc_charlen_type_node, len1);
10755	len2 = fold_convert (gfc_charlen_type_node, len2);
10756
10757	return fold_build2_loc (input_location, PLUS_EXPR,
10758	gfc_charlen_type_node, len1, len2);
10759	}
10760
10761
10762	/ Allocate the lhs of an assignment to an allocatable array, otherwise*
10763	reallocate it. /*
10764
10765	tree
10766	gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
10767	gfc_expr *expr1,
10768	gfc_expr *expr2)
10769	{
10770	stmtblock_t realloc_block;
10771	stmtblock_t alloc_block;
10772	stmtblock_t fblock;
10773	gfc_ss *rss;
10774	gfc_ss *lss;
10775	gfc_array_info *linfo;
10776	tree realloc_expr;
10777	tree alloc_expr;
10778	tree size1;
10779	tree size2;
10780	tree elemsize1;
10781	tree elemsize2;
10782	tree array1;
10783	tree cond_null;
10784	tree cond;
10785	tree tmp;
10786	tree tmp2;
10787	tree lbound;
10788	tree ubound;
10789	tree desc;
10790	tree old_desc;
10791	tree desc2;
10792	tree offset;
10793	tree jump_label1;
10794	tree jump_label2;
10795	tree lbd;
10796	tree class_expr2 = NULL_TREE;
10797	int n;
10798	int dim;
10799	gfc_array_spec * as;
10800	bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
10801	&& gfc_caf_attr (expr1, i: true).codimension);
10802	tree token;
10803	gfc_se caf_se;
10804
10805	/ x = f(...) with x allocatable. In this case, expr1 is the rhs.*
10806	Find the lhs expression in the loop chain and set expr1 and
10807	expr2 accordingly. /*
10808	if (expr1->expr_type == EXPR_FUNCTION && expr2 == NULL)
10809	{
10810	expr2 = expr1;
10811	/ Find the ss for the lhs. /
10812	lss = loop->ss;
10813	for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
10814	if (lss->info->expr && lss->info->expr->expr_type == EXPR_VARIABLE)
10815	break;
10816	if (lss == gfc_ss_terminator)
10817	return NULL_TREE;
10818	expr1 = lss->info->expr;
10819	}
10820
10821	/ Bail out if this is not a valid allocate on assignment. /
10822	if (!gfc_is_reallocatable_lhs (expr: expr1)
10823	\|\| (expr2 && !expr2->rank))
10824	return NULL_TREE;
10825
10826	/ Find the ss for the lhs. /
10827	lss = loop->ss;
10828	for (; lss && lss != gfc_ss_terminator; lss = lss->loop_chain)
10829	if (lss->info->expr == expr1)
10830	break;
10831
10832	if (lss == gfc_ss_terminator)
10833	return NULL_TREE;
10834
10835	linfo = &lss->info->data.array;
10836
10837	/ Find an ss for the rhs. For operator expressions, we see the*
10838	ss's for the operands. Any one of these will do. /*
10839	rss = loop->ss;
10840	for (; rss && rss != gfc_ss_terminator; rss = rss->loop_chain)
10841	if (rss->info->expr != expr1 && rss != loop->temp_ss)
10842	break;
10843
10844	if (expr2 && rss == gfc_ss_terminator)
10845	return NULL_TREE;
10846
10847	/ Ensure that the string length from the current scope is used. /
10848	if (expr2->ts.type == BT_CHARACTER
10849	&& expr2->expr_type == EXPR_FUNCTION
10850	&& !expr2->value.function.isym)
10851	expr2->ts.u.cl->backend_decl = rss->info->string_length;
10852
10853	gfc_start_block (&fblock);
10854
10855	/ Since the lhs is allocatable, this must be a descriptor type.*
10856	Get the data and array size. /*
10857	desc = linfo->descriptor;
10858	gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
10859	array1 = gfc_conv_descriptor_data_get (desc);
10860
10861	if (expr2)
10862	desc2 = rss->info->data.array.descriptor;
10863	else
10864	desc2 = NULL_TREE;
10865
10866	/ Get the old lhs element size for deferred character and class expr1. /
10867	if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10868	{
10869	if (expr1->ts.u.cl->backend_decl
10870	&& VAR_P (expr1->ts.u.cl->backend_decl))
10871	elemsize1 = expr1->ts.u.cl->backend_decl;
10872	else
10873	elemsize1 = lss->info->string_length;
10874	tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
10875	elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
10876	TREE_TYPE (elemsize1), elemsize1,
10877	fold_convert (TREE_TYPE (elemsize1), unit_size));
10878
10879	}
10880	else if (expr1->ts.type == BT_CLASS)
10881	{
10882	/ Unfortunately, the lhs vptr is set too early in many cases.*
10883	Play it safe by using the descriptor element length. /*
10884	tmp = gfc_conv_descriptor_elem_len (desc);
10885	elemsize1 = fold_convert (gfc_array_index_type, tmp);
10886	}
10887	else
10888	elemsize1 = NULL_TREE;
10889	if (elemsize1 != NULL_TREE)
10890	elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
10891
10892	/ Get the new lhs size in bytes. /
10893	if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10894	{
10895	if (expr2->ts.deferred)
10896	{
10897	if (expr2->ts.u.cl->backend_decl
10898	&& VAR_P (expr2->ts.u.cl->backend_decl))
10899	tmp = expr2->ts.u.cl->backend_decl;
10900	else
10901	tmp = rss->info->string_length;
10902	}
10903	else
10904	{
10905	tmp = expr2->ts.u.cl->backend_decl;
10906	if (!tmp && expr2->expr_type == EXPR_OP
10907	&& expr2->value.op.op == INTRINSIC_CONCAT)
10908	{
10909	tmp = concat_str_length (expr: expr2);
10910	expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
10911	}
10912	else if (!tmp && expr2->ts.u.cl->length)
10913	{
10914	gfc_se tmpse;
10915	gfc_init_se (&tmpse, NULL);
10916	gfc_conv_expr_type (se: &tmpse, expr2->ts.u.cl->length,
10917	gfc_charlen_type_node);
10918	tmp = tmpse.expr;
10919	expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
10920	}
10921	tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
10922	}
10923
10924	if (expr1->ts.u.cl->backend_decl
10925	&& VAR_P (expr1->ts.u.cl->backend_decl))
10926	gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
10927	else
10928	gfc_add_modify (&fblock, lss->info->string_length, tmp);
10929
10930	if (expr1->ts.kind > `1`)
10931	tmp = fold_build2_loc (input_location, MULT_EXPR,
10932	TREE_TYPE (tmp),
10933	tmp, build_int_cst (TREE_TYPE (tmp),
10934	expr1->ts.kind));
10935	}
10936	else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
10937	{
10938	tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
10939	tmp = fold_build2_loc (input_location, MULT_EXPR,
10940	gfc_array_index_type, tmp,
10941	expr1->ts.u.cl->backend_decl);
10942	}
10943	else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
10944	tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
10945	else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
10946	{
10947	tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
10948	if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
10949	tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
10950
10951	if (tmp != NULL_TREE)
10952	tmp = gfc_class_vtab_size_get (tmp);
10953	else
10954	tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
10955	}
10956	else
10957	tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
10958	elemsize2 = fold_convert (gfc_array_index_type, tmp);
10959	elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
10960
10961	/ 7.4.1.3 "If variable is an allocated allocatable variable, it is*
10962	deallocated if expr is an array of different shape or any of the
10963	corresponding length type parameter values of variable and expr
10964	differ." This assures F95 compatibility. /*
10965	jump_label1 = gfc_build_label_decl (NULL_TREE);
10966	jump_label2 = gfc_build_label_decl (NULL_TREE);
10967
10968	/ Allocate if data is NULL. /
10969	cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10970	array1, build_int_cst (TREE_TYPE (array1), `0`));
10971	cond_null= gfc_evaluate_now (cond_null, &fblock);
10972
10973	tmp = build3_v (COND_EXPR, cond_null,
10974	build1_v (GOTO_EXPR, jump_label1),
10975	build_empty_stmt (input_location));
10976	gfc_add_expr_to_block (&fblock, tmp);
10977
10978	/ Get arrayspec if expr is a full array. /
10979	if (expr2 && expr2->expr_type == EXPR_FUNCTION
10980	&& expr2->value.function.isym
10981	&& expr2->value.function.isym->conversion)
10982	{
10983	/ For conversion functions, take the arg. /
10984	gfc_expr *arg = expr2->value.function.actual->expr;
10985	as = gfc_get_full_arrayspec_from_expr (expr: arg);
10986	}
10987	else if (expr2)
10988	as = gfc_get_full_arrayspec_from_expr (expr: expr2);
10989	else
10990	as = NULL;
10991
10992	/ If the lhs shape is not the same as the rhs jump to setting the*
10993	bounds and doing the reallocation....... /*
10994	for (n = `0`; n < expr1->rank; n++)
10995	{
10996	/ Check the shape. /
10997	lbound = gfc_conv_descriptor_lbound_get (desc, dim: gfc_rank_cst[n]);
10998	ubound = gfc_conv_descriptor_ubound_get (desc, dim: gfc_rank_cst[n]);
10999	tmp = fold_build2_loc (input_location, MINUS_EXPR,
11000	gfc_array_index_type,
11001	loop->to[n], loop->from[n]);
11002	tmp = fold_build2_loc (input_location, PLUS_EXPR,
11003	gfc_array_index_type,
11004	tmp, lbound);
11005	tmp = fold_build2_loc (input_location, MINUS_EXPR,
11006	gfc_array_index_type,
11007	tmp, ubound);
11008	cond = fold_build2_loc (input_location, NE_EXPR,
11009	logical_type_node,
11010	tmp, gfc_index_zero_node);
11011	tmp = build3_v (COND_EXPR, cond,
11012	build1_v (GOTO_EXPR, jump_label1),
11013	build_empty_stmt (input_location));
11014	gfc_add_expr_to_block (&fblock, tmp);
11015	}
11016
11017	/ ...else if the element lengths are not the same also go to*
11018	setting the bounds and doing the reallocation.... /*
11019	if (elemsize1 != NULL_TREE)
11020	{
11021	cond = fold_build2_loc (input_location, NE_EXPR,
11022	logical_type_node,
11023	elemsize1, elemsize2);
11024	tmp = build3_v (COND_EXPR, cond,
11025	build1_v (GOTO_EXPR, jump_label1),
11026	build_empty_stmt (input_location));
11027	gfc_add_expr_to_block (&fblock, tmp);
11028	}
11029
11030	/ ....else jump past the (re)alloc code. /
11031	tmp = build1_v (GOTO_EXPR, jump_label2);
11032	gfc_add_expr_to_block (&fblock, tmp);
11033
11034	/ Add the label to start automatic (re)allocation. /
11035	tmp = build1_v (LABEL_EXPR, jump_label1);
11036	gfc_add_expr_to_block (&fblock, tmp);
11037
11038	/ Get the rhs size and fix it. /
11039	size2 = gfc_index_one_node;
11040	for (n = `0`; n < expr2->rank; n++)
11041	{
11042	tmp = fold_build2_loc (input_location, MINUS_EXPR,
11043	gfc_array_index_type,
11044	loop->to[n], loop->from[n]);
11045	tmp = fold_build2_loc (input_location, PLUS_EXPR,
11046	gfc_array_index_type,
11047	tmp, gfc_index_one_node);
11048	size2 = fold_build2_loc (input_location, MULT_EXPR,
11049	gfc_array_index_type,
11050	tmp, size2);
11051	}
11052	size2 = gfc_evaluate_now (size2, &fblock);
11053
11054	/ Deallocation of allocatable components will have to occur on*
11055	reallocation. Fix the old descriptor now. /*
11056	if ((expr1->ts.type == BT_DERIVED)
11057	&& expr1->ts.u.derived->attr.alloc_comp)
11058	old_desc = gfc_evaluate_now (desc, &fblock);
11059	else
11060	old_desc = NULL_TREE;
11061
11062	/ Now modify the lhs descriptor and the associated scalarizer*
11063	variables. F2003 7.4.1.3: "If variable is or becomes an
11064	unallocated allocatable variable, then it is allocated with each
11065	deferred type parameter equal to the corresponding type parameters
11066	of expr , with the shape of expr , and with each lower bound equal
11067	to the corresponding element of LBOUND(expr)."
11068	Reuse size1 to keep a dimension-by-dimension track of the
11069	stride of the new array. /*
11070	size1 = gfc_index_one_node;
11071	offset = gfc_index_zero_node;
11072
11073	for (n = `0`; n < expr2->rank; n++)
11074	{
11075	tmp = fold_build2_loc (input_location, MINUS_EXPR,
11076	gfc_array_index_type,
11077	loop->to[n], loop->from[n]);
11078	tmp = fold_build2_loc (input_location, PLUS_EXPR,
11079	gfc_array_index_type,
11080	tmp, gfc_index_one_node);
11081
11082	lbound = gfc_index_one_node;
11083	ubound = tmp;
11084
11085	if (as)
11086	{
11087	lbd = get_std_lbound (expr: expr2, desc: desc2, dim: n,
11088	assumed_size: as->type == AS_ASSUMED_SIZE);
11089	ubound = fold_build2_loc (input_location,
11090	MINUS_EXPR,
11091	gfc_array_index_type,
11092	ubound, lbound);
11093	ubound = fold_build2_loc (input_location,
11094	PLUS_EXPR,
11095	gfc_array_index_type,
11096	ubound, lbd);
11097	lbound = lbd;
11098	}
11099
11100	gfc_conv_descriptor_lbound_set (block: &fblock, desc,
11101	dim: gfc_rank_cst[n],
11102	value: lbound);
11103	gfc_conv_descriptor_ubound_set (block: &fblock, desc,
11104	dim: gfc_rank_cst[n],
11105	value: ubound);
11106	gfc_conv_descriptor_stride_set (block: &fblock, desc,
11107	dim: gfc_rank_cst[n],
11108	value: size1);
11109	lbound = gfc_conv_descriptor_lbound_get (desc,
11110	dim: gfc_rank_cst[n]);
11111	tmp2 = fold_build2_loc (input_location, MULT_EXPR,
11112	gfc_array_index_type,
11113	lbound, size1);
11114	offset = fold_build2_loc (input_location, MINUS_EXPR,
11115	gfc_array_index_type,
11116	offset, tmp2);
11117	size1 = fold_build2_loc (input_location, MULT_EXPR,
11118	gfc_array_index_type,
11119	tmp, size1);
11120	}
11121
11122	/ Set the lhs descriptor and scalarizer offsets. For rank > 1,*
11123	the array offset is saved and the info.offset is used for a
11124	running offset. Use the saved_offset instead. /*
11125	tmp = gfc_conv_descriptor_offset (desc);
11126	gfc_add_modify (&fblock, tmp, offset);
11127	if (linfo->saved_offset
11128	&& VAR_P (linfo->saved_offset))
11129	gfc_add_modify (&fblock, linfo->saved_offset, tmp);
11130
11131	/ Now set the deltas for the lhs. /
11132	for (n = `0`; n < expr1->rank; n++)
11133	{
11134	tmp = gfc_conv_descriptor_lbound_get (desc, dim: gfc_rank_cst[n]);
11135	dim = lss->dim[n];
11136	tmp = fold_build2_loc (input_location, MINUS_EXPR,
11137	gfc_array_index_type, tmp,
11138	loop->from[dim]);
11139	if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
11140	gfc_add_modify (&fblock, linfo->delta[dim], tmp);
11141	}
11142
11143	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11144	gfc_conv_descriptor_span_set (block: &fblock, desc, value: elemsize2);
11145
11146	size2 = fold_build2_loc (input_location, MULT_EXPR,
11147	gfc_array_index_type,
11148	elemsize2, size2);
11149	size2 = fold_convert (size_type_node, size2);
11150	size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
11151	size2, size_one_node);
11152	size2 = gfc_evaluate_now (size2, &fblock);
11153
11154	/ For deferred character length, the 'size' field of the dtype might*
11155	have changed so set the dtype. /*
11156	if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
11157	&& expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11158	{
11159	tree type;
11160	tmp = gfc_conv_descriptor_dtype (desc);
11161	if (expr2->ts.u.cl->backend_decl)
11162	type = gfc_typenode_for_spec (&expr2->ts);
11163	else
11164	type = gfc_typenode_for_spec (&expr1->ts);
11165
11166	gfc_add_modify (&fblock, tmp,
11167	gfc_get_dtype_rank_type (expr1->rank,type));
11168	}
11169	else if (expr1->ts.type == BT_CLASS)
11170	{
11171	tree type;
11172	tmp = gfc_conv_descriptor_dtype (desc);
11173
11174	if (expr2->ts.type != BT_CLASS)
11175	type = gfc_typenode_for_spec (&expr2->ts);
11176	else
11177	type = gfc_get_character_type_len (`1`, elemsize2);
11178
11179	gfc_add_modify (&fblock, tmp,
11180	gfc_get_dtype_rank_type (expr2->rank,type));
11181	/ Set the _len field as well... /
11182	if (UNLIMITED_POLY (expr1))
11183	{
11184	tmp = gfc_class_len_get (TREE_OPERAND (desc, `0`));
11185	if (expr2->ts.type == BT_CHARACTER)
11186	gfc_add_modify (&fblock, tmp,
11187	fold_convert (TREE_TYPE (tmp),
11188	TYPE_SIZE_UNIT (type)));
11189	else
11190	gfc_add_modify (&fblock, tmp,
11191	build_int_cst (TREE_TYPE (tmp), `0`));
11192	}
11193	/ ...and the vptr. /
11194	tmp = gfc_class_vptr_get (TREE_OPERAND (desc, `0`));
11195	if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
11196	&& TREE_CODE (desc2) == COMPONENT_REF)
11197	{
11198	tmp2 = gfc_get_class_from_expr (desc2);
11199	tmp2 = gfc_class_vptr_get (tmp2);
11200	}
11201	else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
11202	tmp2 = gfc_class_vptr_get (class_expr2);
11203	else
11204	{
11205	tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
11206	tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
11207	}
11208
11209	gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
11210	}
11211	else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
11212	{
11213	gfc_add_modify (&fblock, gfc_conv_descriptor_dtype (desc),
11214	gfc_get_dtype (TREE_TYPE (desc)));
11215	}
11216
11217	/ Realloc expression. Note that the scalarizer uses desc.data*
11218	in the array reference - (desc.data)[<element>]. /
11219	gfc_init_block (&realloc_block);
11220	gfc_init_se (&caf_se, NULL);
11221
11222	if (coarray)
11223	{
11224	token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&caf_se, expr1);
11225	if (token == NULL_TREE)
11226	{
11227	tmp = gfc_get_tree_for_caf_expr (expr1);
11228	if (POINTER_TYPE_P (TREE_TYPE (tmp)))
11229	tmp = build_fold_indirect_ref (tmp);
11230	gfc_get_caf_token_offset (&caf_se, &token, NULL, tmp, NULL_TREE,
11231	expr1);
11232	token = gfc_build_addr_expr (NULL_TREE, token);
11233	}
11234
11235	gfc_add_block_to_block (&realloc_block, &caf_se.pre);
11236	}
11237	if ((expr1->ts.type == BT_DERIVED)
11238	&& expr1->ts.u.derived->attr.alloc_comp)
11239	{
11240	tmp = gfc_deallocate_alloc_comp_no_caf (der_type: expr1->ts.u.derived, decl: old_desc,
11241	rank: expr1->rank, no_finalization: true);
11242	gfc_add_expr_to_block (&realloc_block, tmp);
11243	}
11244
11245	if (!coarray)
11246	{
11247	tmp = build_call_expr_loc (input_location,
11248	builtin_decl_explicit (fncode: BUILT_IN_REALLOC), `2`,
11249	fold_convert (pvoid_type_node, array1),
11250	size2);
11251	gfc_conv_descriptor_data_set (block: &realloc_block,
11252	desc, value: tmp);
11253	}
11254	else
11255	{
11256	tmp = build_call_expr_loc (input_location,
11257	gfor_fndecl_caf_deregister, `5`, token,
11258	build_int_cst (integer_type_node,
11259	GFC_CAF_COARRAY_DEALLOCATE_ONLY),
11260	null_pointer_node, null_pointer_node,
11261	integer_zero_node);
11262	gfc_add_expr_to_block (&realloc_block, tmp);
11263	tmp = build_call_expr_loc (input_location,
11264	gfor_fndecl_caf_register,
11265	`7`, size2,
11266	build_int_cst (integer_type_node,
11267	GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY),
11268	token, gfc_build_addr_expr (NULL_TREE, desc),
11269	null_pointer_node, null_pointer_node,
11270	integer_zero_node);
11271	gfc_add_expr_to_block (&realloc_block, tmp);
11272	}
11273
11274	if ((expr1->ts.type == BT_DERIVED)
11275	&& expr1->ts.u.derived->attr.alloc_comp)
11276	{
11277	tmp = gfc_nullify_alloc_comp (der_type: expr1->ts.u.derived, decl: desc,
11278	rank: expr1->rank);
11279	gfc_add_expr_to_block (&realloc_block, tmp);
11280	}
11281
11282	gfc_add_block_to_block (&realloc_block, &caf_se.post);
11283	realloc_expr = gfc_finish_block (&realloc_block);
11284
11285	/ Malloc expression. /
11286	gfc_init_block (&alloc_block);
11287	if (!coarray)
11288	{
11289	tmp = build_call_expr_loc (input_location,
11290	builtin_decl_explicit (fncode: BUILT_IN_MALLOC),
11291	`1`, size2);
11292	gfc_conv_descriptor_data_set (block: &alloc_block,
11293	desc, value: tmp);
11294	}
11295	else
11296	{
11297	tmp = build_call_expr_loc (input_location,
11298	gfor_fndecl_caf_register,
11299	`7`, size2,
11300	build_int_cst (integer_type_node,
11301	GFC_CAF_COARRAY_ALLOC),
11302	token, gfc_build_addr_expr (NULL_TREE, desc),
11303	null_pointer_node, null_pointer_node,
11304	integer_zero_node);
11305	gfc_add_expr_to_block (&alloc_block, tmp);
11306	}
11307
11308
11309	/ We already set the dtype in the case of deferred character*
11310	length arrays and class lvalues. /*
11311	if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
11312	&& ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11313	\|\| coarray))
11314	&& expr1->ts.type != BT_CLASS)
11315	{
11316	tmp = gfc_conv_descriptor_dtype (desc);
11317	gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
11318	}
11319
11320	if ((expr1->ts.type == BT_DERIVED)
11321	&& expr1->ts.u.derived->attr.alloc_comp)
11322	{
11323	tmp = gfc_nullify_alloc_comp (der_type: expr1->ts.u.derived, decl: desc,
11324	rank: expr1->rank);
11325	gfc_add_expr_to_block (&alloc_block, tmp);
11326	}
11327	alloc_expr = gfc_finish_block (&alloc_block);
11328
11329	/ Malloc if not allocated; realloc otherwise. /
11330	tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
11331	gfc_add_expr_to_block (&fblock, tmp);
11332
11333	/ Make sure that the scalarizer data pointer is updated. /
11334	if (linfo->data && VAR_P (linfo->data))
11335	{
11336	tmp = gfc_conv_descriptor_data_get (desc);
11337	gfc_add_modify (&fblock, linfo->data, tmp);
11338	}
11339
11340	/ Add the label for same shape lhs and rhs. /
11341	tmp = build1_v (LABEL_EXPR, jump_label2);
11342	gfc_add_expr_to_block (&fblock, tmp);
11343
11344	return gfc_finish_block (&fblock);
11345	}
11346
11347
11348	/ Initialize class descriptor's TKR information. /
11349
11350	void
11351	gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
11352	{
11353	tree type, etype;
11354	tree tmp;
11355	tree descriptor;
11356	stmtblock_t init;
11357	locus loc;
11358	int rank;
11359
11360	/ Make sure the frontend gets these right. /
11361	gcc_assert (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
11362	&& (CLASS_DATA (sym)->attr.class_pointer
11363	\|\| CLASS_DATA (sym)->attr.allocatable));
11364
11365	gcc_assert (VAR_P (sym->backend_decl)
11366	\|\| TREE_CODE (sym->backend_decl) == PARM_DECL);
11367
11368	if (sym->attr.dummy)
11369	return;
11370
11371	descriptor = gfc_class_data_get (sym->backend_decl);
11372	type = TREE_TYPE (descriptor);
11373
11374	if (type == NULL \|\| !GFC_DESCRIPTOR_TYPE_P (type))
11375	return;
11376
11377	gfc_save_backend_locus (&loc);
11378	gfc_set_backend_locus (&sym->declared_at);
11379	gfc_init_block (&init);
11380
11381	rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (`0`);
11382	gcc_assert (rank>=`0`);
11383	tmp = gfc_conv_descriptor_dtype (desc: descriptor);
11384	etype = gfc_get_element_type (type);
11385	tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
11386	gfc_get_dtype_rank_type (rank, etype));
11387	gfc_add_expr_to_block (&init, tmp);
11388
11389	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
11390	gfc_restore_backend_locus (&loc);
11391	}
11392
11393
11394	/ NULLIFY an allocatable/pointer array on function entry, free it on exit.*
11395	Do likewise, recursively if necessary, with the allocatable components of
11396	derived types. This function is also called for assumed-rank arrays, which
11397	are always dummy arguments. /*
11398
11399	void
11400	gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
11401	{
11402	tree type;
11403	tree tmp;
11404	tree descriptor;
11405	stmtblock_t init;
11406	stmtblock_t cleanup;
11407	locus loc;
11408	int rank;
11409	bool sym_has_alloc_comp, has_finalizer;
11410
11411	sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
11412	\|\| sym->ts.type == BT_CLASS)
11413	&& sym->ts.u.derived->attr.alloc_comp;
11414	has_finalizer = gfc_may_be_finalized (sym->ts);
11415
11416	/ Make sure the frontend gets these right. /
11417	gcc_assert (sym->attr.pointer \|\| sym->attr.allocatable \|\| sym_has_alloc_comp
11418	\|\| has_finalizer
11419	\|\| (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
11420
11421	gfc_save_backend_locus (&loc);
11422	gfc_set_backend_locus (&sym->declared_at);
11423	gfc_init_block (&init);
11424
11425	gcc_assert (VAR_P (sym->backend_decl)
11426	\|\| TREE_CODE (sym->backend_decl) == PARM_DECL);
11427
11428	if (sym->ts.type == BT_CHARACTER
11429	&& !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
11430	{
11431	gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
11432	gfc_trans_vla_type_sizes (sym, &init);
11433	}
11434
11435	/ Dummy, use associated and result variables don't need anything special. /
11436	if (sym->attr.dummy \|\| sym->attr.use_assoc \|\| sym->attr.result)
11437	{
11438	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
11439	gfc_restore_backend_locus (&loc);
11440	return;
11441	}
11442
11443	descriptor = sym->backend_decl;
11444
11445	/ Although static, derived types with default initializers and*
11446	allocatable components must not be nulled wholesale; instead they
11447	are treated component by component. /*
11448	if (TREE_STATIC (descriptor) && !sym_has_alloc_comp && !has_finalizer)
11449	{
11450	/ SAVEd variables are not freed on exit. /
11451	gfc_trans_static_array_pointer (sym);
11452
11453	gfc_add_init_cleanup (block, init: gfc_finish_block (&init), NULL_TREE);
11454	gfc_restore_backend_locus (&loc);
11455	return;
11456	}
11457
11458	/ Get the descriptor type. /
11459	type = TREE_TYPE (sym->backend_decl);
11460
11461	if ((sym_has_alloc_comp \|\| (has_finalizer && sym->ts.type != BT_CLASS))
11462	&& !(sym->attr.pointer \|\| sym->attr.allocatable))
11463	{
11464	if (!sym->attr.save
11465	&& !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
11466	{
11467	if (sym->value == NULL
11468	\|\| !gfc_has_default_initializer (sym->ts.u.derived))
11469	{
11470	rank = sym->as ? sym->as->rank : `0`;
11471	tmp = gfc_nullify_alloc_comp (der_type: sym->ts.u.derived,
11472	decl: descriptor, rank);
11473	gfc_add_expr_to_block (&init, tmp);
11474	}
11475	else
11476	gfc_init_default_dt (sym, &init, false);
11477	}
11478	}
11479	else if (!GFC_DESCRIPTOR_TYPE_P (type))
11480	{
11481	/ If the backend_decl is not a descriptor, we must have a pointer*
11482	to one. /*
11483	descriptor = build_fold_indirect_ref_loc (input_location,
11484	sym->backend_decl);
11485	type = TREE_TYPE (descriptor);
11486	}
11487
11488	/ NULLIFY the data pointer, for non-saved allocatables. /
11489	if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save && sym->attr.allocatable)
11490	{
11491	gfc_conv_descriptor_data_set (block: &init, desc: descriptor, null_pointer_node);
11492	if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
11493	{
11494	/ Declare the variable static so its array descriptor stays present*
11495	after leaving the scope. It may still be accessed through another
11496	image. This may happen, for example, with the caf_mpi
11497	implementation. /*
11498	TREE_STATIC (descriptor) = `1`;
11499	tmp = gfc_conv_descriptor_token (desc: descriptor);
11500	gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
11501	null_pointer_node));
11502	}
11503	}
11504
11505	/ Set initial TKR for pointers and allocatables /
11506	if (GFC_DESCRIPTOR_TYPE_P (type)
11507	&& (sym->attr.pointer \|\| sym->attr.allocatable))
11508	{
11509	tree etype;
11510
11511	gcc_assert (sym->as && sym->as->rank>=`0`);
11512	tmp = gfc_conv_descriptor_dtype (desc: descriptor);
11513	etype = gfc_get_element_type (type);
11514	tmp = fold_build2_loc (input_location, MODIFY_EXPR,
11515	TREE_TYPE (tmp), tmp,
11516	gfc_get_dtype_rank_type (sym->as->rank, etype));
11517	gfc_add_expr_to_block (&init, tmp);
11518	}
11519	gfc_restore_backend_locus (&loc);
11520	gfc_init_block (&cleanup);
11521
11522	/ Allocatable arrays need to be freed when they go out of scope.*
11523	The allocatable components of pointers must not be touched. /*
11524	if (!sym->attr.allocatable && has_finalizer && sym->ts.type != BT_CLASS
11525	&& !sym->attr.pointer && !sym->attr.artificial && !sym->attr.save
11526	&& !sym->ns->proc_name->attr.is_main_program)
11527	{
11528	gfc_expr *e;
11529	sym->attr.referenced = `1`;
11530	e = gfc_lval_expr_from_sym (sym);
11531	gfc_add_finalizer_call (&cleanup, e);
11532	gfc_free_expr (e);
11533	}
11534	else if ((!sym->attr.allocatable \|\| !has_finalizer)
11535	&& sym_has_alloc_comp && !(sym->attr.function \|\| sym->attr.result)
11536	&& !sym->attr.pointer && !sym->attr.save
11537	&& !(sym->attr.artificial && sym->name[`0`] == `'_'`)
11538	&& !sym->ns->proc_name->attr.is_main_program)
11539	{
11540	int rank;
11541	rank = sym->as ? sym->as->rank : `0`;
11542	tmp = gfc_deallocate_alloc_comp (der_type: sym->ts.u.derived, decl: descriptor, rank,
11543	caf_mode: (sym->attr.codimension
11544	&& flag_coarray == GFC_FCOARRAY_LIB)
11545	? GFC_STRUCTURE_CAF_MODE_IN_COARRAY
11546	: `0`);
11547	gfc_add_expr_to_block (&cleanup, tmp);
11548	}
11549
11550	if (sym->attr.allocatable && (sym->attr.dimension \|\| sym->attr.codimension)
11551	&& !sym->attr.save && !sym->attr.result
11552	&& !sym->ns->proc_name->attr.is_main_program)
11553	{
11554	gfc_expr *e;
11555	e = has_finalizer ? gfc_lval_expr_from_sym (sym) : NULL;
11556	tmp = gfc_deallocate_with_status (sym->backend_decl, NULL_TREE, NULL_TREE,
11557	NULL_TREE, NULL_TREE, true, e,
11558	sym->attr.codimension
11559	? GFC_CAF_COARRAY_DEREGISTER
11560	: GFC_CAF_COARRAY_NOCOARRAY,
11561	NULL_TREE, a: gfc_finish_block (&cleanup));
11562	if (e)
11563	gfc_free_expr (e);
11564	gfc_init_block (&cleanup);
11565	gfc_add_expr_to_block (&cleanup, tmp);
11566	}
11567
11568	gfc_add_init_cleanup (block, init: gfc_finish_block (&init),
11569	cleanup: gfc_finish_block (&cleanup));
11570	}
11571
11572	/********* Expression Walking Functions ***************/
11573
11574	/ Walk a variable reference.*
11575
11576	Possible extension - multiple component subscripts.
11577	x(:,:) = foo%a(:)%b(:)
11578	Transforms to
11579	forall (i=..., j=...)
11580	x(i,j) = foo%a(j)%b(i)
11581	end forall
11582	This adds a fair amount of complexity because you need to deal with more
11583	than one ref. Maybe handle in a similar manner to vector subscripts.
11584	Maybe not worth the effort. /*
11585
11586
11587	static gfc_ss *
11588	gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
11589	{
11590	gfc_ref *ref;
11591
11592	gfc_fix_class_refs (e: expr);
11593
11594	for (ref = expr->ref; ref; ref = ref->next)
11595	if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
11596	break;
11597
11598	return gfc_walk_array_ref (ss, expr, ref);
11599	}
11600
11601
11602	gfc_ss *
11603	gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
11604	{
11605	gfc_array_ref *ar;
11606	gfc_ss *newss;
11607	int n;
11608
11609	for (; ref; ref = ref->next)
11610	{
11611	if (ref->type == REF_SUBSTRING)
11612	{
11613	ss = gfc_get_scalar_ss (next: ss, expr: ref->u.ss.start);
11614	if (ref->u.ss.end)
11615	ss = gfc_get_scalar_ss (next: ss, expr: ref->u.ss.end);
11616	}
11617
11618	/ We're only interested in array sections from now on. /
11619	if (ref->type != REF_ARRAY)
11620	continue;
11621
11622	ar = &ref->u.ar;
11623
11624	switch (ar->type)
11625	{
11626	case AR_ELEMENT:
11627	for (n = ar->dimen - `1`; n >= `0`; n--)
11628	ss = gfc_get_scalar_ss (next: ss, expr: ar->start[n]);
11629	break;
11630
11631	case AR_FULL:
11632	/ Assumed shape arrays from interface mapping need this fix. /
11633	if (!ar->as && expr->symtree->n.sym->as)
11634	{
11635	ar->as = gfc_get_array_spec();
11636	ar->as = expr->symtree->n.sym->as;
11637	}
11638	newss = gfc_get_array_ss (next: ss, expr, dimen: ar->as->rank, type: GFC_SS_SECTION);
11639	newss->info->data.array.ref = ref;
11640
11641	/ Make sure array is the same as array(:,:), this way*
11642	we don't need to special case all the time. /*
11643	ar->dimen = ar->as->rank;
11644	for (n = `0`; n < ar->dimen; n++)
11645	{
11646	ar->dimen_type[n] = DIMEN_RANGE;
11647
11648	gcc_assert (ar->start[n] == NULL);
11649	gcc_assert (ar->end[n] == NULL);
11650	gcc_assert (ar->stride[n] == NULL);
11651	}
11652	ss = newss;
11653	break;
11654
11655	case AR_SECTION:
11656	newss = gfc_get_array_ss (next: ss, expr, dimen: `0`, type: GFC_SS_SECTION);
11657	newss->info->data.array.ref = ref;
11658
11659	/ We add SS chains for all the subscripts in the section. /
11660	for (n = `0`; n < ar->dimen; n++)
11661	{
11662	gfc_ss *indexss;
11663
11664	switch (ar->dimen_type[n])
11665	{
11666	case DIMEN_ELEMENT:
11667	/ Add SS for elemental (scalar) subscripts. /
11668	gcc_assert (ar->start[n]);
11669	indexss = gfc_get_scalar_ss (next: gfc_ss_terminator, expr: ar->start[n]);
11670	indexss->loop_chain = gfc_ss_terminator;
11671	newss->info->data.array.subscript[n] = indexss;
11672	break;
11673
11674	case DIMEN_RANGE:
11675	/ We don't add anything for sections, just remember this*
11676	dimension for later. /*
11677	newss->dim[newss->dimen] = n;
11678	newss->dimen++;
11679	break;
11680
11681	case DIMEN_VECTOR:
11682	/ Create a GFC_SS_VECTOR index in which we can store*
11683	the vector's descriptor. /*
11684	indexss = gfc_get_array_ss (next: gfc_ss_terminator, expr: ar->start[n],
11685	dimen: `1`, type: GFC_SS_VECTOR);
11686	indexss->loop_chain = gfc_ss_terminator;
11687	newss->info->data.array.subscript[n] = indexss;
11688	newss->dim[newss->dimen] = n;
11689	newss->dimen++;
11690	break;
11691
11692	default:
11693	/ We should know what sort of section it is by now. /
11694	gcc_unreachable ();
11695	}
11696	}
11697	/ We should have at least one non-elemental dimension,*
11698	unless we are creating a descriptor for a (scalar) coarray. /*
11699	gcc_assert (newss->dimen > `0`
11700	\|\| newss->info->data.array.ref->u.ar.as->corank > `0`);
11701	ss = newss;
11702	break;
11703
11704	default:
11705	/ We should know what sort of section it is by now. /
11706	gcc_unreachable ();
11707	}
11708
11709	}
11710	return ss;
11711	}
11712
11713
11714	/ Walk an expression operator. If only one operand of a binary expression is*
11715	scalar, we must also add the scalar term to the SS chain. /*
11716
11717	static gfc_ss *
11718	gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
11719	{
11720	gfc_ss *head;
11721	gfc_ss *head2;
11722
11723	head = gfc_walk_subexpr (ss, expr->value.op.op1);
11724	if (expr->value.op.op2 == NULL)
11725	head2 = head;
11726	else
11727	head2 = gfc_walk_subexpr (head, expr->value.op.op2);
11728
11729	/ All operands are scalar. Pass back and let the caller deal with it. /
11730	if (head2 == ss)
11731	return head2;
11732
11733	/ All operands require scalarization. /
11734	if (head != ss && (expr->value.op.op2 == NULL \|\| head2 != head))
11735	return head2;
11736
11737	/ One of the operands needs scalarization, the other is scalar.*
11738	Create a gfc_ss for the scalar expression. /*
11739	if (head == ss)
11740	{
11741	/ First operand is scalar. We build the chain in reverse order, so*
11742	add the scalar SS after the second operand. /*
11743	head = head2;
11744	while (head && head->next != ss)
11745	head = head->next;
11746	/ Check we haven't somehow broken the chain. /
11747	gcc_assert (head);
11748	head->next = gfc_get_scalar_ss (next: ss, expr: expr->value.op.op1);
11749	}
11750	else / head2 == head /
11751	{
11752	gcc_assert (head2 == head);
11753	/ Second operand is scalar. /
11754	head2 = gfc_get_scalar_ss (next: head2, expr: expr->value.op.op2);
11755	}
11756
11757	return head2;
11758	}
11759
11760
11761	/ Reverse a SS chain. /
11762
11763	gfc_ss *
11764	gfc_reverse_ss (gfc_ss * ss)
11765	{
11766	gfc_ss *next;
11767	gfc_ss *head;
11768
11769	gcc_assert (ss != NULL);
11770
11771	head = gfc_ss_terminator;
11772	while (ss != gfc_ss_terminator)
11773	{
11774	next = ss->next;
11775	/ Check we didn't somehow break the chain. /
11776	gcc_assert (next != NULL);
11777	ss->next = head;
11778	head = ss;
11779	ss = next;
11780	}
11781
11782	return (head);
11783	}
11784
11785
11786	/ Given an expression referring to a procedure, return the symbol of its*
11787	interface. We can't get the procedure symbol directly as we have to handle
11788	the case of (deferred) type-bound procedures. /*
11789
11790	gfc_symbol *
11791	gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
11792	{
11793	gfc_symbol *sym;
11794	gfc_ref *ref;
11795
11796	if (procedure_ref == NULL)
11797	return NULL;
11798
11799	/ Normal procedure case. /
11800	if (procedure_ref->expr_type == EXPR_FUNCTION
11801	&& procedure_ref->value.function.esym)
11802	sym = procedure_ref->value.function.esym;
11803	else
11804	sym = procedure_ref->symtree->n.sym;
11805
11806	/ Typebound procedure case. /
11807	for (ref = procedure_ref->ref; ref; ref = ref->next)
11808	{
11809	if (ref->type == REF_COMPONENT
11810	&& ref->u.c.component->attr.proc_pointer)
11811	sym = ref->u.c.component->ts.interface;
11812	else
11813	sym = NULL;
11814	}
11815
11816	return sym;
11817	}
11818
11819
11820	/ Given an expression referring to an intrinsic function call,*
11821	return the intrinsic symbol. /*
11822
11823	gfc_intrinsic_sym *
11824	gfc_get_intrinsic_for_expr (gfc_expr *call)
11825	{
11826	if (call == NULL)
11827	return NULL;
11828
11829	/ Normal procedure case. /
11830	if (call->expr_type == EXPR_FUNCTION)
11831	return call->value.function.isym;
11832	else
11833	return NULL;
11834	}
11835
11836
11837	/ Indicates whether an argument to an intrinsic function should be used in*
11838	scalarization. It is usually the case, except for some intrinsics
11839	requiring the value to be constant, and using the value at compile time only.
11840	As the value is not used at runtime in those cases, we don’t produce code
11841	for it, and it should not be visible to the scalarizer.
11842	FUNCTION is the intrinsic function being called, ACTUAL_ARG is the actual
11843	argument being examined in that call, and ARG_NUM the index number
11844	of ACTUAL_ARG in the list of arguments.
11845	The intrinsic procedure’s dummy argument associated with ACTUAL_ARG is
11846	identified using the name in ACTUAL_ARG if it is present (that is: if it’s
11847	a keyword argument), otherwise using ARG_NUM. /*
11848
11849	static bool
11850	arg_evaluated_for_scalarization (gfc_intrinsic_sym *function,
11851	gfc_dummy_arg *dummy_arg)
11852	{
11853	if (function != NULL && dummy_arg != NULL)
11854	{
11855	switch (function->id)
11856	{
11857	case GFC_ISYM_INDEX:
11858	case GFC_ISYM_LEN_TRIM:
11859	case GFC_ISYM_MASKL:
11860	case GFC_ISYM_MASKR:
11861	case GFC_ISYM_SCAN:
11862	case GFC_ISYM_VERIFY:
11863	if (strcmp (s1: "kind", s2: gfc_dummy_arg_get_name (*dummy_arg)) == `0`)
11864	return false;
11865	/ Fallthrough. /
11866
11867	default:
11868	break;
11869	}
11870	}
11871
11872	return true;
11873	}
11874
11875
11876	/ Walk the arguments of an elemental function.*
11877	PROC_EXPR is used to check whether an argument is permitted to be absent. If
11878	it is NULL, we don't do the check and the argument is assumed to be present.
11879	*/
11880
11881	gfc_ss *
11882	gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
11883	gfc_intrinsic_sym *intrinsic_sym,
11884	gfc_ss_type type)
11885	{
11886	int scalar;
11887	gfc_ss *head;
11888	gfc_ss *tail;
11889	gfc_ss *newss;
11890
11891	head = gfc_ss_terminator;
11892	tail = NULL;
11893
11894	scalar = `1`;
11895	for (; arg; arg = arg->next)
11896	{
11897	gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
11898	if (!arg->expr
11899	\|\| arg->expr->expr_type == EXPR_NULL
11900	\|\| !arg_evaluated_for_scalarization (function: intrinsic_sym, dummy_arg))
11901	continue;
11902
11903	newss = gfc_walk_subexpr (head, arg->expr);
11904	if (newss == head)
11905	{
11906	/ Scalar argument. /
11907	gcc_assert (type == GFC_SS_SCALAR \|\| type == GFC_SS_REFERENCE);
11908	newss = gfc_get_scalar_ss (next: head, expr: arg->expr);
11909	newss->info->type = type;
11910	if (dummy_arg)
11911	newss->info->data.scalar.dummy_arg = dummy_arg;
11912	}
11913	else
11914	scalar = `0`;
11915
11916	if (dummy_arg != NULL
11917	&& gfc_dummy_arg_is_optional (*dummy_arg)
11918	&& arg->expr->expr_type == EXPR_VARIABLE
11919	&& (gfc_expr_attr (arg->expr).optional
11920	\|\| gfc_expr_attr (arg->expr).allocatable
11921	\|\| gfc_expr_attr (arg->expr).pointer))
11922	newss->info->can_be_null_ref = true;
11923
11924	head = newss;
11925	if (!tail)
11926	{
11927	tail = head;
11928	while (tail->next != gfc_ss_terminator)
11929	tail = tail->next;
11930	}
11931	}
11932
11933	if (scalar)
11934	{
11935	/ If all the arguments are scalar we don't need the argument SS. /
11936	gfc_free_ss_chain (ss: head);
11937	/ Pass it back. /
11938	return ss;
11939	}
11940
11941	/ Add it onto the existing chain. /
11942	tail->next = ss;
11943	return head;
11944	}
11945
11946
11947	/ Walk a function call. Scalar functions are passed back, and taken out of*
11948	scalarization loops. For elemental functions we walk their arguments.
11949	The result of functions returning arrays is stored in a temporary outside
11950	the loop, so that the function is only called once. Hence we do not need
11951	to walk their arguments. /*
11952
11953	static gfc_ss *
11954	gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
11955	{
11956	gfc_intrinsic_sym *isym;
11957	gfc_symbol *sym;
11958	gfc_component *comp = NULL;
11959
11960	isym = expr->value.function.isym;
11961
11962	/ Handle intrinsic functions separately. /
11963	if (isym)
11964	return gfc_walk_intrinsic_function (ss, expr, isym);
11965
11966	sym = expr->value.function.esym;
11967	if (!sym)
11968	sym = expr->symtree->n.sym;
11969
11970	if (gfc_is_class_array_function (expr))
11971	return gfc_get_array_ss (next: ss, expr,
11972	CLASS_DATA (expr->value.function.esym->result)->as->rank,
11973	type: GFC_SS_FUNCTION);
11974
11975	/ A function that returns arrays. /
11976	comp = gfc_get_proc_ptr_comp (expr);
11977	if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
11978	\|\| (comp && comp->attr.dimension))
11979	return gfc_get_array_ss (next: ss, expr, dimen: expr->rank, type: GFC_SS_FUNCTION);
11980
11981	/ Walk the parameters of an elemental function. For now we always pass*
11982	by reference. /*
11983	if (sym->attr.elemental \|\| (comp && comp->attr.elemental))
11984	{
11985	gfc_ss *old_ss = ss;
11986
11987	ss = gfc_walk_elemental_function_args (ss: old_ss,
11988	arg: expr->value.function.actual,
11989	intrinsic_sym: gfc_get_intrinsic_for_expr (call: expr),
11990	type: GFC_SS_REFERENCE);
11991	if (ss != old_ss
11992	&& (comp
11993	\|\| sym->attr.proc_pointer
11994	\|\| sym->attr.if_source != IFSRC_DECL
11995	\|\| sym->attr.array_outer_dependency))
11996	ss->info->array_outer_dependency = `1`;
11997	}
11998
11999	/ Scalar functions are OK as these are evaluated outside the scalarization*
12000	loop. Pass back and let the caller deal with it. /*
12001	return ss;
12002	}
12003
12004
12005	/ An array temporary is constructed for array constructors. /
12006
12007	static gfc_ss *
12008	gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
12009	{
12010	return gfc_get_array_ss (next: ss, expr, dimen: expr->rank, type: GFC_SS_CONSTRUCTOR);
12011	}
12012
12013
12014	/ Walk an expression. Add walked expressions to the head of the SS chain.*
12015	A wholly scalar expression will not be added. /*
12016
12017	gfc_ss *
12018	gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
12019	{
12020	gfc_ss *head;
12021
12022	switch (expr->expr_type)
12023	{
12024	case EXPR_VARIABLE:
12025	head = gfc_walk_variable_expr (ss, expr);
12026	return head;
12027
12028	case EXPR_OP:
12029	head = gfc_walk_op_expr (ss, expr);
12030	return head;
12031
12032	case EXPR_FUNCTION:
12033	head = gfc_walk_function_expr (ss, expr);
12034	return head;
12035
12036	case EXPR_CONSTANT:
12037	case EXPR_NULL:
12038	case EXPR_STRUCTURE:
12039	/ Pass back and let the caller deal with it. /
12040	break;
12041
12042	case EXPR_ARRAY:
12043	head = gfc_walk_array_constructor (ss, expr);
12044	return head;
12045
12046	case EXPR_SUBSTRING:
12047	/ Pass back and let the caller deal with it. /
12048	break;
12049
12050	default:
12051	gfc_internal_error ("bad expression type during walk (%d)",
12052	expr->expr_type);
12053	}
12054	return ss;
12055	}
12056
12057
12058	/ Entry point for expression walking.*
12059	A return value equal to the passed chain means this is
12060	a scalar expression. It is up to the caller to take whatever action is
12061	necessary to translate these. /*
12062
12063	gfc_ss *
12064	gfc_walk_expr (gfc_expr * expr)
12065	{
12066	gfc_ss *res;
12067
12068	res = gfc_walk_subexpr (ss: gfc_ss_terminator, expr);
12069	return gfc_reverse_ss (ss: res);
12070	}
12071

source code of gcc/fortran/trans-array.cc