Branch data Line data Source code
1 : : /* Expression translation
2 : : Copyright (C) 2002-2025 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook <paul@nowt.org>
4 : : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 : :
6 : : This file is part of GCC.
7 : :
8 : : GCC is free software; you can redistribute it and/or modify it under
9 : : the terms of the GNU General Public License as published by the Free
10 : : Software Foundation; either version 3, or (at your option) any later
11 : : version.
12 : :
13 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : : for more details.
17 : :
18 : : You should have received a copy of the GNU General Public License
19 : : along with GCC; see the file COPYING3. If not see
20 : : <http://www.gnu.org/licenses/>. */
21 : :
22 : : /* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
23 : :
24 : : #define INCLUDE_MEMORY
25 : : #include "config.h"
26 : : #include "system.h"
27 : : #include "coretypes.h"
28 : : #include "options.h"
29 : : #include "tree.h"
30 : : #include "gfortran.h"
31 : : #include "trans.h"
32 : : #include "stringpool.h"
33 : : #include "diagnostic-core.h" /* For fatal_error. */
34 : : #include "fold-const.h"
35 : : #include "langhooks.h"
36 : : #include "arith.h"
37 : : #include "constructor.h"
38 : : #include "trans-const.h"
39 : : #include "trans-types.h"
40 : : #include "trans-array.h"
41 : : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 : : #include "trans-stmt.h"
43 : : #include "dependency.h"
44 : : #include "gimplify.h"
45 : : #include "tm.h" /* For CHAR_TYPE_SIZE. */
46 : :
47 : :
48 : : /* Calculate the number of characters in a string. */
49 : :
50 : : static tree
51 : 35473 : gfc_get_character_len (tree type)
52 : : {
53 : 35473 : tree len;
54 : :
55 : 35473 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
56 : : && TYPE_STRING_FLAG (type));
57 : :
58 : 35473 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
59 : 35473 : len = (len) ? (len) : (integer_zero_node);
60 : 35473 : return fold_convert (gfc_charlen_type_node, len);
61 : : }
62 : :
63 : :
64 : :
65 : : /* Calculate the number of bytes in a string. */
66 : :
67 : : tree
68 : 35473 : gfc_get_character_len_in_bytes (tree type)
69 : : {
70 : 35473 : tree tmp, len;
71 : :
72 : 35473 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
73 : : && TYPE_STRING_FLAG (type));
74 : :
75 : 35473 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
76 : 70946 : tmp = (tmp && !integer_zerop (tmp))
77 : 70946 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
78 : 35473 : len = gfc_get_character_len (type);
79 : 35473 : if (tmp && len && !integer_zerop (len))
80 : 34719 : len = fold_build2_loc (input_location, MULT_EXPR,
81 : : gfc_charlen_type_node, len, tmp);
82 : 35473 : return len;
83 : : }
84 : :
85 : :
86 : : /* Convert a scalar to an array descriptor. To be used for assumed-rank
87 : : arrays. */
88 : :
89 : : static tree
90 : 5976 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
91 : : {
92 : 5976 : enum gfc_array_kind akind;
93 : :
94 : 5976 : if (attr.pointer)
95 : : akind = GFC_ARRAY_POINTER_CONT;
96 : 5626 : else if (attr.allocatable)
97 : : akind = GFC_ARRAY_ALLOCATABLE;
98 : : else
99 : 4863 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
100 : :
101 : 5976 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
102 : 5069 : scalar = TREE_TYPE (scalar);
103 : 5976 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
104 : 5976 : akind, !(attr.pointer || attr.target));
105 : : }
106 : :
107 : : tree
108 : 5299 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
109 : : {
110 : 5299 : tree desc, type, etype;
111 : :
112 : 5299 : type = get_scalar_to_descriptor_type (scalar, attr);
113 : 5299 : etype = TREE_TYPE (scalar);
114 : 5299 : desc = gfc_create_var (type, "desc");
115 : 5299 : DECL_ARTIFICIAL (desc) = 1;
116 : :
117 : 5299 : if (CONSTANT_CLASS_P (scalar))
118 : : {
119 : 54 : tree tmp;
120 : 54 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
121 : 54 : gfc_add_modify (&se->pre, tmp, scalar);
122 : 54 : scalar = tmp;
123 : : }
124 : 5299 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
125 : 907 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
126 : 4392 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
127 : 113 : etype = TREE_TYPE (etype);
128 : 5299 : gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
129 : : gfc_get_dtype_rank_type (0, etype));
130 : 5299 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
131 : 5299 : gfc_conv_descriptor_span_set (&se->pre, desc,
132 : : gfc_conv_descriptor_elem_len (desc));
133 : :
134 : : /* Copy pointer address back - but only if it could have changed and
135 : : if the actual argument is a pointer and not, e.g., NULL(). */
136 : 5299 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
137 : 830 : gfc_add_modify (&se->post, scalar,
138 : 415 : fold_convert (TREE_TYPE (scalar),
139 : : gfc_conv_descriptor_data_get (desc)));
140 : 5299 : return desc;
141 : : }
142 : :
143 : :
144 : : /* Get the coarray token from the ultimate array or component ref.
145 : : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
146 : :
147 : : tree
148 : 411 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
149 : : {
150 : 411 : gfc_symbol *sym = expr->symtree->n.sym;
151 : 822 : bool is_coarray = sym->ts.type == BT_CLASS
152 : 411 : ? CLASS_DATA (sym)->attr.codimension
153 : 376 : : sym->attr.codimension;
154 : 411 : gfc_expr *caf_expr = gfc_copy_expr (expr);
155 : 411 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
156 : :
157 : 1371 : while (ref)
158 : : {
159 : 960 : if (ref->type == REF_COMPONENT
160 : 376 : && (ref->u.c.component->attr.allocatable
161 : 98 : || ref->u.c.component->attr.pointer)
162 : 375 : && (is_coarray || ref->u.c.component->attr.codimension))
163 : 960 : last_caf_ref = ref;
164 : 960 : ref = ref->next;
165 : : }
166 : :
167 : 411 : if (last_caf_ref == NULL)
168 : : {
169 : 116 : gfc_free_expr (caf_expr);
170 : 116 : return NULL_TREE;
171 : : }
172 : :
173 : 133 : tree comp = last_caf_ref->u.c.component->caf_token
174 : 295 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
175 : : : NULL_TREE,
176 : : caf;
177 : 295 : gfc_se se;
178 : 295 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
179 : 295 : if (comp == NULL_TREE && comp_ref)
180 : : {
181 : 34 : gfc_free_expr (caf_expr);
182 : 34 : return NULL_TREE;
183 : : }
184 : 261 : gfc_init_se (&se, outerse);
185 : 261 : gfc_free_ref_list (last_caf_ref->next);
186 : 261 : last_caf_ref->next = NULL;
187 : 261 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
188 : 522 : caf_expr->corank = last_caf_ref->u.c.component->as
189 : 261 : ? last_caf_ref->u.c.component->as->corank
190 : : : expr->corank;
191 : 261 : se.want_pointer = comp_ref;
192 : 261 : gfc_conv_expr (&se, caf_expr);
193 : 261 : gfc_add_block_to_block (&outerse->pre, &se.pre);
194 : :
195 : 261 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
196 : 133 : se.expr = TREE_OPERAND (se.expr, 0);
197 : 261 : gfc_free_expr (caf_expr);
198 : :
199 : 261 : if (comp_ref)
200 : 133 : caf = fold_build3_loc (input_location, COMPONENT_REF,
201 : 133 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
202 : : else
203 : 128 : caf = gfc_conv_descriptor_token (se.expr);
204 : 261 : return gfc_build_addr_expr (NULL_TREE, caf);
205 : : }
206 : :
207 : :
208 : : /* This is the seed for an eventual trans-class.c
209 : :
210 : : The following parameters should not be used directly since they might
211 : : in future implementations. Use the corresponding APIs. */
212 : : #define CLASS_DATA_FIELD 0
213 : : #define CLASS_VPTR_FIELD 1
214 : : #define CLASS_LEN_FIELD 2
215 : : #define VTABLE_HASH_FIELD 0
216 : : #define VTABLE_SIZE_FIELD 1
217 : : #define VTABLE_EXTENDS_FIELD 2
218 : : #define VTABLE_DEF_INIT_FIELD 3
219 : : #define VTABLE_COPY_FIELD 4
220 : : #define VTABLE_FINAL_FIELD 5
221 : : #define VTABLE_DEALLOCATE_FIELD 6
222 : :
223 : :
224 : : tree
225 : 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
226 : : {
227 : 40 : tree tmp;
228 : 40 : tree field;
229 : 40 : vec<constructor_elt, va_gc> *init = NULL;
230 : :
231 : 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
232 : 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
233 : 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
234 : :
235 : 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
236 : 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
237 : :
238 : 40 : return build_constructor (TREE_TYPE (decl), init);
239 : : }
240 : :
241 : :
242 : : tree
243 : 31460 : gfc_class_data_get (tree decl)
244 : : {
245 : 31460 : tree data;
246 : 31460 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
247 : 5200 : decl = build_fold_indirect_ref_loc (input_location, decl);
248 : 31460 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
249 : : CLASS_DATA_FIELD);
250 : 31460 : return fold_build3_loc (input_location, COMPONENT_REF,
251 : 31460 : TREE_TYPE (data), decl, data,
252 : 31460 : NULL_TREE);
253 : : }
254 : :
255 : :
256 : : tree
257 : 44177 : gfc_class_vptr_get (tree decl)
258 : : {
259 : 44177 : tree vptr;
260 : : /* For class arrays decl may be a temporary descriptor handle, the vptr is
261 : : then available through the saved descriptor. */
262 : 26811 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
263 : 45912 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
264 : 1232 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
265 : 44177 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
266 : 2297 : decl = build_fold_indirect_ref_loc (input_location, decl);
267 : 44177 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
268 : : CLASS_VPTR_FIELD);
269 : 44177 : return fold_build3_loc (input_location, COMPONENT_REF,
270 : 44177 : TREE_TYPE (vptr), decl, vptr,
271 : 44177 : NULL_TREE);
272 : : }
273 : :
274 : :
275 : : tree
276 : 6416 : gfc_class_len_get (tree decl)
277 : : {
278 : 6416 : tree len;
279 : : /* For class arrays decl may be a temporary descriptor handle, the len is
280 : : then available through the saved descriptor. */
281 : 4550 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
282 : 6665 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
283 : 85 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
284 : 6416 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
285 : 662 : decl = build_fold_indirect_ref_loc (input_location, decl);
286 : 6416 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
287 : : CLASS_LEN_FIELD);
288 : 6416 : return fold_build3_loc (input_location, COMPONENT_REF,
289 : 6416 : TREE_TYPE (len), decl, len,
290 : 6416 : NULL_TREE);
291 : : }
292 : :
293 : :
294 : : /* Try to get the _len component of a class. When the class is not unlimited
295 : : poly, i.e. no _len field exists, then return a zero node. */
296 : :
297 : : static tree
298 : 4766 : gfc_class_len_or_zero_get (tree decl)
299 : : {
300 : 4766 : tree len;
301 : : /* For class arrays decl may be a temporary descriptor handle, the vptr is
302 : : then available through the saved descriptor. */
303 : 2825 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
304 : 4814 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
305 : 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
306 : 4766 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
307 : 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
308 : 4766 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
309 : : CLASS_LEN_FIELD);
310 : 6551 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
311 : 1785 : TREE_TYPE (len), decl, len,
312 : : NULL_TREE)
313 : 2981 : : build_zero_cst (gfc_charlen_type_node);
314 : : }
315 : :
316 : :
317 : : tree
318 : 4607 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
319 : : {
320 : 4607 : tree tmp;
321 : 4607 : tree tmp2;
322 : 4607 : tree type;
323 : :
324 : 4607 : tmp = gfc_class_len_or_zero_get (class_expr);
325 : :
326 : : /* Include the len value in the element size if present. */
327 : 4607 : if (!integer_zerop (tmp))
328 : : {
329 : 1626 : type = TREE_TYPE (size);
330 : 1626 : if (block)
331 : : {
332 : 937 : size = gfc_evaluate_now (size, block);
333 : 937 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
334 : : }
335 : : else
336 : 689 : tmp = fold_convert (type , tmp);
337 : 1626 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
338 : : type, size, tmp);
339 : 1626 : tmp = fold_build2_loc (input_location, GT_EXPR,
340 : : logical_type_node, tmp,
341 : : build_zero_cst (type));
342 : 1626 : size = fold_build3_loc (input_location, COND_EXPR,
343 : : type, tmp, tmp2, size);
344 : : }
345 : : else
346 : : return size;
347 : :
348 : 1626 : if (block)
349 : 937 : size = gfc_evaluate_now (size, block);
350 : :
351 : : return size;
352 : : }
353 : :
354 : :
355 : : /* Get the specified FIELD from the VPTR. */
356 : :
357 : : static tree
358 : 20406 : vptr_field_get (tree vptr, int fieldno)
359 : : {
360 : 20406 : tree field;
361 : 20406 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
362 : 20406 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
363 : : fieldno);
364 : 20406 : field = fold_build3_loc (input_location, COMPONENT_REF,
365 : 20406 : TREE_TYPE (field), vptr, field,
366 : : NULL_TREE);
367 : 20406 : gcc_assert (field);
368 : 20406 : return field;
369 : : }
370 : :
371 : :
372 : : /* Get the field from the class' vptr. */
373 : :
374 : : static tree
375 : 9838 : class_vtab_field_get (tree decl, int fieldno)
376 : : {
377 : 9838 : tree vptr;
378 : 9838 : vptr = gfc_class_vptr_get (decl);
379 : 9838 : return vptr_field_get (vptr, fieldno);
380 : : }
381 : :
382 : :
383 : : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
384 : : unison. */
385 : : #define VTAB_GET_FIELD_GEN(name, field) tree \
386 : : gfc_class_vtab_## name ##_get (tree cl) \
387 : : { \
388 : : return class_vtab_field_get (cl, field); \
389 : : } \
390 : : \
391 : : tree \
392 : : gfc_vptr_## name ##_get (tree vptr) \
393 : : { \
394 : : return vptr_field_get (vptr, field); \
395 : : }
396 : :
397 : 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
398 : 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
399 : 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
400 : 4237 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
401 : 1811 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
402 : 460 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
403 : : #undef VTAB_GET_FIELD_GEN
404 : :
405 : : /* The size field is returned as an array index type. Therefore treat
406 : : it and only it specially. */
407 : :
408 : : tree
409 : 7832 : gfc_class_vtab_size_get (tree cl)
410 : : {
411 : 7832 : tree size;
412 : 7832 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
413 : : /* Always return size as an array index type. */
414 : 7832 : size = fold_convert (gfc_array_index_type, size);
415 : 7832 : gcc_assert (size);
416 : 7832 : return size;
417 : : }
418 : :
419 : : tree
420 : 5883 : gfc_vptr_size_get (tree vptr)
421 : : {
422 : 5883 : tree size;
423 : 5883 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
424 : : /* Always return size as an array index type. */
425 : 5883 : size = fold_convert (gfc_array_index_type, size);
426 : 5883 : gcc_assert (size);
427 : 5883 : return size;
428 : : }
429 : :
430 : :
431 : : #undef CLASS_DATA_FIELD
432 : : #undef CLASS_VPTR_FIELD
433 : : #undef CLASS_LEN_FIELD
434 : : #undef VTABLE_HASH_FIELD
435 : : #undef VTABLE_SIZE_FIELD
436 : : #undef VTABLE_EXTENDS_FIELD
437 : : #undef VTABLE_DEF_INIT_FIELD
438 : : #undef VTABLE_COPY_FIELD
439 : : #undef VTABLE_FINAL_FIELD
440 : :
441 : :
442 : : /* IF ts is null (default), search for the last _class ref in the chain
443 : : of references of the expression and cut the chain there. Although
444 : : this routine is similiar to class.cc:gfc_add_component_ref (), there
445 : : is a significant difference: gfc_add_component_ref () concentrates
446 : : on an array ref that is the last ref in the chain and is oblivious
447 : : to the kind of refs following.
448 : : ELSE IF ts is non-null the cut is at the class entity or component
449 : : that is followed by an array reference, which is not an element.
450 : : These calls come from trans-array.cc:build_class_array_ref, which
451 : : handles scalarized class array references.*/
452 : :
453 : : gfc_expr *
454 : 8953 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
455 : : gfc_typespec **ts)
456 : : {
457 : 8953 : gfc_expr *base_expr;
458 : 8953 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
459 : :
460 : : /* Find the last class reference. */
461 : 8953 : class_ref = NULL;
462 : 8953 : array_ref = NULL;
463 : :
464 : 8953 : if (ts)
465 : : {
466 : 387 : if (e->symtree
467 : 362 : && e->symtree->n.sym->ts.type == BT_CLASS)
468 : 362 : *ts = &e->symtree->n.sym->ts;
469 : : else
470 : 25 : *ts = NULL;
471 : : }
472 : :
473 : 22415 : for (ref = e->ref; ref; ref = ref->next)
474 : : {
475 : 13834 : if (ts)
476 : : {
477 : 942 : if (ref->type == REF_COMPONENT
478 : 442 : && ref->u.c.component->ts.type == BT_CLASS
479 : 0 : && ref->next && ref->next->type == REF_COMPONENT
480 : 0 : && !strcmp (ref->next->u.c.component->name, "_data")
481 : 0 : && ref->next->next
482 : 0 : && ref->next->next->type == REF_ARRAY
483 : 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
484 : : {
485 : 0 : *ts = &ref->u.c.component->ts;
486 : 0 : class_ref = ref;
487 : 0 : break;
488 : : }
489 : :
490 : 942 : if (ref->next == NULL)
491 : : break;
492 : : }
493 : : else
494 : : {
495 : 12892 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
496 : 12892 : array_ref = ref;
497 : :
498 : 12892 : if (ref->type == REF_COMPONENT
499 : 7823 : && ref->u.c.component->ts.type == BT_CLASS)
500 : : {
501 : : /* Component to the right of a part reference with nonzero
502 : : rank must not have the ALLOCATABLE attribute. If attempts
503 : : are made to reference such a component reference, an error
504 : : results followed by an ICE. */
505 : 1579 : if (array_ref
506 : 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
507 : : return NULL;
508 : : class_ref = ref;
509 : : }
510 : : }
511 : : }
512 : :
513 : 8943 : if (ts && *ts == NULL)
514 : : return NULL;
515 : :
516 : : /* Remove and store all subsequent references after the
517 : : CLASS reference. */
518 : 8918 : if (class_ref)
519 : : {
520 : 1389 : tail = class_ref->next;
521 : 1389 : class_ref->next = NULL;
522 : : }
523 : 7529 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
524 : : {
525 : 7511 : tail = e->ref;
526 : 7511 : e->ref = NULL;
527 : : }
528 : :
529 : 8918 : if (is_mold)
530 : 61 : base_expr = gfc_expr_to_initialize (e);
531 : : else
532 : 8857 : base_expr = gfc_copy_expr (e);
533 : :
534 : : /* Restore the original tail expression. */
535 : 8918 : if (class_ref)
536 : : {
537 : 1389 : gfc_free_ref_list (class_ref->next);
538 : 1389 : class_ref->next = tail;
539 : : }
540 : 7529 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
541 : : {
542 : 7511 : gfc_free_ref_list (e->ref);
543 : 7511 : e->ref = tail;
544 : : }
545 : : return base_expr;
546 : : }
547 : :
548 : : /* Reset the vptr to the declared type, e.g. after deallocation.
549 : : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
550 : : one with e or class_type. At least one of the two has to be set. The
551 : : generated assignment code is added at the end of BLOCK. */
552 : :
553 : : void
554 : 10543 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
555 : : gfc_symbol *class_type)
556 : : {
557 : 10543 : tree vptr = NULL_TREE;
558 : :
559 : 10543 : if (class_container != NULL_TREE)
560 : 6222 : vptr = gfc_get_vptr_from_expr (class_container);
561 : :
562 : 6222 : if (vptr == NULL_TREE)
563 : : {
564 : 4328 : gfc_se se;
565 : 4328 : gcc_assert (e);
566 : :
567 : : /* Evaluate the expression and obtain the vptr from it. */
568 : 4328 : gfc_init_se (&se, NULL);
569 : 4328 : if (e->rank)
570 : 2119 : gfc_conv_expr_descriptor (&se, e);
571 : : else
572 : 2209 : gfc_conv_expr (&se, e);
573 : 4328 : gfc_add_block_to_block (block, &se.pre);
574 : :
575 : 4328 : vptr = gfc_get_vptr_from_expr (se.expr);
576 : : }
577 : :
578 : : /* If a vptr is not found, we can do nothing more. */
579 : 4328 : if (vptr == NULL_TREE)
580 : : return;
581 : :
582 : 10533 : if (UNLIMITED_POLY (e)
583 : 9563 : || UNLIMITED_POLY (class_type)
584 : : /* When the class_type's source is not a symbol (e.g. a component's ts),
585 : : then look at the _data-components type. */
586 : 1465 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
587 : 1465 : && class_type->components && class_type->components->ts.u.derived
588 : 1459 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
589 : 1116 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
590 : : else
591 : : {
592 : 9417 : gfc_symbol *vtab, *type = nullptr;
593 : 9417 : tree vtable;
594 : :
595 : 9417 : if (e)
596 : 8098 : type = e->ts.u.derived;
597 : 1319 : else if (class_type)
598 : : {
599 : 1319 : if (class_type->ts.type == BT_CLASS)
600 : 0 : type = CLASS_DATA (class_type)->ts.u.derived;
601 : : else
602 : : type = class_type;
603 : : }
604 : 8098 : gcc_assert (type);
605 : : /* Return the vptr to the address of the declared type. */
606 : 9417 : vtab = gfc_find_derived_vtab (type);
607 : 9417 : vtable = vtab->backend_decl;
608 : 9417 : if (vtable == NULL_TREE)
609 : 70 : vtable = gfc_get_symbol_decl (vtab);
610 : 9417 : vtable = gfc_build_addr_expr (NULL, vtable);
611 : 9417 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
612 : 9417 : gfc_add_modify (block, vptr, vtable);
613 : : }
614 : : }
615 : :
616 : : /* Set the vptr of a class in to from the type given in from. If from is NULL,
617 : : then reset the vptr to the default or to. */
618 : :
619 : : void
620 : 216 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
621 : : {
622 : 216 : tree tmp, vptr_ref;
623 : 216 : gfc_symbol *type;
624 : :
625 : 216 : vptr_ref = gfc_get_vptr_from_expr (to);
626 : 252 : if (POINTER_TYPE_P (TREE_TYPE (from))
627 : 216 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
628 : : {
629 : 44 : gfc_add_modify (block, vptr_ref,
630 : 22 : fold_convert (TREE_TYPE (vptr_ref),
631 : : gfc_get_vptr_from_expr (from)));
632 : 238 : return;
633 : : }
634 : 194 : tmp = gfc_get_vptr_from_expr (from);
635 : 194 : if (tmp)
636 : : {
637 : 158 : gfc_add_modify (block, vptr_ref,
638 : 158 : fold_convert (TREE_TYPE (vptr_ref), tmp));
639 : 158 : return;
640 : : }
641 : 36 : if (VAR_P (from)
642 : 36 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
643 : : {
644 : 36 : gfc_add_modify (block, vptr_ref,
645 : 36 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
646 : 36 : return;
647 : : }
648 : 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
649 : 0 : && GFC_CLASS_TYPE_P (
650 : : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
651 : : {
652 : 0 : gfc_add_modify (block, vptr_ref,
653 : 0 : fold_convert (TREE_TYPE (vptr_ref),
654 : : gfc_get_vptr_from_expr (TREE_OPERAND (
655 : : TREE_OPERAND (from, 0), 0))));
656 : 0 : return;
657 : : }
658 : :
659 : : /* If nothing of the above matches, set the vtype according to the type. */
660 : 0 : tmp = TREE_TYPE (from);
661 : 0 : if (POINTER_TYPE_P (tmp))
662 : 0 : tmp = TREE_TYPE (tmp);
663 : 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
664 : : &type);
665 : 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
666 : 0 : gcc_assert (tmp);
667 : 0 : gfc_add_modify (block, vptr_ref,
668 : 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
669 : : }
670 : :
671 : : /* Reset the len for unlimited polymorphic objects. */
672 : :
673 : : void
674 : 581 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
675 : : {
676 : 581 : gfc_expr *e;
677 : 581 : gfc_se se_len;
678 : 581 : e = gfc_find_and_cut_at_last_class_ref (expr);
679 : 581 : if (e == NULL)
680 : 0 : return;
681 : 581 : gfc_add_len_component (e);
682 : 581 : gfc_init_se (&se_len, NULL);
683 : 581 : gfc_conv_expr (&se_len, e);
684 : 581 : gfc_add_modify (block, se_len.expr,
685 : 581 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
686 : 581 : gfc_free_expr (e);
687 : : }
688 : :
689 : :
690 : : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
691 : : reference is found. Note that it is up to the caller to avoid using this
692 : : for expressions other than variables. */
693 : :
694 : : tree
695 : 1284 : gfc_get_class_from_gfc_expr (gfc_expr *e)
696 : : {
697 : 1284 : gfc_expr *class_expr;
698 : 1284 : gfc_se cse;
699 : 1284 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
700 : 1284 : if (class_expr == NULL)
701 : : return NULL_TREE;
702 : 1284 : gfc_init_se (&cse, NULL);
703 : 1284 : gfc_conv_expr (&cse, class_expr);
704 : 1284 : gfc_free_expr (class_expr);
705 : 1284 : return cse.expr;
706 : : }
707 : :
708 : :
709 : : /* Obtain the last class reference in an expression.
710 : : Return NULL_TREE if no class reference is found. */
711 : :
712 : : tree
713 : 103483 : gfc_get_class_from_expr (tree expr)
714 : : {
715 : 103483 : tree tmp;
716 : 103483 : tree type;
717 : 103483 : bool array_descr_found = false;
718 : 103483 : bool comp_after_descr_found = false;
719 : :
720 : 269527 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
721 : : {
722 : 269527 : if (CONSTANT_CLASS_P (tmp))
723 : : return NULL_TREE;
724 : :
725 : 269490 : type = TREE_TYPE (tmp);
726 : 313407 : while (type)
727 : : {
728 : 305801 : if (GFC_CLASS_TYPE_P (type))
729 : : return tmp;
730 : 286844 : if (GFC_DESCRIPTOR_TYPE_P (type))
731 : 35080 : array_descr_found = true;
732 : 286844 : if (type != TYPE_CANONICAL (type))
733 : 43917 : type = TYPE_CANONICAL (type);
734 : : else
735 : : type = NULL_TREE;
736 : : }
737 : 250533 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
738 : : break;
739 : :
740 : : /* Avoid walking up the reference chain too far. For class arrays, the
741 : : array descriptor is a direct component (through a pointer) of the class
742 : : container. So there is exactly one COMPONENT_REF between a class
743 : : container and its child array descriptor. After seeing an array
744 : : descriptor, we can give up on the second COMPONENT_REF we see, if no
745 : : class container was found until that point. */
746 : 166044 : if (array_descr_found)
747 : : {
748 : 7129 : if (comp_after_descr_found)
749 : : {
750 : 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
751 : : return NULL_TREE;
752 : : }
753 : 7117 : else if (TREE_CODE (tmp) == COMPONENT_REF)
754 : 7129 : comp_after_descr_found = true;
755 : : }
756 : : }
757 : :
758 : 84489 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
759 : 55426 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
760 : :
761 : 84489 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
762 : : return tmp;
763 : :
764 : : return NULL_TREE;
765 : : }
766 : :
767 : :
768 : : /* Obtain the vptr of the last class reference in an expression.
769 : : Return NULL_TREE if no class reference is found. */
770 : :
771 : : tree
772 : 11150 : gfc_get_vptr_from_expr (tree expr)
773 : : {
774 : 11150 : tree tmp;
775 : :
776 : 11150 : tmp = gfc_get_class_from_expr (expr);
777 : :
778 : 11150 : if (tmp != NULL_TREE)
779 : 11097 : return gfc_class_vptr_get (tmp);
780 : :
781 : : return NULL_TREE;
782 : : }
783 : :
784 : : void
785 : 1988 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
786 : : bool lhs_type)
787 : : {
788 : 1988 : tree tmp, tmp2, type;
789 : :
790 : 1988 : gfc_conv_descriptor_data_set (block, lhs_desc,
791 : : gfc_conv_descriptor_data_get (rhs_desc));
792 : 1988 : gfc_conv_descriptor_offset_set (block, lhs_desc,
793 : : gfc_conv_descriptor_offset_get (rhs_desc));
794 : :
795 : 1988 : gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
796 : : gfc_conv_descriptor_dtype (rhs_desc));
797 : :
798 : : /* Assign the dimension as range-ref. */
799 : 1988 : tmp = gfc_get_descriptor_dimension (lhs_desc);
800 : 1988 : tmp2 = gfc_get_descriptor_dimension (rhs_desc);
801 : :
802 : 1988 : type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
803 : 1988 : tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
804 : : gfc_index_zero_node, NULL_TREE, NULL_TREE);
805 : 1988 : tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
806 : : gfc_index_zero_node, NULL_TREE, NULL_TREE);
807 : 1988 : gfc_add_modify (block, tmp, tmp2);
808 : 1988 : }
809 : :
810 : : /* Takes a derived type expression and returns the address of a temporary
811 : : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
812 : : used for the temporary class object.
813 : : optional_alloc_ptr is false when the dummy is neither allocatable
814 : : nor a pointer; that's only relevant for the optional handling.
815 : : The optional argument 'derived_array' is used to preserve the parmse
816 : : expression for deallocation of allocatable components. Assumed rank
817 : : formal arguments made this necessary. */
818 : : void
819 : 4763 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
820 : : tree opt_vptr_src, bool optional,
821 : : bool optional_alloc_ptr, const char *proc_name,
822 : : tree *derived_array)
823 : : {
824 : 4763 : tree cond_optional = NULL_TREE;
825 : 4763 : gfc_ss *ss;
826 : 4763 : tree ctree;
827 : 4763 : tree var;
828 : 4763 : tree tmp;
829 : 4763 : tree packed = NULL_TREE;
830 : :
831 : : /* The derived type needs to be converted to a temporary CLASS object. */
832 : 4763 : tmp = gfc_typenode_for_spec (&fsym->ts);
833 : 4763 : var = gfc_create_var (tmp, "class");
834 : :
835 : : /* Set the vptr. */
836 : 4763 : if (opt_vptr_src)
837 : 116 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
838 : : else
839 : 4647 : gfc_reset_vptr (&parmse->pre, e, var);
840 : :
841 : : /* Now set the data field. */
842 : 4763 : ctree = gfc_class_data_get (var);
843 : :
844 : 4763 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
845 : : {
846 : 2 : tree token;
847 : 2 : tmp = gfc_get_tree_for_caf_expr (e);
848 : 2 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
849 : 1 : tmp = build_fold_indirect_ref (tmp);
850 : 2 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
851 : 2 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), token);
852 : : }
853 : :
854 : 4763 : if (optional)
855 : 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
856 : :
857 : : /* Set the _len as early as possible. */
858 : 4763 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
859 : 4763 : && fsym->ts.u.derived->components->ts.u.derived->attr
860 : 4763 : .unlimited_polymorphic)
861 : : {
862 : : /* Take care about initializing the _len component correctly. */
863 : 386 : tree len_tree = gfc_class_len_get (var);
864 : 386 : if (UNLIMITED_POLY (e))
865 : : {
866 : 12 : gfc_expr *len;
867 : 12 : gfc_se se;
868 : :
869 : 12 : len = gfc_find_and_cut_at_last_class_ref (e);
870 : 12 : gfc_add_len_component (len);
871 : 12 : gfc_init_se (&se, NULL);
872 : 12 : gfc_conv_expr (&se, len);
873 : 12 : if (optional)
874 : 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
875 : : cond_optional, se.expr,
876 : 0 : fold_convert (TREE_TYPE (se.expr),
877 : : integer_zero_node));
878 : : else
879 : 12 : tmp = se.expr;
880 : 12 : gfc_free_expr (len);
881 : 12 : }
882 : : else
883 : 374 : tmp = integer_zero_node;
884 : 386 : gfc_add_modify (&parmse->pre, len_tree,
885 : 386 : fold_convert (TREE_TYPE (len_tree), tmp));
886 : : }
887 : :
888 : 4763 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
889 : : {
890 : : /* If there is a ready made pointer to a derived type, use it
891 : : rather than evaluating the expression again. */
892 : 504 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
893 : 504 : gfc_add_modify (&parmse->pre, ctree, tmp);
894 : : }
895 : 4259 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
896 : : {
897 : : /* For an array reference in an elemental procedure call we need
898 : : to retain the ss to provide the scalarized array reference. */
899 : 252 : gfc_conv_expr_reference (parmse, e);
900 : 252 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
901 : 252 : if (optional)
902 : 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
903 : : cond_optional, tmp,
904 : 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
905 : 252 : gfc_add_modify (&parmse->pre, ctree, tmp);
906 : : }
907 : : else
908 : : {
909 : 4007 : ss = gfc_walk_expr (e);
910 : 4007 : if (ss == gfc_ss_terminator)
911 : : {
912 : 2796 : parmse->ss = NULL;
913 : 2796 : gfc_conv_expr_reference (parmse, e);
914 : :
915 : : /* Scalar to an assumed-rank array. */
916 : 2796 : if (fsym->ts.u.derived->components->as)
917 : : {
918 : 321 : tree type;
919 : 321 : type = get_scalar_to_descriptor_type (parmse->expr,
920 : : gfc_expr_attr (e));
921 : 321 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
922 : : gfc_get_dtype (type));
923 : 321 : if (optional)
924 : 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
925 : 96 : TREE_TYPE (parmse->expr),
926 : : cond_optional, parmse->expr,
927 : 96 : fold_convert (TREE_TYPE (parmse->expr),
928 : : null_pointer_node));
929 : 321 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
930 : : }
931 : : else
932 : : {
933 : 2475 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
934 : 2475 : if (optional)
935 : 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
936 : : cond_optional, tmp,
937 : 132 : fold_convert (TREE_TYPE (tmp),
938 : : null_pointer_node));
939 : 2475 : gfc_add_modify (&parmse->pre, ctree, tmp);
940 : : }
941 : : }
942 : : else
943 : : {
944 : 1211 : stmtblock_t block;
945 : 1211 : gfc_init_block (&block);
946 : 1211 : gfc_ref *ref;
947 : 1211 : int dim;
948 : 1211 : tree lbshift = NULL_TREE;
949 : :
950 : : /* Array refs with sections indicate, that a for a formal argument
951 : : expecting contiguous repacking needs to be done. */
952 : 2271 : for (ref = e->ref; ref; ref = ref->next)
953 : 1210 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
954 : : break;
955 : 1211 : if (IS_CLASS_ARRAY (fsym)
956 : 1103 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
957 : 845 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
958 : 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
959 : 144 : fsym->attr.contiguous = 1;
960 : :
961 : : /* Detect any array references with vector subscripts. */
962 : 2415 : for (ref = e->ref; ref; ref = ref->next)
963 : 1210 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
964 : 1168 : && ref->u.ar.type != AR_FULL)
965 : : {
966 : 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
967 : 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
968 : : break;
969 : 150 : if (dim < ref->u.ar.dimen)
970 : : break;
971 : : }
972 : : /* Array references with vector subscripts and non-variable
973 : : expressions need be converted to a one-based descriptor. */
974 : 1211 : if (ref || e->expr_type != EXPR_VARIABLE)
975 : 49 : lbshift = gfc_index_one_node;
976 : :
977 : 1211 : parmse->expr = var;
978 : 1211 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
979 : : &lbshift, &packed);
980 : :
981 : 1211 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
982 : : {
983 : 1115 : *derived_array
984 : 1115 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
985 : 1115 : gfc_add_modify (&block, *derived_array, parmse->expr);
986 : : }
987 : :
988 : 1211 : if (optional)
989 : : {
990 : 348 : tmp = gfc_finish_block (&block);
991 : :
992 : 348 : gfc_init_block (&block);
993 : 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
994 : 348 : if (derived_array && *derived_array != NULL_TREE)
995 : 348 : gfc_conv_descriptor_data_set (&block, *derived_array,
996 : : null_pointer_node);
997 : :
998 : 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
999 : : gfc_finish_block (&block));
1000 : 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
1001 : : }
1002 : : else
1003 : 863 : gfc_add_block_to_block (&parmse->pre, &block);
1004 : : }
1005 : : }
1006 : :
1007 : : /* Pass the address of the class object. */
1008 : 4763 : if (packed)
1009 : 96 : parmse->expr = packed;
1010 : : else
1011 : 4667 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1012 : :
1013 : 4763 : if (optional && optional_alloc_ptr)
1014 : 84 : parmse->expr
1015 : 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1016 : : cond_optional, parmse->expr,
1017 : 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1018 : 4763 : }
1019 : :
1020 : : /* Create a new class container, which is required as scalar coarrays
1021 : : have an array descriptor while normal scalars haven't. Optionally,
1022 : : NULL pointer checks are added if the argument is OPTIONAL. */
1023 : :
1024 : : static void
1025 : 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1026 : : gfc_typespec class_ts, bool optional)
1027 : : {
1028 : 48 : tree var, ctree, tmp;
1029 : 48 : stmtblock_t block;
1030 : 48 : gfc_ref *ref;
1031 : 48 : gfc_ref *class_ref;
1032 : :
1033 : 48 : gfc_init_block (&block);
1034 : :
1035 : 48 : class_ref = NULL;
1036 : 144 : for (ref = e->ref; ref; ref = ref->next)
1037 : : {
1038 : 96 : if (ref->type == REF_COMPONENT
1039 : 48 : && ref->u.c.component->ts.type == BT_CLASS)
1040 : 96 : class_ref = ref;
1041 : : }
1042 : :
1043 : 48 : if (class_ref == NULL
1044 : 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1045 : 48 : tmp = e->symtree->n.sym->backend_decl;
1046 : : else
1047 : : {
1048 : : /* Remove everything after the last class reference, convert the
1049 : : expression and then recover its tailend once more. */
1050 : 0 : gfc_se tmpse;
1051 : 0 : ref = class_ref->next;
1052 : 0 : class_ref->next = NULL;
1053 : 0 : gfc_init_se (&tmpse, NULL);
1054 : 0 : gfc_conv_expr (&tmpse, e);
1055 : 0 : class_ref->next = ref;
1056 : 0 : tmp = tmpse.expr;
1057 : : }
1058 : :
1059 : 48 : var = gfc_typenode_for_spec (&class_ts);
1060 : 48 : var = gfc_create_var (var, "class");
1061 : :
1062 : 48 : ctree = gfc_class_vptr_get (var);
1063 : 96 : gfc_add_modify (&block, ctree,
1064 : 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1065 : :
1066 : 48 : ctree = gfc_class_data_get (var);
1067 : 48 : tmp = gfc_conv_descriptor_data_get (
1068 : 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1069 : : ? tmp
1070 : 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1071 : 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1072 : :
1073 : : /* Pass the address of the class object. */
1074 : 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1075 : :
1076 : 48 : if (optional)
1077 : : {
1078 : 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1079 : 48 : tree tmp2;
1080 : :
1081 : 48 : tmp = gfc_finish_block (&block);
1082 : :
1083 : 48 : gfc_init_block (&block);
1084 : 48 : tmp2 = gfc_class_data_get (var);
1085 : 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1086 : : null_pointer_node));
1087 : 48 : tmp2 = gfc_finish_block (&block);
1088 : :
1089 : 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1090 : : cond, tmp, tmp2);
1091 : 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1092 : : }
1093 : : else
1094 : 0 : gfc_add_block_to_block (&parmse->pre, &block);
1095 : 48 : }
1096 : :
1097 : :
1098 : : /* Takes an intrinsic type expression and returns the address of a temporary
1099 : : class object of the 'declared' type. */
1100 : : void
1101 : 882 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1102 : : gfc_typespec class_ts)
1103 : : {
1104 : 882 : gfc_symbol *vtab;
1105 : 882 : gfc_ss *ss;
1106 : 882 : tree ctree;
1107 : 882 : tree var;
1108 : 882 : tree tmp;
1109 : 882 : int dim;
1110 : 882 : bool unlimited_poly;
1111 : :
1112 : 1764 : unlimited_poly = class_ts.type == BT_CLASS
1113 : 882 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1114 : 882 : && class_ts.u.derived->components->ts.u.derived
1115 : 882 : ->attr.unlimited_polymorphic;
1116 : :
1117 : : /* The intrinsic type needs to be converted to a temporary
1118 : : CLASS object. */
1119 : 882 : tmp = gfc_typenode_for_spec (&class_ts);
1120 : 882 : var = gfc_create_var (tmp, "class");
1121 : :
1122 : : /* Force a temporary for component or substring references. */
1123 : 882 : if (unlimited_poly
1124 : 882 : && class_ts.u.derived->components->attr.dimension
1125 : 623 : && !class_ts.u.derived->components->attr.allocatable
1126 : 623 : && !class_ts.u.derived->components->attr.class_pointer
1127 : 1505 : && is_subref_array (e))
1128 : 17 : parmse->force_tmp = 1;
1129 : :
1130 : : /* Set the vptr. */
1131 : 882 : ctree = gfc_class_vptr_get (var);
1132 : :
1133 : 882 : vtab = gfc_find_vtab (&e->ts);
1134 : 882 : gcc_assert (vtab);
1135 : 882 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1136 : 882 : gfc_add_modify (&parmse->pre, ctree,
1137 : 882 : fold_convert (TREE_TYPE (ctree), tmp));
1138 : :
1139 : : /* Now set the data field. */
1140 : 882 : ctree = gfc_class_data_get (var);
1141 : 882 : if (parmse->ss && parmse->ss->info->useflags)
1142 : : {
1143 : : /* For an array reference in an elemental procedure call we need
1144 : : to retain the ss to provide the scalarized array reference. */
1145 : 36 : gfc_conv_expr_reference (parmse, e);
1146 : 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1147 : 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1148 : : }
1149 : : else
1150 : : {
1151 : 846 : ss = gfc_walk_expr (e);
1152 : 846 : if (ss == gfc_ss_terminator)
1153 : : {
1154 : 247 : parmse->ss = NULL;
1155 : 247 : gfc_conv_expr_reference (parmse, e);
1156 : 247 : if (class_ts.u.derived->components->as
1157 : 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1158 : : {
1159 : 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1160 : : gfc_expr_attr (e));
1161 : 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1162 : 24 : TREE_TYPE (ctree), tmp);
1163 : : }
1164 : : else
1165 : 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1166 : 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1167 : : }
1168 : : else
1169 : : {
1170 : 599 : parmse->ss = ss;
1171 : 599 : gfc_conv_expr_descriptor (parmse, e);
1172 : :
1173 : : /* Array references with vector subscripts and non-variable expressions
1174 : : need be converted to a one-based descriptor. */
1175 : 599 : if (e->expr_type != EXPR_VARIABLE)
1176 : : {
1177 : 368 : for (dim = 0; dim < e->rank; ++dim)
1178 : 193 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1179 : : dim, gfc_index_one_node);
1180 : : }
1181 : :
1182 : 599 : if (class_ts.u.derived->components->as->rank != e->rank)
1183 : : {
1184 : 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1185 : 49 : TREE_TYPE (ctree), parmse->expr);
1186 : 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1187 : : }
1188 : : else
1189 : 550 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1190 : : }
1191 : : }
1192 : :
1193 : 882 : gcc_assert (class_ts.type == BT_CLASS);
1194 : 882 : if (unlimited_poly)
1195 : : {
1196 : 882 : ctree = gfc_class_len_get (var);
1197 : : /* When the actual arg is a char array, then set the _len component of the
1198 : : unlimited polymorphic entity to the length of the string. */
1199 : 882 : if (e->ts.type == BT_CHARACTER)
1200 : : {
1201 : : /* Start with parmse->string_length because this seems to be set to a
1202 : : correct value more often. */
1203 : 175 : if (parmse->string_length)
1204 : : tmp = parmse->string_length;
1205 : : /* When the string_length is not yet set, then try the backend_decl of
1206 : : the cl. */
1207 : 0 : else if (e->ts.u.cl->backend_decl)
1208 : : tmp = e->ts.u.cl->backend_decl;
1209 : : /* If both of the above approaches fail, then try to generate an
1210 : : expression from the input, which is only feasible currently, when the
1211 : : expression can be evaluated to a constant one. */
1212 : : else
1213 : : {
1214 : : /* Try to simplify the expression. */
1215 : 0 : gfc_simplify_expr (e, 0);
1216 : 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1217 : : {
1218 : : /* Amazingly all data is present to compute the length of a
1219 : : constant string, but the expression is not yet there. */
1220 : 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1221 : : gfc_charlen_int_kind,
1222 : : &e->where);
1223 : 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1224 : 0 : e->value.character.length);
1225 : 0 : gfc_conv_const_charlen (e->ts.u.cl);
1226 : 0 : e->ts.u.cl->resolved = 1;
1227 : 0 : tmp = e->ts.u.cl->backend_decl;
1228 : : }
1229 : : else
1230 : : {
1231 : 0 : gfc_error ("Cannot compute the length of the char array "
1232 : : "at %L.", &e->where);
1233 : : }
1234 : : }
1235 : : }
1236 : : else
1237 : 707 : tmp = integer_zero_node;
1238 : :
1239 : 882 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1240 : : }
1241 : :
1242 : : /* Pass the address of the class object. */
1243 : 882 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1244 : 882 : }
1245 : :
1246 : :
1247 : : /* Takes a scalarized class array expression and returns the
1248 : : address of a temporary scalar class object of the 'declared'
1249 : : type.
1250 : : OOP-TODO: This could be improved by adding code that branched on
1251 : : the dynamic type being the same as the declared type. In this case
1252 : : the original class expression can be passed directly.
1253 : : optional_alloc_ptr is false when the dummy is neither allocatable
1254 : : nor a pointer; that's relevant for the optional handling.
1255 : : Set copyback to true if class container's _data and _vtab pointers
1256 : : might get modified. */
1257 : :
1258 : : void
1259 : 3439 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1260 : : bool elemental, bool copyback, bool optional,
1261 : : bool optional_alloc_ptr)
1262 : : {
1263 : 3439 : tree ctree;
1264 : 3439 : tree var;
1265 : 3439 : tree tmp;
1266 : 3439 : tree vptr;
1267 : 3439 : tree cond = NULL_TREE;
1268 : 3439 : tree slen = NULL_TREE;
1269 : 3439 : gfc_ref *ref;
1270 : 3439 : gfc_ref *class_ref;
1271 : 3439 : stmtblock_t block;
1272 : 3439 : bool full_array = false;
1273 : :
1274 : : /* Class transformational function results are the data field of a class
1275 : : temporary and so the class expression can be obtained directly. */
1276 : 3439 : if (e->expr_type == EXPR_FUNCTION
1277 : 168 : && e->value.function.isym
1278 : 30 : && e->value.function.isym->transformational
1279 : 30 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1280 : 3463 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr)))
1281 : : {
1282 : 24 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1283 : 24 : if (!VAR_P (parmse->expr))
1284 : 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1285 : 24 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1286 : 162 : return;
1287 : : }
1288 : :
1289 : 3415 : gfc_init_block (&block);
1290 : :
1291 : 3415 : class_ref = NULL;
1292 : 6845 : for (ref = e->ref; ref; ref = ref->next)
1293 : : {
1294 : 6469 : if (ref->type == REF_COMPONENT
1295 : 3464 : && ref->u.c.component->ts.type == BT_CLASS)
1296 : 6469 : class_ref = ref;
1297 : :
1298 : 6469 : if (ref->next == NULL)
1299 : : break;
1300 : : }
1301 : :
1302 : 3415 : if ((ref == NULL || class_ref == ref)
1303 : 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1304 : 3885 : && (!class_ts.u.derived->components->as
1305 : 379 : || class_ts.u.derived->components->as->rank != -1))
1306 : : return;
1307 : :
1308 : : /* Test for FULL_ARRAY. */
1309 : 3277 : if (e->rank == 0
1310 : 3277 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1311 : 493 : || (class_ts.u.derived->components->as
1312 : 365 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1313 : 407 : full_array = true;
1314 : : else
1315 : 2870 : gfc_is_class_array_ref (e, &full_array);
1316 : :
1317 : : /* The derived type needs to be converted to a temporary
1318 : : CLASS object. */
1319 : 3277 : tmp = gfc_typenode_for_spec (&class_ts);
1320 : 3277 : var = gfc_create_var (tmp, "class");
1321 : :
1322 : : /* Set the data. */
1323 : 3277 : ctree = gfc_class_data_get (var);
1324 : 3277 : if (class_ts.u.derived->components->as
1325 : 3017 : && e->rank != class_ts.u.derived->components->as->rank)
1326 : : {
1327 : 965 : if (e->rank == 0)
1328 : : {
1329 : 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1330 : : gfc_expr_attr (e));
1331 : 356 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1332 : : gfc_get_dtype (type));
1333 : :
1334 : 356 : tmp = gfc_class_data_get (parmse->expr);
1335 : 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1336 : 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1337 : :
1338 : 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1339 : : }
1340 : : else
1341 : 609 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1342 : : }
1343 : : else
1344 : : {
1345 : 2312 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1346 : 1335 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1347 : 1335 : TREE_TYPE (ctree), parmse->expr);
1348 : 2312 : gfc_add_modify (&block, ctree, parmse->expr);
1349 : : }
1350 : :
1351 : : /* Return the data component, except in the case of scalarized array
1352 : : references, where nullification of the cannot occur and so there
1353 : : is no need. */
1354 : 3277 : if (!elemental && full_array && copyback)
1355 : : {
1356 : 1128 : if (class_ts.u.derived->components->as
1357 : 1128 : && e->rank != class_ts.u.derived->components->as->rank)
1358 : : {
1359 : 270 : if (e->rank == 0)
1360 : : {
1361 : 102 : tmp = gfc_class_data_get (parmse->expr);
1362 : 204 : gfc_add_modify (&parmse->post, tmp,
1363 : 102 : fold_convert (TREE_TYPE (tmp),
1364 : : gfc_conv_descriptor_data_get (ctree)));
1365 : : }
1366 : : else
1367 : 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1368 : : true);
1369 : : }
1370 : : else
1371 : 858 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1372 : : }
1373 : :
1374 : : /* Set the vptr. */
1375 : 3277 : ctree = gfc_class_vptr_get (var);
1376 : :
1377 : : /* The vptr is the second field of the actual argument.
1378 : : First we have to find the corresponding class reference. */
1379 : :
1380 : 3277 : tmp = NULL_TREE;
1381 : 3277 : if (gfc_is_class_array_function (e)
1382 : 3277 : && parmse->class_vptr != NULL_TREE)
1383 : : tmp = parmse->class_vptr;
1384 : 3259 : else if (class_ref == NULL
1385 : 2816 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1386 : : {
1387 : 2816 : tmp = e->symtree->n.sym->backend_decl;
1388 : :
1389 : 2816 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1390 : 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1391 : :
1392 : 2816 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1393 : 372 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1394 : :
1395 : 2816 : slen = build_zero_cst (size_type_node);
1396 : : }
1397 : 443 : else if (parmse->class_container != NULL_TREE)
1398 : : /* Don't redundantly evaluate the expression if the required information
1399 : : is already available. */
1400 : : tmp = parmse->class_container;
1401 : : else
1402 : : {
1403 : : /* Remove everything after the last class reference, convert the
1404 : : expression and then recover its tailend once more. */
1405 : 18 : gfc_se tmpse;
1406 : 18 : ref = class_ref->next;
1407 : 18 : class_ref->next = NULL;
1408 : 18 : gfc_init_se (&tmpse, NULL);
1409 : 18 : gfc_conv_expr (&tmpse, e);
1410 : 18 : class_ref->next = ref;
1411 : 18 : tmp = tmpse.expr;
1412 : 18 : slen = tmpse.string_length;
1413 : : }
1414 : :
1415 : 3277 : gcc_assert (tmp != NULL_TREE);
1416 : :
1417 : : /* Dereference if needs be. */
1418 : 3277 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1419 : 320 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1420 : :
1421 : 3277 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1422 : 3259 : vptr = gfc_class_vptr_get (tmp);
1423 : : else
1424 : : vptr = tmp;
1425 : :
1426 : 3277 : gfc_add_modify (&block, ctree,
1427 : 3277 : fold_convert (TREE_TYPE (ctree), vptr));
1428 : :
1429 : : /* Return the vptr component, except in the case of scalarized array
1430 : : references, where the dynamic type cannot change. */
1431 : 3277 : if (!elemental && full_array && copyback)
1432 : 1128 : gfc_add_modify (&parmse->post, vptr,
1433 : 1128 : fold_convert (TREE_TYPE (vptr), ctree));
1434 : :
1435 : : /* For unlimited polymorphic objects also set the _len component. */
1436 : 3277 : if (class_ts.type == BT_CLASS
1437 : 3277 : && class_ts.u.derived->components
1438 : 3277 : && class_ts.u.derived->components->ts.u
1439 : 3277 : .derived->attr.unlimited_polymorphic)
1440 : : {
1441 : 1013 : ctree = gfc_class_len_get (var);
1442 : 1013 : if (UNLIMITED_POLY (e))
1443 : 817 : tmp = gfc_class_len_get (tmp);
1444 : 196 : else if (e->ts.type == BT_CHARACTER)
1445 : : {
1446 : 0 : gcc_assert (slen != NULL_TREE);
1447 : : tmp = slen;
1448 : : }
1449 : : else
1450 : 196 : tmp = build_zero_cst (size_type_node);
1451 : 1013 : gfc_add_modify (&parmse->pre, ctree,
1452 : 1013 : fold_convert (TREE_TYPE (ctree), tmp));
1453 : :
1454 : : /* Return the len component, except in the case of scalarized array
1455 : : references, where the dynamic type cannot change. */
1456 : 1013 : if (!elemental && full_array && copyback
1457 : 440 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1458 : 428 : gfc_add_modify (&parmse->post, tmp,
1459 : 428 : fold_convert (TREE_TYPE (tmp), ctree));
1460 : : }
1461 : :
1462 : 3277 : if (optional)
1463 : : {
1464 : 510 : tree tmp2;
1465 : :
1466 : 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1467 : : /* parmse->pre may contain some preparatory instructions for the
1468 : : temporary array descriptor. Those may only be executed when the
1469 : : optional argument is set, therefore add parmse->pre's instructions
1470 : : to block, which is later guarded by an if (optional_arg_given). */
1471 : 510 : gfc_add_block_to_block (&parmse->pre, &block);
1472 : 510 : block.head = parmse->pre.head;
1473 : 510 : parmse->pre.head = NULL_TREE;
1474 : 510 : tmp = gfc_finish_block (&block);
1475 : :
1476 : 510 : if (optional_alloc_ptr)
1477 : 102 : tmp2 = build_empty_stmt (input_location);
1478 : : else
1479 : : {
1480 : 408 : gfc_init_block (&block);
1481 : :
1482 : 408 : tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1483 : 408 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1484 : : null_pointer_node));
1485 : 408 : tmp2 = gfc_finish_block (&block);
1486 : : }
1487 : :
1488 : 510 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1489 : : cond, tmp, tmp2);
1490 : 510 : gfc_add_expr_to_block (&parmse->pre, tmp);
1491 : :
1492 : 510 : if (!elemental && full_array && copyback)
1493 : : {
1494 : 30 : tmp2 = build_empty_stmt (input_location);
1495 : 30 : tmp = gfc_finish_block (&parmse->post);
1496 : 30 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1497 : : cond, tmp, tmp2);
1498 : 30 : gfc_add_expr_to_block (&parmse->post, tmp);
1499 : : }
1500 : : }
1501 : : else
1502 : 2767 : gfc_add_block_to_block (&parmse->pre, &block);
1503 : :
1504 : : /* Pass the address of the class object. */
1505 : 3277 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1506 : :
1507 : 3277 : if (optional && optional_alloc_ptr)
1508 : 204 : parmse->expr = build3_loc (input_location, COND_EXPR,
1509 : 102 : TREE_TYPE (parmse->expr),
1510 : : cond, parmse->expr,
1511 : 102 : fold_convert (TREE_TYPE (parmse->expr),
1512 : : null_pointer_node));
1513 : : }
1514 : :
1515 : :
1516 : : /* Given a class array declaration and an index, returns the address
1517 : : of the referenced element. */
1518 : :
1519 : : static tree
1520 : 720 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1521 : : bool unlimited)
1522 : : {
1523 : 720 : tree data, size, tmp, ctmp, offset, ptr;
1524 : :
1525 : 720 : data = data_comp != NULL_TREE ? data_comp :
1526 : 0 : gfc_class_data_get (class_decl);
1527 : 720 : size = gfc_class_vtab_size_get (class_decl);
1528 : :
1529 : 720 : if (unlimited)
1530 : : {
1531 : 200 : tmp = fold_convert (gfc_array_index_type,
1532 : : gfc_class_len_get (class_decl));
1533 : 200 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1534 : : gfc_array_index_type, size, tmp);
1535 : 200 : tmp = fold_build2_loc (input_location, GT_EXPR,
1536 : : logical_type_node, tmp,
1537 : 200 : build_zero_cst (TREE_TYPE (tmp)));
1538 : 200 : size = fold_build3_loc (input_location, COND_EXPR,
1539 : : gfc_array_index_type, tmp, ctmp, size);
1540 : : }
1541 : :
1542 : 720 : offset = fold_build2_loc (input_location, MULT_EXPR,
1543 : : gfc_array_index_type,
1544 : : index, size);
1545 : :
1546 : 720 : data = gfc_conv_descriptor_data_get (data);
1547 : 720 : ptr = fold_convert (pvoid_type_node, data);
1548 : 720 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1549 : 720 : return fold_convert (TREE_TYPE (data), ptr);
1550 : : }
1551 : :
1552 : :
1553 : : /* Copies one class expression to another, assuming that if either
1554 : : 'to' or 'from' are arrays they are packed. Should 'from' be
1555 : : NULL_TREE, the initialization expression for 'to' is used, assuming
1556 : : that the _vptr is set. */
1557 : :
1558 : : tree
1559 : 758 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1560 : : {
1561 : 758 : tree fcn;
1562 : 758 : tree fcn_type;
1563 : 758 : tree from_data;
1564 : 758 : tree from_len;
1565 : 758 : tree to_data;
1566 : 758 : tree to_len;
1567 : 758 : tree to_ref;
1568 : 758 : tree from_ref;
1569 : 758 : vec<tree, va_gc> *args;
1570 : 758 : tree tmp;
1571 : 758 : tree stdcopy;
1572 : 758 : tree extcopy;
1573 : 758 : tree index;
1574 : 758 : bool is_from_desc = false, is_to_class = false;
1575 : :
1576 : 758 : args = NULL;
1577 : : /* To prevent warnings on uninitialized variables. */
1578 : 758 : from_len = to_len = NULL_TREE;
1579 : :
1580 : 758 : if (from != NULL_TREE)
1581 : 758 : fcn = gfc_class_vtab_copy_get (from);
1582 : : else
1583 : 0 : fcn = gfc_class_vtab_copy_get (to);
1584 : :
1585 : 758 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1586 : :
1587 : 758 : if (from != NULL_TREE)
1588 : : {
1589 : 758 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1590 : 758 : if (is_from_desc)
1591 : : {
1592 : 0 : from_data = from;
1593 : 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1594 : : }
1595 : : else
1596 : : {
1597 : : /* Check that from is a class. When the class is part of a coarray,
1598 : : then from is a common pointer and is to be used as is. */
1599 : 1516 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1600 : 758 : ? build_fold_indirect_ref (from) : from;
1601 : 1516 : from_data =
1602 : 758 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1603 : 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1604 : 758 : ? gfc_class_data_get (from) : from;
1605 : 758 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1606 : : }
1607 : : }
1608 : : else
1609 : 0 : from_data = gfc_class_vtab_def_init_get (to);
1610 : :
1611 : 758 : if (unlimited)
1612 : : {
1613 : 159 : if (from != NULL_TREE && unlimited)
1614 : 159 : from_len = gfc_class_len_or_zero_get (from);
1615 : : else
1616 : 0 : from_len = build_zero_cst (size_type_node);
1617 : : }
1618 : :
1619 : 758 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1620 : : {
1621 : 758 : is_to_class = true;
1622 : 758 : to_data = gfc_class_data_get (to);
1623 : 758 : if (unlimited)
1624 : 159 : to_len = gfc_class_len_get (to);
1625 : : }
1626 : : else
1627 : : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1628 : 0 : to_data = to;
1629 : :
1630 : 758 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1631 : : {
1632 : 360 : stmtblock_t loopbody;
1633 : 360 : stmtblock_t body;
1634 : 360 : stmtblock_t ifbody;
1635 : 360 : gfc_loopinfo loop;
1636 : :
1637 : 360 : gfc_init_block (&body);
1638 : 360 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1639 : : gfc_array_index_type, nelems,
1640 : : gfc_index_one_node);
1641 : 360 : nelems = gfc_evaluate_now (tmp, &body);
1642 : 360 : index = gfc_create_var (gfc_array_index_type, "S");
1643 : :
1644 : 360 : if (is_from_desc)
1645 : : {
1646 : 360 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1647 : : unlimited);
1648 : 360 : vec_safe_push (args, from_ref);
1649 : : }
1650 : : else
1651 : 0 : vec_safe_push (args, from_data);
1652 : :
1653 : 360 : if (is_to_class)
1654 : 360 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1655 : : else
1656 : : {
1657 : 0 : tmp = gfc_conv_array_data (to);
1658 : 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1659 : 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1660 : : gfc_build_array_ref (tmp, index, to));
1661 : : }
1662 : 360 : vec_safe_push (args, to_ref);
1663 : :
1664 : : /* Add bounds check. */
1665 : 360 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1666 : : {
1667 : 25 : const char *name = "<<unknown>>";
1668 : 25 : int dim, rank;
1669 : :
1670 : 25 : if (DECL_P (to))
1671 : 0 : name = IDENTIFIER_POINTER (DECL_NAME (to));
1672 : :
1673 : 25 : rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
1674 : 55 : for (dim = 1; dim <= rank; dim++)
1675 : : {
1676 : 30 : tree from_len, to_len, cond;
1677 : 30 : char *msg;
1678 : :
1679 : 30 : from_len = gfc_conv_descriptor_size (from_data, dim);
1680 : 30 : from_len = fold_convert (long_integer_type_node, from_len);
1681 : 30 : to_len = gfc_conv_descriptor_size (to_data, dim);
1682 : 30 : to_len = fold_convert (long_integer_type_node, to_len);
1683 : 30 : msg = xasprintf ("Array bound mismatch for dimension %d "
1684 : : "of array '%s' (%%ld/%%ld)",
1685 : : dim, name);
1686 : 30 : cond = fold_build2_loc (input_location, NE_EXPR,
1687 : : logical_type_node, from_len, to_len);
1688 : 30 : gfc_trans_runtime_check (true, false, cond, &body,
1689 : : NULL, msg, to_len, from_len);
1690 : 30 : free (msg);
1691 : : }
1692 : : }
1693 : :
1694 : 360 : tmp = build_call_vec (fcn_type, fcn, args);
1695 : :
1696 : : /* Build the body of the loop. */
1697 : 360 : gfc_init_block (&loopbody);
1698 : 360 : gfc_add_expr_to_block (&loopbody, tmp);
1699 : :
1700 : : /* Build the loop and return. */
1701 : 360 : gfc_init_loopinfo (&loop);
1702 : 360 : loop.dimen = 1;
1703 : 360 : loop.from[0] = gfc_index_zero_node;
1704 : 360 : loop.loopvar[0] = index;
1705 : 360 : loop.to[0] = nelems;
1706 : 360 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1707 : 360 : gfc_init_block (&ifbody);
1708 : 360 : gfc_add_block_to_block (&ifbody, &loop.pre);
1709 : 360 : stdcopy = gfc_finish_block (&ifbody);
1710 : : /* In initialization mode from_len is a constant zero. */
1711 : 360 : if (unlimited && !integer_zerop (from_len))
1712 : : {
1713 : 100 : vec_safe_push (args, from_len);
1714 : 100 : vec_safe_push (args, to_len);
1715 : 100 : tmp = build_call_vec (fcn_type, fcn, args);
1716 : : /* Build the body of the loop. */
1717 : 100 : gfc_init_block (&loopbody);
1718 : 100 : gfc_add_expr_to_block (&loopbody, tmp);
1719 : :
1720 : : /* Build the loop and return. */
1721 : 100 : gfc_init_loopinfo (&loop);
1722 : 100 : loop.dimen = 1;
1723 : 100 : loop.from[0] = gfc_index_zero_node;
1724 : 100 : loop.loopvar[0] = index;
1725 : 100 : loop.to[0] = nelems;
1726 : 100 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1727 : 100 : gfc_init_block (&ifbody);
1728 : 100 : gfc_add_block_to_block (&ifbody, &loop.pre);
1729 : 100 : extcopy = gfc_finish_block (&ifbody);
1730 : :
1731 : 100 : tmp = fold_build2_loc (input_location, GT_EXPR,
1732 : : logical_type_node, from_len,
1733 : 100 : build_zero_cst (TREE_TYPE (from_len)));
1734 : 100 : tmp = fold_build3_loc (input_location, COND_EXPR,
1735 : : void_type_node, tmp, extcopy, stdcopy);
1736 : 100 : gfc_add_expr_to_block (&body, tmp);
1737 : 100 : tmp = gfc_finish_block (&body);
1738 : : }
1739 : : else
1740 : : {
1741 : 260 : gfc_add_expr_to_block (&body, stdcopy);
1742 : 260 : tmp = gfc_finish_block (&body);
1743 : : }
1744 : 360 : gfc_cleanup_loop (&loop);
1745 : : }
1746 : : else
1747 : : {
1748 : 398 : gcc_assert (!is_from_desc);
1749 : 398 : vec_safe_push (args, from_data);
1750 : 398 : vec_safe_push (args, to_data);
1751 : 398 : stdcopy = build_call_vec (fcn_type, fcn, args);
1752 : :
1753 : : /* In initialization mode from_len is a constant zero. */
1754 : 398 : if (unlimited && !integer_zerop (from_len))
1755 : : {
1756 : 59 : vec_safe_push (args, from_len);
1757 : 59 : vec_safe_push (args, to_len);
1758 : 59 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1759 : 59 : tmp = fold_build2_loc (input_location, GT_EXPR,
1760 : : logical_type_node, from_len,
1761 : 59 : build_zero_cst (TREE_TYPE (from_len)));
1762 : 59 : tmp = fold_build3_loc (input_location, COND_EXPR,
1763 : : void_type_node, tmp, extcopy, stdcopy);
1764 : : }
1765 : : else
1766 : : tmp = stdcopy;
1767 : : }
1768 : :
1769 : : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1770 : 758 : if (from == NULL_TREE)
1771 : : {
1772 : 0 : tree cond;
1773 : 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1774 : : logical_type_node,
1775 : : from_data, null_pointer_node);
1776 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1777 : : void_type_node, cond,
1778 : : tmp, build_empty_stmt (input_location));
1779 : : }
1780 : :
1781 : 758 : return tmp;
1782 : : }
1783 : :
1784 : :
1785 : : static tree
1786 : 106 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1787 : : {
1788 : 106 : gfc_actual_arglist *actual;
1789 : 106 : gfc_expr *ppc;
1790 : 106 : gfc_code *ppc_code;
1791 : 106 : tree res;
1792 : :
1793 : 106 : actual = gfc_get_actual_arglist ();
1794 : 106 : actual->expr = gfc_copy_expr (rhs);
1795 : 106 : actual->next = gfc_get_actual_arglist ();
1796 : 106 : actual->next->expr = gfc_copy_expr (lhs);
1797 : 106 : ppc = gfc_copy_expr (obj);
1798 : 106 : gfc_add_vptr_component (ppc);
1799 : 106 : gfc_add_component_ref (ppc, "_copy");
1800 : 106 : ppc_code = gfc_get_code (EXEC_CALL);
1801 : 106 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1802 : : /* Although '_copy' is set to be elemental in class.cc, it is
1803 : : not staying that way. Find out why, sometime.... */
1804 : 106 : ppc_code->resolved_sym->attr.elemental = 1;
1805 : 106 : ppc_code->ext.actual = actual;
1806 : 106 : ppc_code->expr1 = ppc;
1807 : : /* Since '_copy' is elemental, the scalarizer will take care
1808 : : of arrays in gfc_trans_call. */
1809 : 106 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1810 : 106 : gfc_free_statements (ppc_code);
1811 : :
1812 : 106 : if (UNLIMITED_POLY(obj))
1813 : : {
1814 : : /* Check if rhs is non-NULL. */
1815 : 24 : gfc_se src;
1816 : 24 : gfc_init_se (&src, NULL);
1817 : 24 : gfc_conv_expr (&src, rhs);
1818 : 24 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1819 : 24 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1820 : 24 : src.expr, fold_convert (TREE_TYPE (src.expr),
1821 : : null_pointer_node));
1822 : 24 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1823 : : build_empty_stmt (input_location));
1824 : : }
1825 : :
1826 : 106 : return res;
1827 : : }
1828 : :
1829 : : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1830 : : A MEMCPY is needed to copy the full data from the default initializer
1831 : : of the dynamic type. */
1832 : :
1833 : : tree
1834 : 441 : gfc_trans_class_init_assign (gfc_code *code)
1835 : : {
1836 : 441 : stmtblock_t block;
1837 : 441 : tree tmp;
1838 : 441 : bool cmp_flag = true;
1839 : 441 : gfc_se dst,src,memsz;
1840 : 441 : gfc_expr *lhs, *rhs, *sz;
1841 : 441 : gfc_component *cmp;
1842 : 441 : gfc_symbol *sym;
1843 : 441 : gfc_ref *ref;
1844 : :
1845 : 441 : gfc_start_block (&block);
1846 : :
1847 : 441 : lhs = gfc_copy_expr (code->expr1);
1848 : :
1849 : 441 : rhs = gfc_copy_expr (code->expr1);
1850 : 441 : gfc_add_vptr_component (rhs);
1851 : :
1852 : : /* Make sure that the component backend_decls have been built, which
1853 : : will not have happened if the derived types concerned have not
1854 : : been referenced. */
1855 : 441 : gfc_get_derived_type (rhs->ts.u.derived);
1856 : 441 : gfc_add_def_init_component (rhs);
1857 : : /* The _def_init is always scalar. */
1858 : 441 : rhs->rank = 0;
1859 : :
1860 : : /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
1861 : : default initializer components NULL, use the passed value even though
1862 : : F2018(8.5.10) asserts that it should considered to be undefined. This is
1863 : : needed for consistency with other brands. */
1864 : 441 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1865 : : : NULL;
1866 : 441 : if (code->op != EXEC_ALLOCATE
1867 : 380 : && sym && sym->attr.dummy
1868 : 380 : && sym->attr.intent == INTENT_OUT)
1869 : : {
1870 : 380 : ref = rhs->ref;
1871 : 760 : while (ref && ref->next)
1872 : : ref = ref->next;
1873 : 380 : cmp = ref->u.c.component->ts.u.derived->components;
1874 : 591 : for (; cmp; cmp = cmp->next)
1875 : : {
1876 : 415 : if (cmp->initializer)
1877 : : break;
1878 : 211 : else if (!cmp->next)
1879 : 146 : cmp_flag = false;
1880 : : }
1881 : : }
1882 : :
1883 : 441 : if (code->expr1->ts.type == BT_CLASS
1884 : 418 : && CLASS_DATA (code->expr1)->attr.dimension)
1885 : : {
1886 : 106 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1887 : 106 : *tmparr = *CLASS_DATA (code->expr1)->as;
1888 : : /* Adding the array ref to the class expression results in correct
1889 : : indexing to the dynamic type. */
1890 : 106 : gfc_add_full_array_ref (lhs, tmparr);
1891 : 106 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1892 : 106 : }
1893 : 335 : else if (cmp_flag)
1894 : : {
1895 : : /* Scalar initialization needs the _data component. */
1896 : 202 : gfc_add_data_component (lhs);
1897 : 202 : sz = gfc_copy_expr (code->expr1);
1898 : 202 : gfc_add_vptr_component (sz);
1899 : 202 : gfc_add_size_component (sz);
1900 : :
1901 : 202 : gfc_init_se (&dst, NULL);
1902 : 202 : gfc_init_se (&src, NULL);
1903 : 202 : gfc_init_se (&memsz, NULL);
1904 : 202 : gfc_conv_expr (&dst, lhs);
1905 : 202 : gfc_conv_expr (&src, rhs);
1906 : 202 : gfc_conv_expr (&memsz, sz);
1907 : 202 : gfc_add_block_to_block (&block, &src.pre);
1908 : 202 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1909 : :
1910 : 202 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1911 : :
1912 : 202 : if (UNLIMITED_POLY(code->expr1))
1913 : : {
1914 : : /* Check if _def_init is non-NULL. */
1915 : 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1916 : : logical_type_node, src.expr,
1917 : 7 : fold_convert (TREE_TYPE (src.expr),
1918 : : null_pointer_node));
1919 : 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1920 : : tmp, build_empty_stmt (input_location));
1921 : : }
1922 : : }
1923 : : else
1924 : 133 : tmp = build_empty_stmt (input_location);
1925 : :
1926 : 441 : if (code->expr1->symtree->n.sym->attr.dummy
1927 : 390 : && (code->expr1->symtree->n.sym->attr.optional
1928 : 384 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1929 : : {
1930 : 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1931 : 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1932 : : present, tmp,
1933 : : build_empty_stmt (input_location));
1934 : : }
1935 : :
1936 : 441 : gfc_add_expr_to_block (&block, tmp);
1937 : 441 : gfc_free_expr (lhs);
1938 : 441 : gfc_free_expr (rhs);
1939 : :
1940 : 441 : return gfc_finish_block (&block);
1941 : : }
1942 : :
1943 : :
1944 : : /* Class valued elemental function calls or class array elements arriving
1945 : : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1946 : : is used to ensure that the rhs dynamic type is assigned to the lhs. */
1947 : :
1948 : : static bool
1949 : 758 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1950 : : {
1951 : 758 : tree fcn;
1952 : 758 : tree rse_expr;
1953 : 758 : tree class_data;
1954 : 758 : tree tmp;
1955 : 758 : tree zero;
1956 : 758 : tree cond;
1957 : 758 : tree final_cond;
1958 : 758 : stmtblock_t inner_block;
1959 : 758 : bool is_descriptor;
1960 : 758 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
1961 : 758 : bool not_lhs_array_type;
1962 : :
1963 : : /* Temporaries arising from dependencies in assignment get cast as a
1964 : : character type of the dynamic size of the rhs. Use the vptr copy
1965 : : for this case. */
1966 : 758 : tmp = TREE_TYPE (lse->expr);
1967 : 758 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
1968 : 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
1969 : :
1970 : : /* Use ordinary assignment if the rhs is not a call expression or
1971 : : the lhs is not a class entity or an array(ie. character) type. */
1972 : 710 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
1973 : 1025 : && not_lhs_array_type)
1974 : : return false;
1975 : :
1976 : : /* Ordinary assignment can be used if both sides are class expressions
1977 : : since the dynamic type is preserved by copying the vptr. This
1978 : : should only occur, where temporaries are involved. */
1979 : 491 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
1980 : 491 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
1981 : : return false;
1982 : :
1983 : : /* Fix the class expression and the class data of the rhs. */
1984 : 430 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
1985 : 430 : || not_call_expr)
1986 : : {
1987 : 430 : tmp = gfc_get_class_from_expr (rse->expr);
1988 : 430 : if (tmp == NULL_TREE)
1989 : : return false;
1990 : 134 : rse_expr = gfc_evaluate_now (tmp, block);
1991 : : }
1992 : : else
1993 : 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
1994 : :
1995 : 134 : class_data = gfc_class_data_get (rse_expr);
1996 : :
1997 : : /* Check that the rhs data is not null. */
1998 : 134 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
1999 : 134 : if (is_descriptor)
2000 : 134 : class_data = gfc_conv_descriptor_data_get (class_data);
2001 : 134 : class_data = gfc_evaluate_now (class_data, block);
2002 : :
2003 : 134 : zero = build_int_cst (TREE_TYPE (class_data), 0);
2004 : 134 : cond = fold_build2_loc (input_location, NE_EXPR,
2005 : : logical_type_node,
2006 : : class_data, zero);
2007 : :
2008 : : /* Copy the rhs to the lhs. */
2009 : 134 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
2010 : 134 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2011 : 134 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
2012 : 134 : tmp = is_descriptor ? tmp : class_data;
2013 : 134 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
2014 : : gfc_build_addr_expr (NULL, lse->expr));
2015 : 134 : gfc_add_expr_to_block (block, tmp);
2016 : :
2017 : : /* Only elemental function results need to be finalised and freed. */
2018 : 134 : if (not_call_expr)
2019 : : return true;
2020 : :
2021 : : /* Finalize the class data if needed. */
2022 : 0 : gfc_init_block (&inner_block);
2023 : 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
2024 : 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
2025 : 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
2026 : : logical_type_node, fcn, zero);
2027 : 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2028 : 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
2029 : 0 : tmp = build3_v (COND_EXPR, final_cond,
2030 : : tmp, build_empty_stmt (input_location));
2031 : 0 : gfc_add_expr_to_block (&inner_block, tmp);
2032 : :
2033 : : /* Free the class data. */
2034 : 0 : tmp = gfc_call_free (class_data);
2035 : 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2036 : : build_empty_stmt (input_location));
2037 : 0 : gfc_add_expr_to_block (&inner_block, tmp);
2038 : :
2039 : : /* Finish the inner block and subject it to the condition on the
2040 : : class data being non-zero. */
2041 : 0 : tmp = gfc_finish_block (&inner_block);
2042 : 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2043 : : build_empty_stmt (input_location));
2044 : 0 : gfc_add_expr_to_block (block, tmp);
2045 : :
2046 : 0 : return true;
2047 : : }
2048 : :
2049 : : /* End of prototype trans-class.c */
2050 : :
2051 : :
2052 : : static void
2053 : 11774 : realloc_lhs_warning (bt type, bool array, locus *where)
2054 : : {
2055 : 11774 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
2056 : 25 : gfc_warning (OPT_Wrealloc_lhs,
2057 : : "Code for reallocating the allocatable array at %L will "
2058 : : "be added", where);
2059 : 11749 : else if (warn_realloc_lhs_all)
2060 : 4 : gfc_warning (OPT_Wrealloc_lhs_all,
2061 : : "Code for reallocating the allocatable variable at %L "
2062 : : "will be added", where);
2063 : 11774 : }
2064 : :
2065 : :
2066 : : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
2067 : : gfc_expr *);
2068 : :
2069 : : /* Copy the scalarization loop variables. */
2070 : :
2071 : : static void
2072 : 1238134 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2073 : : {
2074 : 1238134 : dest->ss = src->ss;
2075 : 1238134 : dest->loop = src->loop;
2076 : 1238134 : }
2077 : :
2078 : :
2079 : : /* Initialize a simple expression holder.
2080 : :
2081 : : Care must be taken when multiple se are created with the same parent.
2082 : : The child se must be kept in sync. The easiest way is to delay creation
2083 : : of a child se until after the previous se has been translated. */
2084 : :
2085 : : void
2086 : 4436104 : gfc_init_se (gfc_se * se, gfc_se * parent)
2087 : : {
2088 : 4436104 : memset (se, 0, sizeof (gfc_se));
2089 : 4436104 : gfc_init_block (&se->pre);
2090 : 4436104 : gfc_init_block (&se->finalblock);
2091 : 4436104 : gfc_init_block (&se->post);
2092 : :
2093 : 4436104 : se->parent = parent;
2094 : :
2095 : 4436104 : if (parent)
2096 : 1238134 : gfc_copy_se_loopvars (se, parent);
2097 : 4436104 : }
2098 : :
2099 : :
2100 : : /* Advances to the next SS in the chain. Use this rather than setting
2101 : : se->ss = se->ss->next because all the parents needs to be kept in sync.
2102 : : See gfc_init_se. */
2103 : :
2104 : : void
2105 : 234775 : gfc_advance_se_ss_chain (gfc_se * se)
2106 : : {
2107 : 234775 : gfc_se *p;
2108 : :
2109 : 234775 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2110 : :
2111 : : p = se;
2112 : : /* Walk down the parent chain. */
2113 : 618010 : while (p != NULL)
2114 : : {
2115 : : /* Simple consistency check. */
2116 : 383235 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2117 : : || p->parent->ss->nested_ss == p->ss);
2118 : :
2119 : 383235 : p->ss = p->ss->next;
2120 : :
2121 : 383235 : p = p->parent;
2122 : : }
2123 : 234775 : }
2124 : :
2125 : :
2126 : : /* Ensures the result of the expression as either a temporary variable
2127 : : or a constant so that it can be used repeatedly. */
2128 : :
2129 : : void
2130 : 7958 : gfc_make_safe_expr (gfc_se * se)
2131 : : {
2132 : 7958 : tree var;
2133 : :
2134 : 7958 : if (CONSTANT_CLASS_P (se->expr))
2135 : : return;
2136 : :
2137 : : /* We need a temporary for this result. */
2138 : 206 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2139 : 206 : gfc_add_modify (&se->pre, var, se->expr);
2140 : 206 : se->expr = var;
2141 : : }
2142 : :
2143 : :
2144 : : /* Return an expression which determines if a dummy parameter is present.
2145 : : Also used for arguments to procedures with multiple entry points. */
2146 : :
2147 : : tree
2148 : 11325 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2149 : : {
2150 : 11325 : tree decl, orig_decl, cond;
2151 : :
2152 : 11325 : gcc_assert (sym->attr.dummy);
2153 : 11325 : orig_decl = decl = gfc_get_symbol_decl (sym);
2154 : :
2155 : : /* Intrinsic scalars and derived types with VALUE attribute which are passed
2156 : : by value use a hidden argument to denote the presence status. */
2157 : 11325 : if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
2158 : : {
2159 : 1040 : char name[GFC_MAX_SYMBOL_LEN + 2];
2160 : 1040 : tree tree_name;
2161 : :
2162 : 1040 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2163 : 1040 : name[0] = '.';
2164 : 1040 : strcpy (&name[1], sym->name);
2165 : 1040 : tree_name = get_identifier (name);
2166 : :
2167 : : /* Walk function argument list to find hidden arg. */
2168 : 1040 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2169 : 5296 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2170 : 5296 : if (DECL_NAME (cond) == tree_name
2171 : 5296 : && DECL_ARTIFICIAL (cond))
2172 : : break;
2173 : :
2174 : 1040 : gcc_assert (cond);
2175 : 1040 : return cond;
2176 : : }
2177 : :
2178 : : /* Assumed-shape arrays use a local variable for the array data;
2179 : : the actual PARAM_DECL is in a saved decl. As the local variable
2180 : : is NULL, it can be checked instead, unless use_saved_desc is
2181 : : requested. */
2182 : :
2183 : 10285 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2184 : : {
2185 : 821 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2186 : : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2187 : 821 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2188 : : }
2189 : :
2190 : 10285 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2191 : 10285 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2192 : :
2193 : : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2194 : : as actual argument to denote absent dummies. For array descriptors,
2195 : : we thus also need to check the array descriptor. For BT_CLASS, it
2196 : : can also occur for scalars and F2003 due to type->class wrapping and
2197 : : class->class wrapping. Note further that BT_CLASS always uses an
2198 : : array descriptor for arrays, also for explicit-shape/assumed-size.
2199 : : For assumed-rank arrays, no local variable is generated, hence,
2200 : : the following also applies with !use_saved_desc. */
2201 : :
2202 : 10285 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2203 : 7364 : && !sym->attr.allocatable
2204 : 6198 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2205 : 2266 : || (sym->ts.type == BT_CLASS
2206 : 1041 : && !CLASS_DATA (sym)->attr.allocatable
2207 : 567 : && !CLASS_DATA (sym)->attr.class_pointer))
2208 : 4139 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2209 : 6 : || sym->ts.type == BT_CLASS))
2210 : : {
2211 : 4133 : tree tmp;
2212 : :
2213 : 4133 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2214 : 1455 : || sym->as->type == AS_ASSUMED_RANK
2215 : 1373 : || sym->attr.codimension))
2216 : 3272 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2217 : : {
2218 : 1032 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2219 : 1032 : if (sym->ts.type == BT_CLASS)
2220 : 171 : tmp = gfc_class_data_get (tmp);
2221 : 1032 : tmp = gfc_conv_array_data (tmp);
2222 : : }
2223 : 3101 : else if (sym->ts.type == BT_CLASS)
2224 : 36 : tmp = gfc_class_data_get (decl);
2225 : : else
2226 : : tmp = NULL_TREE;
2227 : :
2228 : 1068 : if (tmp != NULL_TREE)
2229 : : {
2230 : 1068 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2231 : 1068 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2232 : 1068 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2233 : : logical_type_node, cond, tmp);
2234 : : }
2235 : : }
2236 : :
2237 : : return cond;
2238 : : }
2239 : :
2240 : :
2241 : : /* Converts a missing, dummy argument into a null or zero. */
2242 : :
2243 : : void
2244 : 843 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2245 : : {
2246 : 843 : tree present;
2247 : 843 : tree tmp;
2248 : :
2249 : 843 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2250 : :
2251 : 843 : if (kind > 0)
2252 : : {
2253 : : /* Create a temporary and convert it to the correct type. */
2254 : 54 : tmp = gfc_get_int_type (kind);
2255 : 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2256 : : se->expr));
2257 : :
2258 : : /* Test for a NULL value. */
2259 : 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2260 : 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2261 : 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2262 : 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2263 : : }
2264 : : else
2265 : : {
2266 : 789 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2267 : : present, se->expr,
2268 : 789 : build_zero_cst (TREE_TYPE (se->expr)));
2269 : 789 : tmp = gfc_evaluate_now (tmp, &se->pre);
2270 : 789 : se->expr = tmp;
2271 : : }
2272 : :
2273 : 843 : if (ts.type == BT_CHARACTER)
2274 : : {
2275 : : /* Handle deferred-length dummies that pass the character length by
2276 : : reference so that the value can be returned. */
2277 : 244 : if (ts.deferred && INDIRECT_REF_P (se->string_length))
2278 : : {
2279 : 18 : tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
2280 : 18 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2281 : : present, tmp, null_pointer_node);
2282 : 18 : tmp = gfc_evaluate_now (tmp, &se->pre);
2283 : 18 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2284 : : }
2285 : : else
2286 : : {
2287 : 226 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2288 : 226 : tmp = fold_build3_loc (input_location, COND_EXPR,
2289 : : gfc_charlen_type_node,
2290 : : present, se->string_length, tmp);
2291 : 226 : tmp = gfc_evaluate_now (tmp, &se->pre);
2292 : : }
2293 : 244 : se->string_length = tmp;
2294 : : }
2295 : 843 : return;
2296 : : }
2297 : :
2298 : :
2299 : : /* Get the character length of an expression, looking through gfc_refs
2300 : : if necessary. */
2301 : :
2302 : : tree
2303 : 19860 : gfc_get_expr_charlen (gfc_expr *e)
2304 : : {
2305 : 19860 : gfc_ref *r;
2306 : 19860 : tree length;
2307 : 19860 : tree previous = NULL_TREE;
2308 : 19860 : gfc_se se;
2309 : :
2310 : 19860 : gcc_assert (e->expr_type == EXPR_VARIABLE
2311 : : && e->ts.type == BT_CHARACTER);
2312 : :
2313 : 19860 : length = NULL; /* To silence compiler warning. */
2314 : :
2315 : 19860 : if (is_subref_array (e) && e->ts.u.cl->length)
2316 : : {
2317 : 767 : gfc_se tmpse;
2318 : 767 : gfc_init_se (&tmpse, NULL);
2319 : 767 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2320 : 767 : e->ts.u.cl->backend_decl = tmpse.expr;
2321 : 767 : return tmpse.expr;
2322 : : }
2323 : :
2324 : : /* First candidate: if the variable is of type CHARACTER, the
2325 : : expression's length could be the length of the character
2326 : : variable. */
2327 : 19093 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2328 : 18805 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2329 : :
2330 : : /* Look through the reference chain for component references. */
2331 : 38325 : for (r = e->ref; r; r = r->next)
2332 : : {
2333 : 19232 : previous = length;
2334 : 19232 : switch (r->type)
2335 : : {
2336 : 288 : case REF_COMPONENT:
2337 : 288 : if (r->u.c.component->ts.type == BT_CHARACTER)
2338 : 288 : length = r->u.c.component->ts.u.cl->backend_decl;
2339 : : break;
2340 : :
2341 : : case REF_ARRAY:
2342 : : /* Do nothing. */
2343 : : break;
2344 : :
2345 : 20 : case REF_SUBSTRING:
2346 : 20 : gfc_init_se (&se, NULL);
2347 : 20 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2348 : 20 : length = se.expr;
2349 : 20 : if (r->u.ss.end)
2350 : 0 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2351 : : else
2352 : 20 : se.expr = previous;
2353 : 20 : length = fold_build2_loc (input_location, MINUS_EXPR,
2354 : : gfc_charlen_type_node,
2355 : : se.expr, length);
2356 : 20 : length = fold_build2_loc (input_location, PLUS_EXPR,
2357 : : gfc_charlen_type_node, length,
2358 : : gfc_index_one_node);
2359 : 20 : break;
2360 : :
2361 : 0 : default:
2362 : 0 : gcc_unreachable ();
2363 : 19232 : break;
2364 : : }
2365 : : }
2366 : :
2367 : 19093 : gcc_assert (length != NULL);
2368 : : return length;
2369 : : }
2370 : :
2371 : :
2372 : : /* Return for an expression the backend decl of the coarray. */
2373 : :
2374 : : tree
2375 : 1543 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2376 : : {
2377 : 1543 : tree caf_decl;
2378 : 1543 : bool found = false;
2379 : 1543 : gfc_ref *ref;
2380 : :
2381 : 1543 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2382 : :
2383 : : /* Not-implemented diagnostic. */
2384 : 1543 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2385 : 30 : && UNLIMITED_POLY (expr->symtree->n.sym)
2386 : 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2387 : 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2388 : : "%L is not supported", &expr->where);
2389 : :
2390 : 3297 : for (ref = expr->ref; ref; ref = ref->next)
2391 : 1754 : if (ref->type == REF_COMPONENT)
2392 : : {
2393 : 175 : if (ref->u.c.component->ts.type == BT_CLASS
2394 : 0 : && UNLIMITED_POLY (ref->u.c.component)
2395 : 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2396 : 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2397 : : "component at %L is not supported", &expr->where);
2398 : : }
2399 : :
2400 : : /* Make sure the backend_decl is present before accessing it. */
2401 : 1543 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2402 : 1543 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2403 : : : expr->symtree->n.sym->backend_decl;
2404 : :
2405 : 1543 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2406 : : {
2407 : 30 : if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2408 : 33 : && GFC_DECL_SAVED_DESCRIPTOR (caf_decl))
2409 : 3 : caf_decl = GFC_DECL_SAVED_DESCRIPTOR (caf_decl);
2410 : :
2411 : 30 : if (expr->ref && expr->ref->type == REF_ARRAY)
2412 : : {
2413 : 23 : caf_decl = gfc_class_data_get (caf_decl);
2414 : 23 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2415 : : return caf_decl;
2416 : : }
2417 : 7 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2418 : 1 : && GFC_DECL_TOKEN (caf_decl)
2419 : 8 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2420 : : return caf_decl;
2421 : :
2422 : 15 : for (ref = expr->ref; ref; ref = ref->next)
2423 : : {
2424 : 12 : if (ref->type == REF_COMPONENT
2425 : 6 : && strcmp (ref->u.c.component->name, "_data") != 0)
2426 : : {
2427 : 0 : caf_decl = gfc_class_data_get (caf_decl);
2428 : 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2429 : : return caf_decl;
2430 : : break;
2431 : : }
2432 : 12 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2433 : : break;
2434 : : }
2435 : : }
2436 : 1519 : if (expr->symtree->n.sym->attr.codimension)
2437 : : return caf_decl;
2438 : :
2439 : : /* The following code assumes that the coarray is a component reachable via
2440 : : only scalar components/variables; the Fortran standard guarantees this. */
2441 : :
2442 : 34 : for (ref = expr->ref; ref; ref = ref->next)
2443 : 34 : if (ref->type == REF_COMPONENT)
2444 : : {
2445 : 34 : gfc_component *comp = ref->u.c.component;
2446 : :
2447 : 34 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2448 : 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2449 : 34 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2450 : 34 : TREE_TYPE (comp->backend_decl), caf_decl,
2451 : : comp->backend_decl, NULL_TREE);
2452 : 34 : if (comp->ts.type == BT_CLASS)
2453 : : {
2454 : 0 : caf_decl = gfc_class_data_get (caf_decl);
2455 : 0 : if (CLASS_DATA (comp)->attr.codimension)
2456 : : {
2457 : : found = true;
2458 : : break;
2459 : : }
2460 : : }
2461 : 34 : if (comp->attr.codimension)
2462 : : {
2463 : : found = true;
2464 : : break;
2465 : : }
2466 : : }
2467 : 34 : gcc_assert (found && caf_decl);
2468 : : return caf_decl;
2469 : : }
2470 : :
2471 : :
2472 : : /* Obtain the Coarray token - and optionally also the offset. */
2473 : :
2474 : : void
2475 : 1460 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2476 : : tree se_expr, gfc_expr *expr)
2477 : : {
2478 : 1460 : tree tmp;
2479 : :
2480 : 1460 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2481 : :
2482 : : /* Coarray token. */
2483 : 1460 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2484 : 357 : *token = gfc_conv_descriptor_token (caf_decl);
2485 : 1102 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2486 : 1204 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2487 : 4 : *token = GFC_DECL_TOKEN (caf_decl);
2488 : : else
2489 : : {
2490 : 1099 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2491 : : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2492 : 1099 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2493 : : }
2494 : :
2495 : 1460 : if (offset == NULL)
2496 : : return;
2497 : :
2498 : : /* Offset between the coarray base address and the address wanted. */
2499 : 91 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2500 : 91 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2501 : 0 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2502 : 0 : *offset = build_int_cst (gfc_array_index_type, 0);
2503 : 91 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2504 : 91 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2505 : 0 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2506 : 91 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2507 : 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2508 : : else
2509 : 91 : *offset = build_int_cst (gfc_array_index_type, 0);
2510 : :
2511 : 91 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2512 : 91 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2513 : : {
2514 : 0 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2515 : 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2516 : : }
2517 : 91 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2518 : 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2519 : : else
2520 : : {
2521 : 91 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2522 : : tmp = se_expr;
2523 : : }
2524 : :
2525 : 91 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2526 : : *offset, fold_convert (gfc_array_index_type, tmp));
2527 : :
2528 : 91 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2529 : 0 : && expr->symtree->n.sym->attr.codimension
2530 : 0 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2531 : : {
2532 : 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2533 : 0 : gfc_ref *ref = base_expr->ref;
2534 : 0 : gfc_se base_se;
2535 : :
2536 : : // Iterate through the refs until the last one.
2537 : 0 : while (ref->next)
2538 : : ref = ref->next;
2539 : :
2540 : 0 : if (ref->type == REF_ARRAY
2541 : 0 : && ref->u.ar.type != AR_FULL)
2542 : : {
2543 : 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2544 : 0 : int i;
2545 : 0 : for (i = 0; i < ranksum; ++i)
2546 : : {
2547 : 0 : ref->u.ar.start[i] = NULL;
2548 : 0 : ref->u.ar.end[i] = NULL;
2549 : : }
2550 : 0 : ref->u.ar.type = AR_FULL;
2551 : : }
2552 : 0 : gfc_init_se (&base_se, NULL);
2553 : 0 : if (gfc_caf_attr (base_expr).dimension)
2554 : : {
2555 : 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2556 : 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2557 : : }
2558 : : else
2559 : : {
2560 : 0 : gfc_conv_expr (&base_se, base_expr);
2561 : 0 : tmp = base_se.expr;
2562 : : }
2563 : :
2564 : 0 : gfc_free_expr (base_expr);
2565 : 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2566 : 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2567 : 0 : }
2568 : 91 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2569 : 0 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2570 : 91 : else if (INDIRECT_REF_P (caf_decl))
2571 : 0 : tmp = TREE_OPERAND (caf_decl, 0);
2572 : : else
2573 : : {
2574 : 91 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2575 : : tmp = caf_decl;
2576 : : }
2577 : :
2578 : 91 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2579 : : fold_convert (gfc_array_index_type, *offset),
2580 : : fold_convert (gfc_array_index_type, tmp));
2581 : : }
2582 : :
2583 : :
2584 : : /* Convert the coindex of a coarray into an image index; the result is
2585 : : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2586 : : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2587 : :
2588 : : tree
2589 : 1265 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2590 : : {
2591 : 1265 : gfc_ref *ref;
2592 : 1265 : tree lbound, ubound, extent, tmp, img_idx;
2593 : 1265 : gfc_se se;
2594 : 1265 : int i;
2595 : :
2596 : 1287 : for (ref = e->ref; ref; ref = ref->next)
2597 : 1287 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2598 : : break;
2599 : 1265 : gcc_assert (ref != NULL);
2600 : :
2601 : 1265 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2602 : 66 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2603 : 66 : null_pointer_node);
2604 : :
2605 : 1199 : img_idx = build_zero_cst (gfc_array_index_type);
2606 : 1199 : extent = build_one_cst (gfc_array_index_type);
2607 : 1199 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2608 : 456 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2609 : : {
2610 : 231 : gfc_init_se (&se, NULL);
2611 : 231 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2612 : 231 : gfc_add_block_to_block (block, &se.pre);
2613 : 231 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2614 : 231 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2615 : 231 : TREE_TYPE (lbound), se.expr, lbound);
2616 : 231 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2617 : : extent, tmp);
2618 : 231 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2619 : 231 : TREE_TYPE (tmp), img_idx, tmp);
2620 : 231 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2621 : : {
2622 : 6 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2623 : 6 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2624 : 6 : extent = fold_build2_loc (input_location, MULT_EXPR,
2625 : 6 : TREE_TYPE (tmp), extent, tmp);
2626 : : }
2627 : : }
2628 : : else
2629 : 1956 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2630 : : {
2631 : 982 : gfc_init_se (&se, NULL);
2632 : 982 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2633 : 982 : gfc_add_block_to_block (block, &se.pre);
2634 : 982 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2635 : 982 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2636 : 982 : TREE_TYPE (lbound), se.expr, lbound);
2637 : 982 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2638 : : extent, tmp);
2639 : 982 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2640 : : img_idx, tmp);
2641 : 982 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2642 : : {
2643 : 8 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2644 : 8 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2645 : 8 : TREE_TYPE (ubound), ubound, lbound);
2646 : 8 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2647 : 8 : tmp, build_one_cst (TREE_TYPE (tmp)));
2648 : 8 : extent = fold_build2_loc (input_location, MULT_EXPR,
2649 : 8 : TREE_TYPE (tmp), extent, tmp);
2650 : : }
2651 : : }
2652 : 1199 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2653 : 1199 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2654 : 1199 : return fold_convert (integer_type_node, img_idx);
2655 : : }
2656 : :
2657 : :
2658 : : /* For each character array constructor subexpression without a ts.u.cl->length,
2659 : : replace it by its first element (if there aren't any elements, the length
2660 : : should already be set to zero). */
2661 : :
2662 : : static void
2663 : 105 : flatten_array_ctors_without_strlen (gfc_expr* e)
2664 : : {
2665 : 105 : gfc_actual_arglist* arg;
2666 : 105 : gfc_constructor* c;
2667 : :
2668 : 105 : if (!e)
2669 : : return;
2670 : :
2671 : 105 : switch (e->expr_type)
2672 : : {
2673 : :
2674 : 0 : case EXPR_OP:
2675 : 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2676 : 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2677 : 0 : break;
2678 : :
2679 : 0 : case EXPR_COMPCALL:
2680 : : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2681 : 0 : gcc_unreachable ();
2682 : :
2683 : 12 : case EXPR_FUNCTION:
2684 : 36 : for (arg = e->value.function.actual; arg; arg = arg->next)
2685 : 24 : flatten_array_ctors_without_strlen (arg->expr);
2686 : : break;
2687 : :
2688 : 0 : case EXPR_ARRAY:
2689 : :
2690 : : /* We've found what we're looking for. */
2691 : 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2692 : : {
2693 : 0 : gfc_constructor *c;
2694 : 0 : gfc_expr* new_expr;
2695 : :
2696 : 0 : gcc_assert (e->value.constructor);
2697 : :
2698 : 0 : c = gfc_constructor_first (e->value.constructor);
2699 : 0 : new_expr = c->expr;
2700 : 0 : c->expr = NULL;
2701 : :
2702 : 0 : flatten_array_ctors_without_strlen (new_expr);
2703 : 0 : gfc_replace_expr (e, new_expr);
2704 : 0 : break;
2705 : : }
2706 : :
2707 : : /* Otherwise, fall through to handle constructor elements. */
2708 : 0 : gcc_fallthrough ();
2709 : 0 : case EXPR_STRUCTURE:
2710 : 0 : for (c = gfc_constructor_first (e->value.constructor);
2711 : 0 : c; c = gfc_constructor_next (c))
2712 : 0 : flatten_array_ctors_without_strlen (c->expr);
2713 : : break;
2714 : :
2715 : : default:
2716 : : break;
2717 : :
2718 : : }
2719 : : }
2720 : :
2721 : :
2722 : : /* Generate code to initialize a string length variable. Returns the
2723 : : value. For array constructors, cl->length might be NULL and in this case,
2724 : : the first element of the constructor is needed. expr is the original
2725 : : expression so we can access it but can be NULL if this is not needed. */
2726 : :
2727 : : void
2728 : 3693 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2729 : : {
2730 : 3693 : gfc_se se;
2731 : :
2732 : 3693 : gfc_init_se (&se, NULL);
2733 : :
2734 : 3693 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2735 : 1293 : return;
2736 : :
2737 : : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2738 : : "flatten" array constructors by taking their first element; all elements
2739 : : should be the same length or a cl->length should be present. */
2740 : 2480 : if (!cl->length)
2741 : : {
2742 : 161 : gfc_expr* expr_flat;
2743 : 161 : if (!expr)
2744 : : return;
2745 : 81 : expr_flat = gfc_copy_expr (expr);
2746 : 81 : flatten_array_ctors_without_strlen (expr_flat);
2747 : 81 : gfc_resolve_expr (expr_flat);
2748 : 81 : if (expr_flat->rank)
2749 : 12 : gfc_conv_expr_descriptor (&se, expr_flat);
2750 : : else
2751 : 69 : gfc_conv_expr (&se, expr_flat);
2752 : 81 : if (expr_flat->expr_type != EXPR_VARIABLE)
2753 : 75 : gfc_add_block_to_block (pblock, &se.pre);
2754 : 81 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2755 : 81 : gfc_add_block_to_block (pblock, &se.post);
2756 : 81 : gfc_free_expr (expr_flat);
2757 : : }
2758 : : else
2759 : : {
2760 : : /* Convert cl->length. */
2761 : 2319 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2762 : 2319 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2763 : : gfc_charlen_type_node, se.expr,
2764 : 2319 : build_zero_cst (TREE_TYPE (se.expr)));
2765 : 2319 : gfc_add_block_to_block (pblock, &se.pre);
2766 : : }
2767 : :
2768 : 2400 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2769 : 1540 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2770 : : else
2771 : 860 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2772 : : }
2773 : :
2774 : :
2775 : : static void
2776 : 6791 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2777 : : const char *name, locus *where)
2778 : : {
2779 : 6791 : tree tmp;
2780 : 6791 : tree type;
2781 : 6791 : tree fault;
2782 : 6791 : gfc_se start;
2783 : 6791 : gfc_se end;
2784 : 6791 : char *msg;
2785 : 6791 : mpz_t length;
2786 : :
2787 : 6791 : type = gfc_get_character_type (kind, ref->u.ss.length);
2788 : 6791 : type = build_pointer_type (type);
2789 : :
2790 : 6791 : gfc_init_se (&start, se);
2791 : 6791 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2792 : 6791 : gfc_add_block_to_block (&se->pre, &start.pre);
2793 : :
2794 : 6791 : if (integer_onep (start.expr))
2795 : 2309 : gfc_conv_string_parameter (se);
2796 : : else
2797 : : {
2798 : 4482 : tmp = start.expr;
2799 : 4482 : STRIP_NOPS (tmp);
2800 : : /* Avoid multiple evaluation of substring start. */
2801 : 4482 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2802 : 1666 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2803 : :
2804 : : /* Change the start of the string. */
2805 : 4482 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2806 : 1152 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2807 : 3450 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2808 : 5514 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2809 : 1032 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2810 : : tmp = se->expr;
2811 : : else
2812 : 1024 : tmp = build_fold_indirect_ref_loc (input_location,
2813 : : se->expr);
2814 : : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2815 : 4482 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2816 : : {
2817 : 4354 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2818 : 4354 : se->expr = gfc_build_addr_expr (type, tmp);
2819 : : }
2820 : 128 : else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2821 : : {
2822 : 8 : tree diff;
2823 : 8 : diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr,
2824 : : build_one_cst (gfc_charlen_type_node));
2825 : 8 : diff = fold_convert (size_type_node, diff);
2826 : 8 : se->expr
2827 : 8 : = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff);
2828 : : }
2829 : : }
2830 : :
2831 : : /* Length = end + 1 - start. */
2832 : 6791 : gfc_init_se (&end, se);
2833 : 6791 : if (ref->u.ss.end == NULL)
2834 : 178 : end.expr = se->string_length;
2835 : : else
2836 : : {
2837 : 6613 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2838 : 6613 : gfc_add_block_to_block (&se->pre, &end.pre);
2839 : : }
2840 : 6791 : tmp = end.expr;
2841 : 6791 : STRIP_NOPS (tmp);
2842 : 6791 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2843 : 2290 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2844 : :
2845 : 6791 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2846 : 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2847 : 7246 : && !gfc_contains_implied_index_p (ref->u.ss.end))
2848 : : {
2849 : 455 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2850 : : logical_type_node, start.expr,
2851 : : end.expr);
2852 : :
2853 : : /* Check lower bound. */
2854 : 455 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2855 : : start.expr,
2856 : 455 : build_one_cst (TREE_TYPE (start.expr)));
2857 : 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2858 : : logical_type_node, nonempty, fault);
2859 : 455 : if (name)
2860 : 454 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2861 : : "is less than one", name);
2862 : : else
2863 : 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2864 : : "is less than one");
2865 : 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2866 : : fold_convert (long_integer_type_node,
2867 : : start.expr));
2868 : 455 : free (msg);
2869 : :
2870 : : /* Check upper bound. */
2871 : 455 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2872 : : end.expr, se->string_length);
2873 : 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2874 : : logical_type_node, nonempty, fault);
2875 : 455 : if (name)
2876 : 454 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2877 : : "exceeds string length (%%ld)", name);
2878 : : else
2879 : 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2880 : : "exceeds string length (%%ld)");
2881 : 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2882 : : fold_convert (long_integer_type_node, end.expr),
2883 : : fold_convert (long_integer_type_node,
2884 : : se->string_length));
2885 : 455 : free (msg);
2886 : : }
2887 : :
2888 : : /* Try to calculate the length from the start and end expressions. */
2889 : 6791 : if (ref->u.ss.end
2890 : 6791 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2891 : : {
2892 : 5606 : HOST_WIDE_INT i_len;
2893 : :
2894 : 5606 : i_len = gfc_mpz_get_hwi (length) + 1;
2895 : 5606 : if (i_len < 0)
2896 : : i_len = 0;
2897 : :
2898 : 5606 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2899 : 5606 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2900 : : }
2901 : : else
2902 : : {
2903 : 1185 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2904 : : fold_convert (gfc_charlen_type_node, end.expr),
2905 : : fold_convert (gfc_charlen_type_node, start.expr));
2906 : 1185 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2907 : : build_int_cst (gfc_charlen_type_node, 1), tmp);
2908 : 1185 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2909 : : tmp, build_int_cst (gfc_charlen_type_node, 0));
2910 : : }
2911 : :
2912 : 6791 : se->string_length = tmp;
2913 : 6791 : }
2914 : :
2915 : :
2916 : : /* Convert a derived type component reference. */
2917 : :
2918 : : void
2919 : 165447 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2920 : : {
2921 : 165447 : gfc_component *c;
2922 : 165447 : tree tmp;
2923 : 165447 : tree decl;
2924 : 165447 : tree field;
2925 : 165447 : tree context;
2926 : :
2927 : 165447 : c = ref->u.c.component;
2928 : :
2929 : 165447 : if (c->backend_decl == NULL_TREE
2930 : 6 : && ref->u.c.sym != NULL)
2931 : 6 : gfc_get_derived_type (ref->u.c.sym);
2932 : :
2933 : 165447 : field = c->backend_decl;
2934 : 165447 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2935 : 165447 : decl = se->expr;
2936 : 165447 : context = DECL_FIELD_CONTEXT (field);
2937 : :
2938 : : /* Components can correspond to fields of different containing
2939 : : types, as components are created without context, whereas
2940 : : a concrete use of a component has the type of decl as context.
2941 : : So, if the type doesn't match, we search the corresponding
2942 : : FIELD_DECL in the parent type. To not waste too much time
2943 : : we cache this result in norestrict_decl.
2944 : : On the other hand, if the context is a UNION or a MAP (a
2945 : : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2946 : :
2947 : 165447 : if (context != TREE_TYPE (decl)
2948 : 165447 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2949 : 11293 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2950 : : {
2951 : 11293 : tree f2 = c->norestrict_decl;
2952 : 19382 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2953 : 6485 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2954 : 6485 : if (TREE_CODE (f2) == FIELD_DECL
2955 : 6485 : && DECL_NAME (f2) == DECL_NAME (field))
2956 : : break;
2957 : 11293 : gcc_assert (f2);
2958 : 11293 : c->norestrict_decl = f2;
2959 : 11293 : field = f2;
2960 : : }
2961 : :
2962 : 165447 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2963 : 0 : && strcmp ("_data", c->name) == 0)
2964 : : {
2965 : : /* Found a ref to the _data component. Store the associated ref to
2966 : : the vptr in se->class_vptr. */
2967 : 0 : se->class_vptr = gfc_class_vptr_get (decl);
2968 : : }
2969 : : else
2970 : 165447 : se->class_vptr = NULL_TREE;
2971 : :
2972 : 165447 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2973 : : decl, field, NULL_TREE);
2974 : :
2975 : 165447 : se->expr = tmp;
2976 : :
2977 : : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2978 : : strlen () conditional below. */
2979 : 165447 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2980 : 8460 : && !c->ts.deferred
2981 : 5459 : && !c->attr.pdt_string)
2982 : : {
2983 : 5333 : tmp = c->ts.u.cl->backend_decl;
2984 : : /* Components must always be constant length. */
2985 : 5333 : gcc_assert (tmp && INTEGER_CST_P (tmp));
2986 : 5333 : se->string_length = tmp;
2987 : : }
2988 : :
2989 : 165447 : if (gfc_deferred_strlen (c, &field))
2990 : : {
2991 : 3127 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2992 : 3127 : TREE_TYPE (field),
2993 : : decl, field, NULL_TREE);
2994 : 3127 : se->string_length = tmp;
2995 : : }
2996 : :
2997 : 165447 : if (((c->attr.pointer || c->attr.allocatable)
2998 : 95424 : && (!c->attr.dimension && !c->attr.codimension)
2999 : 53376 : && c->ts.type != BT_CHARACTER)
3000 : 114101 : || c->attr.proc_pointer)
3001 : 57228 : se->expr = build_fold_indirect_ref_loc (input_location,
3002 : : se->expr);
3003 : 165447 : }
3004 : :
3005 : :
3006 : : /* This function deals with component references to components of the
3007 : : parent type for derived type extensions. */
3008 : : void
3009 : 62011 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
3010 : : {
3011 : 62011 : gfc_component *c;
3012 : 62011 : gfc_component *cmp;
3013 : 62011 : gfc_symbol *dt;
3014 : 62011 : gfc_ref parent;
3015 : :
3016 : 62011 : dt = ref->u.c.sym;
3017 : 62011 : c = ref->u.c.component;
3018 : :
3019 : : /* Return if the component is in this type, i.e. not in the parent type. */
3020 : 106806 : for (cmp = dt->components; cmp; cmp = cmp->next)
3021 : 96698 : if (c == cmp)
3022 : 51903 : return;
3023 : :
3024 : : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3025 : 10108 : parent.type = REF_COMPONENT;
3026 : 10108 : parent.next = NULL;
3027 : 10108 : parent.u.c.sym = dt;
3028 : 10108 : parent.u.c.component = dt->components;
3029 : :
3030 : 10108 : if (dt->backend_decl == NULL)
3031 : 0 : gfc_get_derived_type (dt);
3032 : :
3033 : : /* Build the reference and call self. */
3034 : 10108 : gfc_conv_component_ref (se, &parent);
3035 : 10108 : parent.u.c.sym = dt->components->ts.u.derived;
3036 : 10108 : parent.u.c.component = c;
3037 : 10108 : conv_parent_component_references (se, &parent);
3038 : : }
3039 : :
3040 : :
3041 : : static void
3042 : 537 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
3043 : : {
3044 : 537 : tree res = se->expr;
3045 : :
3046 : 537 : switch (ref->u.i)
3047 : : {
3048 : 259 : case INQUIRY_RE:
3049 : 518 : res = fold_build1_loc (input_location, REALPART_EXPR,
3050 : 259 : TREE_TYPE (TREE_TYPE (res)), res);
3051 : 259 : break;
3052 : :
3053 : 233 : case INQUIRY_IM:
3054 : 466 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
3055 : 233 : TREE_TYPE (TREE_TYPE (res)), res);
3056 : 233 : break;
3057 : :
3058 : 7 : case INQUIRY_KIND:
3059 : 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
3060 : 7 : ts->kind);
3061 : 7 : se->string_length = NULL_TREE;
3062 : 7 : break;
3063 : :
3064 : 38 : case INQUIRY_LEN:
3065 : 38 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
3066 : : se->string_length);
3067 : 38 : se->string_length = NULL_TREE;
3068 : 38 : break;
3069 : :
3070 : 0 : default:
3071 : 0 : gcc_unreachable ();
3072 : : }
3073 : 537 : se->expr = res;
3074 : 537 : }
3075 : :
3076 : : /* Dereference VAR where needed if it is a pointer, reference, etc.
3077 : : according to Fortran semantics. */
3078 : :
3079 : : tree
3080 : 1396304 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3081 : : bool is_classarray)
3082 : : {
3083 : 1396304 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3084 : : return var;
3085 : 274952 : if (is_CFI_desc (sym, NULL))
3086 : 11890 : return build_fold_indirect_ref_loc (input_location, var);
3087 : :
3088 : : /* Characters are entirely different from other types, they are treated
3089 : : separately. */
3090 : 263062 : if (sym->ts.type == BT_CHARACTER)
3091 : : {
3092 : : /* Dereference character pointer dummy arguments
3093 : : or results. */
3094 : 30494 : if ((sym->attr.pointer || sym->attr.allocatable
3095 : 17210 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3096 : 13620 : && (sym->attr.dummy
3097 : 10481 : || sym->attr.function
3098 : 10131 : || sym->attr.result))
3099 : 4144 : var = build_fold_indirect_ref_loc (input_location, var);
3100 : : }
3101 : 232568 : else if (!sym->attr.value)
3102 : : {
3103 : : /* Dereference temporaries for class array dummy arguments. */
3104 : 162794 : if (sym->attr.dummy && is_classarray
3105 : 239006 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3106 : : {
3107 : 4950 : if (!descriptor_only_p)
3108 : 2507 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3109 : :
3110 : 4950 : var = build_fold_indirect_ref_loc (input_location, var);
3111 : : }
3112 : :
3113 : : /* Dereference non-character scalar dummy arguments. */
3114 : 231764 : if (sym->attr.dummy && !sym->attr.dimension
3115 : 100204 : && !(sym->attr.codimension && sym->attr.allocatable)
3116 : 100143 : && (sym->ts.type != BT_CLASS
3117 : 18560 : || (!CLASS_DATA (sym)->attr.dimension
3118 : 10859 : && !(CLASS_DATA (sym)->attr.codimension
3119 : 270 : && CLASS_DATA (sym)->attr.allocatable))))
3120 : 92304 : var = build_fold_indirect_ref_loc (input_location, var);
3121 : :
3122 : : /* Dereference scalar hidden result. */
3123 : 231764 : if (flag_f2c && sym->ts.type == BT_COMPLEX
3124 : 286 : && (sym->attr.function || sym->attr.result)
3125 : 108 : && !sym->attr.dimension && !sym->attr.pointer
3126 : 60 : && !sym->attr.always_explicit)
3127 : 36 : var = build_fold_indirect_ref_loc (input_location, var);
3128 : :
3129 : : /* Dereference non-character, non-class pointer variables.
3130 : : These must be dummies, results, or scalars. */
3131 : 231764 : if (!is_classarray
3132 : 224098 : && (sym->attr.pointer || sym->attr.allocatable
3133 : 177796 : || gfc_is_associate_pointer (sym)
3134 : 173214 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3135 : 301631 : && (sym->attr.dummy
3136 : 33443 : || sym->attr.function
3137 : 32519 : || sym->attr.result
3138 : 31567 : || (!sym->attr.dimension
3139 : 31564 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3140 : 69864 : var = build_fold_indirect_ref_loc (input_location, var);
3141 : : /* Now treat the class array pointer variables accordingly. */
3142 : 161900 : else if (sym->ts.type == BT_CLASS
3143 : 18984 : && sym->attr.dummy
3144 : 18560 : && (CLASS_DATA (sym)->attr.dimension
3145 : 10859 : || CLASS_DATA (sym)->attr.codimension)
3146 : 7971 : && ((CLASS_DATA (sym)->as
3147 : 7971 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3148 : 6974 : || CLASS_DATA (sym)->attr.allocatable
3149 : 5649 : || CLASS_DATA (sym)->attr.class_pointer))
3150 : 2889 : var = build_fold_indirect_ref_loc (input_location, var);
3151 : : /* And the case where a non-dummy, non-result, non-function,
3152 : : non-allocable and non-pointer classarray is present. This case was
3153 : : previously covered by the first if, but with introducing the
3154 : : condition !is_classarray there, that case has to be covered
3155 : : explicitly. */
3156 : 159011 : else if (sym->ts.type == BT_CLASS
3157 : 16095 : && !sym->attr.dummy
3158 : 424 : && !sym->attr.function
3159 : 424 : && !sym->attr.result
3160 : 424 : && (CLASS_DATA (sym)->attr.dimension
3161 : 3 : || CLASS_DATA (sym)->attr.codimension)
3162 : 424 : && (sym->assoc
3163 : 0 : || !CLASS_DATA (sym)->attr.allocatable)
3164 : 424 : && !CLASS_DATA (sym)->attr.class_pointer)
3165 : 424 : var = build_fold_indirect_ref_loc (input_location, var);
3166 : : }
3167 : :
3168 : : return var;
3169 : : }
3170 : :
3171 : : /* Return the contents of a variable. Also handles reference/pointer
3172 : : variables (all Fortran pointer references are implicit). */
3173 : :
3174 : : static void
3175 : 1543533 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3176 : : {
3177 : 1543533 : gfc_ss *ss;
3178 : 1543533 : gfc_ref *ref;
3179 : 1543533 : gfc_symbol *sym;
3180 : 1543533 : tree parent_decl = NULL_TREE;
3181 : 1543533 : int parent_flag;
3182 : 1543533 : bool return_value;
3183 : 1543533 : bool alternate_entry;
3184 : 1543533 : bool entry_master;
3185 : 1543533 : bool is_classarray;
3186 : 1543533 : bool first_time = true;
3187 : :
3188 : 1543533 : sym = expr->symtree->n.sym;
3189 : 1543533 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3190 : 1543533 : ss = se->ss;
3191 : 1543533 : if (ss != NULL)
3192 : : {
3193 : 128217 : gfc_ss_info *ss_info = ss->info;
3194 : :
3195 : : /* Check that something hasn't gone horribly wrong. */
3196 : 128217 : gcc_assert (ss != gfc_ss_terminator);
3197 : 128217 : gcc_assert (ss_info->expr == expr);
3198 : :
3199 : : /* A scalarized term. We already know the descriptor. */
3200 : 128217 : se->expr = ss_info->data.array.descriptor;
3201 : 128217 : se->string_length = ss_info->string_length;
3202 : 128217 : ref = ss_info->data.array.ref;
3203 : 128217 : if (ref)
3204 : 127899 : gcc_assert (ref->type == REF_ARRAY
3205 : : && ref->u.ar.type != AR_ELEMENT);
3206 : : else
3207 : 318 : gfc_conv_tmp_array_ref (se);
3208 : : }
3209 : : else
3210 : : {
3211 : 1415316 : tree se_expr = NULL_TREE;
3212 : :
3213 : 1415316 : se->expr = gfc_get_symbol_decl (sym);
3214 : :
3215 : : /* Deal with references to a parent results or entries by storing
3216 : : the current_function_decl and moving to the parent_decl. */
3217 : 1415316 : return_value = sym->attr.function && sym->result == sym;
3218 : 19668 : alternate_entry = sym->attr.function && sym->attr.entry
3219 : 1416391 : && sym->result == sym;
3220 : 2830632 : entry_master = sym->attr.result
3221 : 11540 : && sym->ns->proc_name->attr.entry_master
3222 : 1415697 : && !gfc_return_by_reference (sym->ns->proc_name);
3223 : 1415316 : if (current_function_decl)
3224 : 1396525 : parent_decl = DECL_CONTEXT (current_function_decl);
3225 : :
3226 : 1415316 : if ((se->expr == parent_decl && return_value)
3227 : 1415205 : || (sym->ns && sym->ns->proc_name
3228 : 1410381 : && parent_decl
3229 : 1391590 : && sym->ns->proc_name->backend_decl == parent_decl
3230 : 37727 : && (alternate_entry || entry_master)))
3231 : : parent_flag = 1;
3232 : : else
3233 : 1415172 : parent_flag = 0;
3234 : :
3235 : : /* Special case for assigning the return value of a function.
3236 : : Self recursive functions must have an explicit return value. */
3237 : 1415316 : if (return_value && (se->expr == current_function_decl || parent_flag))
3238 : 11969 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3239 : :
3240 : : /* Similarly for alternate entry points. */
3241 : 1403347 : else if (alternate_entry
3242 : 1042 : && (sym->ns->proc_name->backend_decl == current_function_decl
3243 : 0 : || parent_flag))
3244 : : {
3245 : 1042 : gfc_entry_list *el = NULL;
3246 : :
3247 : 1609 : for (el = sym->ns->entries; el; el = el->next)
3248 : 1609 : if (sym == el->sym)
3249 : : {
3250 : 1042 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3251 : 1042 : break;
3252 : : }
3253 : : }
3254 : :
3255 : 1402305 : else if (entry_master
3256 : 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3257 : 0 : || parent_flag))
3258 : 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3259 : :
3260 : 13306 : if (se_expr)
3261 : 13306 : se->expr = se_expr;
3262 : :
3263 : : /* Procedure actual arguments. Look out for temporary variables
3264 : : with the same attributes as function values. */
3265 : 1402010 : else if (!sym->attr.temporary
3266 : 1401942 : && sym->attr.flavor == FL_PROCEDURE
3267 : 20728 : && se->expr != current_function_decl)
3268 : : {
3269 : 20689 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3270 : : {
3271 : 19151 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3272 : 19151 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3273 : : }
3274 : 20689 : return;
3275 : : }
3276 : :
3277 : 1394627 : if (sym->ts.type == BT_CLASS
3278 : 69141 : && sym->attr.class_ok
3279 : 68899 : && sym->ts.u.derived->attr.is_class)
3280 : : {
3281 : 25929 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3282 : 75994 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3283 : 5082 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3284 : : else
3285 : 63817 : se->class_container = se->expr;
3286 : : }
3287 : :
3288 : : /* Dereference the expression, where needed. */
3289 : 1394627 : if (se->class_container && CLASS_DATA (sym)->attr.codimension
3290 : 1890 : && !CLASS_DATA (sym)->attr.dimension)
3291 : 779 : se->expr
3292 : 779 : = gfc_maybe_dereference_var (sym, se->class_container,
3293 : 779 : se->descriptor_only, is_classarray);
3294 : : else
3295 : 1393848 : se->expr
3296 : 1393848 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3297 : : is_classarray);
3298 : :
3299 : 1394627 : ref = expr->ref;
3300 : : }
3301 : :
3302 : : /* For character variables, also get the length. */
3303 : 1522844 : if (sym->ts.type == BT_CHARACTER)
3304 : : {
3305 : : /* If the character length of an entry isn't set, get the length from
3306 : : the master function instead. */
3307 : 158124 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3308 : 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3309 : : else
3310 : 158124 : se->string_length = sym->ts.u.cl->backend_decl;
3311 : 158124 : gcc_assert (se->string_length);
3312 : :
3313 : : /* For coarray strings return the pointer to the data and not the
3314 : : descriptor. */
3315 : 3459 : if (sym->attr.codimension && sym->attr.associate_var
3316 : 6 : && !se->descriptor_only
3317 : 158130 : && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
3318 : 6 : se->expr = gfc_conv_descriptor_data_get (se->expr);
3319 : : }
3320 : :
3321 : : /* F202Y: Runtime warning that an assumed rank object is associated
3322 : : with an assumed size object. */
3323 : 1522844 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3324 : 88984 : && (gfc_option.allow_std & GFC_STD_F202Y)
3325 : 1523078 : && expr->rank == -1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3326 : : {
3327 : 60 : tree dim, lower, upper, cond;
3328 : 60 : char *msg;
3329 : :
3330 : 60 : dim = fold_convert (signed_char_type_node,
3331 : : gfc_conv_descriptor_rank (se->expr));
3332 : 60 : dim = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
3333 : : dim, build_int_cst (signed_char_type_node, 1));
3334 : 60 : lower = gfc_conv_descriptor_lbound_get (se->expr, dim);
3335 : 60 : upper = gfc_conv_descriptor_ubound_get (se->expr, dim);
3336 : :
3337 : 60 : msg = xasprintf ("Assumed rank object %s is associated with an "
3338 : : "assumed size object", sym->name);
3339 : 60 : cond = fold_build2_loc (input_location, LT_EXPR,
3340 : : logical_type_node, upper, lower);
3341 : 60 : gfc_trans_runtime_check (false, true, cond, &se->pre,
3342 : : &gfc_current_locus, msg);
3343 : 60 : free (msg);
3344 : : }
3345 : :
3346 : : /* Some expressions leak through that haven't been fixed up. */
3347 : 1522844 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3348 : 386 : gfc_fixup_inferred_type_refs (expr);
3349 : :
3350 : 1522844 : gfc_typespec *ts = &sym->ts;
3351 : 1933039 : while (ref)
3352 : : {
3353 : 745716 : switch (ref->type)
3354 : : {
3355 : 582878 : case REF_ARRAY:
3356 : : /* Return the descriptor if that's what we want and this is an array
3357 : : section reference. */
3358 : 582878 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3359 : : return;
3360 : : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3361 : : /* Return the descriptor for array pointers and allocations. */
3362 : 256292 : if (se->want_pointer
3363 : 22541 : && ref->next == NULL && (se->descriptor_only))
3364 : : return;
3365 : :
3366 : 247357 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3367 : : /* Return a pointer to an element. */
3368 : 247357 : break;
3369 : :
3370 : 155768 : case REF_COMPONENT:
3371 : 155768 : ts = &ref->u.c.component->ts;
3372 : 155768 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3373 : 5528 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3374 : 2910 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3375 : 2910 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3376 : 2443 : && strcmp ("_data", ref->u.c.component->name) == 0)
3377 : : /* Skip the first ref of a _data component, because for class
3378 : : arrays that one is already done by introducing a temporary
3379 : : array descriptor. */
3380 : : break;
3381 : :
3382 : 153325 : if (ref->u.c.sym->attr.extension)
3383 : 51812 : conv_parent_component_references (se, ref);
3384 : :
3385 : 153325 : gfc_conv_component_ref (se, ref);
3386 : :
3387 : 153325 : if (ref->u.c.component->ts.type == BT_CLASS
3388 : 11821 : && ref->u.c.component->attr.class_ok
3389 : 11821 : && ref->u.c.component->ts.u.derived->attr.is_class)
3390 : 11821 : se->class_container = se->expr;
3391 : 141504 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3392 : 139010 : && ref->u.c.sym->attr.is_class))
3393 : 76422 : se->class_container = NULL_TREE;
3394 : :
3395 : 153325 : if (!ref->next && ref->u.c.sym->attr.codimension
3396 : 0 : && se->want_pointer && se->descriptor_only)
3397 : : return;
3398 : :
3399 : : break;
3400 : :
3401 : 6533 : case REF_SUBSTRING:
3402 : 6533 : gfc_conv_substring (se, ref, expr->ts.kind,
3403 : 6533 : expr->symtree->name, &expr->where);
3404 : 6533 : break;
3405 : :
3406 : 537 : case REF_INQUIRY:
3407 : 537 : conv_inquiry (se, ref, expr, ts);
3408 : 537 : break;
3409 : :
3410 : 0 : default:
3411 : 0 : gcc_unreachable ();
3412 : 410195 : break;
3413 : : }
3414 : 410195 : first_time = false;
3415 : 410195 : ref = ref->next;
3416 : : }
3417 : : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3418 : : separately. */
3419 : 1187323 : if (se->want_pointer)
3420 : : {
3421 : 128127 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3422 : 7698 : gfc_conv_string_parameter (se);
3423 : : else
3424 : 120429 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3425 : : }
3426 : : }
3427 : :
3428 : :
3429 : : /* Unary ops are easy... Or they would be if ! was a valid op. */
3430 : :
3431 : : static void
3432 : 28102 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3433 : : {
3434 : 28102 : gfc_se operand;
3435 : 28102 : tree type;
3436 : :
3437 : 28102 : gcc_assert (expr->ts.type != BT_CHARACTER);
3438 : : /* Initialize the operand. */
3439 : 28102 : gfc_init_se (&operand, se);
3440 : 28102 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3441 : 28102 : gfc_add_block_to_block (&se->pre, &operand.pre);
3442 : :
3443 : 28102 : type = gfc_typenode_for_spec (&expr->ts);
3444 : :
3445 : : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3446 : : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3447 : : All other unary operators have an equivalent GIMPLE unary operator. */
3448 : 28102 : if (code == TRUTH_NOT_EXPR)
3449 : 19872 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3450 : : build_int_cst (type, 0));
3451 : : else
3452 : 8230 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3453 : :
3454 : 28102 : }
3455 : :
3456 : : /* Expand power operator to optimal multiplications when a value is raised
3457 : : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3458 : : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3459 : : Programming", 3rd Edition, 1998. */
3460 : :
3461 : : /* This code is mostly duplicated from expand_powi in the backend.
3462 : : We establish the "optimal power tree" lookup table with the defined size.
3463 : : The items in the table are the exponents used to calculate the index
3464 : : exponents. Any integer n less than the value can get an "addition chain",
3465 : : with the first node being one. */
3466 : : #define POWI_TABLE_SIZE 256
3467 : :
3468 : : /* The table is from builtins.cc. */
3469 : : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3470 : : {
3471 : : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3472 : : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3473 : : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3474 : : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3475 : : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3476 : : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3477 : : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3478 : : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3479 : : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3480 : : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3481 : : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3482 : : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3483 : : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3484 : : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3485 : : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3486 : : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3487 : : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3488 : : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3489 : : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3490 : : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3491 : : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3492 : : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3493 : : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3494 : : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3495 : : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3496 : : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3497 : : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3498 : : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3499 : : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3500 : : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3501 : : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3502 : : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3503 : : };
3504 : :
3505 : : /* If n is larger than lookup table's max index, we use the "window
3506 : : method". */
3507 : : #define POWI_WINDOW_SIZE 3
3508 : :
3509 : : /* Recursive function to expand the power operator. The temporary
3510 : : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3511 : : static tree
3512 : 176241 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3513 : : {
3514 : 176241 : tree op0;
3515 : 176241 : tree op1;
3516 : 176241 : tree tmp;
3517 : 176241 : int digit;
3518 : :
3519 : 176241 : if (n < POWI_TABLE_SIZE)
3520 : : {
3521 : 136094 : if (tmpvar[n])
3522 : : return tmpvar[n];
3523 : :
3524 : 56205 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3525 : 56205 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3526 : : }
3527 : 40147 : else if (n & 1)
3528 : : {
3529 : 9799 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3530 : 9799 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3531 : 9799 : op1 = gfc_conv_powi (se, digit, tmpvar);
3532 : : }
3533 : : else
3534 : : {
3535 : 30348 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3536 : 30348 : op1 = op0;
3537 : : }
3538 : :
3539 : 96352 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3540 : 96352 : tmp = gfc_evaluate_now (tmp, &se->pre);
3541 : :
3542 : 96352 : if (n < POWI_TABLE_SIZE)
3543 : 56205 : tmpvar[n] = tmp;
3544 : :
3545 : : return tmp;
3546 : : }
3547 : :
3548 : :
3549 : : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3550 : : return 1. Else return 0 and a call to runtime library functions
3551 : : will have to be built. */
3552 : : static int
3553 : 2562 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3554 : : {
3555 : 2562 : tree cond;
3556 : 2562 : tree tmp;
3557 : 2562 : tree type;
3558 : 2562 : tree vartmp[POWI_TABLE_SIZE];
3559 : 2562 : HOST_WIDE_INT m;
3560 : 2562 : unsigned HOST_WIDE_INT n;
3561 : 2562 : int sgn;
3562 : 2562 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3563 : :
3564 : : /* If exponent is too large, we won't expand it anyway, so don't bother
3565 : : with large integer values. */
3566 : 2562 : if (!wi::fits_shwi_p (wrhs))
3567 : : return 0;
3568 : :
3569 : 2202 : m = wrhs.to_shwi ();
3570 : : /* Use the wide_int's routine to reliably get the absolute value on all
3571 : : platforms. Then convert it to a HOST_WIDE_INT like above. */
3572 : 2202 : n = wi::abs (wrhs).to_shwi ();
3573 : :
3574 : 2202 : type = TREE_TYPE (lhs);
3575 : 2202 : sgn = tree_int_cst_sgn (rhs);
3576 : :
3577 : 2202 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3578 : 4404 : || optimize_size) && (m > 2 || m < -1))
3579 : : return 0;
3580 : :
3581 : : /* rhs == 0 */
3582 : 1244 : if (sgn == 0)
3583 : : {
3584 : 167 : se->expr = gfc_build_const (type, integer_one_node);
3585 : 167 : return 1;
3586 : : }
3587 : :
3588 : : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3589 : 1077 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3590 : : {
3591 : 152 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3592 : 152 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3593 : 152 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3594 : 152 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3595 : :
3596 : : /* If rhs is even,
3597 : : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3598 : 152 : if ((n & 1) == 0)
3599 : : {
3600 : 72 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3601 : : logical_type_node, tmp, cond);
3602 : 72 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3603 : : tmp, build_int_cst (type, 1),
3604 : : build_int_cst (type, 0));
3605 : 72 : return 1;
3606 : : }
3607 : : /* If rhs is odd,
3608 : : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3609 : 80 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3610 : : build_int_cst (type, -1),
3611 : : build_int_cst (type, 0));
3612 : 80 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3613 : : cond, build_int_cst (type, 1), tmp);
3614 : 80 : return 1;
3615 : : }
3616 : :
3617 : 925 : memset (vartmp, 0, sizeof (vartmp));
3618 : 925 : vartmp[1] = lhs;
3619 : 925 : if (sgn == -1)
3620 : : {
3621 : 91 : tmp = gfc_build_const (type, integer_one_node);
3622 : 91 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3623 : : vartmp[1]);
3624 : : }
3625 : :
3626 : 925 : se->expr = gfc_conv_powi (se, n, vartmp);
3627 : :
3628 : 925 : return 1;
3629 : : }
3630 : :
3631 : : /* Convert lhs**rhs, for constant rhs, when both are unsigned.
3632 : : Method:
3633 : : if (rhs == 0) ! Checked here.
3634 : : return 1;
3635 : : if (lhs & 1 == 1) ! odd_cnd
3636 : : {
3637 : : if (bit_size(rhs) < bit_size(lhs)) ! Checked here.
3638 : : return lhs ** rhs;
3639 : :
3640 : : mask = 1 << (bit_size(a) - 1) / 2;
3641 : : return lhs ** (n & rhs);
3642 : : }
3643 : : if (rhs > bit_size(lhs)) ! Checked here.
3644 : : return 0;
3645 : :
3646 : : return lhs ** rhs;
3647 : : */
3648 : :
3649 : : static int
3650 : 15120 : gfc_conv_cst_uint_power (gfc_se * se, tree lhs, tree rhs)
3651 : : {
3652 : 15120 : tree type = TREE_TYPE (lhs);
3653 : 15120 : tree tmp, is_odd, odd_branch, even_branch;
3654 : 15120 : unsigned HOST_WIDE_INT lhs_prec, rhs_prec;
3655 : 15120 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3656 : 15120 : unsigned HOST_WIDE_INT n, n_odd;
3657 : 15120 : tree vartmp_odd[POWI_TABLE_SIZE], vartmp_even[POWI_TABLE_SIZE];
3658 : :
3659 : : /* Anything ** 0 is one. */
3660 : 15120 : if (integer_zerop (rhs))
3661 : : {
3662 : 1800 : se->expr = build_int_cst (type, 1);
3663 : 1800 : return 1;
3664 : : }
3665 : :
3666 : 13320 : if (!wi::fits_uhwi_p (wrhs))
3667 : : return 0;
3668 : :
3669 : 12960 : n = wrhs.to_uhwi ();
3670 : :
3671 : : /* tmp = a & 1; . */
3672 : 12960 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3673 : : lhs, build_int_cst (type, 1));
3674 : 12960 : is_odd = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3675 : : tmp, build_int_cst (type, 1));
3676 : :
3677 : 12960 : lhs_prec = TYPE_PRECISION (type);
3678 : 12960 : rhs_prec = TYPE_PRECISION (TREE_TYPE (rhs));
3679 : :
3680 : 12960 : if (rhs_prec >= lhs_prec && lhs_prec <= HOST_BITS_PER_WIDE_INT)
3681 : : {
3682 : 7044 : unsigned HOST_WIDE_INT mask = (HOST_WIDE_INT_1U << (lhs_prec - 1)) - 1;
3683 : 7044 : n_odd = n & mask;
3684 : : }
3685 : : else
3686 : : n_odd = n;
3687 : :
3688 : 12960 : memset (vartmp_odd, 0, sizeof (vartmp_odd));
3689 : 12960 : vartmp_odd[0] = build_int_cst (type, 1);
3690 : 12960 : vartmp_odd[1] = lhs;
3691 : 12960 : odd_branch = gfc_conv_powi (se, n_odd, vartmp_odd);
3692 : 12960 : even_branch = NULL_TREE;
3693 : :
3694 : 12960 : if (n > lhs_prec)
3695 : 4260 : even_branch = build_int_cst (type, 0);
3696 : : else
3697 : : {
3698 : 8700 : if (n_odd != n)
3699 : : {
3700 : 0 : memset (vartmp_even, 0, sizeof (vartmp_even));
3701 : 0 : vartmp_even[0] = build_int_cst (type, 1);
3702 : 0 : vartmp_even[1] = lhs;
3703 : 0 : even_branch = gfc_conv_powi (se, n, vartmp_even);
3704 : : }
3705 : : }
3706 : 4260 : if (even_branch != NULL_TREE)
3707 : 4260 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, is_odd,
3708 : : odd_branch, even_branch);
3709 : : else
3710 : 8700 : se->expr = odd_branch;
3711 : :
3712 : : return 1;
3713 : : }
3714 : :
3715 : : /* Power op (**). Constant integer exponent and powers of 2 have special
3716 : : handling. */
3717 : :
3718 : : static void
3719 : 48553 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3720 : : {
3721 : 48553 : tree gfc_int4_type_node;
3722 : 48553 : int kind;
3723 : 48553 : int ikind;
3724 : 48553 : int res_ikind_1, res_ikind_2;
3725 : 48553 : gfc_se lse;
3726 : 48553 : gfc_se rse;
3727 : 48553 : tree fndecl = NULL;
3728 : :
3729 : 48553 : gfc_init_se (&lse, se);
3730 : 48553 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3731 : 48553 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3732 : 48553 : gfc_add_block_to_block (&se->pre, &lse.pre);
3733 : :
3734 : 48553 : gfc_init_se (&rse, se);
3735 : 48553 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3736 : 48553 : gfc_add_block_to_block (&se->pre, &rse.pre);
3737 : :
3738 : 48553 : if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
3739 : : {
3740 : 16994 : if (expr->value.op.op2->ts.type == BT_INTEGER)
3741 : : {
3742 : 1723 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3743 : 20023 : return;
3744 : : }
3745 : 15271 : else if (expr->value.op.op2->ts.type == BT_UNSIGNED)
3746 : : {
3747 : 15120 : if (gfc_conv_cst_uint_power (se, lse.expr, rse.expr))
3748 : : return;
3749 : : }
3750 : : }
3751 : :
3752 : 32549 : if ((expr->value.op.op2->ts.type == BT_INTEGER
3753 : 31467 : || expr->value.op.op2->ts.type == BT_UNSIGNED)
3754 : 31682 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3755 : 839 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3756 : : return;
3757 : :
3758 : 32549 : if (INTEGER_CST_P (lse.expr)
3759 : 15365 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE
3760 : 47914 : && expr->value.op.op2->ts.type == BT_INTEGER)
3761 : : {
3762 : 245 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3763 : 245 : HOST_WIDE_INT v;
3764 : 245 : unsigned HOST_WIDE_INT w;
3765 : 245 : int kind, ikind, bit_size;
3766 : :
3767 : 245 : v = wlhs.to_shwi ();
3768 : 245 : w = absu_hwi (v);
3769 : :
3770 : 245 : kind = expr->value.op.op1->ts.kind;
3771 : 245 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3772 : 245 : bit_size = gfc_integer_kinds[ikind].bit_size;
3773 : :
3774 : 245 : if (v == 1)
3775 : : {
3776 : : /* 1**something is always 1. */
3777 : 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3778 : 239 : return;
3779 : : }
3780 : 210 : else if (v == -1)
3781 : : {
3782 : : /* (-1)**n is 1 - ((n & 1) << 1) */
3783 : 34 : tree type;
3784 : 34 : tree tmp;
3785 : :
3786 : 34 : type = TREE_TYPE (lse.expr);
3787 : 34 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3788 : : rse.expr, build_int_cst (type, 1));
3789 : 34 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3790 : : tmp, build_int_cst (type, 1));
3791 : 34 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3792 : : build_int_cst (type, 1), tmp);
3793 : 34 : se->expr = tmp;
3794 : 34 : return;
3795 : : }
3796 : 176 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3797 : : {
3798 : : /* Here v is +/- 2**e. The further simplification uses
3799 : : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3800 : : 1<<(4*n), etc., but we have to make sure to return zero
3801 : : if the number of bits is too large. */
3802 : 170 : tree lshift;
3803 : 170 : tree type;
3804 : 170 : tree shift;
3805 : 170 : tree ge;
3806 : 170 : tree cond;
3807 : 170 : tree num_bits;
3808 : 170 : tree cond2;
3809 : 170 : tree tmp1;
3810 : :
3811 : 170 : type = TREE_TYPE (lse.expr);
3812 : :
3813 : 170 : if (w == 2)
3814 : 110 : shift = rse.expr;
3815 : 60 : else if (w == 4)
3816 : 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3817 : 12 : TREE_TYPE (rse.expr),
3818 : : rse.expr, rse.expr);
3819 : : else
3820 : : {
3821 : : /* use popcount for fast log2(w) */
3822 : 48 : int e = wi::popcount (w-1);
3823 : 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3824 : 48 : TREE_TYPE (rse.expr),
3825 : 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3826 : : rse.expr);
3827 : : }
3828 : :
3829 : 170 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3830 : : build_int_cst (type, 1), shift);
3831 : 170 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3832 : : rse.expr, build_int_cst (type, 0));
3833 : 170 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3834 : : build_int_cst (type, 0));
3835 : 170 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3836 : 170 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3837 : : rse.expr, num_bits);
3838 : 170 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3839 : : build_int_cst (type, 0), cond);
3840 : 170 : if (v > 0)
3841 : : {
3842 : 128 : se->expr = tmp1;
3843 : : }
3844 : : else
3845 : : {
3846 : : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3847 : 42 : tree tmp2;
3848 : 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3849 : : rse.expr, build_int_cst (type, 1));
3850 : 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3851 : : tmp2, build_int_cst (type, 1));
3852 : 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3853 : : build_int_cst (type, 1), tmp2);
3854 : 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3855 : : tmp1, tmp2);
3856 : : }
3857 : 170 : return;
3858 : : }
3859 : : }
3860 : : /* Handle unsigned separate from signed above, things would be too
3861 : : complicated otherwise. */
3862 : :
3863 : 32310 : if (INTEGER_CST_P (lse.expr) && expr->value.op.op1->ts.type == BT_UNSIGNED)
3864 : : {
3865 : 15120 : gfc_expr * op1 = expr->value.op.op1;
3866 : 15120 : tree type;
3867 : :
3868 : 15120 : type = TREE_TYPE (lse.expr);
3869 : :
3870 : 15120 : if (mpz_cmp_ui (op1->value.integer, 1) == 0)
3871 : : {
3872 : : /* 1**something is always 1. */
3873 : 1260 : se->expr = build_int_cst (type, 1);
3874 : 1260 : return;
3875 : : }
3876 : :
3877 : : /* Simplify 2u**x to a shift, with the value set to zero if it falls
3878 : : outside the range. */
3879 : 26460 : if (mpz_popcount (op1->value.integer) == 1)
3880 : : {
3881 : 2520 : tree prec_m1, lim, shift, lshift, cond, tmp;
3882 : 2520 : tree rtype = TREE_TYPE (rse.expr);
3883 : 2520 : int e = mpz_scan1 (op1->value.integer, 0);
3884 : :
3885 : 2520 : shift = fold_build2_loc (input_location, MULT_EXPR,
3886 : 2520 : rtype, build_int_cst (rtype, e),
3887 : : rse.expr);
3888 : 2520 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3889 : : build_int_cst (type, 1), shift);
3890 : 5040 : prec_m1 = fold_build2_loc (input_location, MINUS_EXPR, rtype,
3891 : 2520 : build_int_cst (rtype, TYPE_PRECISION (type)),
3892 : : build_int_cst (rtype, 1));
3893 : 2520 : lim = fold_build2_loc (input_location, TRUNC_DIV_EXPR, rtype,
3894 : 2520 : prec_m1, build_int_cst (rtype, e));
3895 : 2520 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3896 : : rse.expr, lim);
3897 : 2520 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond,
3898 : : build_int_cst (type, 0), lshift);
3899 : 2520 : se->expr = tmp;
3900 : 2520 : return;
3901 : : }
3902 : : }
3903 : :
3904 : 28530 : gfc_int4_type_node = gfc_get_int_type (4);
3905 : :
3906 : : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3907 : : library routine. But in the end, we have to convert the result back
3908 : : if this case applies -- with res_ikind_K, we keep track whether operand K
3909 : : falls into this case. */
3910 : 28530 : res_ikind_1 = -1;
3911 : 28530 : res_ikind_2 = -1;
3912 : :
3913 : 28530 : kind = expr->value.op.op1->ts.kind;
3914 : 28530 : switch (expr->value.op.op2->ts.type)
3915 : : {
3916 : 843 : case BT_INTEGER:
3917 : 843 : ikind = expr->value.op.op2->ts.kind;
3918 : 843 : switch (ikind)
3919 : : {
3920 : 144 : case 1:
3921 : 144 : case 2:
3922 : 144 : rse.expr = convert (gfc_int4_type_node, rse.expr);
3923 : 144 : res_ikind_2 = ikind;
3924 : : /* Fall through. */
3925 : :
3926 : : case 4:
3927 : : ikind = 0;
3928 : : break;
3929 : :
3930 : : case 8:
3931 : : ikind = 1;
3932 : : break;
3933 : :
3934 : 6 : case 16:
3935 : 6 : ikind = 2;
3936 : 6 : break;
3937 : :
3938 : 0 : default:
3939 : 0 : gcc_unreachable ();
3940 : : }
3941 : 843 : switch (kind)
3942 : : {
3943 : 0 : case 1:
3944 : 0 : case 2:
3945 : 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
3946 : : {
3947 : 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
3948 : 0 : res_ikind_1 = kind;
3949 : : }
3950 : : else
3951 : 0 : gcc_unreachable ();
3952 : : /* Fall through. */
3953 : :
3954 : : case 4:
3955 : : kind = 0;
3956 : : break;
3957 : :
3958 : : case 8:
3959 : : kind = 1;
3960 : : break;
3961 : :
3962 : 6 : case 10:
3963 : 6 : kind = 2;
3964 : 6 : break;
3965 : :
3966 : 18 : case 16:
3967 : 18 : kind = 3;
3968 : 18 : break;
3969 : :
3970 : 0 : default:
3971 : 0 : gcc_unreachable ();
3972 : : }
3973 : :
3974 : 843 : switch (expr->value.op.op1->ts.type)
3975 : : {
3976 : 99 : case BT_INTEGER:
3977 : 99 : if (kind == 3) /* Case 16 was not handled properly above. */
3978 : : kind = 2;
3979 : 99 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3980 : 99 : break;
3981 : :
3982 : 557 : case BT_REAL:
3983 : : /* Use builtins for real ** int4. */
3984 : 557 : if (ikind == 0)
3985 : : {
3986 : 500 : switch (kind)
3987 : : {
3988 : 327 : case 0:
3989 : 327 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3990 : 327 : break;
3991 : :
3992 : 155 : case 1:
3993 : 155 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3994 : 155 : break;
3995 : :
3996 : 6 : case 2:
3997 : 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3998 : 6 : break;
3999 : :
4000 : 12 : case 3:
4001 : : /* Use the __builtin_powil() only if real(kind=16) is
4002 : : actually the C long double type. */
4003 : 12 : if (!gfc_real16_is_float128)
4004 : 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4005 : : break;
4006 : :
4007 : : default:
4008 : : gcc_unreachable ();
4009 : : }
4010 : : }
4011 : :
4012 : : /* If we don't have a good builtin for this, go for the
4013 : : library function. */
4014 : 488 : if (!fndecl)
4015 : 69 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
4016 : : break;
4017 : :
4018 : 187 : case BT_COMPLEX:
4019 : 187 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
4020 : 187 : break;
4021 : :
4022 : 0 : default:
4023 : 0 : gcc_unreachable ();
4024 : : }
4025 : : break;
4026 : :
4027 : 138 : case BT_REAL:
4028 : 138 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
4029 : 138 : break;
4030 : :
4031 : 729 : case BT_COMPLEX:
4032 : 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
4033 : 729 : break;
4034 : :
4035 : 26820 : case BT_UNSIGNED:
4036 : 26820 : {
4037 : : /* Valid kinds for unsigned are 1, 2, 4, 8, 16. Instead of using a
4038 : : large switch statement, let's just use __builtin_ctz. */
4039 : 26820 : int base = __builtin_ctz (expr->value.op.op1->ts.kind);
4040 : 26820 : int expon = __builtin_ctz (expr->value.op.op2->ts.kind);
4041 : 26820 : fndecl = gfor_fndecl_unsigned_pow_list[base][expon];
4042 : : }
4043 : 26820 : break;
4044 : :
4045 : 0 : default:
4046 : 0 : gcc_unreachable ();
4047 : 28530 : break;
4048 : : }
4049 : :
4050 : 28530 : se->expr = build_call_expr_loc (input_location,
4051 : : fndecl, 2, lse.expr, rse.expr);
4052 : :
4053 : : /* Convert the result back if it is of wrong integer kind. */
4054 : 28530 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
4055 : : {
4056 : : /* We want the maximum of both operand kinds as result. */
4057 : 0 : if (res_ikind_1 < res_ikind_2)
4058 : 0 : res_ikind_1 = res_ikind_2;
4059 : 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
4060 : : }
4061 : : }
4062 : :
4063 : :
4064 : : /* Generate code to allocate a string temporary. */
4065 : :
4066 : : tree
4067 : 4627 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4068 : : {
4069 : 4627 : tree var;
4070 : 4627 : tree tmp;
4071 : :
4072 : 4627 : if (gfc_can_put_var_on_stack (len))
4073 : : {
4074 : : /* Create a temporary variable to hold the result. */
4075 : 4044 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4076 : 2022 : TREE_TYPE (len), len,
4077 : 2022 : build_int_cst (TREE_TYPE (len), 1));
4078 : 2022 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4079 : :
4080 : 2022 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4081 : 1992 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4082 : : else
4083 : 30 : tmp = build_array_type (TREE_TYPE (type), tmp);
4084 : :
4085 : 2022 : var = gfc_create_var (tmp, "str");
4086 : 2022 : var = gfc_build_addr_expr (type, var);
4087 : : }
4088 : : else
4089 : : {
4090 : : /* Allocate a temporary to hold the result. */
4091 : 2605 : var = gfc_create_var (type, "pstr");
4092 : 2605 : gcc_assert (POINTER_TYPE_P (type));
4093 : 2605 : tmp = TREE_TYPE (type);
4094 : 2605 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4095 : 2563 : tmp = TREE_TYPE (tmp);
4096 : 2605 : tmp = TYPE_SIZE_UNIT (tmp);
4097 : 2605 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4098 : : fold_convert (size_type_node, len),
4099 : : fold_convert (size_type_node, tmp));
4100 : 2605 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4101 : 2605 : gfc_add_modify (&se->pre, var, tmp);
4102 : :
4103 : : /* Free the temporary afterwards. */
4104 : 2605 : tmp = gfc_call_free (var);
4105 : 2605 : gfc_add_expr_to_block (&se->post, tmp);
4106 : : }
4107 : :
4108 : 4627 : return var;
4109 : : }
4110 : :
4111 : :
4112 : : /* Handle a string concatenation operation. A temporary will be allocated to
4113 : : hold the result. */
4114 : :
4115 : : static void
4116 : 1168 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4117 : : {
4118 : 1168 : gfc_se lse, rse;
4119 : 1168 : tree len, type, var, tmp, fndecl;
4120 : :
4121 : 1168 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4122 : : && expr->value.op.op2->ts.type == BT_CHARACTER);
4123 : 1168 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4124 : :
4125 : 1168 : gfc_init_se (&lse, se);
4126 : 1168 : gfc_conv_expr (&lse, expr->value.op.op1);
4127 : 1168 : gfc_conv_string_parameter (&lse);
4128 : 1168 : gfc_init_se (&rse, se);
4129 : 1168 : gfc_conv_expr (&rse, expr->value.op.op2);
4130 : 1168 : gfc_conv_string_parameter (&rse);
4131 : :
4132 : 1168 : gfc_add_block_to_block (&se->pre, &lse.pre);
4133 : 1168 : gfc_add_block_to_block (&se->pre, &rse.pre);
4134 : :
4135 : 1168 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4136 : 1168 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4137 : 1168 : if (len == NULL_TREE)
4138 : : {
4139 : 1004 : len = fold_build2_loc (input_location, PLUS_EXPR,
4140 : : gfc_charlen_type_node,
4141 : : fold_convert (gfc_charlen_type_node,
4142 : : lse.string_length),
4143 : : fold_convert (gfc_charlen_type_node,
4144 : : rse.string_length));
4145 : : }
4146 : :
4147 : 1168 : type = build_pointer_type (type);
4148 : :
4149 : 1168 : var = gfc_conv_string_tmp (se, type, len);
4150 : :
4151 : : /* Do the actual concatenation. */
4152 : 1168 : if (expr->ts.kind == 1)
4153 : 1079 : fndecl = gfor_fndecl_concat_string;
4154 : 89 : else if (expr->ts.kind == 4)
4155 : 89 : fndecl = gfor_fndecl_concat_string_char4;
4156 : : else
4157 : 0 : gcc_unreachable ();
4158 : :
4159 : 1168 : tmp = build_call_expr_loc (input_location,
4160 : : fndecl, 6, len, var, lse.string_length, lse.expr,
4161 : : rse.string_length, rse.expr);
4162 : 1168 : gfc_add_expr_to_block (&se->pre, tmp);
4163 : :
4164 : : /* Add the cleanup for the operands. */
4165 : 1168 : gfc_add_block_to_block (&se->pre, &rse.post);
4166 : 1168 : gfc_add_block_to_block (&se->pre, &lse.post);
4167 : :
4168 : 1168 : se->expr = var;
4169 : 1168 : se->string_length = len;
4170 : 1168 : }
4171 : :
4172 : : /* Translates an op expression. Common (binary) cases are handled by this
4173 : : function, others are passed on. Recursion is used in either case.
4174 : : We use the fact that (op1.ts == op2.ts) (except for the power
4175 : : operator **).
4176 : : Operators need no special handling for scalarized expressions as long as
4177 : : they call gfc_conv_simple_val to get their operands.
4178 : : Character strings get special handling. */
4179 : :
4180 : : static void
4181 : 491493 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4182 : : {
4183 : 491493 : enum tree_code code;
4184 : 491493 : gfc_se lse;
4185 : 491493 : gfc_se rse;
4186 : 491493 : tree tmp, type;
4187 : 491493 : int lop;
4188 : 491493 : int checkstring;
4189 : :
4190 : 491493 : checkstring = 0;
4191 : 491493 : lop = 0;
4192 : 491493 : switch (expr->value.op.op)
4193 : : {
4194 : 14594 : case INTRINSIC_PARENTHESES:
4195 : 14594 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4196 : 3458 : && flag_protect_parens)
4197 : : {
4198 : 3325 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
4199 : 3325 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
4200 : 89098 : return;
4201 : : }
4202 : :
4203 : : /* Fallthrough. */
4204 : 11275 : case INTRINSIC_UPLUS:
4205 : 11275 : gfc_conv_expr (se, expr->value.op.op1);
4206 : 11275 : return;
4207 : :
4208 : 4905 : case INTRINSIC_UMINUS:
4209 : 4905 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4210 : 4905 : return;
4211 : :
4212 : 19872 : case INTRINSIC_NOT:
4213 : 19872 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4214 : 19872 : return;
4215 : :
4216 : : case INTRINSIC_PLUS:
4217 : : code = PLUS_EXPR;
4218 : : break;
4219 : :
4220 : 27048 : case INTRINSIC_MINUS:
4221 : 27048 : code = MINUS_EXPR;
4222 : 27048 : break;
4223 : :
4224 : 30772 : case INTRINSIC_TIMES:
4225 : 30772 : code = MULT_EXPR;
4226 : 30772 : break;
4227 : :
4228 : 6348 : case INTRINSIC_DIVIDE:
4229 : : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
4230 : : an integer or unsigned, we must round towards zero, so we use a
4231 : : TRUNC_DIV_EXPR. */
4232 : 6348 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4233 : : code = TRUNC_DIV_EXPR;
4234 : : else
4235 : 402395 : code = RDIV_EXPR;
4236 : : break;
4237 : :
4238 : 48553 : case INTRINSIC_POWER:
4239 : 48553 : gfc_conv_power_op (se, expr);
4240 : 48553 : return;
4241 : :
4242 : 1168 : case INTRINSIC_CONCAT:
4243 : 1168 : gfc_conv_concat_op (se, expr);
4244 : 1168 : return;
4245 : :
4246 : 4695 : case INTRINSIC_AND:
4247 : 4695 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4248 : : lop = 1;
4249 : : break;
4250 : :
4251 : 55430 : case INTRINSIC_OR:
4252 : 55430 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
4253 : : lop = 1;
4254 : : break;
4255 : :
4256 : : /* EQV and NEQV only work on logicals, but since we represent them
4257 : : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4258 : 12162 : case INTRINSIC_EQ:
4259 : 12162 : case INTRINSIC_EQ_OS:
4260 : 12162 : case INTRINSIC_EQV:
4261 : 12162 : code = EQ_EXPR;
4262 : 12162 : checkstring = 1;
4263 : 12162 : lop = 1;
4264 : 12162 : break;
4265 : :
4266 : 201177 : case INTRINSIC_NE:
4267 : 201177 : case INTRINSIC_NE_OS:
4268 : 201177 : case INTRINSIC_NEQV:
4269 : 201177 : code = NE_EXPR;
4270 : 201177 : checkstring = 1;
4271 : 201177 : lop = 1;
4272 : 201177 : break;
4273 : :
4274 : 11732 : case INTRINSIC_GT:
4275 : 11732 : case INTRINSIC_GT_OS:
4276 : 11732 : code = GT_EXPR;
4277 : 11732 : checkstring = 1;
4278 : 11732 : lop = 1;
4279 : 11732 : break;
4280 : :
4281 : 1650 : case INTRINSIC_GE:
4282 : 1650 : case INTRINSIC_GE_OS:
4283 : 1650 : code = GE_EXPR;
4284 : 1650 : checkstring = 1;
4285 : 1650 : lop = 1;
4286 : 1650 : break;
4287 : :
4288 : 4284 : case INTRINSIC_LT:
4289 : 4284 : case INTRINSIC_LT_OS:
4290 : 4284 : code = LT_EXPR;
4291 : 4284 : checkstring = 1;
4292 : 4284 : lop = 1;
4293 : 4284 : break;
4294 : :
4295 : 2584 : case INTRINSIC_LE:
4296 : 2584 : case INTRINSIC_LE_OS:
4297 : 2584 : code = LE_EXPR;
4298 : 2584 : checkstring = 1;
4299 : 2584 : lop = 1;
4300 : 2584 : break;
4301 : :
4302 : 0 : case INTRINSIC_USER:
4303 : 0 : case INTRINSIC_ASSIGN:
4304 : : /* These should be converted into function calls by the frontend. */
4305 : 0 : gcc_unreachable ();
4306 : :
4307 : 0 : default:
4308 : 0 : fatal_error (input_location, "Unknown intrinsic op");
4309 : 402395 : return;
4310 : : }
4311 : :
4312 : : /* The only exception to this is **, which is handled separately anyway. */
4313 : 402395 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4314 : :
4315 : 402395 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4316 : 370446 : checkstring = 0;
4317 : :
4318 : : /* lhs */
4319 : 402395 : gfc_init_se (&lse, se);
4320 : 402395 : gfc_conv_expr (&lse, expr->value.op.op1);
4321 : 402395 : gfc_add_block_to_block (&se->pre, &lse.pre);
4322 : :
4323 : : /* rhs */
4324 : 402395 : gfc_init_se (&rse, se);
4325 : 402395 : gfc_conv_expr (&rse, expr->value.op.op2);
4326 : 402395 : gfc_add_block_to_block (&se->pre, &rse.pre);
4327 : :
4328 : 402395 : if (checkstring)
4329 : : {
4330 : 31949 : gfc_conv_string_parameter (&lse);
4331 : 31949 : gfc_conv_string_parameter (&rse);
4332 : :
4333 : 63898 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4334 : : rse.string_length, rse.expr,
4335 : 31949 : expr->value.op.op1->ts.kind,
4336 : : code);
4337 : 31949 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4338 : 31949 : gfc_add_block_to_block (&lse.post, &rse.post);
4339 : : }
4340 : :
4341 : 402395 : type = gfc_typenode_for_spec (&expr->ts);
4342 : :
4343 : 402395 : if (lop)
4344 : : {
4345 : : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4346 : 293714 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4347 : 165144 : && expr->value.op.op1->ts.type == BT_INTEGER
4348 : 71100 : && expr->value.op.op1->symtree
4349 : 71100 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4350 : 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4351 : :
4352 : 293714 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4353 : 71102 : && expr->value.op.op2->ts.type == BT_INTEGER
4354 : 12258 : && expr->value.op.op2->symtree
4355 : 12258 : && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
4356 : 12 : TREE_THIS_VOLATILE (rse.expr) = 1;
4357 : :
4358 : : /* The result of logical ops is always logical_type_node. */
4359 : 293714 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4360 : : lse.expr, rse.expr);
4361 : 293714 : se->expr = convert (type, tmp);
4362 : : }
4363 : : else
4364 : 108681 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4365 : :
4366 : : /* Add the post blocks. */
4367 : 402395 : gfc_add_block_to_block (&se->post, &rse.post);
4368 : 402395 : gfc_add_block_to_block (&se->post, &lse.post);
4369 : : }
4370 : :
4371 : : static void
4372 : 79 : gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
4373 : : {
4374 : 79 : gfc_se cond_se, true_se, false_se;
4375 : 79 : tree condition, true_val, false_val;
4376 : 79 : tree type;
4377 : :
4378 : 79 : gfc_init_se (&cond_se, se);
4379 : 79 : gfc_init_se (&true_se, se);
4380 : 79 : gfc_init_se (&false_se, se);
4381 : :
4382 : 79 : gfc_conv_expr (&cond_se, expr->value.conditional.condition);
4383 : 79 : gfc_add_block_to_block (&se->pre, &cond_se.pre);
4384 : 79 : condition = gfc_evaluate_now (cond_se.expr, &se->pre);
4385 : :
4386 : 79 : true_se.want_pointer = se->want_pointer;
4387 : 79 : gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
4388 : 79 : true_val = true_se.expr;
4389 : 79 : false_se.want_pointer = se->want_pointer;
4390 : 79 : gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
4391 : 79 : false_val = false_se.expr;
4392 : :
4393 : 79 : if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
4394 : 18 : gfc_add_expr_to_block (
4395 : : &se->pre,
4396 : : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4397 : 18 : true_se.pre.head != NULL_TREE
4398 : 0 : ? gfc_finish_block (&true_se.pre)
4399 : 18 : : build_empty_stmt (input_location),
4400 : 18 : false_se.pre.head != NULL_TREE
4401 : 18 : ? gfc_finish_block (&false_se.pre)
4402 : 0 : : build_empty_stmt (input_location)));
4403 : :
4404 : 79 : if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
4405 : 6 : gfc_add_expr_to_block (
4406 : : &se->post,
4407 : : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4408 : 6 : true_se.post.head != NULL_TREE
4409 : 0 : ? gfc_finish_block (&true_se.post)
4410 : 6 : : build_empty_stmt (input_location),
4411 : 6 : false_se.post.head != NULL_TREE
4412 : 6 : ? gfc_finish_block (&false_se.post)
4413 : 0 : : build_empty_stmt (input_location)));
4414 : :
4415 : 79 : type = gfc_typenode_for_spec (&expr->ts);
4416 : 79 : if (se->want_pointer)
4417 : 12 : type = build_pointer_type (type);
4418 : :
4419 : 79 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
4420 : : true_val, false_val);
4421 : 79 : }
4422 : :
4423 : : /* If a string's length is one, we convert it to a single character. */
4424 : :
4425 : : tree
4426 : 132000 : gfc_string_to_single_character (tree len, tree str, int kind)
4427 : : {
4428 : :
4429 : 132000 : if (len == NULL
4430 : 132000 : || !tree_fits_uhwi_p (len)
4431 : 242074 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4432 : : return NULL_TREE;
4433 : :
4434 : 110022 : if (TREE_INT_CST_LOW (len) == 1)
4435 : : {
4436 : 21975 : str = fold_convert (gfc_get_pchar_type (kind), str);
4437 : 21975 : return build_fold_indirect_ref_loc (input_location, str);
4438 : : }
4439 : :
4440 : 88047 : if (kind == 1
4441 : 72033 : && TREE_CODE (str) == ADDR_EXPR
4442 : 61859 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4443 : 44746 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4444 : 27255 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4445 : 27255 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4446 : 27255 : && TREE_INT_CST_LOW (len) > 1
4447 : 113547 : && TREE_INT_CST_LOW (len)
4448 : : == (unsigned HOST_WIDE_INT)
4449 : 25500 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4450 : : {
4451 : 25500 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4452 : 25500 : ret = build_fold_indirect_ref_loc (input_location, ret);
4453 : 25500 : if (TREE_CODE (ret) == INTEGER_CST)
4454 : : {
4455 : 25500 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4456 : 25500 : int i, length = TREE_STRING_LENGTH (string_cst);
4457 : 25500 : const char *ptr = TREE_STRING_POINTER (string_cst);
4458 : :
4459 : 37248 : for (i = 1; i < length; i++)
4460 : 36684 : if (ptr[i] != ' ')
4461 : : return NULL_TREE;
4462 : :
4463 : : return ret;
4464 : : }
4465 : : }
4466 : :
4467 : : return NULL_TREE;
4468 : : }
4469 : :
4470 : :
4471 : : static void
4472 : 172 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4473 : : {
4474 : 172 : gcc_assert (expr);
4475 : :
4476 : : /* We used to modify the tree here. Now it is done earlier in
4477 : : the front-end, so we only check it here to avoid regressions. */
4478 : 172 : if (sym->backend_decl)
4479 : : {
4480 : 67 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4481 : 67 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4482 : 67 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4483 : 67 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4484 : : }
4485 : :
4486 : : /* If we have a constant character expression, make it into an
4487 : : integer of type C char. */
4488 : 172 : if ((*expr)->expr_type == EXPR_CONSTANT)
4489 : : {
4490 : 166 : gfc_typespec ts;
4491 : 166 : gfc_clear_ts (&ts);
4492 : :
4493 : 332 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4494 : 166 : (*expr)->value.character.string[0]);
4495 : 166 : gfc_replace_expr (*expr, tmp);
4496 : : }
4497 : 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4498 : : {
4499 : 6 : if ((*expr)->ref == NULL)
4500 : : {
4501 : 6 : se->expr = gfc_string_to_single_character
4502 : 6 : (integer_one_node,
4503 : 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4504 : : gfc_get_symbol_decl
4505 : 6 : ((*expr)->symtree->n.sym)),
4506 : : (*expr)->ts.kind);
4507 : : }
4508 : : else
4509 : : {
4510 : 0 : gfc_conv_variable (se, *expr);
4511 : 0 : se->expr = gfc_string_to_single_character
4512 : 0 : (integer_one_node,
4513 : : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4514 : : se->expr),
4515 : 0 : (*expr)->ts.kind);
4516 : : }
4517 : : }
4518 : 172 : }
4519 : :
4520 : : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4521 : : if STR is a string literal, otherwise return -1. */
4522 : :
4523 : : static int
4524 : 29612 : gfc_optimize_len_trim (tree len, tree str, int kind)
4525 : : {
4526 : 29612 : if (kind == 1
4527 : 24914 : && TREE_CODE (str) == ADDR_EXPR
4528 : 21601 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4529 : 14002 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4530 : 8934 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4531 : 8934 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4532 : 8934 : && tree_fits_uhwi_p (len)
4533 : 8934 : && tree_to_uhwi (len) >= 1
4534 : 29612 : && tree_to_uhwi (len)
4535 : 8890 : == (unsigned HOST_WIDE_INT)
4536 : 8890 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4537 : : {
4538 : 8890 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4539 : 8890 : folded = build_fold_indirect_ref_loc (input_location, folded);
4540 : 8890 : if (TREE_CODE (folded) == INTEGER_CST)
4541 : : {
4542 : 8890 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4543 : 8890 : int length = TREE_STRING_LENGTH (string_cst);
4544 : 8890 : const char *ptr = TREE_STRING_POINTER (string_cst);
4545 : :
4546 : 12031 : for (; length > 0; length--)
4547 : 12031 : if (ptr[length - 1] != ' ')
4548 : : break;
4549 : :
4550 : : return length;
4551 : : }
4552 : : }
4553 : : return -1;
4554 : : }
4555 : :
4556 : : /* Helper to build a call to memcmp. */
4557 : :
4558 : : static tree
4559 : 11797 : build_memcmp_call (tree s1, tree s2, tree n)
4560 : : {
4561 : 11797 : tree tmp;
4562 : :
4563 : 11797 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4564 : 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4565 : : else
4566 : 11797 : s1 = fold_convert (pvoid_type_node, s1);
4567 : :
4568 : 11797 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4569 : 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4570 : : else
4571 : 11797 : s2 = fold_convert (pvoid_type_node, s2);
4572 : :
4573 : 11797 : n = fold_convert (size_type_node, n);
4574 : :
4575 : 11797 : tmp = build_call_expr_loc (input_location,
4576 : : builtin_decl_explicit (BUILT_IN_MEMCMP),
4577 : : 3, s1, s2, n);
4578 : :
4579 : 11797 : return fold_convert (integer_type_node, tmp);
4580 : : }
4581 : :
4582 : : /* Compare two strings. If they are all single characters, the result is the
4583 : : subtraction of them. Otherwise, we build a library call. */
4584 : :
4585 : : tree
4586 : 32048 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4587 : : enum tree_code code)
4588 : : {
4589 : 32048 : tree sc1;
4590 : 32048 : tree sc2;
4591 : 32048 : tree fndecl;
4592 : :
4593 : 32048 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4594 : 32048 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4595 : :
4596 : 32048 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4597 : 32048 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4598 : :
4599 : 32048 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4600 : : {
4601 : : /* Deal with single character specially. */
4602 : 4732 : sc1 = fold_convert (integer_type_node, sc1);
4603 : 4732 : sc2 = fold_convert (integer_type_node, sc2);
4604 : 4732 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4605 : 4732 : sc1, sc2);
4606 : : }
4607 : :
4608 : 27316 : if ((code == EQ_EXPR || code == NE_EXPR)
4609 : 26760 : && optimize
4610 : 22491 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4611 : : {
4612 : : /* If one string is a string literal with LEN_TRIM longer
4613 : : than the length of the second string, the strings
4614 : : compare unequal. */
4615 : 14806 : int len = gfc_optimize_len_trim (len1, str1, kind);
4616 : 14806 : if (len > 0 && compare_tree_int (len2, len) < 0)
4617 : 0 : return integer_one_node;
4618 : 14806 : len = gfc_optimize_len_trim (len2, str2, kind);
4619 : 14806 : if (len > 0 && compare_tree_int (len1, len) < 0)
4620 : 0 : return integer_one_node;
4621 : : }
4622 : :
4623 : : /* We can compare via memcpy if the strings are known to be equal
4624 : : in length and they are
4625 : : - kind=1
4626 : : - kind=4 and the comparison is for (in)equality. */
4627 : :
4628 : 17988 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4629 : 17650 : && tree_int_cst_equal (len1, len2)
4630 : 39173 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4631 : : {
4632 : 11797 : tree tmp;
4633 : 11797 : tree chartype;
4634 : :
4635 : 11797 : chartype = gfc_get_char_type (kind);
4636 : 11797 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4637 : 11797 : fold_convert (TREE_TYPE(len1),
4638 : : TYPE_SIZE_UNIT(chartype)),
4639 : : len1);
4640 : 11797 : return build_memcmp_call (str1, str2, tmp);
4641 : : }
4642 : :
4643 : : /* Build a call for the comparison. */
4644 : 15519 : if (kind == 1)
4645 : 12683 : fndecl = gfor_fndecl_compare_string;
4646 : 2836 : else if (kind == 4)
4647 : 2836 : fndecl = gfor_fndecl_compare_string_char4;
4648 : : else
4649 : 0 : gcc_unreachable ();
4650 : :
4651 : 15519 : return build_call_expr_loc (input_location, fndecl, 4,
4652 : 15519 : len1, str1, len2, str2);
4653 : : }
4654 : :
4655 : :
4656 : : /* Return the backend_decl for a procedure pointer component. */
4657 : :
4658 : : static tree
4659 : 1725 : get_proc_ptr_comp (gfc_expr *e)
4660 : : {
4661 : 1725 : gfc_se comp_se;
4662 : 1725 : gfc_expr *e2;
4663 : 1725 : expr_t old_type;
4664 : :
4665 : 1725 : gfc_init_se (&comp_se, NULL);
4666 : 1725 : e2 = gfc_copy_expr (e);
4667 : : /* We have to restore the expr type later so that gfc_free_expr frees
4668 : : the exact same thing that was allocated.
4669 : : TODO: This is ugly. */
4670 : 1725 : old_type = e2->expr_type;
4671 : 1725 : e2->expr_type = EXPR_VARIABLE;
4672 : 1725 : gfc_conv_expr (&comp_se, e2);
4673 : 1725 : e2->expr_type = old_type;
4674 : 1725 : gfc_free_expr (e2);
4675 : 1725 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4676 : : }
4677 : :
4678 : :
4679 : : /* Convert a typebound function reference from a class object. */
4680 : : static void
4681 : 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4682 : : {
4683 : 80 : gfc_ref *ref;
4684 : 80 : tree var;
4685 : :
4686 : 80 : if (!VAR_P (base_object))
4687 : : {
4688 : 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4689 : 0 : gfc_add_modify (&se->pre, var, base_object);
4690 : : }
4691 : 80 : se->expr = gfc_class_vptr_get (base_object);
4692 : 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4693 : 80 : ref = expr->ref;
4694 : 308 : while (ref && ref->next)
4695 : : ref = ref->next;
4696 : 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4697 : 80 : if (ref->u.c.sym->attr.extension)
4698 : 0 : conv_parent_component_references (se, ref);
4699 : 80 : gfc_conv_component_ref (se, ref);
4700 : 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4701 : 80 : }
4702 : :
4703 : : static tree
4704 : 124756 : get_builtin_fn (gfc_symbol * sym)
4705 : : {
4706 : 124756 : if (!gfc_option.disable_omp_is_initial_device
4707 : 124752 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4708 : 610 : && !strcmp (sym->name, "omp_is_initial_device"))
4709 : 23 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4710 : :
4711 : 124733 : if (!gfc_option.disable_omp_get_initial_device
4712 : 124726 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4713 : 4053 : && !strcmp (sym->name, "omp_get_initial_device"))
4714 : 24 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4715 : :
4716 : 124709 : if (!gfc_option.disable_omp_get_num_devices
4717 : 124702 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4718 : 4029 : && !strcmp (sym->name, "omp_get_num_devices"))
4719 : 70 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4720 : :
4721 : 124639 : if (!gfc_option.disable_acc_on_device
4722 : 124459 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4723 : 1163 : && !strcmp (sym->name, "acc_on_device_h"))
4724 : 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4725 : :
4726 : : return NULL_TREE;
4727 : : }
4728 : :
4729 : : static tree
4730 : 507 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4731 : : {
4732 : 507 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4733 : :
4734 : 507 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4735 : : /* In Fortran omp_is_initial_device returns logical(4)
4736 : : but the builtin uses 'int'. */
4737 : 23 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4738 : :
4739 : 484 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4740 : : {
4741 : : /* Likewise for the return type; additionally, the argument it a
4742 : : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4743 : 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4744 : 390 : CALL_EXPR_ARG (fn_call, 0));
4745 : 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4746 : 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4747 : : }
4748 : : return fn_call;
4749 : : }
4750 : :
4751 : : static void
4752 : 127284 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4753 : : gfc_expr * expr, gfc_actual_arglist *actual_args)
4754 : : {
4755 : 127284 : tree tmp;
4756 : :
4757 : 127284 : if (gfc_is_proc_ptr_comp (expr))
4758 : 1725 : tmp = get_proc_ptr_comp (expr);
4759 : 125559 : else if (sym->attr.dummy)
4760 : : {
4761 : 803 : tmp = gfc_get_symbol_decl (sym);
4762 : 803 : if (sym->attr.proc_pointer)
4763 : 83 : tmp = build_fold_indirect_ref_loc (input_location,
4764 : : tmp);
4765 : 803 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4766 : : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4767 : : }
4768 : : else
4769 : : {
4770 : 124756 : if (!sym->backend_decl)
4771 : 31380 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4772 : :
4773 : 124756 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4774 : 507 : *is_builtin = true;
4775 : : else
4776 : : {
4777 : 124249 : TREE_USED (sym->backend_decl) = 1;
4778 : 124249 : tmp = sym->backend_decl;
4779 : : }
4780 : :
4781 : 124756 : if (sym->attr.cray_pointee)
4782 : : {
4783 : : /* TODO - make the cray pointee a pointer to a procedure,
4784 : : assign the pointer to it and use it for the call. This
4785 : : will do for now! */
4786 : 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4787 : 19 : gfc_get_symbol_decl (sym->cp_pointer));
4788 : 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4789 : : }
4790 : :
4791 : 124756 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4792 : : {
4793 : 124177 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4794 : 124177 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4795 : : }
4796 : : }
4797 : 127284 : se->expr = tmp;
4798 : 127284 : }
4799 : :
4800 : :
4801 : : /* Initialize MAPPING. */
4802 : :
4803 : : void
4804 : 127401 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4805 : : {
4806 : 127401 : mapping->syms = NULL;
4807 : 127401 : mapping->charlens = NULL;
4808 : 127401 : }
4809 : :
4810 : :
4811 : : /* Free all memory held by MAPPING (but not MAPPING itself). */
4812 : :
4813 : : void
4814 : 127401 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4815 : : {
4816 : 127401 : gfc_interface_sym_mapping *sym;
4817 : 127401 : gfc_interface_sym_mapping *nextsym;
4818 : 127401 : gfc_charlen *cl;
4819 : 127401 : gfc_charlen *nextcl;
4820 : :
4821 : 168072 : for (sym = mapping->syms; sym; sym = nextsym)
4822 : : {
4823 : 40671 : nextsym = sym->next;
4824 : 40671 : sym->new_sym->n.sym->formal = NULL;
4825 : 40671 : gfc_free_symbol (sym->new_sym->n.sym);
4826 : 40671 : gfc_free_expr (sym->expr);
4827 : 40671 : free (sym->new_sym);
4828 : 40671 : free (sym);
4829 : : }
4830 : 131970 : for (cl = mapping->charlens; cl; cl = nextcl)
4831 : : {
4832 : 4569 : nextcl = cl->next;
4833 : 4569 : gfc_free_expr (cl->length);
4834 : 4569 : free (cl);
4835 : : }
4836 : 127401 : }
4837 : :
4838 : :
4839 : : /* Return a copy of gfc_charlen CL. Add the returned structure to
4840 : : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4841 : :
4842 : : static gfc_charlen *
4843 : 4569 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4844 : : gfc_charlen * cl)
4845 : : {
4846 : 4569 : gfc_charlen *new_charlen;
4847 : :
4848 : 4569 : new_charlen = gfc_get_charlen ();
4849 : 4569 : new_charlen->next = mapping->charlens;
4850 : 4569 : new_charlen->length = gfc_copy_expr (cl->length);
4851 : :
4852 : 4569 : mapping->charlens = new_charlen;
4853 : 4569 : return new_charlen;
4854 : : }
4855 : :
4856 : :
4857 : : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4858 : : array variable that can be used as the actual argument for dummy
4859 : : argument SYM. Add any initialization code to BLOCK. PACKED is as
4860 : : for gfc_get_nodesc_array_type and DATA points to the first element
4861 : : in the passed array. */
4862 : :
4863 : : static tree
4864 : 8375 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4865 : : gfc_packed packed, tree data, tree len)
4866 : : {
4867 : 8375 : tree type;
4868 : 8375 : tree var;
4869 : :
4870 : 8375 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4871 : 58 : type = gfc_get_character_type_len (sym->ts.kind, len);
4872 : : else
4873 : 8317 : type = gfc_typenode_for_spec (&sym->ts);
4874 : 8375 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4875 : 8351 : !sym->attr.target && !sym->attr.pointer
4876 : 16726 : && !sym->attr.proc_pointer);
4877 : :
4878 : 8375 : var = gfc_create_var (type, "ifm");
4879 : 8375 : gfc_add_modify (block, var, fold_convert (type, data));
4880 : :
4881 : 8375 : return var;
4882 : : }
4883 : :
4884 : :
4885 : : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4886 : : and offset of descriptorless array type TYPE given that it has the same
4887 : : size as DESC. Add any set-up code to BLOCK. */
4888 : :
4889 : : static void
4890 : 8105 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4891 : : {
4892 : 8105 : int n;
4893 : 8105 : tree dim;
4894 : 8105 : tree offset;
4895 : 8105 : tree tmp;
4896 : :
4897 : 8105 : offset = gfc_index_zero_node;
4898 : 9180 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4899 : : {
4900 : 1075 : dim = gfc_rank_cst[n];
4901 : 1075 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4902 : 1075 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4903 : : {
4904 : 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
4905 : 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
4906 : 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
4907 : 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
4908 : : }
4909 : 1074 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4910 : : {
4911 : 1074 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4912 : : gfc_array_index_type,
4913 : : gfc_conv_descriptor_ubound_get (desc, dim),
4914 : : gfc_conv_descriptor_lbound_get (desc, dim));
4915 : 3222 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4916 : : gfc_array_index_type,
4917 : 1074 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4918 : 1074 : tmp = gfc_evaluate_now (tmp, block);
4919 : 1074 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4920 : : }
4921 : 4300 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4922 : 1075 : GFC_TYPE_ARRAY_LBOUND (type, n),
4923 : 1075 : GFC_TYPE_ARRAY_STRIDE (type, n));
4924 : 1075 : offset = fold_build2_loc (input_location, MINUS_EXPR,
4925 : : gfc_array_index_type, offset, tmp);
4926 : : }
4927 : 8105 : offset = gfc_evaluate_now (offset, block);
4928 : 8105 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
4929 : 8105 : }
4930 : :
4931 : :
4932 : : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4933 : : in SE. The caller may still use se->expr and se->string_length after
4934 : : calling this function. */
4935 : :
4936 : : void
4937 : 40671 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4938 : : gfc_symbol * sym, gfc_se * se,
4939 : : gfc_expr *expr)
4940 : : {
4941 : 40671 : gfc_interface_sym_mapping *sm;
4942 : 40671 : tree desc;
4943 : 40671 : tree tmp;
4944 : 40671 : tree value;
4945 : 40671 : gfc_symbol *new_sym;
4946 : 40671 : gfc_symtree *root;
4947 : 40671 : gfc_symtree *new_symtree;
4948 : :
4949 : : /* Create a new symbol to represent the actual argument. */
4950 : 40671 : new_sym = gfc_new_symbol (sym->name, NULL);
4951 : 40671 : new_sym->ts = sym->ts;
4952 : 40671 : new_sym->as = gfc_copy_array_spec (sym->as);
4953 : 40671 : new_sym->attr.referenced = 1;
4954 : 40671 : new_sym->attr.dimension = sym->attr.dimension;
4955 : 40671 : new_sym->attr.contiguous = sym->attr.contiguous;
4956 : 40671 : new_sym->attr.codimension = sym->attr.codimension;
4957 : 40671 : new_sym->attr.pointer = sym->attr.pointer;
4958 : 40671 : new_sym->attr.allocatable = sym->attr.allocatable;
4959 : 40671 : new_sym->attr.flavor = sym->attr.flavor;
4960 : 40671 : new_sym->attr.function = sym->attr.function;
4961 : :
4962 : : /* Ensure that the interface is available and that
4963 : : descriptors are passed for array actual arguments. */
4964 : 40671 : if (sym->attr.flavor == FL_PROCEDURE)
4965 : : {
4966 : 36 : new_sym->formal = expr->symtree->n.sym->formal;
4967 : 36 : new_sym->attr.always_explicit
4968 : 36 : = expr->symtree->n.sym->attr.always_explicit;
4969 : : }
4970 : :
4971 : : /* Create a fake symtree for it. */
4972 : 40671 : root = NULL;
4973 : 40671 : new_symtree = gfc_new_symtree (&root, sym->name);
4974 : 40671 : new_symtree->n.sym = new_sym;
4975 : 40671 : gcc_assert (new_symtree == root);
4976 : :
4977 : : /* Create a dummy->actual mapping. */
4978 : 40671 : sm = XCNEW (gfc_interface_sym_mapping);
4979 : 40671 : sm->next = mapping->syms;
4980 : 40671 : sm->old = sym;
4981 : 40671 : sm->new_sym = new_symtree;
4982 : 40671 : sm->expr = gfc_copy_expr (expr);
4983 : 40671 : mapping->syms = sm;
4984 : :
4985 : : /* Stabilize the argument's value. */
4986 : 40671 : if (!sym->attr.function && se)
4987 : 40573 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
4988 : :
4989 : 40671 : if (sym->ts.type == BT_CHARACTER)
4990 : : {
4991 : : /* Create a copy of the dummy argument's length. */
4992 : 2785 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4993 : 2785 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
4994 : :
4995 : : /* If the length is specified as "*", record the length that
4996 : : the caller is passing. We should use the callee's length
4997 : : in all other cases. */
4998 : 2785 : if (!new_sym->ts.u.cl->length && se)
4999 : : {
5000 : 2557 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5001 : 2557 : new_sym->ts.u.cl->backend_decl = se->string_length;
5002 : : }
5003 : : }
5004 : :
5005 : 40657 : if (!se)
5006 : 62 : return;
5007 : :
5008 : : /* Use the passed value as-is if the argument is a function. */
5009 : 40609 : if (sym->attr.flavor == FL_PROCEDURE)
5010 : 36 : value = se->expr;
5011 : :
5012 : : /* If the argument is a pass-by-value scalar, use the value as is. */
5013 : 40573 : else if (!sym->attr.dimension && sym->attr.value)
5014 : 63 : value = se->expr;
5015 : :
5016 : : /* If the argument is either a string or a pointer to a string,
5017 : : convert it to a boundless character type. */
5018 : 40510 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5019 : : {
5020 : 1216 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5021 : 1216 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5022 : 1216 : tmp = build_pointer_type (tmp);
5023 : 1216 : if (sym->attr.pointer)
5024 : 126 : value = build_fold_indirect_ref_loc (input_location,
5025 : : se->expr);
5026 : : else
5027 : 1090 : value = se->expr;
5028 : 1216 : value = fold_convert (tmp, value);
5029 : : }
5030 : :
5031 : : /* If the argument is a scalar, a pointer to an array or an allocatable,
5032 : : dereference it. */
5033 : 39294 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5034 : 29422 : value = build_fold_indirect_ref_loc (input_location,
5035 : : se->expr);
5036 : :
5037 : : /* For character(*), use the actual argument's descriptor. */
5038 : 9872 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5039 : 1497 : value = build_fold_indirect_ref_loc (input_location,
5040 : : se->expr);
5041 : :
5042 : : /* If the argument is an array descriptor, use it to determine
5043 : : information about the actual argument's shape. */
5044 : 8375 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5045 : 8375 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5046 : : {
5047 : : /* Get the actual argument's descriptor. */
5048 : 8105 : desc = build_fold_indirect_ref_loc (input_location,
5049 : : se->expr);
5050 : :
5051 : : /* Create the replacement variable. */
5052 : 8105 : tmp = gfc_conv_descriptor_data_get (desc);
5053 : 8105 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5054 : : PACKED_NO, tmp,
5055 : : se->string_length);
5056 : :
5057 : : /* Use DESC to work out the upper bounds, strides and offset. */
5058 : 8105 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5059 : : }
5060 : : else
5061 : : /* Otherwise we have a packed array. */
5062 : 270 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5063 : : PACKED_FULL, se->expr,
5064 : : se->string_length);
5065 : :
5066 : 40609 : new_sym->backend_decl = value;
5067 : : }
5068 : :
5069 : :
5070 : : /* Called once all dummy argument mappings have been added to MAPPING,
5071 : : but before the mapping is used to evaluate expressions. Pre-evaluate
5072 : : the length of each argument, adding any initialization code to PRE and
5073 : : any finalization code to POST. */
5074 : :
5075 : : static void
5076 : 127364 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5077 : : stmtblock_t * pre, stmtblock_t * post)
5078 : : {
5079 : 127364 : gfc_interface_sym_mapping *sym;
5080 : 127364 : gfc_expr *expr;
5081 : 127364 : gfc_se se;
5082 : :
5083 : 167973 : for (sym = mapping->syms; sym; sym = sym->next)
5084 : 40609 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5085 : 2771 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5086 : : {
5087 : 214 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5088 : 214 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5089 : 214 : gfc_init_se (&se, NULL);
5090 : 214 : gfc_conv_expr (&se, expr);
5091 : 214 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5092 : 214 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5093 : 214 : gfc_add_block_to_block (pre, &se.pre);
5094 : 214 : gfc_add_block_to_block (post, &se.post);
5095 : :
5096 : 214 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5097 : : }
5098 : 127364 : }
5099 : :
5100 : :
5101 : : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5102 : : constructor C. */
5103 : :
5104 : : static void
5105 : 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5106 : : gfc_constructor_base base)
5107 : : {
5108 : 47 : gfc_constructor *c;
5109 : 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5110 : : {
5111 : 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5112 : 381 : if (c->iterator)
5113 : : {
5114 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5115 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5116 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5117 : : }
5118 : : }
5119 : 47 : }
5120 : :
5121 : :
5122 : : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5123 : : reference REF. */
5124 : :
5125 : : static void
5126 : 12445 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5127 : : gfc_ref * ref)
5128 : : {
5129 : 12445 : int n;
5130 : :
5131 : 13888 : for (; ref; ref = ref->next)
5132 : 1443 : switch (ref->type)
5133 : : {
5134 : : case REF_ARRAY:
5135 : 2873 : for (n = 0; n < ref->u.ar.dimen; n++)
5136 : : {
5137 : 1632 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5138 : 1632 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5139 : 1632 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5140 : : }
5141 : : break;
5142 : :
5143 : : case REF_COMPONENT:
5144 : : case REF_INQUIRY:
5145 : : break;
5146 : :
5147 : 43 : case REF_SUBSTRING:
5148 : 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5149 : 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5150 : 43 : break;
5151 : : }
5152 : 12445 : }
5153 : :
5154 : :
5155 : : /* Convert intrinsic function calls into result expressions. */
5156 : :
5157 : : static bool
5158 : 2184 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5159 : : {
5160 : 2184 : gfc_symbol *sym;
5161 : 2184 : gfc_expr *new_expr;
5162 : 2184 : gfc_expr *arg1;
5163 : 2184 : gfc_expr *arg2;
5164 : 2184 : int d, dup;
5165 : :
5166 : 2184 : arg1 = expr->value.function.actual->expr;
5167 : 2184 : if (expr->value.function.actual->next)
5168 : 2063 : arg2 = expr->value.function.actual->next->expr;
5169 : : else
5170 : : arg2 = NULL;
5171 : :
5172 : 2184 : sym = arg1->symtree->n.sym;
5173 : :
5174 : 2184 : if (sym->attr.dummy)
5175 : : return false;
5176 : :
5177 : 2160 : new_expr = NULL;
5178 : :
5179 : 2160 : switch (expr->value.function.isym->id)
5180 : : {
5181 : 929 : case GFC_ISYM_LEN:
5182 : : /* TODO figure out why this condition is necessary. */
5183 : 929 : if (sym->attr.function
5184 : 43 : && (arg1->ts.u.cl->length == NULL
5185 : 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5186 : 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5187 : : return false;
5188 : :
5189 : 886 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5190 : 886 : break;
5191 : :
5192 : 228 : case GFC_ISYM_LEN_TRIM:
5193 : 228 : new_expr = gfc_copy_expr (arg1);
5194 : 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5195 : :
5196 : 228 : if (!new_expr)
5197 : : return false;
5198 : :
5199 : 228 : gfc_replace_expr (arg1, new_expr);
5200 : 228 : return true;
5201 : :
5202 : 588 : case GFC_ISYM_SIZE:
5203 : 588 : if (!sym->as || sym->as->rank == 0)
5204 : : return false;
5205 : :
5206 : 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5207 : : {
5208 : 360 : dup = mpz_get_si (arg2->value.integer);
5209 : 360 : d = dup - 1;
5210 : : }
5211 : : else
5212 : : {
5213 : 530 : dup = sym->as->rank;
5214 : 530 : d = 0;
5215 : : }
5216 : :
5217 : 542 : for (; d < dup; d++)
5218 : : {
5219 : 530 : gfc_expr *tmp;
5220 : :
5221 : 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5222 : : {
5223 : 518 : gfc_free_expr (new_expr);
5224 : 518 : return false;
5225 : : }
5226 : :
5227 : 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5228 : : gfc_get_int_expr (gfc_default_integer_kind,
5229 : : NULL, 1));
5230 : 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5231 : 12 : if (new_expr)
5232 : 0 : new_expr = gfc_multiply (new_expr, tmp);
5233 : : else
5234 : : new_expr = tmp;
5235 : : }
5236 : : break;
5237 : :
5238 : 44 : case GFC_ISYM_LBOUND:
5239 : 44 : case GFC_ISYM_UBOUND:
5240 : : /* TODO These implementations of lbound and ubound do not limit if
5241 : : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5242 : :
5243 : 44 : if (!sym->as || sym->as->rank == 0)
5244 : : return false;
5245 : :
5246 : 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5247 : 38 : d = mpz_get_si (arg2->value.integer) - 1;
5248 : : else
5249 : : return false;
5250 : :
5251 : 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5252 : : {
5253 : 23 : if (sym->as->lower[d])
5254 : 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5255 : : }
5256 : : else
5257 : : {
5258 : 15 : if (sym->as->upper[d])
5259 : 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5260 : : }
5261 : : break;
5262 : :
5263 : : default:
5264 : : break;
5265 : : }
5266 : :
5267 : 1307 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5268 : 1307 : if (!new_expr)
5269 : : return false;
5270 : :
5271 : 113 : gfc_replace_expr (expr, new_expr);
5272 : 113 : return true;
5273 : : }
5274 : :
5275 : :
5276 : : static void
5277 : 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5278 : : gfc_interface_mapping * mapping)
5279 : : {
5280 : 24 : gfc_formal_arglist *f;
5281 : 24 : gfc_actual_arglist *actual;
5282 : :
5283 : 24 : actual = expr->value.function.actual;
5284 : 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5285 : :
5286 : 72 : for (; f && actual; f = f->next, actual = actual->next)
5287 : : {
5288 : 24 : if (!actual->expr)
5289 : 0 : continue;
5290 : :
5291 : 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5292 : : }
5293 : :
5294 : 24 : if (map_expr->symtree->n.sym->attr.dimension)
5295 : : {
5296 : 6 : int d;
5297 : 6 : gfc_array_spec *as;
5298 : :
5299 : 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5300 : :
5301 : 18 : for (d = 0; d < as->rank; d++)
5302 : : {
5303 : 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5304 : 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5305 : : }
5306 : :
5307 : 6 : expr->value.function.esym->as = as;
5308 : : }
5309 : :
5310 : 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5311 : : {
5312 : 0 : expr->value.function.esym->ts.u.cl->length
5313 : 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5314 : :
5315 : 0 : gfc_apply_interface_mapping_to_expr (mapping,
5316 : 0 : expr->value.function.esym->ts.u.cl->length);
5317 : : }
5318 : 24 : }
5319 : :
5320 : :
5321 : : /* EXPR is a copy of an expression that appeared in the interface
5322 : : associated with MAPPING. Walk it recursively looking for references to
5323 : : dummy arguments that MAPPING maps to actual arguments. Replace each such
5324 : : reference with a reference to the associated actual argument. */
5325 : :
5326 : : static void
5327 : 20870 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5328 : : gfc_expr * expr)
5329 : : {
5330 : 22423 : gfc_interface_sym_mapping *sym;
5331 : 22423 : gfc_actual_arglist *actual;
5332 : :
5333 : 22423 : if (!expr)
5334 : : return;
5335 : :
5336 : : /* Copying an expression does not copy its length, so do that here. */
5337 : 12445 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5338 : : {
5339 : 1784 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5340 : 1784 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5341 : : }
5342 : :
5343 : : /* Apply the mapping to any references. */
5344 : 12445 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5345 : :
5346 : : /* ...and to the expression's symbol, if it has one. */
5347 : : /* TODO Find out why the condition on expr->symtree had to be moved into
5348 : : the loop rather than being outside it, as originally. */
5349 : 29650 : for (sym = mapping->syms; sym; sym = sym->next)
5350 : 17205 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5351 : : {
5352 : 3345 : if (sym->new_sym->n.sym->backend_decl)
5353 : 3301 : expr->symtree = sym->new_sym;
5354 : 44 : else if (sym->expr)
5355 : 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5356 : : }
5357 : :
5358 : : /* ...and to subexpressions in expr->value. */
5359 : 12445 : switch (expr->expr_type)
5360 : : {
5361 : : case EXPR_VARIABLE:
5362 : : case EXPR_CONSTANT:
5363 : : case EXPR_NULL:
5364 : : case EXPR_SUBSTRING:
5365 : : break;
5366 : :
5367 : 1553 : case EXPR_OP:
5368 : 1553 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5369 : 1553 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5370 : 1553 : break;
5371 : :
5372 : 0 : case EXPR_CONDITIONAL:
5373 : 0 : gfc_apply_interface_mapping_to_expr (mapping,
5374 : 0 : expr->value.conditional.true_expr);
5375 : 0 : gfc_apply_interface_mapping_to_expr (mapping,
5376 : 0 : expr->value.conditional.false_expr);
5377 : 0 : break;
5378 : :
5379 : 2927 : case EXPR_FUNCTION:
5380 : 9388 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5381 : 6461 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5382 : :
5383 : 2927 : if (expr->value.function.esym == NULL
5384 : 2614 : && expr->value.function.isym != NULL
5385 : 2602 : && expr->value.function.actual
5386 : 2601 : && expr->value.function.actual->expr
5387 : 2601 : && expr->value.function.actual->expr->symtree
5388 : 5111 : && gfc_map_intrinsic_function (expr, mapping))
5389 : : break;
5390 : :
5391 : 6094 : for (sym = mapping->syms; sym; sym = sym->next)
5392 : 3508 : if (sym->old == expr->value.function.esym)
5393 : : {
5394 : 24 : expr->value.function.esym = sym->new_sym->n.sym;
5395 : 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5396 : 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5397 : : }
5398 : : break;
5399 : :
5400 : 47 : case EXPR_ARRAY:
5401 : 47 : case EXPR_STRUCTURE:
5402 : 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5403 : 47 : break;
5404 : :
5405 : 0 : case EXPR_COMPCALL:
5406 : 0 : case EXPR_PPC:
5407 : 0 : case EXPR_UNKNOWN:
5408 : 0 : gcc_unreachable ();
5409 : : break;
5410 : : }
5411 : :
5412 : : return;
5413 : : }
5414 : :
5415 : :
5416 : : /* Evaluate interface expression EXPR using MAPPING. Store the result
5417 : : in SE. */
5418 : :
5419 : : void
5420 : 3930 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5421 : : gfc_se * se, gfc_expr * expr)
5422 : : {
5423 : 3930 : expr = gfc_copy_expr (expr);
5424 : 3930 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5425 : 3930 : gfc_conv_expr (se, expr);
5426 : 3930 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5427 : 3930 : gfc_free_expr (expr);
5428 : 3930 : }
5429 : :
5430 : :
5431 : : /* Returns a reference to a temporary array into which a component of
5432 : : an actual argument derived type array is copied and then returned
5433 : : after the function call. */
5434 : : void
5435 : 2380 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5436 : : sym_intent intent, bool formal_ptr,
5437 : : const gfc_symbol *fsym, const char *proc_name,
5438 : : gfc_symbol *sym, bool check_contiguous)
5439 : : {
5440 : 2380 : gfc_se lse;
5441 : 2380 : gfc_se rse;
5442 : 2380 : gfc_ss *lss;
5443 : 2380 : gfc_ss *rss;
5444 : 2380 : gfc_loopinfo loop;
5445 : 2380 : gfc_loopinfo loop2;
5446 : 2380 : gfc_array_info *info;
5447 : 2380 : tree offset;
5448 : 2380 : tree tmp_index;
5449 : 2380 : tree tmp;
5450 : 2380 : tree base_type;
5451 : 2380 : tree size;
5452 : 2380 : stmtblock_t body;
5453 : 2380 : int n;
5454 : 2380 : int dimen;
5455 : 2380 : gfc_se work_se;
5456 : 2380 : gfc_se *parmse;
5457 : 2380 : bool pass_optional;
5458 : 2380 : bool readonly;
5459 : :
5460 : 2380 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5461 : :
5462 : 2369 : if (pass_optional || check_contiguous)
5463 : : {
5464 : 1349 : gfc_init_se (&work_se, NULL);
5465 : 1349 : parmse = &work_se;
5466 : : }
5467 : : else
5468 : : parmse = se;
5469 : :
5470 : 2380 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5471 : : {
5472 : : /* We will create a temporary array, so let us warn. */
5473 : 868 : char * msg;
5474 : :
5475 : 868 : if (fsym && proc_name)
5476 : 868 : msg = xasprintf ("An array temporary was created for argument "
5477 : 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5478 : : else
5479 : 0 : msg = xasprintf ("An array temporary was created");
5480 : :
5481 : 868 : tmp = build_int_cst (logical_type_node, 1);
5482 : 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5483 : : &expr->where, msg);
5484 : 868 : free (msg);
5485 : : }
5486 : :
5487 : 2380 : gfc_init_se (&lse, NULL);
5488 : 2380 : gfc_init_se (&rse, NULL);
5489 : :
5490 : : /* Walk the argument expression. */
5491 : 2380 : rss = gfc_walk_expr (expr);
5492 : :
5493 : 2380 : gcc_assert (rss != gfc_ss_terminator);
5494 : :
5495 : : /* Initialize the scalarizer. */
5496 : 2380 : gfc_init_loopinfo (&loop);
5497 : 2380 : gfc_add_ss_to_loop (&loop, rss);
5498 : :
5499 : : /* Calculate the bounds of the scalarization. */
5500 : 2380 : gfc_conv_ss_startstride (&loop);
5501 : :
5502 : : /* Build an ss for the temporary. */
5503 : 2380 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5504 : 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5505 : :
5506 : 2380 : base_type = gfc_typenode_for_spec (&expr->ts);
5507 : 2380 : if (GFC_ARRAY_TYPE_P (base_type)
5508 : 2380 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5509 : 0 : base_type = gfc_get_element_type (base_type);
5510 : :
5511 : 2380 : if (expr->ts.type == BT_CLASS)
5512 : 121 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5513 : :
5514 : 3538 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5515 : 1158 : ? expr->ts.u.cl->backend_decl
5516 : : : NULL),
5517 : : loop.dimen);
5518 : :
5519 : 2380 : parmse->string_length = loop.temp_ss->info->string_length;
5520 : :
5521 : : /* Associate the SS with the loop. */
5522 : 2380 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5523 : :
5524 : : /* Setup the scalarizing loops. */
5525 : 2380 : gfc_conv_loop_setup (&loop, &expr->where);
5526 : :
5527 : : /* Pass the temporary descriptor back to the caller. */
5528 : 2380 : info = &loop.temp_ss->info->data.array;
5529 : 2380 : parmse->expr = info->descriptor;
5530 : :
5531 : : /* Setup the gfc_se structures. */
5532 : 2380 : gfc_copy_loopinfo_to_se (&lse, &loop);
5533 : 2380 : gfc_copy_loopinfo_to_se (&rse, &loop);
5534 : :
5535 : 2380 : rse.ss = rss;
5536 : 2380 : lse.ss = loop.temp_ss;
5537 : 2380 : gfc_mark_ss_chain_used (rss, 1);
5538 : 2380 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5539 : :
5540 : : /* Start the scalarized loop body. */
5541 : 2380 : gfc_start_scalarized_body (&loop, &body);
5542 : :
5543 : : /* Translate the expression. */
5544 : 2380 : gfc_conv_expr (&rse, expr);
5545 : :
5546 : 2380 : gfc_conv_tmp_array_ref (&lse);
5547 : :
5548 : 2380 : if (intent != INTENT_OUT)
5549 : : {
5550 : 2342 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5551 : 2342 : gfc_add_expr_to_block (&body, tmp);
5552 : 2342 : gcc_assert (rse.ss == gfc_ss_terminator);
5553 : 2342 : gfc_trans_scalarizing_loops (&loop, &body);
5554 : : }
5555 : : else
5556 : : {
5557 : : /* Make sure that the temporary declaration survives by merging
5558 : : all the loop declarations into the current context. */
5559 : 85 : for (n = 0; n < loop.dimen; n++)
5560 : : {
5561 : 47 : gfc_merge_block_scope (&body);
5562 : 47 : body = loop.code[loop.order[n]];
5563 : : }
5564 : 38 : gfc_merge_block_scope (&body);
5565 : : }
5566 : :
5567 : : /* Add the post block after the second loop, so that any
5568 : : freeing of allocated memory is done at the right time. */
5569 : 2380 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5570 : :
5571 : : /**********Copy the temporary back again.*********/
5572 : :
5573 : 2380 : gfc_init_se (&lse, NULL);
5574 : 2380 : gfc_init_se (&rse, NULL);
5575 : :
5576 : : /* Walk the argument expression. */
5577 : 2380 : lss = gfc_walk_expr (expr);
5578 : 2380 : rse.ss = loop.temp_ss;
5579 : 2380 : lse.ss = lss;
5580 : :
5581 : : /* Initialize the scalarizer. */
5582 : 2380 : gfc_init_loopinfo (&loop2);
5583 : 2380 : gfc_add_ss_to_loop (&loop2, lss);
5584 : :
5585 : 2380 : dimen = rse.ss->dimen;
5586 : :
5587 : : /* Skip the write-out loop for this case. */
5588 : 2380 : if (gfc_is_class_array_function (expr))
5589 : 13 : goto class_array_fcn;
5590 : :
5591 : : /* Calculate the bounds of the scalarization. */
5592 : 2367 : gfc_conv_ss_startstride (&loop2);
5593 : :
5594 : : /* Setup the scalarizing loops. */
5595 : 2367 : gfc_conv_loop_setup (&loop2, &expr->where);
5596 : :
5597 : 2367 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5598 : 2367 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5599 : :
5600 : 2367 : gfc_mark_ss_chain_used (lss, 1);
5601 : 2367 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5602 : :
5603 : : /* Declare the variable to hold the temporary offset and start the
5604 : : scalarized loop body. */
5605 : 2367 : offset = gfc_create_var (gfc_array_index_type, NULL);
5606 : 2367 : gfc_start_scalarized_body (&loop2, &body);
5607 : :
5608 : : /* Build the offsets for the temporary from the loop variables. The
5609 : : temporary array has lbounds of zero and strides of one in all
5610 : : dimensions, so this is very simple. The offset is only computed
5611 : : outside the innermost loop, so the overall transfer could be
5612 : : optimized further. */
5613 : 2367 : info = &rse.ss->info->data.array;
5614 : :
5615 : 2367 : tmp_index = gfc_index_zero_node;
5616 : 3711 : for (n = dimen - 1; n > 0; n--)
5617 : : {
5618 : 1344 : tree tmp_str;
5619 : 1344 : tmp = rse.loop->loopvar[n];
5620 : 1344 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5621 : : tmp, rse.loop->from[n]);
5622 : 1344 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5623 : : tmp, tmp_index);
5624 : :
5625 : 2688 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5626 : : gfc_array_index_type,
5627 : 1344 : rse.loop->to[n-1], rse.loop->from[n-1]);
5628 : 1344 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5629 : : gfc_array_index_type,
5630 : : tmp_str, gfc_index_one_node);
5631 : :
5632 : 1344 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5633 : : gfc_array_index_type, tmp, tmp_str);
5634 : : }
5635 : :
5636 : 4734 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5637 : : gfc_array_index_type,
5638 : 2367 : tmp_index, rse.loop->from[0]);
5639 : 2367 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5640 : :
5641 : 4734 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5642 : : gfc_array_index_type,
5643 : 2367 : rse.loop->loopvar[0], offset);
5644 : :
5645 : : /* Now use the offset for the reference. */
5646 : 2367 : tmp = build_fold_indirect_ref_loc (input_location,
5647 : : info->data);
5648 : 2367 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5649 : :
5650 : 2367 : if (expr->ts.type == BT_CHARACTER)
5651 : 1158 : rse.string_length = expr->ts.u.cl->backend_decl;
5652 : :
5653 : 2367 : gfc_conv_expr (&lse, expr);
5654 : :
5655 : 2367 : gcc_assert (lse.ss == gfc_ss_terminator);
5656 : :
5657 : 2367 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
5658 : 2367 : gfc_add_expr_to_block (&body, tmp);
5659 : :
5660 : : /* Generate the copying loops. */
5661 : 2367 : gfc_trans_scalarizing_loops (&loop2, &body);
5662 : :
5663 : : /* Wrap the whole thing up by adding the second loop to the post-block
5664 : : and following it by the post-block of the first loop. In this way,
5665 : : if the temporary needs freeing, it is done after use!
5666 : : If input expr is read-only, e.g. a PARAMETER array, copying back
5667 : : modified values is undefined behavior. */
5668 : 4734 : readonly = (expr->expr_type == EXPR_VARIABLE
5669 : 2313 : && expr->symtree
5670 : 4680 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5671 : :
5672 : 2367 : if ((intent != INTENT_IN) && !readonly)
5673 : : {
5674 : 1138 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5675 : 1138 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5676 : : }
5677 : :
5678 : 1229 : class_array_fcn:
5679 : :
5680 : 2380 : gfc_add_block_to_block (&parmse->post, &loop.post);
5681 : :
5682 : 2380 : gfc_cleanup_loop (&loop);
5683 : 2380 : gfc_cleanup_loop (&loop2);
5684 : :
5685 : : /* Pass the string length to the argument expression. */
5686 : 2380 : if (expr->ts.type == BT_CHARACTER)
5687 : 1158 : parmse->string_length = expr->ts.u.cl->backend_decl;
5688 : :
5689 : : /* Determine the offset for pointer formal arguments and set the
5690 : : lbounds to one. */
5691 : 2380 : if (formal_ptr)
5692 : : {
5693 : 0 : size = gfc_index_one_node;
5694 : 0 : offset = gfc_index_zero_node;
5695 : 0 : for (n = 0; n < dimen; n++)
5696 : : {
5697 : 0 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5698 : : gfc_rank_cst[n]);
5699 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5700 : : gfc_array_index_type, tmp,
5701 : : gfc_index_one_node);
5702 : 0 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5703 : : parmse->expr,
5704 : : gfc_rank_cst[n],
5705 : : tmp);
5706 : 0 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5707 : : parmse->expr,
5708 : : gfc_rank_cst[n],
5709 : : gfc_index_one_node);
5710 : 0 : size = gfc_evaluate_now (size, &parmse->pre);
5711 : 0 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5712 : : gfc_array_index_type,
5713 : : offset, size);
5714 : 0 : offset = gfc_evaluate_now (offset, &parmse->pre);
5715 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5716 : : gfc_array_index_type,
5717 : 0 : rse.loop->to[n], rse.loop->from[n]);
5718 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5719 : : gfc_array_index_type,
5720 : : tmp, gfc_index_one_node);
5721 : 0 : size = fold_build2_loc (input_location, MULT_EXPR,
5722 : : gfc_array_index_type, size, tmp);
5723 : : }
5724 : :
5725 : 0 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5726 : : offset);
5727 : : }
5728 : :
5729 : : /* We want either the address for the data or the address of the descriptor,
5730 : : depending on the mode of passing array arguments. */
5731 : 2380 : if (g77)
5732 : 433 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5733 : : else
5734 : 1947 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5735 : :
5736 : : /* Basically make this into
5737 : :
5738 : : if (present)
5739 : : {
5740 : : if (contiguous)
5741 : : {
5742 : : pointer = a;
5743 : : }
5744 : : else
5745 : : {
5746 : : parmse->pre();
5747 : : pointer = parmse->expr;
5748 : : }
5749 : : }
5750 : : else
5751 : : pointer = NULL;
5752 : :
5753 : : foo (pointer);
5754 : : if (present && !contiguous)
5755 : : se->post();
5756 : :
5757 : : */
5758 : :
5759 : 2380 : if (pass_optional || check_contiguous)
5760 : : {
5761 : 1349 : tree type;
5762 : 1349 : stmtblock_t else_block;
5763 : 1349 : tree pre_stmts, post_stmts;
5764 : 1349 : tree pointer;
5765 : 1349 : tree else_stmt;
5766 : 1349 : tree present_var = NULL_TREE;
5767 : 1349 : tree cont_var = NULL_TREE;
5768 : 1349 : tree post_cond;
5769 : :
5770 : 1349 : type = TREE_TYPE (parmse->expr);
5771 : 1349 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5772 : 1021 : type = TREE_TYPE (type);
5773 : 1349 : pointer = gfc_create_var (type, "arg_ptr");
5774 : :
5775 : 1349 : if (check_contiguous)
5776 : : {
5777 : 1349 : gfc_se cont_se, array_se;
5778 : 1349 : stmtblock_t if_block, else_block;
5779 : 1349 : tree if_stmt, else_stmt;
5780 : 1349 : mpz_t size;
5781 : 1349 : bool size_set;
5782 : :
5783 : 1349 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5784 : :
5785 : : /* If the size is known to be one at compile-time, set
5786 : : cont_var to true unconditionally. This may look
5787 : : inelegant, but we're only doing this during
5788 : : optimization, so the statements will be optimized away,
5789 : : and this saves complexity here. */
5790 : :
5791 : 1349 : size_set = gfc_array_size (expr, &size);
5792 : 1349 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5793 : : {
5794 : 6 : gfc_add_modify (&se->pre, cont_var,
5795 : : build_one_cst (boolean_type_node));
5796 : : }
5797 : : else
5798 : : {
5799 : : /* cont_var = is_contiguous (expr); . */
5800 : 1343 : gfc_init_se (&cont_se, parmse);
5801 : 1343 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5802 : 1343 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5803 : 1343 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5804 : 1343 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5805 : : }
5806 : :
5807 : 1349 : if (size_set)
5808 : 1145 : mpz_clear (size);
5809 : :
5810 : : /* arrayse->expr = descriptor of a. */
5811 : 1349 : gfc_init_se (&array_se, se);
5812 : 1349 : gfc_conv_expr_descriptor (&array_se, expr);
5813 : 1349 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5814 : 1349 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5815 : :
5816 : : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5817 : 1349 : gfc_init_block (&if_block);
5818 : 1349 : if (GFC_DESCRIPTOR_TYPE_P (type))
5819 : 1021 : gfc_add_modify (&if_block, pointer, array_se.expr);
5820 : : else
5821 : : {
5822 : 328 : tmp = gfc_conv_array_data (array_se.expr);
5823 : 328 : tmp = fold_convert (type, tmp);
5824 : 328 : gfc_add_modify (&if_block, pointer, tmp);
5825 : : }
5826 : 1349 : if_stmt = gfc_finish_block (&if_block);
5827 : :
5828 : : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5829 : 1349 : gfc_init_block (&else_block);
5830 : 1349 : gfc_add_block_to_block (&else_block, &parmse->pre);
5831 : 1677 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5832 : 1349 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5833 : : : parmse->expr);
5834 : 1349 : gfc_add_modify (&else_block, pointer, tmp);
5835 : 1349 : else_stmt = gfc_finish_block (&else_block);
5836 : :
5837 : : /* And put the above into an if statement. */
5838 : 1349 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5839 : : gfc_likely (cont_var,
5840 : : PRED_FORTRAN_CONTIGUOUS),
5841 : : if_stmt, else_stmt);
5842 : : }
5843 : : else
5844 : : {
5845 : : /* pointer = pramse->expr; . */
5846 : 0 : gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5847 : 0 : pre_stmts = gfc_finish_block (&parmse->pre);
5848 : : }
5849 : :
5850 : 1349 : if (pass_optional)
5851 : : {
5852 : 11 : present_var = gfc_create_var (boolean_type_node, "present");
5853 : :
5854 : : /* present_var = present(sym); . */
5855 : 11 : tmp = gfc_conv_expr_present (sym);
5856 : 11 : tmp = fold_convert (boolean_type_node, tmp);
5857 : 11 : gfc_add_modify (&se->pre, present_var, tmp);
5858 : :
5859 : : /* else_stmt = { pointer = NULL; } . */
5860 : 11 : gfc_init_block (&else_block);
5861 : 11 : if (GFC_DESCRIPTOR_TYPE_P (type))
5862 : 0 : gfc_conv_descriptor_data_set (&else_block, pointer,
5863 : : null_pointer_node);
5864 : : else
5865 : 11 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5866 : 11 : else_stmt = gfc_finish_block (&else_block);
5867 : :
5868 : 11 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5869 : : gfc_likely (present_var,
5870 : : PRED_FORTRAN_ABSENT_DUMMY),
5871 : : pre_stmts, else_stmt);
5872 : 11 : gfc_add_expr_to_block (&se->pre, tmp);
5873 : : }
5874 : : else
5875 : 1338 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5876 : :
5877 : 1349 : post_stmts = gfc_finish_block (&parmse->post);
5878 : :
5879 : : /* Put together the post stuff, plus the optional
5880 : : deallocation. */
5881 : 1349 : if (check_contiguous)
5882 : : {
5883 : : /* !cont_var. */
5884 : 1349 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5885 : : cont_var,
5886 : : build_zero_cst (boolean_type_node));
5887 : 1349 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5888 : :
5889 : 1349 : if (pass_optional)
5890 : : {
5891 : 11 : tree present_likely = gfc_likely (present_var,
5892 : : PRED_FORTRAN_ABSENT_DUMMY);
5893 : 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5894 : : boolean_type_node, present_likely,
5895 : : tmp);
5896 : : }
5897 : : else
5898 : : post_cond = tmp;
5899 : : }
5900 : : else
5901 : : {
5902 : 0 : gcc_assert (pass_optional);
5903 : : post_cond = present_var;
5904 : : }
5905 : :
5906 : 1349 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5907 : : post_stmts, build_empty_stmt (input_location));
5908 : 1349 : gfc_add_expr_to_block (&se->post, tmp);
5909 : 1349 : if (GFC_DESCRIPTOR_TYPE_P (type))
5910 : : {
5911 : 1021 : type = TREE_TYPE (parmse->expr);
5912 : 1021 : if (POINTER_TYPE_P (type))
5913 : : {
5914 : 1021 : pointer = gfc_build_addr_expr (type, pointer);
5915 : 1021 : if (pass_optional)
5916 : : {
5917 : 0 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5918 : 0 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
5919 : : tmp, pointer,
5920 : : fold_convert (type,
5921 : : null_pointer_node));
5922 : : }
5923 : : }
5924 : : else
5925 : 0 : gcc_assert (!pass_optional);
5926 : : }
5927 : 1349 : se->expr = pointer;
5928 : : }
5929 : :
5930 : 2380 : return;
5931 : : }
5932 : :
5933 : :
5934 : : /* Generate the code for argument list functions. */
5935 : :
5936 : : static void
5937 : 5822 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5938 : : {
5939 : : /* Pass by value for g77 %VAL(arg), pass the address
5940 : : indirectly for %LOC, else by reference. Thus %REF
5941 : : is a "do-nothing" and %LOC is the same as an F95
5942 : : pointer. */
5943 : 5822 : if (strcmp (name, "%VAL") == 0)
5944 : 5810 : gfc_conv_expr (se, expr);
5945 : 12 : else if (strcmp (name, "%LOC") == 0)
5946 : : {
5947 : 6 : gfc_conv_expr_reference (se, expr);
5948 : 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
5949 : : }
5950 : 6 : else if (strcmp (name, "%REF") == 0)
5951 : 6 : gfc_conv_expr_reference (se, expr);
5952 : : else
5953 : 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
5954 : 5822 : }
5955 : :
5956 : :
5957 : : /* This function tells whether the middle-end representation of the expression
5958 : : E given as input may point to data otherwise accessible through a variable
5959 : : (sub-)reference.
5960 : : It is assumed that the only expressions that may alias are variables,
5961 : : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5962 : : may alias.
5963 : : This function is used to decide whether freeing an expression's allocatable
5964 : : components is safe or should be avoided.
5965 : :
5966 : : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5967 : : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5968 : : is necessary because for array constructors, aliasing depends on how
5969 : : the array is used:
5970 : : - If E is an array constructor used as argument to an elemental procedure,
5971 : : the array, which is generated through shallow copy by the scalarizer,
5972 : : is used directly and can alias the expressions it was copied from.
5973 : : - If E is an array constructor used as argument to a non-elemental
5974 : : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5975 : : the array as in the previous case, but then that array is used
5976 : : to initialize a new descriptor through deep copy. There is no alias
5977 : : possible in that case.
5978 : : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5979 : : above. */
5980 : :
5981 : : static bool
5982 : 7314 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5983 : : {
5984 : 7314 : gfc_constructor *c;
5985 : :
5986 : 7314 : if (e->expr_type == EXPR_VARIABLE)
5987 : : return true;
5988 : 398 : else if (e->expr_type == EXPR_FUNCTION)
5989 : : {
5990 : 160 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5991 : :
5992 : 160 : if (proc_ifc->result != NULL
5993 : 160 : && ((proc_ifc->result->ts.type == BT_CLASS
5994 : 25 : && proc_ifc->result->ts.u.derived->attr.is_class
5995 : 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
5996 : 160 : || proc_ifc->result->attr.pointer))
5997 : : return true;
5998 : : else
5999 : : return false;
6000 : : }
6001 : 238 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6002 : : return false;
6003 : :
6004 : 67 : for (c = gfc_constructor_first (e->value.constructor);
6005 : 101 : c; c = gfc_constructor_next (c))
6006 : 69 : if (c->expr
6007 : 69 : && expr_may_alias_variables (c->expr, array_may_alias))
6008 : : return true;
6009 : :
6010 : : return false;
6011 : : }
6012 : :
6013 : :
6014 : : /* A helper function to set the dtype for unallocated or unassociated
6015 : : entities. */
6016 : :
6017 : : static void
6018 : 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6019 : : {
6020 : 891 : tree tmp;
6021 : 891 : tree desc;
6022 : 891 : tree cond;
6023 : 891 : tree type;
6024 : 891 : stmtblock_t block;
6025 : :
6026 : : /* TODO Figure out how to handle optional dummies. */
6027 : 891 : if (e && e->expr_type == EXPR_VARIABLE
6028 : 807 : && e->symtree->n.sym->attr.optional)
6029 : 108 : return;
6030 : :
6031 : 819 : desc = parmse->expr;
6032 : 819 : if (desc == NULL_TREE)
6033 : : return;
6034 : :
6035 : 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6036 : 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6037 : 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6038 : 192 : desc = gfc_class_data_get (desc);
6039 : 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6040 : : return;
6041 : :
6042 : 783 : gfc_init_block (&block);
6043 : 783 : tmp = gfc_conv_descriptor_data_get (desc);
6044 : 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6045 : : logical_type_node, tmp,
6046 : 783 : build_int_cst (TREE_TYPE (tmp), 0));
6047 : 783 : tmp = gfc_conv_descriptor_dtype (desc);
6048 : 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6049 : 1566 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6050 : 783 : TREE_TYPE (tmp), tmp,
6051 : : gfc_get_dtype_rank_type (e->rank, type));
6052 : 783 : gfc_add_expr_to_block (&block, tmp);
6053 : 783 : cond = build3_v (COND_EXPR, cond,
6054 : : gfc_finish_block (&block),
6055 : : build_empty_stmt (input_location));
6056 : 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6057 : : }
6058 : :
6059 : :
6060 : :
6061 : : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6062 : : ISO_Fortran_binding array descriptors. */
6063 : :
6064 : : static void
6065 : 6536 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6066 : : {
6067 : 6536 : stmtblock_t block, block2;
6068 : 6536 : tree cfi, gfc, tmp, tmp2;
6069 : 6536 : tree present = NULL;
6070 : 6536 : tree gfc_strlen = NULL;
6071 : 6536 : tree rank;
6072 : 6536 : gfc_se se;
6073 : :
6074 : 6536 : if (fsym->attr.optional
6075 : 1094 : && e->expr_type == EXPR_VARIABLE
6076 : 1094 : && e->symtree->n.sym->attr.optional)
6077 : 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6078 : :
6079 : 6536 : gfc_init_block (&block);
6080 : :
6081 : : /* Convert original argument to a tree. */
6082 : 6536 : gfc_init_se (&se, NULL);
6083 : 6536 : if (e->rank == 0)
6084 : : {
6085 : 686 : se.want_pointer = 1;
6086 : 686 : gfc_conv_expr (&se, e);
6087 : 686 : gfc = se.expr;
6088 : : /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
6089 : 686 : if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
6090 : 20 : gfc = gfc_build_addr_expr (NULL, gfc);
6091 : : }
6092 : : else
6093 : : {
6094 : : /* If the actual argument can be noncontiguous, copy-in/out is required,
6095 : : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6096 : : length assumed-length/assumed-size CHARACTER array. This only
6097 : : applies if the actual argument is a "variable"; if it's some
6098 : : non-lvalue expression, we are going to evaluate it to a
6099 : : temporary below anyway. */
6100 : 5850 : se.force_no_tmp = 1;
6101 : 5850 : if ((fsym->attr.contiguous
6102 : 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6103 : 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6104 : 937 : || fsym->as->type == AS_EXPLICIT)))
6105 : 2023 : && !gfc_is_simply_contiguous (e, false, true)
6106 : 6877 : && gfc_expr_is_variable (e))
6107 : : {
6108 : 1021 : bool optional = fsym->attr.optional;
6109 : 1021 : fsym->attr.optional = 0;
6110 : 1021 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6111 : 1021 : fsym->attr.pointer, fsym,
6112 : 1021 : fsym->ns->proc_name->name, NULL,
6113 : : /* check_contiguous= */ true);
6114 : 1021 : fsym->attr.optional = optional;
6115 : : }
6116 : : else
6117 : 4829 : gfc_conv_expr_descriptor (&se, e);
6118 : 5850 : gfc = se.expr;
6119 : : /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
6120 : : elem_len = sizeof(dt) and base_addr = dt(lb) instead.
6121 : : gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
6122 : : While sm is fine as it uses span*stride and not elem_len. */
6123 : 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6124 : 1021 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6125 : 4829 : else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
6126 : 12 : gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
6127 : : }
6128 : 6536 : if (e->ts.type == BT_CHARACTER)
6129 : : {
6130 : 3409 : if (se.string_length)
6131 : : gfc_strlen = se.string_length;
6132 : 883 : else if (e->ts.u.cl->backend_decl)
6133 : : gfc_strlen = e->ts.u.cl->backend_decl;
6134 : : else
6135 : 0 : gcc_unreachable ();
6136 : : }
6137 : 6536 : gfc_add_block_to_block (&block, &se.pre);
6138 : :
6139 : : /* Create array descriptor and set version, rank, attribute, type. */
6140 : 12767 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6141 : : ? GFC_MAX_DIMENSIONS : e->rank,
6142 : : false), "cfi");
6143 : : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6144 : 6536 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6145 : : {
6146 : 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6147 : 2338 : tmp = build_pointer_type (tmp);
6148 : 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6149 : 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6150 : : }
6151 : : else
6152 : 4198 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6153 : :
6154 : 6536 : tmp = gfc_get_cfi_desc_version (cfi);
6155 : 6536 : gfc_add_modify (&block, tmp,
6156 : 6536 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6157 : 6536 : if (e->rank < 0)
6158 : 305 : rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
6159 : : else
6160 : 6231 : rank = build_int_cst (signed_char_type_node, e->rank);
6161 : 6536 : tmp = gfc_get_cfi_desc_rank (cfi);
6162 : 6536 : gfc_add_modify (&block, tmp, rank);
6163 : 6536 : int itype = CFI_type_other;
6164 : 6536 : if (e->ts.f90_type == BT_VOID)
6165 : 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6166 : 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6167 : : else
6168 : : {
6169 : 6440 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6170 : 1 : e->ts = fsym->ts;
6171 : 6440 : switch (e->ts.type)
6172 : : {
6173 : 2296 : case BT_INTEGER:
6174 : 2296 : case BT_LOGICAL:
6175 : 2296 : case BT_REAL:
6176 : 2296 : case BT_COMPLEX:
6177 : 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6178 : 2296 : break;
6179 : 3410 : case BT_CHARACTER:
6180 : 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6181 : 3410 : break;
6182 : : case BT_DERIVED:
6183 : 6536 : itype = CFI_type_struct;
6184 : : break;
6185 : 0 : case BT_VOID:
6186 : 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6187 : 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6188 : : break;
6189 : : case BT_ASSUMED:
6190 : : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6191 : : break;
6192 : 1 : case BT_CLASS:
6193 : 1 : if (fsym->ts.type == BT_ASSUMED)
6194 : : {
6195 : : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6196 : : // type specifier is assumed-type and is an unlimited polymorphic
6197 : : // entity." The actual argument _data component is passed.
6198 : : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6199 : : break;
6200 : : }
6201 : : else
6202 : 0 : gcc_unreachable ();
6203 : :
6204 : 0 : case BT_UNSIGNED:
6205 : 0 : gfc_internal_error ("Unsigned not yet implemented");
6206 : :
6207 : 0 : case BT_PROCEDURE:
6208 : 0 : case BT_HOLLERITH:
6209 : 0 : case BT_UNION:
6210 : 0 : case BT_BOZ:
6211 : 0 : case BT_UNKNOWN:
6212 : : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6213 : 0 : gcc_unreachable ();
6214 : : }
6215 : : }
6216 : :
6217 : 6536 : tmp = gfc_get_cfi_desc_type (cfi);
6218 : 6536 : gfc_add_modify (&block, tmp,
6219 : 6536 : build_int_cst (TREE_TYPE (tmp), itype));
6220 : :
6221 : 6536 : int attr = CFI_attribute_other;
6222 : 6536 : if (fsym->attr.pointer)
6223 : : attr = CFI_attribute_pointer;
6224 : 5774 : else if (fsym->attr.allocatable)
6225 : 433 : attr = CFI_attribute_allocatable;
6226 : 6536 : tmp = gfc_get_cfi_desc_attribute (cfi);
6227 : 6536 : gfc_add_modify (&block, tmp,
6228 : 6536 : build_int_cst (TREE_TYPE (tmp), attr));
6229 : :
6230 : : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6231 : : That is very sensible for undefined pointers, but the C code might assume
6232 : : that the pointer retains the value, in particular, if it was NULL. */
6233 : 6536 : if (e->rank == 0)
6234 : : {
6235 : 686 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6236 : 686 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6237 : : }
6238 : : else
6239 : : {
6240 : 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6241 : 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6242 : 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6243 : : }
6244 : :
6245 : : /* Set elem_len if known - must be before the next if block.
6246 : : Note that allocatable implies 'len=:'. */
6247 : 6536 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6248 : : {
6249 : : /* Length is known at compile time; use 'block' for it. */
6250 : 3072 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6251 : 3072 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6252 : 3072 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6253 : : }
6254 : :
6255 : 6536 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6256 : 91 : goto done;
6257 : :
6258 : : /* When allocatable + intent out, free the cfi descriptor. */
6259 : 6445 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6260 : : {
6261 : 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6262 : 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6263 : 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6264 : 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6265 : 90 : gfc_add_modify (&block, tmp,
6266 : 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6267 : 90 : goto done;
6268 : : }
6269 : :
6270 : : /* If not unallocated/unassociated. */
6271 : 6355 : gfc_init_block (&block2);
6272 : :
6273 : : /* Set elem_len, which may be only known at run time. */
6274 : 6355 : if (e->ts.type == BT_CHARACTER
6275 : 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6276 : : {
6277 : 3408 : gcc_assert (gfc_strlen);
6278 : 3409 : tmp = gfc_strlen;
6279 : 3409 : if (e->ts.kind != 1)
6280 : 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6281 : : gfc_charlen_type_node, tmp,
6282 : : build_int_cst (gfc_charlen_type_node,
6283 : 1117 : e->ts.kind));
6284 : 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6285 : 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6286 : : }
6287 : 2946 : else if (e->ts.type == BT_ASSUMED)
6288 : : {
6289 : 54 : tmp = gfc_conv_descriptor_elem_len (gfc);
6290 : 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6291 : 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6292 : : }
6293 : :
6294 : 6355 : if (e->ts.type == BT_ASSUMED)
6295 : : {
6296 : : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6297 : : an CFI descriptor. Use the type in the descriptor as it provide
6298 : : mode information. (Quality of implementation feature.) */
6299 : 54 : tree cond;
6300 : 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6301 : 54 : tree type = fold_convert (TREE_TYPE (ctype),
6302 : : gfc_conv_descriptor_type (gfc));
6303 : 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6304 : : gfc_conv_descriptor_elem_len (gfc));
6305 : 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6306 : 54 : kind, build_int_cst (TREE_TYPE (type),
6307 : : CFI_type_kind_shift));
6308 : :
6309 : : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6310 : : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6311 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6312 : 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6313 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6314 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6315 : 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6316 : : ctype,
6317 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6318 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6319 : : tmp, tmp2);
6320 : : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6321 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6322 : 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6323 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6324 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6325 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6326 : : tmp, tmp2);
6327 : : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6328 : : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6329 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6330 : 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6331 : 54 : tmp = build_int_cst (TREE_TYPE (type),
6332 : : CFI_type_from_type_kind (CFI_type_Character, 1));
6333 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6334 : : ctype, tmp);
6335 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6336 : : tmp, tmp2);
6337 : : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6338 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6339 : 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6340 : 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6341 : 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6342 : 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6343 : 54 : build_int_cst (TREE_TYPE (type),
6344 : : CFI_type_Complex));
6345 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6346 : : ctype, tmp);
6347 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6348 : : tmp, tmp2);
6349 : : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6350 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6351 : 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6352 : 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6353 : 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6354 : 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6355 : : cond, tmp);
6356 : 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6357 : 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6358 : 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6359 : : cond, tmp);
6360 : 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6361 : : type, kind);
6362 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6363 : : ctype, tmp);
6364 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6365 : : tmp, tmp2);
6366 : 54 : gfc_add_expr_to_block (&block2, tmp2);
6367 : : }
6368 : :
6369 : 6355 : if (e->rank != 0)
6370 : : {
6371 : : /* Loop: for (i = 0; i < rank; ++i). */
6372 : 5735 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6373 : : /* Loop body. */
6374 : 5735 : stmtblock_t loop_body;
6375 : 5735 : gfc_init_block (&loop_body);
6376 : : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6377 : : ? gfc->dim[i].lbound : 0 */
6378 : 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6379 : 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6380 : : else
6381 : 5087 : tmp = gfc_index_zero_node;
6382 : 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6383 : : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6384 : 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6385 : : gfc_conv_descriptor_ubound_get (gfc, idx),
6386 : : gfc_conv_descriptor_lbound_get (gfc, idx));
6387 : 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6388 : : tmp, gfc_index_one_node);
6389 : 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6390 : : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6391 : 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6392 : : gfc_conv_descriptor_stride_get (gfc, idx),
6393 : : gfc_conv_descriptor_span_get (gfc));
6394 : 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6395 : :
6396 : : /* Generate loop. */
6397 : 11470 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6398 : 5735 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6399 : : gfc_finish_block (&loop_body));
6400 : :
6401 : 5735 : if (e->expr_type == EXPR_VARIABLE
6402 : 5573 : && e->ref
6403 : 5573 : && e->ref->u.ar.type == AR_FULL
6404 : 2732 : && e->symtree->n.sym->attr.dummy
6405 : 988 : && e->symtree->n.sym->as
6406 : 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6407 : : {
6408 : 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6409 : 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6410 : : }
6411 : : }
6412 : :
6413 : 6355 : if (fsym->attr.allocatable || fsym->attr.pointer)
6414 : : {
6415 : 1014 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6416 : 1014 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6417 : : tmp, null_pointer_node);
6418 : 1014 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6419 : : build_empty_stmt (input_location));
6420 : 1014 : gfc_add_expr_to_block (&block, tmp);
6421 : : }
6422 : : else
6423 : 5341 : gfc_add_block_to_block (&block, &block2);
6424 : :
6425 : :
6426 : 6536 : done:
6427 : 6536 : if (present)
6428 : : {
6429 : 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6430 : 103 : TREE_TYPE (parmse->expr),
6431 : : present, parmse->expr, null_pointer_node);
6432 : 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6433 : : build_empty_stmt (input_location));
6434 : 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6435 : : }
6436 : : else
6437 : 6433 : gfc_add_block_to_block (&parmse->pre, &block);
6438 : :
6439 : 6536 : gfc_init_block (&block);
6440 : :
6441 : 6536 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6442 : 1195 : || fsym->attr.intent == INTENT_IN)
6443 : 5549 : goto post_call;
6444 : :
6445 : 987 : gfc_init_block (&block2);
6446 : 987 : if (e->rank == 0)
6447 : : {
6448 : 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6449 : 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6450 : : }
6451 : : else
6452 : : {
6453 : 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6454 : 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6455 : :
6456 : 559 : if (fsym->attr.allocatable)
6457 : : {
6458 : : /* gfc->span = cfi->elem_len. */
6459 : 252 : tmp = fold_convert (gfc_array_index_type,
6460 : : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6461 : : }
6462 : : else
6463 : : {
6464 : : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6465 : : ? cfi->dim[0].sm : cfi->elem_len). */
6466 : 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6467 : 307 : tmp2 = fold_convert (gfc_array_index_type,
6468 : : gfc_get_cfi_desc_elem_len (cfi));
6469 : 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6470 : : gfc_array_index_type, tmp, tmp2);
6471 : 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6472 : : tmp, gfc_index_zero_node);
6473 : 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6474 : : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6475 : : }
6476 : 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6477 : :
6478 : : /* Calculate offset + set lbound, ubound and stride. */
6479 : 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6480 : : /* Loop: for (i = 0; i < rank; ++i). */
6481 : 559 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6482 : : /* Loop body. */
6483 : 559 : stmtblock_t loop_body;
6484 : 559 : gfc_init_block (&loop_body);
6485 : : /* gfc->dim[i].lbound = ... */
6486 : 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6487 : 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6488 : :
6489 : : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6490 : 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6491 : : gfc_conv_descriptor_lbound_get (gfc, idx),
6492 : : gfc_index_one_node);
6493 : 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6494 : : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6495 : 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6496 : :
6497 : : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6498 : 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6499 : 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6500 : : gfc_array_index_type, tmp,
6501 : : fold_convert (gfc_array_index_type,
6502 : : gfc_get_cfi_desc_elem_len (cfi)));
6503 : 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6504 : :
6505 : : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6506 : 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6507 : : gfc_conv_descriptor_stride_get (gfc, idx),
6508 : : gfc_conv_descriptor_lbound_get (gfc, idx));
6509 : 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6510 : : gfc_conv_descriptor_offset_get (gfc), tmp);
6511 : 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6512 : : /* Generate loop. */
6513 : 1118 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6514 : 559 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6515 : : gfc_finish_block (&loop_body));
6516 : : }
6517 : :
6518 : 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6519 : : {
6520 : 60 : tmp = fold_convert (gfc_charlen_type_node,
6521 : : gfc_get_cfi_desc_elem_len (cfi));
6522 : 60 : if (e->ts.kind != 1)
6523 : 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6524 : : gfc_charlen_type_node, tmp,
6525 : : build_int_cst (gfc_charlen_type_node,
6526 : 24 : e->ts.kind));
6527 : 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6528 : : }
6529 : :
6530 : 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6531 : 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6532 : : tmp, null_pointer_node);
6533 : 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6534 : : build_empty_stmt (input_location));
6535 : 987 : gfc_add_expr_to_block (&block, tmp);
6536 : :
6537 : 6536 : post_call:
6538 : 6536 : gfc_add_block_to_block (&block, &se.post);
6539 : 6536 : if (present && block.head)
6540 : : {
6541 : 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6542 : : build_empty_stmt (input_location));
6543 : 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6544 : : }
6545 : 6530 : else if (block.head)
6546 : 1558 : gfc_add_block_to_block (&parmse->post, &block);
6547 : 6536 : }
6548 : :
6549 : :
6550 : : /* Create "conditional temporary" to handle scalar dummy variables with the
6551 : : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6552 : : as fallback. Does not handle CLASS. */
6553 : :
6554 : : static void
6555 : 222 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6556 : : {
6557 : 222 : tree temp;
6558 : 222 : gcc_assert (e && e->ts.type != BT_CLASS);
6559 : 222 : gcc_assert (e->rank == 0);
6560 : 222 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6561 : 222 : TREE_STATIC (temp) = 1;
6562 : 222 : TREE_CONSTANT (temp) = 1;
6563 : 222 : TREE_READONLY (temp) = 1;
6564 : 222 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6565 : 222 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6566 : 222 : TREE_TYPE (parmse->expr),
6567 : : cond, parmse->expr, temp);
6568 : 222 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6569 : 222 : }
6570 : :
6571 : :
6572 : : /* Returns true if the type specified in TS is a character type whose length
6573 : : is constant. Otherwise returns false. */
6574 : :
6575 : : static bool
6576 : 21766 : gfc_const_length_character_type_p (gfc_typespec *ts)
6577 : : {
6578 : 21766 : return (ts->type == BT_CHARACTER
6579 : 467 : && ts->u.cl
6580 : 467 : && ts->u.cl->length
6581 : 467 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6582 : 22233 : && ts->u.cl->length->ts.type == BT_INTEGER);
6583 : : }
6584 : :
6585 : :
6586 : : /* Helper function for the handling of (currently) scalar dummy variables
6587 : : with the VALUE attribute. Argument parmse should already be set up. */
6588 : : static void
6589 : 22199 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6590 : : vec<tree, va_gc> *& optionalargs)
6591 : : {
6592 : 22199 : tree tmp;
6593 : :
6594 : 22199 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6595 : :
6596 : 22199 : if (e && e->ts.type == BT_DERIVED && e->ts.u.derived->attr.pdt_type)
6597 : : {
6598 : 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6599 : 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6600 : 6 : gfc_add_expr_to_block (&parmse->pre,
6601 : 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6602 : : parmse->expr, tmp,
6603 : : e->rank, 0));
6604 : 6 : parmse->expr = tmp;
6605 : 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6606 : 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6607 : 6 : return;
6608 : : }
6609 : :
6610 : : /* Absent actual argument for optional scalar dummy. */
6611 : 22193 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6612 : : {
6613 : : /* For scalar arguments with VALUE attribute which are passed by
6614 : : value, pass "0" and a hidden argument for the optional status. */
6615 : 427 : if (fsym->ts.type == BT_CHARACTER)
6616 : : {
6617 : : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6618 : : zero. */
6619 : 90 : parmse->expr = null_pointer_node;
6620 : 90 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6621 : : }
6622 : 337 : else if (gfc_bt_struct (fsym->ts.type)
6623 : 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6624 : : {
6625 : : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6626 : : are pointers and passed as such below. */
6627 : 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6628 : 24 : TREE_CONSTANT (temp) = 1;
6629 : 24 : TREE_READONLY (temp) = 1;
6630 : 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6631 : 24 : parmse->expr = temp;
6632 : 24 : }
6633 : : else
6634 : 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6635 : : integer_zero_node);
6636 : 427 : vec_safe_push (optionalargs, boolean_false_node);
6637 : :
6638 : 427 : return;
6639 : : }
6640 : :
6641 : : /* Truncate a too long constant character actual argument. */
6642 : 21766 : if (gfc_const_length_character_type_p (&fsym->ts)
6643 : 467 : && e->expr_type == EXPR_CONSTANT
6644 : 21849 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6645 : : e->value.character.length) < 0)
6646 : : {
6647 : 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6648 : :
6649 : : /* Truncate actual string argument. */
6650 : 17 : gfc_conv_expr (parmse, e);
6651 : 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6652 : 17 : e->value.character.string);
6653 : 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6654 : :
6655 : : /* Indicate value,optional scalar dummy argument as present. */
6656 : 17 : if (fsym->attr.optional)
6657 : 1 : vec_safe_push (optionalargs, boolean_true_node);
6658 : 17 : return;
6659 : : }
6660 : :
6661 : : /* gfortran argument passing conventions:
6662 : : actual arguments to CHARACTER(len=1),VALUE
6663 : : dummy arguments are actually passed by value.
6664 : : Strings are truncated to length 1. */
6665 : 21749 : if (gfc_length_one_character_type_p (&fsym->ts))
6666 : : {
6667 : 378 : if (e->expr_type == EXPR_CONSTANT
6668 : 54 : && e->value.character.length > 1)
6669 : : {
6670 : 0 : e->value.character.length = 1;
6671 : 0 : gfc_conv_expr (parmse, e);
6672 : : }
6673 : :
6674 : 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6675 : 378 : gfc_conv_string_parameter (parmse);
6676 : 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6677 : : e->ts.kind);
6678 : : /* Truncate resulting string to length 1. */
6679 : 378 : parmse->string_length = slen1;
6680 : : }
6681 : :
6682 : 21749 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6683 : : {
6684 : : /* F2018:15.5.2.12 Argument presence and
6685 : : restrictions on arguments not present. */
6686 : 811 : if (e->expr_type == EXPR_VARIABLE
6687 : 638 : && e->rank == 0
6688 : 1395 : && (gfc_expr_attr (e).allocatable
6689 : 482 : || gfc_expr_attr (e).pointer))
6690 : : {
6691 : 186 : gfc_se argse;
6692 : 186 : tree cond;
6693 : 186 : gfc_init_se (&argse, NULL);
6694 : 186 : argse.want_pointer = 1;
6695 : 186 : gfc_conv_expr (&argse, e);
6696 : 186 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6697 : 186 : cond = fold_build2_loc (input_location, NE_EXPR,
6698 : : logical_type_node,
6699 : : argse.expr, cond);
6700 : 372 : vec_safe_push (optionalargs,
6701 : 186 : fold_convert (boolean_type_node, cond));
6702 : : /* Create "conditional temporary". */
6703 : 186 : conv_cond_temp (parmse, e, cond);
6704 : : }
6705 : 625 : else if (e->expr_type != EXPR_VARIABLE
6706 : 452 : || !e->symtree->n.sym->attr.optional
6707 : 260 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6708 : 365 : vec_safe_push (optionalargs, boolean_true_node);
6709 : : else
6710 : : {
6711 : 260 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6712 : 260 : if (gfc_bt_struct (fsym->ts.type)
6713 : 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6714 : 36 : conv_cond_temp (parmse, e, tmp);
6715 : 224 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6716 : 84 : parmse->expr
6717 : 168 : = fold_build3_loc (input_location, COND_EXPR,
6718 : 84 : TREE_TYPE (parmse->expr),
6719 : : tmp, parmse->expr,
6720 : 84 : fold_convert (TREE_TYPE (parmse->expr),
6721 : : integer_zero_node));
6722 : :
6723 : 520 : vec_safe_push (optionalargs,
6724 : 260 : fold_convert (boolean_type_node, tmp));
6725 : : }
6726 : : }
6727 : : }
6728 : :
6729 : :
6730 : : /* Helper function for the handling of NULL() actual arguments associated with
6731 : : non-optional dummy variables. Argument parmse should already be set up. */
6732 : : static void
6733 : 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
6734 : : {
6735 : 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
6736 : :
6737 : : /* Obtain the character length for a NULL() actual with a character
6738 : : MOLD argument. Otherwise substitute a suitable dummy length.
6739 : : Here we handle only non-optional dummies of non-bind(c) procedures. */
6740 : 426 : if (fsym->ts.type == BT_CHARACTER)
6741 : : {
6742 : 216 : if (e->ts.type == BT_CHARACTER
6743 : 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
6744 : : {
6745 : : /* MOLD is present. Substitute a temporary character NULL pointer.
6746 : : For an assumed-rank dummy we need a descriptor that passes the
6747 : : correct rank. */
6748 : 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
6749 : : {
6750 : 54 : tree rank;
6751 : 54 : tree tmp = parmse->expr;
6752 : 54 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6753 : 54 : rank = gfc_conv_descriptor_rank (tmp);
6754 : 54 : gfc_add_modify (&parmse->pre, rank,
6755 : 54 : build_int_cst (TREE_TYPE (rank), e->rank));
6756 : 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6757 : 54 : }
6758 : : else
6759 : : {
6760 : 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
6761 : 108 : gfc_add_modify (&parmse->pre, tmp,
6762 : 108 : build_zero_cst (TREE_TYPE (tmp)));
6763 : 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6764 : : }
6765 : :
6766 : : /* Ensure that a usable length is available. */
6767 : 162 : if (parmse->string_length == NULL_TREE)
6768 : : {
6769 : 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
6770 : :
6771 : 162 : if (ts->u.cl->length != NULL
6772 : 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6773 : 108 : gfc_conv_const_charlen (ts->u.cl);
6774 : :
6775 : 162 : if (ts->u.cl->backend_decl)
6776 : 162 : parmse->string_length = ts->u.cl->backend_decl;
6777 : : }
6778 : : }
6779 : 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
6780 : : {
6781 : : /* MOLD is not present. Pass length of associated dummy character
6782 : : argument if constant, or zero. */
6783 : 54 : if (fsym->ts.u.cl->length != NULL
6784 : 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6785 : : {
6786 : 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
6787 : 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
6788 : : }
6789 : : else
6790 : : {
6791 : 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
6792 : : "slen");
6793 : 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
6794 : : build_zero_cst (gfc_charlen_type_node));
6795 : : }
6796 : : }
6797 : : }
6798 : 210 : else if (fsym->ts.type == BT_DERIVED)
6799 : : {
6800 : 210 : if (e->ts.type != BT_UNKNOWN)
6801 : : /* MOLD is present. Pass a corresponding temporary NULL pointer.
6802 : : For an assumed-rank dummy we provide a descriptor that passes
6803 : : the correct rank. */
6804 : : {
6805 : 138 : tree rank;
6806 : 138 : tree tmp = parmse->expr;
6807 : :
6808 : 138 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, gfc_expr_attr (e));
6809 : 138 : rank = gfc_conv_descriptor_rank (tmp);
6810 : 138 : gfc_add_modify (&parmse->pre, rank,
6811 : 138 : build_int_cst (TREE_TYPE (rank), e->rank));
6812 : 138 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6813 : 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6814 : : }
6815 : : else
6816 : : /* MOLD is not present. Use attributes from dummy argument, which is
6817 : : not allowed to be assumed-rank. */
6818 : : {
6819 : 72 : int dummy_rank;
6820 : 72 : tree tmp = parmse->expr;
6821 : :
6822 : 72 : if ((fsym->attr.allocatable || fsym->attr.pointer)
6823 : 72 : && fsym->attr.intent == INTENT_UNKNOWN)
6824 : 36 : fsym->attr.intent = INTENT_IN;
6825 : 72 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6826 : 72 : dummy_rank = fsym->as ? fsym->as->rank : 0;
6827 : 24 : if (dummy_rank > 0)
6828 : : {
6829 : 24 : tree rank = gfc_conv_descriptor_rank (tmp);
6830 : 24 : gfc_add_modify (&parmse->pre, rank,
6831 : 24 : build_int_cst (TREE_TYPE (rank), dummy_rank));
6832 : : }
6833 : 72 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6834 : 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6835 : : }
6836 : : }
6837 : 426 : }
6838 : :
6839 : :
6840 : : /* Generate code for a procedure call. Note can return se->post != NULL.
6841 : : If se->direct_byref is set then se->expr contains the return parameter.
6842 : : Return nonzero, if the call has alternate specifiers.
6843 : : 'expr' is only needed for procedure pointer components. */
6844 : :
6845 : : int
6846 : 133083 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6847 : : gfc_actual_arglist * args, gfc_expr * expr,
6848 : : vec<tree, va_gc> *append_args)
6849 : : {
6850 : 133083 : gfc_interface_mapping mapping;
6851 : 133083 : vec<tree, va_gc> *arglist;
6852 : 133083 : vec<tree, va_gc> *retargs;
6853 : 133083 : tree tmp;
6854 : 133083 : tree fntype;
6855 : 133083 : gfc_se parmse;
6856 : 133083 : gfc_array_info *info;
6857 : 133083 : int byref;
6858 : 133083 : int parm_kind;
6859 : 133083 : tree type;
6860 : 133083 : tree var;
6861 : 133083 : tree len;
6862 : 133083 : tree base_object;
6863 : 133083 : vec<tree, va_gc> *stringargs;
6864 : 133083 : vec<tree, va_gc> *optionalargs;
6865 : 133083 : tree result = NULL;
6866 : 133083 : gfc_formal_arglist *formal;
6867 : 133083 : gfc_actual_arglist *arg;
6868 : 133083 : int has_alternate_specifier = 0;
6869 : 133083 : bool need_interface_mapping;
6870 : 133083 : bool is_builtin;
6871 : 133083 : bool callee_alloc;
6872 : 133083 : bool ulim_copy;
6873 : 133083 : gfc_typespec ts;
6874 : 133083 : gfc_charlen cl;
6875 : 133083 : gfc_expr *e;
6876 : 133083 : gfc_symbol *fsym;
6877 : 133083 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6878 : 133083 : gfc_component *comp = NULL;
6879 : 133083 : int arglen;
6880 : 133083 : unsigned int argc;
6881 : 133083 : tree arg1_cntnr = NULL_TREE;
6882 : 133083 : arglist = NULL;
6883 : 133083 : retargs = NULL;
6884 : 133083 : stringargs = NULL;
6885 : 133083 : optionalargs = NULL;
6886 : 133083 : var = NULL_TREE;
6887 : 133083 : len = NULL_TREE;
6888 : 133083 : gfc_clear_ts (&ts);
6889 : 133083 : gfc_intrinsic_sym *isym = expr && expr->rank ?
6890 : : expr->value.function.isym : NULL;
6891 : :
6892 : 133083 : comp = gfc_get_proc_ptr_comp (expr);
6893 : :
6894 : 266166 : bool elemental_proc = (comp
6895 : 1854 : && comp->ts.interface
6896 : 1801 : && comp->ts.interface->attr.elemental)
6897 : 1661 : || (comp && comp->attr.elemental)
6898 : 134744 : || sym->attr.elemental;
6899 : :
6900 : 133083 : if (se->ss != NULL)
6901 : : {
6902 : 24769 : if (!elemental_proc)
6903 : : {
6904 : 21475 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
6905 : 21475 : if (se->ss->info->useflags)
6906 : : {
6907 : 5719 : gcc_assert ((!comp && gfc_return_by_reference (sym)
6908 : : && sym->result->attr.dimension)
6909 : : || (comp && comp->attr.dimension)
6910 : : || gfc_is_class_array_function (expr));
6911 : 5719 : gcc_assert (se->loop != NULL);
6912 : : /* Access the previously obtained result. */
6913 : 5719 : gfc_conv_tmp_array_ref (se);
6914 : 5719 : return 0;
6915 : : }
6916 : : }
6917 : 19050 : info = &se->ss->info->data.array;
6918 : : }
6919 : : else
6920 : : info = NULL;
6921 : :
6922 : 127364 : stmtblock_t post, clobbers, dealloc_blk;
6923 : 127364 : gfc_init_block (&post);
6924 : 127364 : gfc_init_block (&clobbers);
6925 : 127364 : gfc_init_block (&dealloc_blk);
6926 : 127364 : gfc_init_interface_mapping (&mapping);
6927 : 127364 : if (!comp)
6928 : : {
6929 : 125559 : formal = gfc_sym_get_dummy_args (sym);
6930 : 125559 : need_interface_mapping = sym->attr.dimension ||
6931 : 110055 : (sym->ts.type == BT_CHARACTER
6932 : 3033 : && sym->ts.u.cl->length
6933 : 2379 : && sym->ts.u.cl->length->expr_type
6934 : : != EXPR_CONSTANT);
6935 : : }
6936 : : else
6937 : : {
6938 : 1805 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
6939 : 1805 : need_interface_mapping = comp->attr.dimension ||
6940 : 1736 : (comp->ts.type == BT_CHARACTER
6941 : 67 : && comp->ts.u.cl->length
6942 : 58 : && comp->ts.u.cl->length->expr_type
6943 : : != EXPR_CONSTANT);
6944 : : }
6945 : :
6946 : 127364 : base_object = NULL_TREE;
6947 : : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
6948 : : is the third and fourth argument to such a function call a value
6949 : : denoting the number of elements to copy (i.e., most of the time the
6950 : : length of a deferred length string). */
6951 : 254728 : ulim_copy = (formal == NULL)
6952 : 31106 : && UNLIMITED_POLY (sym)
6953 : 127443 : && comp && (strcmp ("_copy", comp->name) == 0);
6954 : :
6955 : : /* Scan for allocatable actual arguments passed to allocatable dummy
6956 : : arguments with INTENT(OUT). As the corresponding actual arguments are
6957 : : deallocated before execution of the procedure, we evaluate actual
6958 : : argument expressions to avoid problems with possible dependencies. */
6959 : 127364 : bool force_eval_args = false;
6960 : 127364 : gfc_formal_arglist *tmp_formal;
6961 : 393891 : for (arg = args, tmp_formal = formal; arg != NULL;
6962 : 233246 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
6963 : : {
6964 : 267026 : e = arg->expr;
6965 : 267026 : fsym = tmp_formal ? tmp_formal->sym : NULL;
6966 : 253170 : if (e && fsym
6967 : 221316 : && e->expr_type == EXPR_VARIABLE
6968 : 96935 : && fsym->attr.intent == INTENT_OUT
6969 : 6220 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
6970 : 6220 : ? CLASS_DATA (fsym)->attr.allocatable
6971 : 4746 : : fsym->attr.allocatable)
6972 : 499 : && e->symtree
6973 : 499 : && e->symtree->n.sym
6974 : 520196 : && gfc_variable_attr (e, NULL).allocatable)
6975 : : {
6976 : : force_eval_args = true;
6977 : : break;
6978 : : }
6979 : : }
6980 : :
6981 : : /* Evaluate the arguments. */
6982 : 394792 : for (arg = args, argc = 0; arg != NULL;
6983 : 267428 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
6984 : : {
6985 : 267428 : bool finalized = false;
6986 : 267428 : tree derived_array = NULL_TREE;
6987 : 267428 : symbol_attribute *attr;
6988 : :
6989 : 267428 : e = arg->expr;
6990 : 267428 : fsym = formal ? formal->sym : NULL;
6991 : 501575 : parm_kind = MISSING;
6992 : :
6993 : 234147 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
6994 : : : fsym->attr)
6995 : : : nullptr;
6996 : : /* If the procedure requires an explicit interface, the actual
6997 : : argument is passed according to the corresponding formal
6998 : : argument. If the corresponding formal argument is a POINTER,
6999 : : ALLOCATABLE or assumed shape, we do not use g77's calling
7000 : : convention, and pass the address of the array descriptor
7001 : : instead. Otherwise we use g77's calling convention, in other words
7002 : : pass the array data pointer without descriptor. */
7003 : 234094 : bool nodesc_arg = fsym != NULL
7004 : 234094 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7005 : 225236 : && fsym->as
7006 : 39718 : && fsym->as->type != AS_ASSUMED_SHAPE
7007 : 24586 : && fsym->as->type != AS_ASSUMED_RANK;
7008 : 267428 : if (comp)
7009 : 2715 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7010 : : else
7011 : 264713 : nodesc_arg
7012 : : = nodesc_arg
7013 : 264713 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7014 : :
7015 : : /* Class array expressions are sometimes coming completely unadorned
7016 : : with either arrayspec or _data component. Correct that here.
7017 : : OOP-TODO: Move this to the frontend. */
7018 : 267428 : if (e && e->expr_type == EXPR_VARIABLE
7019 : 111019 : && !e->ref
7020 : 50949 : && e->ts.type == BT_CLASS
7021 : 2593 : && (CLASS_DATA (e)->attr.codimension
7022 : 2593 : || CLASS_DATA (e)->attr.dimension))
7023 : : {
7024 : 0 : gfc_typespec temp_ts = e->ts;
7025 : 0 : gfc_add_class_array_ref (e);
7026 : 0 : e->ts = temp_ts;
7027 : : }
7028 : :
7029 : 267428 : if (e == NULL
7030 : 253566 : || (e->expr_type == EXPR_NULL
7031 : 745 : && fsym
7032 : 745 : && fsym->attr.value
7033 : 72 : && fsym->attr.optional
7034 : 72 : && !fsym->attr.dimension
7035 : 72 : && fsym->ts.type != BT_CLASS))
7036 : : {
7037 : 13934 : if (se->ignore_optional)
7038 : : {
7039 : : /* Some intrinsics have already been resolved to the correct
7040 : : parameters. */
7041 : 422 : continue;
7042 : : }
7043 : 13736 : else if (arg->label)
7044 : : {
7045 : 224 : has_alternate_specifier = 1;
7046 : 224 : continue;
7047 : : }
7048 : : else
7049 : : {
7050 : 13512 : gfc_init_se (&parmse, NULL);
7051 : :
7052 : : /* For scalar arguments with VALUE attribute which are passed by
7053 : : value, pass "0" and a hidden argument gives the optional
7054 : : status. */
7055 : 13512 : if (fsym && fsym->attr.optional && fsym->attr.value
7056 : 427 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7057 : : {
7058 : 427 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7059 : : }
7060 : : else
7061 : : {
7062 : : /* Pass a NULL pointer for an absent arg. */
7063 : 13085 : parmse.expr = null_pointer_node;
7064 : :
7065 : : /* Is it an absent character dummy? */
7066 : 13085 : bool absent_char = false;
7067 : 13085 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7068 : :
7069 : : /* Fall back to inferred type only if no formal. */
7070 : 13085 : if (fsym)
7071 : 12027 : absent_char = (fsym->ts.type == BT_CHARACTER);
7072 : 1058 : else if (dummy_arg)
7073 : 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7074 : : == BT_CHARACTER);
7075 : 13085 : if (absent_char)
7076 : 1115 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7077 : : 0);
7078 : : }
7079 : : }
7080 : : }
7081 : 253494 : else if (e->expr_type == EXPR_NULL
7082 : 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7083 : 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7084 : 293 : && fsym->ts.type == BT_DERIVED)
7085 : : {
7086 : 210 : gfc_init_se (&parmse, NULL);
7087 : 210 : gfc_conv_expr_reference (&parmse, e);
7088 : 210 : conv_null_actual (&parmse, e, fsym);
7089 : : }
7090 : 253284 : else if (arg->expr->expr_type == EXPR_NULL
7091 : 463 : && fsym && !fsym->attr.pointer
7092 : 163 : && (fsym->ts.type != BT_CLASS
7093 : 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7094 : : {
7095 : : /* Pass a NULL pointer to denote an absent arg. */
7096 : 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7097 : : && (fsym->ts.type != BT_CLASS
7098 : : || !CLASS_DATA (fsym)->attr.allocatable));
7099 : 163 : gfc_init_se (&parmse, NULL);
7100 : 163 : parmse.expr = null_pointer_node;
7101 : 163 : if (fsym->ts.type == BT_CHARACTER)
7102 : 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7103 : : }
7104 : 253121 : else if (fsym && fsym->ts.type == BT_CLASS
7105 : 10605 : && e->ts.type == BT_DERIVED)
7106 : : {
7107 : : /* The derived type needs to be converted to a temporary
7108 : : CLASS object. */
7109 : 4259 : gfc_init_se (&parmse, se);
7110 : 4259 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7111 : 4259 : fsym->attr.optional
7112 : 1008 : && e->expr_type == EXPR_VARIABLE
7113 : 5267 : && e->symtree->n.sym->attr.optional,
7114 : 4259 : CLASS_DATA (fsym)->attr.class_pointer
7115 : 4259 : || CLASS_DATA (fsym)->attr.allocatable,
7116 : : sym->name, &derived_array);
7117 : : }
7118 : 217008 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7119 : 906 : && e->ts.type != BT_PROCEDURE
7120 : 882 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7121 : 12 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7122 : : {
7123 : : /* The intrinsic type needs to be converted to a temporary
7124 : : CLASS object for the unlimited polymorphic formal. */
7125 : 882 : gfc_find_vtab (&e->ts);
7126 : 882 : gfc_init_se (&parmse, se);
7127 : 882 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7128 : :
7129 : : }
7130 : 247980 : else if (se->ss && se->ss->info->useflags)
7131 : : {
7132 : 5536 : gfc_ss *ss;
7133 : :
7134 : 5536 : ss = se->ss;
7135 : :
7136 : : /* An elemental function inside a scalarized loop. */
7137 : 5536 : gfc_init_se (&parmse, se);
7138 : 5536 : parm_kind = ELEMENTAL;
7139 : :
7140 : : /* When no fsym is present, ulim_copy is set and this is a third or
7141 : : fourth argument, use call-by-value instead of by reference to
7142 : : hand the length properties to the copy routine (i.e., most of the
7143 : : time this will be a call to a __copy_character_* routine where the
7144 : : third and fourth arguments are the lengths of a deferred length
7145 : : char array). */
7146 : 5536 : if ((fsym && fsym->attr.value)
7147 : 5302 : || (ulim_copy && (argc == 2 || argc == 3)))
7148 : 234 : gfc_conv_expr (&parmse, e);
7149 : 5302 : else if (e->expr_type == EXPR_ARRAY)
7150 : : {
7151 : 294 : gfc_conv_expr (&parmse, e);
7152 : 294 : if (e->ts.type != BT_CHARACTER)
7153 : 251 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7154 : : }
7155 : : else
7156 : 5008 : gfc_conv_expr_reference (&parmse, e);
7157 : :
7158 : 5536 : if (e->ts.type == BT_CHARACTER && !e->rank
7159 : 174 : && e->expr_type == EXPR_FUNCTION)
7160 : 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7161 : : parmse.expr);
7162 : :
7163 : 5486 : if (fsym && fsym->ts.type == BT_DERIVED
7164 : 6882 : && gfc_is_class_container_ref (e))
7165 : : {
7166 : 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7167 : :
7168 : 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7169 : 24 : && e->symtree->n.sym->attr.optional)
7170 : : {
7171 : 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7172 : 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7173 : 0 : TREE_TYPE (parmse.expr),
7174 : : cond, parmse.expr,
7175 : 0 : fold_convert (TREE_TYPE (parmse.expr),
7176 : : null_pointer_node));
7177 : : }
7178 : : }
7179 : :
7180 : : /* Scalar dummy arguments of intrinsic type or derived type with
7181 : : VALUE attribute. */
7182 : 5536 : if (fsym
7183 : 5486 : && fsym->attr.value
7184 : 234 : && fsym->ts.type != BT_CLASS)
7185 : 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7186 : :
7187 : : /* If we are passing an absent array as optional dummy to an
7188 : : elemental procedure, make sure that we pass NULL when the data
7189 : : pointer is NULL. We need this extra conditional because of
7190 : : scalarization which passes arrays elements to the procedure,
7191 : : ignoring the fact that the array can be absent/unallocated/... */
7192 : 5302 : else if (ss->info->can_be_null_ref
7193 : 415 : && ss->info->type != GFC_SS_REFERENCE)
7194 : : {
7195 : 193 : tree descriptor_data;
7196 : :
7197 : 193 : descriptor_data = ss->info->data.array.data;
7198 : 193 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7199 : : descriptor_data,
7200 : 193 : fold_convert (TREE_TYPE (descriptor_data),
7201 : : null_pointer_node));
7202 : 193 : parmse.expr
7203 : 386 : = fold_build3_loc (input_location, COND_EXPR,
7204 : 193 : TREE_TYPE (parmse.expr),
7205 : : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7206 : 193 : fold_convert (TREE_TYPE (parmse.expr),
7207 : : null_pointer_node),
7208 : : parmse.expr);
7209 : : }
7210 : :
7211 : : /* The scalarizer does not repackage the reference to a class
7212 : : array - instead it returns a pointer to the data element. */
7213 : 5536 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7214 : 162 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7215 : 162 : fsym->attr.intent != INTENT_IN
7216 : 162 : && (CLASS_DATA (fsym)->attr.class_pointer
7217 : 12 : || CLASS_DATA (fsym)->attr.allocatable),
7218 : 162 : fsym->attr.optional
7219 : 0 : && e->expr_type == EXPR_VARIABLE
7220 : 162 : && e->symtree->n.sym->attr.optional,
7221 : 162 : CLASS_DATA (fsym)->attr.class_pointer
7222 : 162 : || CLASS_DATA (fsym)->attr.allocatable);
7223 : : }
7224 : : else
7225 : : {
7226 : 242444 : bool scalar;
7227 : 242444 : gfc_ss *argss;
7228 : :
7229 : 242444 : gfc_init_se (&parmse, NULL);
7230 : :
7231 : : /* Check whether the expression is a scalar or not; we cannot use
7232 : : e->rank as it can be nonzero for functions arguments. */
7233 : 242444 : argss = gfc_walk_expr (e);
7234 : 242444 : scalar = argss == gfc_ss_terminator;
7235 : 242444 : if (!scalar)
7236 : 59719 : gfc_free_ss_chain (argss);
7237 : :
7238 : : /* Special handling for passing scalar polymorphic coarrays;
7239 : : otherwise one passes "class->_data.data" instead of "&class". */
7240 : 242444 : if (e->rank == 0 && e->ts.type == BT_CLASS
7241 : 3530 : && fsym && fsym->ts.type == BT_CLASS
7242 : 3108 : && CLASS_DATA (fsym)->attr.codimension
7243 : 51 : && !CLASS_DATA (fsym)->attr.dimension)
7244 : : {
7245 : 51 : gfc_add_class_array_ref (e);
7246 : 51 : parmse.want_coarray = 1;
7247 : 51 : scalar = false;
7248 : : }
7249 : :
7250 : : /* A scalar or transformational function. */
7251 : 242444 : if (scalar)
7252 : : {
7253 : 182674 : if (e->expr_type == EXPR_VARIABLE
7254 : 54386 : && e->symtree->n.sym->attr.cray_pointee
7255 : 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7256 : : {
7257 : : /* The Cray pointer needs to be converted to a pointer to
7258 : : a type given by the expression. */
7259 : 6 : gfc_conv_expr (&parmse, e);
7260 : 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7261 : 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7262 : 6 : parmse.expr = convert (type, tmp);
7263 : : }
7264 : :
7265 : 182668 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7266 : : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7267 : 686 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7268 : :
7269 : 181982 : else if (fsym && fsym->attr.value)
7270 : : {
7271 : 21710 : if (fsym->ts.type == BT_CHARACTER
7272 : 543 : && fsym->ts.is_c_interop
7273 : 181 : && fsym->ns->proc_name != NULL
7274 : 181 : && fsym->ns->proc_name->attr.is_bind_c)
7275 : : {
7276 : 172 : parmse.expr = NULL;
7277 : 172 : conv_scalar_char_value (fsym, &parmse, &e);
7278 : 172 : if (parmse.expr == NULL)
7279 : 166 : gfc_conv_expr (&parmse, e);
7280 : : }
7281 : : else
7282 : : {
7283 : 21538 : gfc_conv_expr (&parmse, e);
7284 : 21538 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7285 : : }
7286 : : }
7287 : :
7288 : 160272 : else if (arg->name && arg->name[0] == '%')
7289 : : /* Argument list functions %VAL, %LOC and %REF are signalled
7290 : : through arg->name. */
7291 : 5822 : conv_arglist_function (&parmse, arg->expr, arg->name);
7292 : 154450 : else if ((e->expr_type == EXPR_FUNCTION)
7293 : 8181 : && ((e->value.function.esym
7294 : 2153 : && e->value.function.esym->result->attr.pointer)
7295 : 8086 : || (!e->value.function.esym
7296 : 6028 : && e->symtree->n.sym->attr.pointer))
7297 : 95 : && fsym && fsym->attr.target)
7298 : : /* Make sure the function only gets called once. */
7299 : 8 : gfc_conv_expr_reference (&parmse, e);
7300 : 154442 : else if (e->expr_type == EXPR_FUNCTION
7301 : 8173 : && e->symtree->n.sym->result
7302 : 7138 : && e->symtree->n.sym->result != e->symtree->n.sym
7303 : 136 : && e->symtree->n.sym->result->attr.proc_pointer)
7304 : : {
7305 : : /* Functions returning procedure pointers. */
7306 : 18 : gfc_conv_expr (&parmse, e);
7307 : 18 : if (fsym && fsym->attr.proc_pointer)
7308 : 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7309 : : }
7310 : :
7311 : : else
7312 : : {
7313 : 154424 : bool defer_to_dealloc_blk = false;
7314 : 154424 : if (e->ts.type == BT_CLASS && fsym
7315 : 3467 : && fsym->ts.type == BT_CLASS
7316 : 3045 : && (!CLASS_DATA (fsym)->as
7317 : 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7318 : 2689 : && CLASS_DATA (e)->attr.codimension)
7319 : : {
7320 : 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7321 : 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7322 : 48 : gfc_add_class_array_ref (e);
7323 : 48 : parmse.want_coarray = 1;
7324 : 48 : gfc_conv_expr_reference (&parmse, e);
7325 : 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7326 : 48 : fsym->attr.optional
7327 : 48 : && e->expr_type == EXPR_VARIABLE);
7328 : : }
7329 : 154376 : else if (e->ts.type == BT_CLASS && fsym
7330 : 3419 : && fsym->ts.type == BT_CLASS
7331 : 2997 : && !CLASS_DATA (fsym)->as
7332 : 2641 : && !CLASS_DATA (e)->as
7333 : 2531 : && strcmp (fsym->ts.u.derived->name,
7334 : : e->ts.u.derived->name))
7335 : : {
7336 : 1614 : type = gfc_typenode_for_spec (&fsym->ts);
7337 : 1614 : var = gfc_create_var (type, fsym->name);
7338 : 1614 : gfc_conv_expr (&parmse, e);
7339 : 1614 : if (fsym->attr.optional
7340 : 153 : && e->expr_type == EXPR_VARIABLE
7341 : 153 : && e->symtree->n.sym->attr.optional)
7342 : : {
7343 : 66 : stmtblock_t block;
7344 : 66 : tree cond;
7345 : 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7346 : 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7347 : : logical_type_node, tmp,
7348 : 66 : fold_convert (TREE_TYPE (tmp),
7349 : : null_pointer_node));
7350 : 66 : gfc_start_block (&block);
7351 : 66 : gfc_add_modify (&block, var,
7352 : : fold_build1_loc (input_location,
7353 : : VIEW_CONVERT_EXPR,
7354 : : type, parmse.expr));
7355 : 66 : gfc_add_expr_to_block (&parmse.pre,
7356 : : fold_build3_loc (input_location,
7357 : : COND_EXPR, void_type_node,
7358 : : cond, gfc_finish_block (&block),
7359 : : build_empty_stmt (input_location)));
7360 : 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7361 : 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7362 : 66 : TREE_TYPE (parmse.expr),
7363 : : cond, parmse.expr,
7364 : 66 : fold_convert (TREE_TYPE (parmse.expr),
7365 : : null_pointer_node));
7366 : 66 : }
7367 : : else
7368 : : {
7369 : : /* Since the internal representation of unlimited
7370 : : polymorphic expressions includes an extra field
7371 : : that other class objects do not, a cast to the
7372 : : formal type does not work. */
7373 : 1548 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7374 : : {
7375 : 91 : tree efield;
7376 : :
7377 : : /* Evaluate arguments just once, when they have
7378 : : side effects. */
7379 : 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7380 : : {
7381 : 25 : tree cldata, zero;
7382 : :
7383 : 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7384 : : &parmse.pre);
7385 : :
7386 : : /* Prevent memory leak, when old component
7387 : : was allocated already. */
7388 : 25 : cldata = gfc_class_data_get (parmse.expr);
7389 : 25 : zero = build_int_cst (TREE_TYPE (cldata),
7390 : : 0);
7391 : 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7392 : : logical_type_node,
7393 : : cldata, zero);
7394 : 25 : tmp = build3_v (COND_EXPR, tmp,
7395 : : gfc_call_free (cldata),
7396 : : build_empty_stmt (
7397 : : input_location));
7398 : 25 : gfc_add_expr_to_block (&parmse.finalblock,
7399 : : tmp);
7400 : 25 : gfc_add_modify (&parmse.finalblock,
7401 : : cldata, zero);
7402 : : }
7403 : :
7404 : : /* Set the _data field. */
7405 : 91 : tmp = gfc_class_data_get (var);
7406 : 91 : efield = fold_convert (TREE_TYPE (tmp),
7407 : : gfc_class_data_get (parmse.expr));
7408 : 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7409 : :
7410 : : /* Set the _vptr field. */
7411 : 91 : tmp = gfc_class_vptr_get (var);
7412 : 91 : efield = fold_convert (TREE_TYPE (tmp),
7413 : : gfc_class_vptr_get (parmse.expr));
7414 : 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7415 : :
7416 : : /* Set the _len field. */
7417 : 91 : tmp = gfc_class_len_get (var);
7418 : 91 : gfc_add_modify (&parmse.pre, tmp,
7419 : 91 : build_int_cst (TREE_TYPE (tmp), 0));
7420 : 91 : }
7421 : : else
7422 : : {
7423 : 1457 : tmp = fold_build1_loc (input_location,
7424 : : VIEW_CONVERT_EXPR,
7425 : : type, parmse.expr);
7426 : 1457 : gfc_add_modify (&parmse.pre, var, tmp);
7427 : 1548 : ;
7428 : : }
7429 : 1548 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7430 : : }
7431 : : }
7432 : : else
7433 : : {
7434 : 152762 : gfc_conv_expr_reference (&parmse, e);
7435 : :
7436 : 152762 : gfc_symbol *dsym = fsym;
7437 : 152762 : gfc_dummy_arg *dummy;
7438 : :
7439 : : /* Use associated dummy as fallback for formal
7440 : : argument if there is no explicit interface. */
7441 : 152762 : if (dsym == NULL
7442 : 27394 : && (dummy = arg->associated_dummy)
7443 : 24870 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7444 : 176238 : && dummy->u.non_intrinsic->sym)
7445 : : dsym = dummy->u.non_intrinsic->sym;
7446 : :
7447 : 152762 : if (dsym
7448 : 148844 : && dsym->attr.intent == INTENT_OUT
7449 : 3215 : && !dsym->attr.allocatable
7450 : 3074 : && !dsym->attr.pointer
7451 : 3056 : && e->expr_type == EXPR_VARIABLE
7452 : 3055 : && e->ref == NULL
7453 : 2948 : && e->symtree
7454 : 2948 : && e->symtree->n.sym
7455 : 2948 : && !e->symtree->n.sym->attr.dimension
7456 : 2948 : && e->ts.type != BT_CHARACTER
7457 : 2846 : && e->ts.type != BT_CLASS
7458 : 2616 : && (e->ts.type != BT_DERIVED
7459 : 492 : || (dsym->ts.type == BT_DERIVED
7460 : 492 : && e->ts.u.derived == dsym->ts.u.derived
7461 : : /* Types with allocatable components are
7462 : : excluded from clobbering because we need
7463 : : the unclobbered pointers to free the
7464 : : allocatable components in the callee.
7465 : : Same goes for finalizable types or types
7466 : : with finalizable components, we need to
7467 : : pass the unclobbered values to the
7468 : : finalization routines.
7469 : : For parameterized types, it's less clear
7470 : : but they may not have a constant size
7471 : : so better exclude them in any case. */
7472 : 477 : && !e->ts.u.derived->attr.alloc_comp
7473 : 351 : && !e->ts.u.derived->attr.pdt_type
7474 : 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7475 : 155195 : && !sym->attr.elemental)
7476 : : {
7477 : 1100 : tree var;
7478 : 1100 : var = build_fold_indirect_ref_loc (input_location,
7479 : : parmse.expr);
7480 : 1100 : tree clobber = build_clobber (TREE_TYPE (var));
7481 : 1100 : gfc_add_modify (&clobbers, var, clobber);
7482 : : }
7483 : : }
7484 : : /* Catch base objects that are not variables. */
7485 : 154424 : if (e->ts.type == BT_CLASS
7486 : 3467 : && e->expr_type != EXPR_VARIABLE
7487 : 306 : && expr && e == expr->base_expr)
7488 : 80 : base_object = build_fold_indirect_ref_loc (input_location,
7489 : : parmse.expr);
7490 : :
7491 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7492 : : allocated on entry, it must be deallocated. */
7493 : 127030 : if (fsym && fsym->attr.intent == INTENT_OUT
7494 : 3144 : && (fsym->attr.allocatable
7495 : 3003 : || (fsym->ts.type == BT_CLASS
7496 : 259 : && CLASS_DATA (fsym)->attr.allocatable))
7497 : 154714 : && !is_CFI_desc (fsym, NULL))
7498 : : {
7499 : 290 : stmtblock_t block;
7500 : 290 : tree ptr;
7501 : :
7502 : 290 : defer_to_dealloc_blk = true;
7503 : :
7504 : 290 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7505 : : &parmse.pre);
7506 : :
7507 : 290 : if (parmse.class_container != NULL_TREE)
7508 : 156 : parmse.class_container
7509 : 156 : = gfc_evaluate_data_ref_now (parmse.class_container,
7510 : : &parmse.pre);
7511 : :
7512 : 290 : gfc_init_block (&block);
7513 : 290 : ptr = parmse.expr;
7514 : 290 : if (e->ts.type == BT_CLASS)
7515 : 156 : ptr = gfc_class_data_get (ptr);
7516 : :
7517 : 290 : tree cls = parmse.class_container;
7518 : 290 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7519 : : NULL_TREE, true,
7520 : : e, e->ts, cls);
7521 : 290 : gfc_add_expr_to_block (&block, tmp);
7522 : 290 : gfc_add_modify (&block, ptr,
7523 : 290 : fold_convert (TREE_TYPE (ptr),
7524 : : null_pointer_node));
7525 : :
7526 : 290 : if (fsym->ts.type == BT_CLASS)
7527 : 149 : gfc_reset_vptr (&block, nullptr,
7528 : : build_fold_indirect_ref (parmse.expr),
7529 : 149 : fsym->ts.u.derived);
7530 : :
7531 : 290 : if (fsym->attr.optional
7532 : 42 : && e->expr_type == EXPR_VARIABLE
7533 : 42 : && e->symtree->n.sym->attr.optional)
7534 : : {
7535 : 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7536 : : void_type_node,
7537 : 18 : gfc_conv_expr_present (e->symtree->n.sym),
7538 : : gfc_finish_block (&block),
7539 : : build_empty_stmt (input_location));
7540 : : }
7541 : : else
7542 : 272 : tmp = gfc_finish_block (&block);
7543 : :
7544 : 290 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7545 : : }
7546 : :
7547 : : /* A class array element needs converting back to be a
7548 : : class object, if the formal argument is a class object. */
7549 : 154424 : if (fsym && fsym->ts.type == BT_CLASS
7550 : 3069 : && e->ts.type == BT_CLASS
7551 : 3045 : && ((CLASS_DATA (fsym)->as
7552 : 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7553 : 2689 : || CLASS_DATA (e)->attr.dimension))
7554 : : {
7555 : 466 : gfc_se class_se = parmse;
7556 : 466 : gfc_init_block (&class_se.pre);
7557 : 466 : gfc_init_block (&class_se.post);
7558 : :
7559 : 466 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7560 : 466 : fsym->attr.intent != INTENT_IN
7561 : 466 : && (CLASS_DATA (fsym)->attr.class_pointer
7562 : 267 : || CLASS_DATA (fsym)->attr.allocatable),
7563 : 466 : fsym->attr.optional
7564 : 198 : && e->expr_type == EXPR_VARIABLE
7565 : 664 : && e->symtree->n.sym->attr.optional,
7566 : 466 : CLASS_DATA (fsym)->attr.class_pointer
7567 : 466 : || CLASS_DATA (fsym)->attr.allocatable);
7568 : :
7569 : 466 : parmse.expr = class_se.expr;
7570 : 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7571 : 466 : ? &dealloc_blk
7572 : : : &parmse.pre;
7573 : 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7574 : 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7575 : : }
7576 : :
7577 : 127030 : if (fsym && (fsym->ts.type == BT_DERIVED
7578 : 115381 : || fsym->ts.type == BT_ASSUMED)
7579 : 12516 : && e->ts.type == BT_CLASS
7580 : 410 : && !CLASS_DATA (e)->attr.dimension
7581 : 374 : && !CLASS_DATA (e)->attr.codimension)
7582 : : {
7583 : 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7584 : : /* The result is a class temporary, whose _data component
7585 : : must be freed to avoid a memory leak. */
7586 : 374 : if (e->expr_type == EXPR_FUNCTION
7587 : 23 : && CLASS_DATA (e)->attr.allocatable)
7588 : : {
7589 : 19 : tree zero;
7590 : :
7591 : : /* Finalize the expression. */
7592 : 19 : gfc_finalize_tree_expr (&parmse, NULL,
7593 : : gfc_expr_attr (e), e->rank);
7594 : 19 : gfc_add_block_to_block (&parmse.post,
7595 : : &parmse.finalblock);
7596 : :
7597 : : /* Then free the class _data. */
7598 : 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7599 : 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7600 : : logical_type_node,
7601 : : parmse.expr, zero);
7602 : 19 : tmp = build3_v (COND_EXPR, tmp,
7603 : : gfc_call_free (parmse.expr),
7604 : : build_empty_stmt (input_location));
7605 : 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7606 : 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7607 : : }
7608 : : }
7609 : :
7610 : : /* Wrap scalar variable in a descriptor. We need to convert
7611 : : the address of a pointer back to the pointer itself before,
7612 : : we can assign it to the data field. */
7613 : :
7614 : 127030 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7615 : 1301 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7616 : : {
7617 : 1229 : tmp = parmse.expr;
7618 : 1229 : if (TREE_CODE (tmp) == ADDR_EXPR)
7619 : 723 : tmp = TREE_OPERAND (tmp, 0);
7620 : 1229 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7621 : : fsym->attr);
7622 : 1229 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
7623 : : parmse.expr);
7624 : : }
7625 : 125801 : else if (fsym && e->expr_type != EXPR_NULL
7626 : 125503 : && ((fsym->attr.pointer
7627 : 1692 : && fsym->attr.flavor != FL_PROCEDURE)
7628 : 123817 : || (fsym->attr.proc_pointer
7629 : 157 : && !(e->expr_type == EXPR_VARIABLE
7630 : 157 : && e->symtree->n.sym->attr.dummy))
7631 : 123672 : || (fsym->attr.proc_pointer
7632 : 12 : && e->expr_type == EXPR_VARIABLE
7633 : 12 : && gfc_is_proc_ptr_comp (e))
7634 : 123666 : || (fsym->attr.allocatable
7635 : 965 : && fsym->attr.flavor != FL_PROCEDURE)))
7636 : : {
7637 : : /* Scalar pointer dummy args require an extra level of
7638 : : indirection. The null pointer already contains
7639 : : this level of indirection. */
7640 : 2796 : parm_kind = SCALAR_POINTER;
7641 : 2796 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7642 : : }
7643 : : }
7644 : : }
7645 : 59770 : else if (e->ts.type == BT_CLASS
7646 : 2567 : && fsym && fsym->ts.type == BT_CLASS
7647 : 2221 : && (CLASS_DATA (fsym)->attr.dimension
7648 : 51 : || CLASS_DATA (fsym)->attr.codimension))
7649 : : {
7650 : : /* Pass a class array. */
7651 : 2221 : gfc_conv_expr_descriptor (&parmse, e);
7652 : 2221 : bool defer_to_dealloc_blk = false;
7653 : :
7654 : 2221 : if (fsym->attr.optional
7655 : 798 : && e->expr_type == EXPR_VARIABLE
7656 : 798 : && e->symtree->n.sym->attr.optional)
7657 : : {
7658 : 438 : stmtblock_t block;
7659 : :
7660 : 438 : gfc_init_block (&block);
7661 : 438 : gfc_add_block_to_block (&block, &parmse.pre);
7662 : :
7663 : 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
7664 : : void_type_node,
7665 : 438 : gfc_conv_expr_present (e->symtree->n.sym),
7666 : : gfc_finish_block (&block),
7667 : : build_empty_stmt (input_location));
7668 : :
7669 : 438 : gfc_add_expr_to_block (&parmse.pre, t);
7670 : : }
7671 : :
7672 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7673 : : allocated on entry, it must be deallocated. */
7674 : 2221 : if (fsym->attr.intent == INTENT_OUT
7675 : 141 : && CLASS_DATA (fsym)->attr.allocatable)
7676 : : {
7677 : 110 : stmtblock_t block;
7678 : 110 : tree ptr;
7679 : :
7680 : : /* In case the data reference to deallocate is dependent on
7681 : : its own content, save the resulting pointer to a variable
7682 : : and only use that variable from now on, before the
7683 : : expression becomes invalid. */
7684 : 110 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7685 : : &parmse.pre);
7686 : :
7687 : 110 : if (parmse.class_container != NULL_TREE)
7688 : 110 : parmse.class_container
7689 : 110 : = gfc_evaluate_data_ref_now (parmse.class_container,
7690 : : &parmse.pre);
7691 : :
7692 : 110 : gfc_init_block (&block);
7693 : 110 : ptr = parmse.expr;
7694 : 110 : ptr = gfc_class_data_get (ptr);
7695 : :
7696 : 110 : tree cls = parmse.class_container;
7697 : 110 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
7698 : : NULL_TREE, NULL_TREE,
7699 : : NULL_TREE, true, e,
7700 : : GFC_CAF_COARRAY_NOCOARRAY,
7701 : : cls);
7702 : 110 : gfc_add_expr_to_block (&block, tmp);
7703 : 110 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7704 : : void_type_node, ptr,
7705 : : null_pointer_node);
7706 : 110 : gfc_add_expr_to_block (&block, tmp);
7707 : 110 : gfc_reset_vptr (&block, e, parmse.class_container);
7708 : :
7709 : 110 : if (fsym->attr.optional
7710 : 30 : && e->expr_type == EXPR_VARIABLE
7711 : 30 : && (!e->ref
7712 : 30 : || (e->ref->type == REF_ARRAY
7713 : 0 : && e->ref->u.ar.type != AR_FULL))
7714 : 0 : && e->symtree->n.sym->attr.optional)
7715 : : {
7716 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7717 : : void_type_node,
7718 : 0 : gfc_conv_expr_present (e->symtree->n.sym),
7719 : : gfc_finish_block (&block),
7720 : : build_empty_stmt (input_location));
7721 : : }
7722 : : else
7723 : 110 : tmp = gfc_finish_block (&block);
7724 : :
7725 : 110 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7726 : 110 : defer_to_dealloc_blk = true;
7727 : : }
7728 : :
7729 : 2221 : gfc_se class_se = parmse;
7730 : 2221 : gfc_init_block (&class_se.pre);
7731 : 2221 : gfc_init_block (&class_se.post);
7732 : :
7733 : : /* The conversion does not repackage the reference to a class
7734 : : array - _data descriptor. */
7735 : 2221 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7736 : 2221 : fsym->attr.intent != INTENT_IN
7737 : 2221 : && (CLASS_DATA (fsym)->attr.class_pointer
7738 : 1187 : || CLASS_DATA (fsym)->attr.allocatable),
7739 : 2221 : fsym->attr.optional
7740 : 798 : && e->expr_type == EXPR_VARIABLE
7741 : 3019 : && e->symtree->n.sym->attr.optional,
7742 : 2221 : CLASS_DATA (fsym)->attr.class_pointer
7743 : 2221 : || CLASS_DATA (fsym)->attr.allocatable);
7744 : :
7745 : 2221 : parmse.expr = class_se.expr;
7746 : 2111 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7747 : 2221 : ? &dealloc_blk
7748 : : : &parmse.pre;
7749 : 2221 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7750 : 2221 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7751 : 2221 : }
7752 : : else
7753 : : {
7754 : : /* If the argument is a function call that may not create
7755 : : a temporary for the result, we have to check that we
7756 : : can do it, i.e. that there is no alias between this
7757 : : argument and another one. */
7758 : 57549 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7759 : : {
7760 : 358 : gfc_expr *iarg;
7761 : 358 : sym_intent intent;
7762 : :
7763 : 358 : if (fsym != NULL)
7764 : 349 : intent = fsym->attr.intent;
7765 : : else
7766 : : intent = INTENT_UNKNOWN;
7767 : :
7768 : 358 : if (gfc_check_fncall_dependency (e, intent, sym, args,
7769 : : NOT_ELEMENTAL))
7770 : 21 : parmse.force_tmp = 1;
7771 : :
7772 : 358 : iarg = e->value.function.actual->expr;
7773 : :
7774 : : /* Temporary needed if aliasing due to host association. */
7775 : 358 : if (sym->attr.contained
7776 : 114 : && !sym->attr.pure
7777 : 114 : && !sym->attr.implicit_pure
7778 : 36 : && !sym->attr.use_assoc
7779 : 36 : && iarg->expr_type == EXPR_VARIABLE
7780 : 36 : && sym->ns == iarg->symtree->n.sym->ns)
7781 : 36 : parmse.force_tmp = 1;
7782 : :
7783 : : /* Ditto within module. */
7784 : 358 : if (sym->attr.use_assoc
7785 : 6 : && !sym->attr.pure
7786 : 6 : && !sym->attr.implicit_pure
7787 : 0 : && iarg->expr_type == EXPR_VARIABLE
7788 : 0 : && sym->module == iarg->symtree->n.sym->module)
7789 : 0 : parmse.force_tmp = 1;
7790 : : }
7791 : :
7792 : : /* Special case for assumed-rank arrays: when passing an
7793 : : argument to a nonallocatable/nonpointer dummy, the bounds have
7794 : : to be reset as otherwise a last-dim ubound of -1 is
7795 : : indistinguishable from an assumed-size array in the callee. */
7796 : 57549 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
7797 : 34096 : && fsym->as->type == AS_ASSUMED_RANK
7798 : 11839 : && e->rank != -1
7799 : 11550 : && e->expr_type == EXPR_VARIABLE
7800 : 11109 : && ((fsym->ts.type == BT_CLASS
7801 : 0 : && !CLASS_DATA (fsym)->attr.class_pointer
7802 : 0 : && !CLASS_DATA (fsym)->attr.allocatable)
7803 : 11109 : || (fsym->ts.type != BT_CLASS
7804 : 11109 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
7805 : : {
7806 : : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7807 : 10566 : gfc_ref *ref;
7808 : 10812 : for (ref = e->ref; ref->next; ref = ref->next)
7809 : : {
7810 : 318 : if (ref->next->type == REF_INQUIRY)
7811 : : break;
7812 : 270 : if (ref->type == REF_ARRAY
7813 : 24 : && ref->u.ar.type != AR_ELEMENT)
7814 : : break;
7815 : 10566 : };
7816 : 10566 : if (ref->u.ar.type == AR_FULL
7817 : 9840 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
7818 : 9720 : ref->u.ar.type = AR_SECTION;
7819 : : }
7820 : :
7821 : 57549 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7822 : : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7823 : 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7824 : :
7825 : 51699 : else if (e->expr_type == EXPR_VARIABLE
7826 : 39965 : && is_subref_array (e)
7827 : 52427 : && !(fsym && fsym->attr.pointer))
7828 : : /* The actual argument is a component reference to an
7829 : : array of derived types. In this case, the argument
7830 : : is converted to a temporary, which is passed and then
7831 : : written back after the procedure call. */
7832 : 523 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7833 : 481 : fsym ? fsym->attr.intent : INTENT_INOUT,
7834 : 523 : fsym && fsym->attr.pointer);
7835 : :
7836 : 51176 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
7837 : 345 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
7838 : 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
7839 : : /* An assumed size class actual argument being passed to
7840 : : a 'no descriptor' formal argument just requires the
7841 : : data pointer to be passed. For class dummy arguments
7842 : : this is stored in the symbol backend decl.. */
7843 : 6 : parmse.expr = e->symtree->n.sym->backend_decl;
7844 : :
7845 : 51170 : else if (gfc_is_class_array_ref (e, NULL)
7846 : 51170 : && fsym && fsym->ts.type == BT_DERIVED)
7847 : : /* The actual argument is a component reference to an
7848 : : array of derived types. In this case, the argument
7849 : : is converted to a temporary, which is passed and then
7850 : : written back after the procedure call.
7851 : : OOP-TODO: Insert code so that if the dynamic type is
7852 : : the same as the declared type, copy-in/copy-out does
7853 : : not occur. */
7854 : 108 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7855 : 108 : fsym->attr.intent,
7856 : 108 : fsym->attr.pointer);
7857 : :
7858 : 51062 : else if (gfc_is_class_array_function (e)
7859 : 51062 : && fsym && fsym->ts.type == BT_DERIVED)
7860 : : /* See previous comment. For function actual argument,
7861 : : the write out is not needed so the intent is set as
7862 : : intent in. */
7863 : : {
7864 : 13 : e->must_finalize = 1;
7865 : 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7866 : 13 : INTENT_IN, fsym->attr.pointer);
7867 : : }
7868 : 47489 : else if (fsym && fsym->attr.contiguous
7869 : 60 : && (fsym->attr.target
7870 : 1674 : ? gfc_is_not_contiguous (e)
7871 : 1614 : : !gfc_is_simply_contiguous (e, false, true))
7872 : 53038 : && gfc_expr_is_variable (e))
7873 : : {
7874 : 303 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7875 : 303 : fsym->attr.intent,
7876 : 303 : fsym->attr.pointer);
7877 : : }
7878 : : else
7879 : : /* This is where we introduce a temporary to store the
7880 : : result of a non-lvalue array expression. */
7881 : 50746 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
7882 : : sym->name, NULL);
7883 : :
7884 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7885 : : allocated on entry, it must be deallocated.
7886 : : CFI descriptors are handled elsewhere. */
7887 : 53947 : if (fsym && fsym->attr.allocatable
7888 : 1741 : && fsym->attr.intent == INTENT_OUT
7889 : 57324 : && !is_CFI_desc (fsym, NULL))
7890 : : {
7891 : 157 : if (fsym->ts.type == BT_DERIVED
7892 : 45 : && fsym->ts.u.derived->attr.alloc_comp)
7893 : : {
7894 : : // deallocate the components first
7895 : 9 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
7896 : : parmse.expr, e->rank);
7897 : : /* But check whether dummy argument is optional. */
7898 : 9 : if (tmp != NULL_TREE
7899 : 9 : && fsym->attr.optional
7900 : 6 : && e->expr_type == EXPR_VARIABLE
7901 : 6 : && e->symtree->n.sym->attr.optional)
7902 : : {
7903 : 6 : tree present;
7904 : 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
7905 : 6 : tmp = build3_v (COND_EXPR, present, tmp,
7906 : : build_empty_stmt (input_location));
7907 : : }
7908 : 9 : if (tmp != NULL_TREE)
7909 : 9 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7910 : : }
7911 : :
7912 : 157 : tmp = parmse.expr;
7913 : : /* With bind(C), the actual argument is replaced by a bind-C
7914 : : descriptor; in this case, the data component arrives here,
7915 : : which shall not be dereferenced, but still freed and
7916 : : nullified. */
7917 : 157 : if (TREE_TYPE(tmp) != pvoid_type_node)
7918 : 157 : tmp = build_fold_indirect_ref_loc (input_location,
7919 : : parmse.expr);
7920 : 157 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7921 : : NULL_TREE, NULL_TREE, true,
7922 : : e,
7923 : : GFC_CAF_COARRAY_NOCOARRAY);
7924 : 157 : if (fsym->attr.optional
7925 : 48 : && e->expr_type == EXPR_VARIABLE
7926 : 48 : && e->symtree->n.sym->attr.optional)
7927 : 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
7928 : : void_type_node,
7929 : 24 : gfc_conv_expr_present (e->symtree->n.sym),
7930 : : tmp, build_empty_stmt (input_location));
7931 : 157 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7932 : : }
7933 : : }
7934 : : }
7935 : : /* Special case for an assumed-rank dummy argument. */
7936 : 267006 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
7937 : 55665 : && (fsym->ts.type == BT_CLASS
7938 : 55665 : ? (CLASS_DATA (fsym)->as
7939 : 4201 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7940 : 51464 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
7941 : : {
7942 : 12689 : if (fsym->ts.type == BT_CLASS
7943 : 12689 : ? (CLASS_DATA (fsym)->attr.class_pointer
7944 : 1055 : || CLASS_DATA (fsym)->attr.allocatable)
7945 : 11634 : : (fsym->attr.pointer || fsym->attr.allocatable))
7946 : : {
7947 : : /* Unallocated allocatable arrays and unassociated pointer
7948 : : arrays need their dtype setting if they are argument
7949 : : associated with assumed rank dummies to set the rank. */
7950 : 891 : set_dtype_for_unallocated (&parmse, e);
7951 : : }
7952 : 11798 : else if (e->expr_type == EXPR_VARIABLE
7953 : 11319 : && e->symtree->n.sym->attr.dummy
7954 : 698 : && (e->ts.type == BT_CLASS
7955 : 891 : ? (e->ref && e->ref->next
7956 : 193 : && e->ref->next->type == REF_ARRAY
7957 : 193 : && e->ref->next->u.ar.type == AR_FULL
7958 : 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
7959 : 505 : : (e->ref && e->ref->type == REF_ARRAY
7960 : 505 : && e->ref->u.ar.type == AR_FULL
7961 : 733 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
7962 : : {
7963 : : /* Assumed-size actual to assumed-rank dummy requires
7964 : : dim[rank-1].ubound = -1. */
7965 : 180 : tree minus_one;
7966 : 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
7967 : 180 : if (fsym->ts.type == BT_CLASS)
7968 : 60 : tmp = gfc_class_data_get (tmp);
7969 : 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
7970 : 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
7971 : 180 : gfc_rank_cst[e->rank - 1],
7972 : : minus_one);
7973 : : }
7974 : : }
7975 : :
7976 : : /* The case with fsym->attr.optional is that of a user subroutine
7977 : : with an interface indicating an optional argument. When we call
7978 : : an intrinsic subroutine, however, fsym is NULL, but we might still
7979 : : have an optional argument, so we proceed to the substitution
7980 : : just in case. Arguments passed to bind(c) procedures via CFI
7981 : : descriptors are handled elsewhere. */
7982 : 253566 : if (e && (fsym == NULL || fsym->attr.optional)
7983 : 327332 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
7984 : : {
7985 : : /* If an optional argument is itself an optional dummy argument,
7986 : : check its presence and substitute a null if absent. This is
7987 : : only needed when passing an array to an elemental procedure
7988 : : as then array elements are accessed - or no NULL pointer is
7989 : : allowed and a "1" or "0" should be passed if not present.
7990 : : When passing a non-array-descriptor full array to a
7991 : : non-array-descriptor dummy, no check is needed. For
7992 : : array-descriptor actual to array-descriptor dummy, see
7993 : : PR 41911 for why a check has to be inserted.
7994 : : fsym == NULL is checked as intrinsics required the descriptor
7995 : : but do not always set fsym.
7996 : : Also, it is necessary to pass a NULL pointer to library routines
7997 : : which usually ignore optional arguments, so they can handle
7998 : : these themselves. */
7999 : 59232 : if (e->expr_type == EXPR_VARIABLE
8000 : 26378 : && e->symtree->n.sym->attr.optional
8001 : 2414 : && (((e->rank != 0 && elemental_proc)
8002 : 2239 : || e->representation.length || e->ts.type == BT_CHARACTER
8003 : 2013 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8004 : 1903 : || (e->rank != 0
8005 : 1069 : && (fsym == NULL
8006 : 1033 : || (fsym->as
8007 : 271 : && (fsym->as->type == AS_ASSUMED_SHAPE
8008 : 235 : || fsym->as->type == AS_ASSUMED_RANK
8009 : 117 : || fsym->as->type == AS_DEFERRED)))))
8010 : 1679 : || se->ignore_optional))
8011 : 763 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8012 : 763 : e->representation.length);
8013 : : }
8014 : :
8015 : : /* Make the class container for the first argument available with class
8016 : : valued transformational functions. */
8017 : 267006 : if (argc == 0 && e && e->ts.type == BT_CLASS
8018 : 4806 : && isym && isym->transformational
8019 : 84 : && se->ss && se->ss->info)
8020 : : {
8021 : 84 : arg1_cntnr = parmse.expr;
8022 : 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8023 : 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8024 : 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8025 : 84 : se->ss->info->class_container = arg1_cntnr;
8026 : : }
8027 : :
8028 : : /* Obtain the character length of an assumed character length procedure
8029 : : from the typespec of the actual argument. */
8030 : 267006 : if (e
8031 : 253566 : && parmse.string_length == NULL_TREE
8032 : 218288 : && e->ts.type == BT_PROCEDURE
8033 : 1875 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8034 : 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8035 : 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8036 : : {
8037 : 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8038 : 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8039 : : }
8040 : :
8041 : 267006 : if (fsym && e)
8042 : : {
8043 : : /* Obtain the character length for a NULL() actual with a character
8044 : : MOLD argument. Otherwise substitute a suitable dummy length.
8045 : : Here we handle non-optional dummies of non-bind(c) procedures. */
8046 : 221712 : if (e->expr_type == EXPR_NULL
8047 : 745 : && fsym->ts.type == BT_CHARACTER
8048 : 296 : && !fsym->attr.optional
8049 : 221930 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8050 : 216 : conv_null_actual (&parmse, e, fsym);
8051 : : }
8052 : :
8053 : : /* If any actual argument of the procedure is allocatable and passed
8054 : : to an allocatable dummy with INTENT(OUT), we conservatively
8055 : : evaluate actual argument expressions before deallocations are
8056 : : performed and the procedure is executed. May create temporaries.
8057 : : This ensures we conform to F2023:15.5.3, 15.5.4. */
8058 : 253566 : if (e && fsym && force_eval_args
8059 : 1102 : && fsym->attr.intent != INTENT_OUT
8060 : 267415 : && !gfc_is_constant_expr (e))
8061 : 268 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8062 : :
8063 : 267006 : if (fsym && need_interface_mapping && e)
8064 : 40609 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8065 : :
8066 : 267006 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8067 : 267006 : gfc_add_block_to_block (&post, &parmse.post);
8068 : 267006 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8069 : :
8070 : : /* Allocated allocatable components of derived types must be
8071 : : deallocated for non-variable scalars, array arguments to elemental
8072 : : procedures, and array arguments with descriptor to non-elemental
8073 : : procedures. As bounds information for descriptorless arrays is no
8074 : : longer available here, they are dealt with in trans-array.cc
8075 : : (gfc_conv_array_parameter). */
8076 : 253566 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8077 : 27089 : && e->ts.u.derived->attr.alloc_comp
8078 : 7363 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8079 : 274251 : && !expr_may_alias_variables (e, elemental_proc))
8080 : : {
8081 : 328 : int parm_rank;
8082 : : /* It is known the e returns a structure type with at least one
8083 : : allocatable component. When e is a function, ensure that the
8084 : : function is called once only by using a temporary variable. */
8085 : 328 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8086 : 139 : parmse.expr = gfc_evaluate_now_loc (input_location,
8087 : : parmse.expr, &se->pre);
8088 : :
8089 : 328 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8090 : 116 : tmp = parmse.expr;
8091 : : else
8092 : 212 : tmp = build_fold_indirect_ref_loc (input_location,
8093 : : parmse.expr);
8094 : :
8095 : 328 : parm_rank = e->rank;
8096 : 328 : switch (parm_kind)
8097 : : {
8098 : : case (ELEMENTAL):
8099 : : case (SCALAR):
8100 : 328 : parm_rank = 0;
8101 : : break;
8102 : :
8103 : 0 : case (SCALAR_POINTER):
8104 : 0 : tmp = build_fold_indirect_ref_loc (input_location,
8105 : : tmp);
8106 : 0 : break;
8107 : : }
8108 : :
8109 : 328 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8110 : : {
8111 : : /* The derived type is passed to gfc_deallocate_alloc_comp.
8112 : : Therefore, class actuals can be handled correctly but derived
8113 : : types passed to class formals need the _data component. */
8114 : 81 : tmp = gfc_class_data_get (tmp);
8115 : 81 : if (!CLASS_DATA (fsym)->attr.dimension)
8116 : : {
8117 : 55 : if (UNLIMITED_POLY (fsym))
8118 : : {
8119 : 12 : tree type = gfc_typenode_for_spec (&e->ts);
8120 : 12 : type = build_pointer_type (type);
8121 : 12 : tmp = fold_convert (type, tmp);
8122 : : }
8123 : 55 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8124 : : }
8125 : : }
8126 : :
8127 : 328 : if (e->expr_type == EXPR_OP
8128 : 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8129 : 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8130 : : {
8131 : 24 : tree local_tmp;
8132 : 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8133 : 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8134 : : parm_rank, 0);
8135 : 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8136 : : }
8137 : :
8138 : : /* Items of array expressions passed to a polymorphic formal arguments
8139 : : create their own clean up, so prevent double free. */
8140 : 328 : if (!finalized && !e->must_finalize
8141 : 327 : && !(e->expr_type == EXPR_ARRAY && fsym
8142 : 50 : && fsym->ts.type == BT_CLASS))
8143 : : {
8144 : 307 : bool scalar_res_outside_loop;
8145 : 909 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8146 : 150 : && parm_rank == 0
8147 : 445 : && parmse.loop;
8148 : :
8149 : : /* Scalars passed to an assumed rank argument are converted to
8150 : : a descriptor. Obtain the data field before deallocating any
8151 : : allocatable components. */
8152 : 278 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8153 : 560 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8154 : 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8155 : :
8156 : 307 : if (scalar_res_outside_loop)
8157 : : {
8158 : : /* Go through the ss chain to find the argument and use
8159 : : the stored value. */
8160 : 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8161 : 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8162 : 60 : if (tmp_ss->info
8163 : 48 : && tmp_ss->info->expr == e
8164 : 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8165 : : {
8166 : 18 : tmp = tmp_ss->info->data.scalar.value;
8167 : 18 : break;
8168 : : }
8169 : : }
8170 : :
8171 : 307 : STRIP_NOPS (tmp);
8172 : :
8173 : 307 : if (derived_array != NULL_TREE)
8174 : 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8175 : : derived_array,
8176 : : parm_rank);
8177 : 307 : else if ((e->ts.type == BT_CLASS
8178 : 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8179 : 307 : || e->ts.type == BT_DERIVED)
8180 : 307 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8181 : : parm_rank);
8182 : 0 : else if (e->ts.type == BT_CLASS)
8183 : 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8184 : : tmp, parm_rank);
8185 : :
8186 : 307 : if (scalar_res_outside_loop)
8187 : 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8188 : : else
8189 : 277 : gfc_prepend_expr_to_block (&post, tmp);
8190 : : }
8191 : : }
8192 : :
8193 : : /* Add argument checking of passing an unallocated/NULL actual to
8194 : : a nonallocatable/nonpointer dummy. */
8195 : :
8196 : 267006 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8197 : : {
8198 : 6536 : symbol_attribute attr;
8199 : 6536 : char *msg;
8200 : 6536 : tree cond;
8201 : 6536 : tree tmp;
8202 : 6536 : symbol_attribute fsym_attr;
8203 : :
8204 : 6536 : if (fsym)
8205 : : {
8206 : 6375 : if (fsym->ts.type == BT_CLASS)
8207 : : {
8208 : 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8209 : 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8210 : : }
8211 : : else
8212 : 6054 : fsym_attr = fsym->attr;
8213 : : }
8214 : :
8215 : 6536 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8216 : 4087 : attr = gfc_expr_attr (e);
8217 : : else
8218 : 6071 : goto end_pointer_check;
8219 : :
8220 : : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8221 : : allocatable to an optional dummy, cf. 12.5.2.12. */
8222 : 4087 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8223 : 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8224 : 1032 : goto end_pointer_check;
8225 : :
8226 : 3055 : if (attr.optional)
8227 : : {
8228 : : /* If the actual argument is an optional pointer/allocatable and
8229 : : the formal argument takes an nonpointer optional value,
8230 : : it is invalid to pass a non-present argument on, even
8231 : : though there is no technical reason for this in gfortran.
8232 : : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8233 : 60 : tree present, null_ptr, type;
8234 : :
8235 : 60 : if (attr.allocatable
8236 : 0 : && (fsym == NULL || !fsym_attr.allocatable))
8237 : 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8238 : : "allocated or not present",
8239 : 0 : e->symtree->n.sym->name);
8240 : 60 : else if (attr.pointer
8241 : 12 : && (fsym == NULL || !fsym_attr.pointer))
8242 : 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8243 : : "associated or not present",
8244 : 12 : e->symtree->n.sym->name);
8245 : 48 : else if (attr.proc_pointer && !e->value.function.actual
8246 : 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8247 : 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8248 : : "associated or not present",
8249 : 0 : e->symtree->n.sym->name);
8250 : : else
8251 : 48 : goto end_pointer_check;
8252 : :
8253 : 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8254 : 12 : type = TREE_TYPE (present);
8255 : 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8256 : : logical_type_node, present,
8257 : : fold_convert (type,
8258 : : null_pointer_node));
8259 : 12 : type = TREE_TYPE (parmse.expr);
8260 : 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8261 : : logical_type_node, parmse.expr,
8262 : : fold_convert (type,
8263 : : null_pointer_node));
8264 : 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8265 : : logical_type_node, present, null_ptr);
8266 : : }
8267 : : else
8268 : : {
8269 : 2995 : if (attr.allocatable
8270 : 256 : && (fsym == NULL || !fsym_attr.allocatable))
8271 : 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8272 : 190 : "allocated", e->symtree->n.sym->name);
8273 : 2805 : else if (attr.pointer
8274 : 265 : && (fsym == NULL || !fsym_attr.pointer))
8275 : 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8276 : 184 : "associated", e->symtree->n.sym->name);
8277 : 2621 : else if (attr.proc_pointer && !e->value.function.actual
8278 : 80 : && (fsym == NULL
8279 : 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8280 : 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8281 : 79 : "associated", e->symtree->n.sym->name);
8282 : : else
8283 : 2542 : goto end_pointer_check;
8284 : :
8285 : 453 : tmp = parmse.expr;
8286 : 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8287 : : {
8288 : 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8289 : 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8290 : 76 : tmp = gfc_class_data_get (tmp);
8291 : 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8292 : 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8293 : : }
8294 : :
8295 : : /* If the argument is passed by value, we need to strip the
8296 : : INDIRECT_REF. */
8297 : 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8298 : 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8299 : :
8300 : 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8301 : : logical_type_node, tmp,
8302 : 453 : fold_convert (TREE_TYPE (tmp),
8303 : : null_pointer_node));
8304 : : }
8305 : :
8306 : 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8307 : : msg);
8308 : 465 : free (msg);
8309 : : }
8310 : 260470 : end_pointer_check:
8311 : :
8312 : : /* Deferred length dummies pass the character length by reference
8313 : : so that the value can be returned. */
8314 : 267006 : if (parmse.string_length && fsym && fsym->ts.deferred)
8315 : : {
8316 : 781 : if (INDIRECT_REF_P (parmse.string_length))
8317 : : {
8318 : : /* In chains of functions/procedure calls the string_length already
8319 : : is a pointer to the variable holding the length. Therefore
8320 : : remove the deref on call. */
8321 : 90 : tmp = parmse.string_length;
8322 : 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8323 : : }
8324 : : else
8325 : : {
8326 : 691 : tmp = parmse.string_length;
8327 : 691 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8328 : 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8329 : 691 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8330 : : }
8331 : :
8332 : 781 : if (e && e->expr_type == EXPR_VARIABLE
8333 : 624 : && fsym->attr.allocatable
8334 : 360 : && e->ts.u.cl->backend_decl
8335 : 360 : && VAR_P (e->ts.u.cl->backend_decl))
8336 : : {
8337 : 276 : if (INDIRECT_REF_P (tmp))
8338 : 0 : tmp = TREE_OPERAND (tmp, 0);
8339 : 276 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8340 : : fold_convert (gfc_charlen_type_node, tmp));
8341 : : }
8342 : : }
8343 : :
8344 : : /* Character strings are passed as two parameters, a length and a
8345 : : pointer - except for Bind(c) and c_ptrs which only passe the pointer.
8346 : : An unlimited polymorphic formal argument likewise does not
8347 : : need the length. */
8348 : 267006 : if (parmse.string_length != NULL_TREE
8349 : 36676 : && !sym->attr.is_bind_c
8350 : 35980 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8351 : 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8352 : 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8353 : 30100 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8354 : 29991 : && !(fsym && UNLIMITED_POLY (fsym)))
8355 : 35690 : vec_safe_push (stringargs, parmse.string_length);
8356 : :
8357 : : /* When calling __copy for character expressions to unlimited
8358 : : polymorphic entities, the dst argument needs a string length. */
8359 : 52383 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8360 : 5321 : && startswith (sym->name, "__vtab_CHARACTER")
8361 : 0 : && arg->next && arg->next->expr
8362 : 0 : && (arg->next->expr->ts.type == BT_DERIVED
8363 : 0 : || arg->next->expr->ts.type == BT_CLASS)
8364 : 267006 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8365 : 0 : vec_safe_push (stringargs, parmse.string_length);
8366 : :
8367 : : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8368 : : pass the token and the offset as additional arguments. */
8369 : 267006 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8370 : 74 : && attr->codimension && !attr->allocatable)
8371 : : {
8372 : : /* Token and offset. */
8373 : 5 : vec_safe_push (stringargs, null_pointer_node);
8374 : 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8375 : 5 : gcc_assert (fsym->attr.optional);
8376 : : }
8377 : 234089 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8378 : 93 : && !attr->allocatable)
8379 : : {
8380 : 78 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8381 : 78 : tree offset, tmp2;
8382 : :
8383 : 78 : caf_decl = gfc_get_tree_for_caf_expr (e);
8384 : 78 : caf_type = TREE_TYPE (caf_decl);
8385 : 78 : if (POINTER_TYPE_P (caf_type)
8386 : 78 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8387 : 2 : caf_desc = TREE_TYPE (caf_type);
8388 : 76 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8389 : : caf_desc = caf_type;
8390 : :
8391 : 32 : if (caf_desc
8392 : 32 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8393 : 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8394 : : {
8395 : 64 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8396 : 34 : ? build_fold_indirect_ref (caf_decl)
8397 : : : caf_decl;
8398 : 32 : tmp = gfc_conv_descriptor_token (tmp);
8399 : : }
8400 : 46 : else if (DECL_LANG_SPECIFIC (caf_decl)
8401 : 46 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8402 : 9 : tmp = GFC_DECL_TOKEN (caf_decl);
8403 : : else
8404 : : {
8405 : 37 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8406 : : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8407 : 37 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8408 : : }
8409 : :
8410 : 78 : vec_safe_push (stringargs, tmp);
8411 : :
8412 : 78 : if (caf_desc
8413 : 78 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8414 : 32 : offset = build_int_cst (gfc_array_index_type, 0);
8415 : 46 : else if (DECL_LANG_SPECIFIC (caf_decl)
8416 : 46 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8417 : 9 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8418 : 37 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8419 : 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8420 : : else
8421 : 37 : offset = build_int_cst (gfc_array_index_type, 0);
8422 : :
8423 : 78 : if (caf_desc)
8424 : : {
8425 : 64 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8426 : 34 : ? build_fold_indirect_ref (caf_decl)
8427 : : : caf_decl;
8428 : 32 : tmp = gfc_conv_descriptor_data_get (tmp);
8429 : : }
8430 : : else
8431 : : {
8432 : 46 : gcc_assert (POINTER_TYPE_P (caf_type));
8433 : 46 : tmp = caf_decl;
8434 : : }
8435 : :
8436 : 69 : tmp2 = fsym->ts.type == BT_CLASS
8437 : 78 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8438 : 78 : if ((fsym->ts.type != BT_CLASS
8439 : 69 : && (fsym->as->type == AS_ASSUMED_SHAPE
8440 : 40 : || fsym->as->type == AS_ASSUMED_RANK))
8441 : 49 : || (fsym->ts.type == BT_CLASS
8442 : 9 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8443 : 6 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8444 : : {
8445 : 32 : if (fsym->ts.type == BT_CLASS)
8446 : 3 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8447 : : else
8448 : : {
8449 : 29 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8450 : 29 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8451 : : }
8452 : 32 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8453 : 32 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8454 : : }
8455 : 46 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8456 : 6 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8457 : : else
8458 : : {
8459 : 40 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8460 : : }
8461 : :
8462 : 78 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8463 : : gfc_array_index_type,
8464 : : fold_convert (gfc_array_index_type, tmp2),
8465 : : fold_convert (gfc_array_index_type, tmp));
8466 : 78 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8467 : : gfc_array_index_type, offset, tmp);
8468 : :
8469 : 78 : vec_safe_push (stringargs, offset);
8470 : : }
8471 : :
8472 : 267006 : vec_safe_push (arglist, parmse.expr);
8473 : : }
8474 : :
8475 : 127364 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8476 : 127364 : gfc_add_block_to_block (&se->pre, &clobbers);
8477 : 127364 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8478 : :
8479 : 127364 : if (comp)
8480 : 1805 : ts = comp->ts;
8481 : 125559 : else if (sym->ts.type == BT_CLASS)
8482 : 848 : ts = CLASS_DATA (sym)->ts;
8483 : : else
8484 : 124711 : ts = sym->ts;
8485 : :
8486 : 127364 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8487 : 186 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8488 : 127178 : else if (ts.type == BT_CHARACTER)
8489 : : {
8490 : 4735 : if (ts.u.cl->length == NULL)
8491 : : {
8492 : : /* Assumed character length results are not allowed by C418 of the 2003
8493 : : standard and are trapped in resolve.cc; except in the case of SPREAD
8494 : : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8495 : : we take the character length of the first argument for the result.
8496 : : For dummies, we have to look through the formal argument list for
8497 : : this function and use the character length found there.
8498 : : Likewise, we handle the case of deferred-length character dummy
8499 : : arguments to intrinsics that determine the characteristics of
8500 : : the result, which cannot be deferred-length. */
8501 : 2215 : if (expr->value.function.isym)
8502 : 1701 : ts.deferred = false;
8503 : 2215 : if (ts.deferred)
8504 : 507 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8505 : 1708 : else if (!sym->attr.dummy)
8506 : 1701 : cl.backend_decl = (*stringargs)[0];
8507 : : else
8508 : : {
8509 : 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8510 : 26 : for (; formal; formal = formal->next)
8511 : 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8512 : 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8513 : : }
8514 : 2215 : len = cl.backend_decl;
8515 : : }
8516 : : else
8517 : : {
8518 : 2520 : tree tmp;
8519 : :
8520 : : /* Calculate the length of the returned string. */
8521 : 2520 : gfc_init_se (&parmse, NULL);
8522 : 2520 : if (need_interface_mapping)
8523 : 1867 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8524 : : else
8525 : 653 : gfc_conv_expr (&parmse, ts.u.cl->length);
8526 : 2520 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8527 : 2520 : gfc_add_block_to_block (&se->post, &parmse.post);
8528 : 2520 : tmp = parmse.expr;
8529 : : /* TODO: It would be better to have the charlens as
8530 : : gfc_charlen_type_node already when the interface is
8531 : : created instead of converting it here (see PR 84615). */
8532 : 2520 : tmp = fold_build2_loc (input_location, MAX_EXPR,
8533 : : gfc_charlen_type_node,
8534 : : fold_convert (gfc_charlen_type_node, tmp),
8535 : : build_zero_cst (gfc_charlen_type_node));
8536 : 2520 : cl.backend_decl = tmp;
8537 : : }
8538 : :
8539 : : /* Set up a charlen structure for it. */
8540 : 4735 : cl.next = NULL;
8541 : 4735 : cl.length = NULL;
8542 : 4735 : ts.u.cl = &cl;
8543 : :
8544 : 4735 : len = cl.backend_decl;
8545 : : }
8546 : :
8547 : 1805 : byref = (comp && (comp->attr.dimension
8548 : 1736 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
8549 : 127364 : || (!comp && gfc_return_by_reference (sym));
8550 : :
8551 : 18548 : if (byref)
8552 : : {
8553 : 18548 : if (se->direct_byref)
8554 : : {
8555 : : /* Sometimes, too much indirection can be applied; e.g. for
8556 : : function_result = array_valued_recursive_function. */
8557 : 7207 : if (TREE_TYPE (TREE_TYPE (se->expr))
8558 : 7207 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
8559 : 7225 : && GFC_DESCRIPTOR_TYPE_P
8560 : : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
8561 : 18 : se->expr = build_fold_indirect_ref_loc (input_location,
8562 : : se->expr);
8563 : :
8564 : : /* If the lhs of an assignment x = f(..) is allocatable and
8565 : : f2003 is allowed, we must do the automatic reallocation.
8566 : : TODO - deal with intrinsics, without using a temporary. */
8567 : 7207 : if (flag_realloc_lhs
8568 : 7132 : && se->ss && se->ss->loop_chain
8569 : 166 : && se->ss->loop_chain->is_alloc_lhs
8570 : 166 : && !expr->value.function.isym
8571 : 166 : && sym->result->as != NULL)
8572 : : {
8573 : : /* Evaluate the bounds of the result, if known. */
8574 : 166 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
8575 : : sym->result->as);
8576 : :
8577 : : /* Perform the automatic reallocation. */
8578 : 166 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
8579 : : expr, NULL);
8580 : 166 : gfc_add_expr_to_block (&se->pre, tmp);
8581 : :
8582 : : /* Pass the temporary as the first argument. */
8583 : 166 : result = info->descriptor;
8584 : : }
8585 : : else
8586 : 7041 : result = build_fold_indirect_ref_loc (input_location,
8587 : : se->expr);
8588 : 7207 : vec_safe_push (retargs, se->expr);
8589 : : }
8590 : 11341 : else if (comp && comp->attr.dimension)
8591 : : {
8592 : 66 : gcc_assert (se->loop && info);
8593 : :
8594 : : /* Set the type of the array. vtable charlens are not always reliable.
8595 : : Use the interface, if possible. */
8596 : 66 : if (comp->ts.type == BT_CHARACTER
8597 : 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
8598 : 1 : && comp->ts.interface && comp->ts.interface->result)
8599 : 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
8600 : : else
8601 : 65 : tmp = gfc_typenode_for_spec (&comp->ts);
8602 : 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
8603 : :
8604 : : /* Evaluate the bounds of the result, if known. */
8605 : 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
8606 : :
8607 : : /* If the lhs of an assignment x = f(..) is allocatable and
8608 : : f2003 is allowed, we must not generate the function call
8609 : : here but should just send back the results of the mapping.
8610 : : This is signalled by the function ss being flagged. */
8611 : 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8612 : : {
8613 : 0 : gfc_free_interface_mapping (&mapping);
8614 : 0 : return has_alternate_specifier;
8615 : : }
8616 : :
8617 : : /* Create a temporary to store the result. In case the function
8618 : : returns a pointer, the temporary will be a shallow copy and
8619 : : mustn't be deallocated. */
8620 : 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
8621 : 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8622 : : tmp, NULL_TREE, false,
8623 : : !comp->attr.pointer, callee_alloc,
8624 : 66 : &se->ss->info->expr->where);
8625 : :
8626 : : /* Pass the temporary as the first argument. */
8627 : 66 : result = info->descriptor;
8628 : 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8629 : 66 : vec_safe_push (retargs, tmp);
8630 : : }
8631 : 11208 : else if (!comp && sym->result->attr.dimension)
8632 : : {
8633 : 8300 : gcc_assert (se->loop && info);
8634 : :
8635 : : /* Set the type of the array. */
8636 : 8300 : tmp = gfc_typenode_for_spec (&ts);
8637 : 8300 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
8638 : 8300 : gcc_assert (se->ss->dimen == se->loop->dimen);
8639 : :
8640 : : /* Evaluate the bounds of the result, if known. */
8641 : 8300 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
8642 : :
8643 : : /* If the lhs of an assignment x = f(..) is allocatable and
8644 : : f2003 is allowed, we must not generate the function call
8645 : : here but should just send back the results of the mapping.
8646 : : This is signalled by the function ss being flagged. */
8647 : 8300 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8648 : : {
8649 : 0 : gfc_free_interface_mapping (&mapping);
8650 : 0 : return has_alternate_specifier;
8651 : : }
8652 : :
8653 : : /* Create a temporary to store the result. In case the function
8654 : : returns a pointer, the temporary will be a shallow copy and
8655 : : mustn't be deallocated. */
8656 : 8300 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
8657 : 8300 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8658 : : tmp, NULL_TREE, false,
8659 : : !sym->attr.pointer, callee_alloc,
8660 : 8300 : &se->ss->info->expr->where);
8661 : :
8662 : : /* Pass the temporary as the first argument. */
8663 : 8300 : result = info->descriptor;
8664 : 8300 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8665 : 8300 : vec_safe_push (retargs, tmp);
8666 : : }
8667 : 2975 : else if (ts.type == BT_CHARACTER)
8668 : : {
8669 : : /* Pass the string length. */
8670 : 2914 : type = gfc_get_character_type (ts.kind, ts.u.cl);
8671 : 2914 : type = build_pointer_type (type);
8672 : :
8673 : : /* Emit a DECL_EXPR for the VLA type. */
8674 : 2914 : tmp = TREE_TYPE (type);
8675 : 2914 : if (TYPE_SIZE (tmp)
8676 : 2914 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
8677 : : {
8678 : 1837 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
8679 : 1837 : DECL_ARTIFICIAL (tmp) = 1;
8680 : 1837 : DECL_IGNORED_P (tmp) = 1;
8681 : 1837 : tmp = fold_build1_loc (input_location, DECL_EXPR,
8682 : 1837 : TREE_TYPE (tmp), tmp);
8683 : 1837 : gfc_add_expr_to_block (&se->pre, tmp);
8684 : : }
8685 : :
8686 : : /* Return an address to a char[0:len-1]* temporary for
8687 : : character pointers. */
8688 : 2914 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8689 : 67 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8690 : : {
8691 : 550 : var = gfc_create_var (type, "pstr");
8692 : :
8693 : 550 : if ((!comp && sym->attr.allocatable)
8694 : 21 : || (comp && comp->attr.allocatable))
8695 : : {
8696 : 265 : gfc_add_modify (&se->pre, var,
8697 : 265 : fold_convert (TREE_TYPE (var),
8698 : : null_pointer_node));
8699 : 265 : tmp = gfc_call_free (var);
8700 : 265 : gfc_add_expr_to_block (&se->post, tmp);
8701 : : }
8702 : :
8703 : : /* Provide an address expression for the function arguments. */
8704 : 550 : var = gfc_build_addr_expr (NULL_TREE, var);
8705 : : }
8706 : : else
8707 : 2364 : var = gfc_conv_string_tmp (se, type, len);
8708 : :
8709 : 2914 : vec_safe_push (retargs, var);
8710 : : }
8711 : : else
8712 : : {
8713 : 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
8714 : :
8715 : 61 : type = gfc_get_complex_type (ts.kind);
8716 : 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
8717 : 61 : vec_safe_push (retargs, var);
8718 : : }
8719 : :
8720 : : /* Add the string length to the argument list. */
8721 : 18548 : if (ts.type == BT_CHARACTER && ts.deferred)
8722 : : {
8723 : 507 : tmp = len;
8724 : 507 : if (!VAR_P (tmp))
8725 : 0 : tmp = gfc_evaluate_now (len, &se->pre);
8726 : 507 : TREE_STATIC (tmp) = 1;
8727 : 507 : gfc_add_modify (&se->pre, tmp,
8728 : 507 : build_int_cst (TREE_TYPE (tmp), 0));
8729 : 507 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8730 : 507 : vec_safe_push (retargs, tmp);
8731 : : }
8732 : 18041 : else if (ts.type == BT_CHARACTER)
8733 : 4228 : vec_safe_push (retargs, len);
8734 : : }
8735 : :
8736 : 127364 : gfc_free_interface_mapping (&mapping);
8737 : :
8738 : : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
8739 : 237458 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
8740 : 152474 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
8741 : 127364 : vec_safe_reserve (retargs, arglen);
8742 : :
8743 : : /* Add the return arguments. */
8744 : 127364 : vec_safe_splice (retargs, arglist);
8745 : :
8746 : : /* Add the hidden present status for optional+value to the arguments. */
8747 : 127364 : vec_safe_splice (retargs, optionalargs);
8748 : :
8749 : : /* Add the hidden string length parameters to the arguments. */
8750 : 127364 : vec_safe_splice (retargs, stringargs);
8751 : :
8752 : : /* We may want to append extra arguments here. This is used e.g. for
8753 : : calls to libgfortran_matmul_??, which need extra information. */
8754 : 127364 : vec_safe_splice (retargs, append_args);
8755 : :
8756 : 127364 : arglist = retargs;
8757 : :
8758 : : /* Generate the actual call. */
8759 : 127364 : is_builtin = false;
8760 : 127364 : if (base_object == NULL_TREE)
8761 : 127284 : conv_function_val (se, &is_builtin, sym, expr, args);
8762 : : else
8763 : 80 : conv_base_obj_fcn_val (se, base_object, expr);
8764 : :
8765 : : /* If there are alternate return labels, function type should be
8766 : : integer. Can't modify the type in place though, since it can be shared
8767 : : with other functions. For dummy arguments, the typing is done to
8768 : : this result, even if it has to be repeated for each call. */
8769 : 127364 : if (has_alternate_specifier
8770 : 127364 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
8771 : : {
8772 : 7 : if (!sym->attr.dummy)
8773 : : {
8774 : 0 : TREE_TYPE (sym->backend_decl)
8775 : 0 : = build_function_type (integer_type_node,
8776 : 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
8777 : 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
8778 : : }
8779 : : else
8780 : 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
8781 : : }
8782 : :
8783 : 127364 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
8784 : 127364 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
8785 : :
8786 : 127364 : if (is_builtin)
8787 : 507 : se->expr = update_builtin_function (se->expr, sym);
8788 : :
8789 : : /* Allocatable scalar function results must be freed and nullified
8790 : : after use. This necessitates the creation of a temporary to
8791 : : hold the result to prevent duplicate calls. */
8792 : 127364 : symbol_attribute attr = comp ? comp->attr : sym->attr;
8793 : 127364 : bool allocatable = attr.allocatable && !attr.dimension;
8794 : 130325 : gfc_symbol *der = comp ?
8795 : 1805 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
8796 : : :
8797 : 125559 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
8798 : 2961 : bool finalizable = der != NULL && der->ns->proc_name
8799 : 5919 : && gfc_is_finalizable (der, NULL);
8800 : :
8801 : 127364 : if (!byref && finalizable)
8802 : 161 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8803 : :
8804 : 127364 : if (!byref && sym->ts.type != BT_CHARACTER
8805 : 108630 : && allocatable && !finalizable)
8806 : : {
8807 : 230 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
8808 : 230 : gfc_add_modify (&se->pre, tmp, se->expr);
8809 : 230 : se->expr = tmp;
8810 : 230 : tmp = gfc_call_free (tmp);
8811 : 230 : gfc_add_expr_to_block (&post, tmp);
8812 : 230 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
8813 : : }
8814 : :
8815 : : /* If we have a pointer function, but we don't want a pointer, e.g.
8816 : : something like
8817 : : x = f()
8818 : : where f is pointer valued, we have to dereference the result. */
8819 : 127364 : if (!se->want_pointer && !byref
8820 : 108265 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8821 : 1625 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
8822 : 450 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8823 : :
8824 : : /* f2c calling conventions require a scalar default real function to
8825 : : return a double precision result. Convert this back to default
8826 : : real. We only care about the cases that can happen in Fortran 77.
8827 : : */
8828 : 127364 : if (flag_f2c && sym->ts.type == BT_REAL
8829 : 97 : && sym->ts.kind == gfc_default_real_kind
8830 : 73 : && !sym->attr.pointer
8831 : 54 : && !sym->attr.allocatable
8832 : 42 : && !sym->attr.always_explicit)
8833 : 42 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
8834 : :
8835 : : /* A pure function may still have side-effects - it may modify its
8836 : : parameters. */
8837 : 127364 : TREE_SIDE_EFFECTS (se->expr) = 1;
8838 : : #if 0
8839 : : if (!sym->attr.pure)
8840 : : TREE_SIDE_EFFECTS (se->expr) = 1;
8841 : : #endif
8842 : :
8843 : 127364 : if (byref)
8844 : : {
8845 : : /* Add the function call to the pre chain. There is no expression. */
8846 : 18548 : gfc_add_expr_to_block (&se->pre, se->expr);
8847 : 18548 : se->expr = NULL_TREE;
8848 : :
8849 : 18548 : if (!se->direct_byref)
8850 : : {
8851 : 11341 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
8852 : : {
8853 : 8366 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
8854 : : {
8855 : : /* Check the data pointer hasn't been modified. This would
8856 : : happen in a function returning a pointer. */
8857 : 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
8858 : 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
8859 : : logical_type_node,
8860 : : tmp, info->data);
8861 : 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
8862 : : gfc_msg_fault);
8863 : : }
8864 : 8366 : se->expr = info->descriptor;
8865 : : /* Bundle in the string length. */
8866 : 8366 : se->string_length = len;
8867 : :
8868 : 8366 : if (finalizable)
8869 : 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8870 : : }
8871 : 2975 : else if (ts.type == BT_CHARACTER)
8872 : : {
8873 : : /* Dereference for character pointer results. */
8874 : 2914 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8875 : 67 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8876 : 550 : se->expr = build_fold_indirect_ref_loc (input_location, var);
8877 : : else
8878 : 2364 : se->expr = var;
8879 : :
8880 : 2914 : se->string_length = len;
8881 : : }
8882 : : else
8883 : : {
8884 : 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
8885 : 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
8886 : : }
8887 : : }
8888 : : }
8889 : :
8890 : : /* Associate the rhs class object's meta-data with the result, when the
8891 : : result is a temporary. */
8892 : 110099 : if (args && args->expr && args->expr->ts.type == BT_CLASS
8893 : 4806 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
8894 : 127396 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
8895 : : {
8896 : 32 : gfc_se parmse;
8897 : 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
8898 : :
8899 : 32 : gfc_init_se (&parmse, NULL);
8900 : 32 : parmse.data_not_needed = 1;
8901 : 32 : gfc_conv_expr (&parmse, class_expr);
8902 : 32 : if (!DECL_LANG_SPECIFIC (result))
8903 : 32 : gfc_allocate_lang_decl (result);
8904 : 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
8905 : 32 : gfc_free_expr (class_expr);
8906 : : /* -fcheck= can add diagnostic code, which has to be placed before
8907 : : the call. */
8908 : 32 : if (parmse.pre.head != NULL)
8909 : 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
8910 : 32 : gcc_assert (parmse.post.head == NULL_TREE);
8911 : : }
8912 : :
8913 : : /* Follow the function call with the argument post block. */
8914 : 127364 : if (byref)
8915 : : {
8916 : 18548 : gfc_add_block_to_block (&se->pre, &post);
8917 : :
8918 : : /* Transformational functions of derived types with allocatable
8919 : : components must have the result allocatable components copied when the
8920 : : argument is actually given. This is unnecessry for REDUCE because the
8921 : : wrapper for the OPERATION function takes care of this. */
8922 : 18548 : arg = expr->value.function.actual;
8923 : 18548 : if (result && arg && expr->rank
8924 : 14775 : && isym && isym->transformational
8925 : 13219 : && isym->id != GFC_ISYM_REDUCE
8926 : 13093 : && arg->expr
8927 : 13051 : && arg->expr->ts.type == BT_DERIVED
8928 : 221 : && arg->expr->ts.u.derived->attr.alloc_comp)
8929 : : {
8930 : 36 : tree tmp2;
8931 : : /* Copy the allocatable components. We have to use a
8932 : : temporary here to prevent source allocatable components
8933 : : from being corrupted. */
8934 : 36 : tmp2 = gfc_evaluate_now (result, &se->pre);
8935 : 36 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
8936 : : result, tmp2, expr->rank, 0);
8937 : 36 : gfc_add_expr_to_block (&se->pre, tmp);
8938 : 36 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
8939 : : expr->rank);
8940 : 36 : gfc_add_expr_to_block (&se->pre, tmp);
8941 : :
8942 : : /* Finally free the temporary's data field. */
8943 : 36 : tmp = gfc_conv_descriptor_data_get (tmp2);
8944 : 36 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8945 : : NULL_TREE, NULL_TREE, true,
8946 : : NULL, GFC_CAF_COARRAY_NOCOARRAY);
8947 : 36 : gfc_add_expr_to_block (&se->pre, tmp);
8948 : : }
8949 : : }
8950 : : else
8951 : : {
8952 : : /* For a function with a class array result, save the result as
8953 : : a temporary, set the info fields needed by the scalarizer and
8954 : : call the finalization function of the temporary. Note that the
8955 : : nullification of allocatable components needed by the result
8956 : : is done in gfc_trans_assignment_1. */
8957 : 33864 : if (expr && (gfc_is_class_array_function (expr)
8958 : 33543 : || gfc_is_alloc_class_scalar_function (expr))
8959 : 840 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
8960 : 109644 : && expr->must_finalize)
8961 : : {
8962 : : /* TODO Eliminate the doubling of temporaries. This
8963 : : one is necessary to ensure no memory leakage. */
8964 : 321 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
8965 : :
8966 : : /* Finalize the result, if necessary. */
8967 : 642 : attr = expr->value.function.esym
8968 : 321 : ? CLASS_DATA (expr->value.function.esym->result)->attr
8969 : 14 : : CLASS_DATA (expr)->attr;
8970 : 321 : if (!((gfc_is_class_array_function (expr)
8971 : 108 : || gfc_is_alloc_class_scalar_function (expr))
8972 : 321 : && attr.pointer))
8973 : 276 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
8974 : : }
8975 : 108816 : gfc_add_block_to_block (&se->post, &post);
8976 : : }
8977 : :
8978 : : return has_alternate_specifier;
8979 : : }
8980 : :
8981 : :
8982 : : /* Fill a character string with spaces. */
8983 : :
8984 : : static tree
8985 : 28709 : fill_with_spaces (tree start, tree type, tree size)
8986 : : {
8987 : 28709 : stmtblock_t block, loop;
8988 : 28709 : tree i, el, exit_label, cond, tmp;
8989 : :
8990 : : /* For a simple char type, we can call memset(). */
8991 : 28709 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
8992 : 47898 : return build_call_expr_loc (input_location,
8993 : : builtin_decl_explicit (BUILT_IN_MEMSET),
8994 : : 3, start,
8995 : : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
8996 : 23949 : lang_hooks.to_target_charset (' ')),
8997 : : fold_convert (size_type_node, size));
8998 : :
8999 : : /* Otherwise, we use a loop:
9000 : : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9001 : : *el = (type) ' ';
9002 : : */
9003 : :
9004 : : /* Initialize variables. */
9005 : 4760 : gfc_init_block (&block);
9006 : 4760 : i = gfc_create_var (sizetype, "i");
9007 : 4760 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9008 : 4760 : el = gfc_create_var (build_pointer_type (type), "el");
9009 : 4760 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9010 : 4760 : exit_label = gfc_build_label_decl (NULL_TREE);
9011 : 4760 : TREE_USED (exit_label) = 1;
9012 : :
9013 : :
9014 : : /* Loop body. */
9015 : 4760 : gfc_init_block (&loop);
9016 : :
9017 : : /* Exit condition. */
9018 : 4760 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9019 : : build_zero_cst (sizetype));
9020 : 4760 : tmp = build1_v (GOTO_EXPR, exit_label);
9021 : 4760 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9022 : : build_empty_stmt (input_location));
9023 : 4760 : gfc_add_expr_to_block (&loop, tmp);
9024 : :
9025 : : /* Assignment. */
9026 : 4760 : gfc_add_modify (&loop,
9027 : : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9028 : 4760 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9029 : :
9030 : : /* Increment loop variables. */
9031 : 4760 : gfc_add_modify (&loop, i,
9032 : : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9033 : 4760 : TYPE_SIZE_UNIT (type)));
9034 : 4760 : gfc_add_modify (&loop, el,
9035 : : fold_build_pointer_plus_loc (input_location,
9036 : 4760 : el, TYPE_SIZE_UNIT (type)));
9037 : :
9038 : : /* Making the loop... actually loop! */
9039 : 4760 : tmp = gfc_finish_block (&loop);
9040 : 4760 : tmp = build1_v (LOOP_EXPR, tmp);
9041 : 4760 : gfc_add_expr_to_block (&block, tmp);
9042 : :
9043 : : /* The exit label. */
9044 : 4760 : tmp = build1_v (LABEL_EXPR, exit_label);
9045 : 4760 : gfc_add_expr_to_block (&block, tmp);
9046 : :
9047 : :
9048 : 4760 : return gfc_finish_block (&block);
9049 : : }
9050 : :
9051 : :
9052 : : /* Generate code to copy a string. */
9053 : :
9054 : : void
9055 : 33752 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9056 : : int dkind, tree slength, tree src, int skind)
9057 : : {
9058 : 33752 : tree tmp, dlen, slen;
9059 : 33752 : tree dsc;
9060 : 33752 : tree ssc;
9061 : 33752 : tree cond;
9062 : 33752 : tree cond2;
9063 : 33752 : tree tmp2;
9064 : 33752 : tree tmp3;
9065 : 33752 : tree tmp4;
9066 : 33752 : tree chartype;
9067 : 33752 : stmtblock_t tempblock;
9068 : :
9069 : 33752 : gcc_assert (dkind == skind);
9070 : :
9071 : 33752 : if (slength != NULL_TREE)
9072 : : {
9073 : 33752 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9074 : 33752 : ssc = gfc_string_to_single_character (slen, src, skind);
9075 : : }
9076 : : else
9077 : : {
9078 : 0 : slen = build_one_cst (gfc_charlen_type_node);
9079 : 0 : ssc = src;
9080 : : }
9081 : :
9082 : 33752 : if (dlength != NULL_TREE)
9083 : : {
9084 : 33752 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9085 : 33752 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9086 : : }
9087 : : else
9088 : : {
9089 : 0 : dlen = build_one_cst (gfc_charlen_type_node);
9090 : 0 : dsc = dest;
9091 : : }
9092 : :
9093 : : /* Assign directly if the types are compatible. */
9094 : 33752 : if (dsc != NULL_TREE && ssc != NULL_TREE
9095 : 33752 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9096 : : {
9097 : 5043 : gfc_add_modify (block, dsc, ssc);
9098 : 5043 : return;
9099 : : }
9100 : :
9101 : : /* The string copy algorithm below generates code like
9102 : :
9103 : : if (destlen > 0)
9104 : : {
9105 : : if (srclen < destlen)
9106 : : {
9107 : : memmove (dest, src, srclen);
9108 : : // Pad with spaces.
9109 : : memset (&dest[srclen], ' ', destlen - srclen);
9110 : : }
9111 : : else
9112 : : {
9113 : : // Truncate if too long.
9114 : : memmove (dest, src, destlen);
9115 : : }
9116 : : }
9117 : : */
9118 : :
9119 : : /* Do nothing if the destination length is zero. */
9120 : 28709 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9121 : 28709 : build_zero_cst (TREE_TYPE (dlen)));
9122 : :
9123 : : /* For non-default character kinds, we have to multiply the string
9124 : : length by the base type size. */
9125 : 28709 : chartype = gfc_get_char_type (dkind);
9126 : 28709 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9127 : : slen,
9128 : 28709 : fold_convert (TREE_TYPE (slen),
9129 : : TYPE_SIZE_UNIT (chartype)));
9130 : 28709 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9131 : : dlen,
9132 : 28709 : fold_convert (TREE_TYPE (dlen),
9133 : : TYPE_SIZE_UNIT (chartype)));
9134 : :
9135 : 28709 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9136 : 28661 : dest = fold_convert (pvoid_type_node, dest);
9137 : : else
9138 : 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9139 : :
9140 : 28709 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9141 : 28705 : src = fold_convert (pvoid_type_node, src);
9142 : : else
9143 : 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9144 : :
9145 : : /* Truncate string if source is too long. */
9146 : 28709 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9147 : : dlen);
9148 : :
9149 : : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9150 : 28709 : if (!CONSTANT_CLASS_P (cond2))
9151 : : {
9152 : 8909 : dest = gfc_evaluate_now (dest, block);
9153 : 8909 : src = gfc_evaluate_now (src, block);
9154 : : }
9155 : :
9156 : : /* Copy and pad with spaces. */
9157 : 28709 : tmp3 = build_call_expr_loc (input_location,
9158 : : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9159 : : 3, dest, src,
9160 : : fold_convert (size_type_node, slen));
9161 : :
9162 : : /* Wstringop-overflow appears at -O3 even though this warning is not
9163 : : explicitly available in fortran nor can it be switched off. If the
9164 : : source length is a constant, its negative appears as a very large
9165 : : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9166 : : the result of the MINUS_EXPR suppresses this spurious warning. */
9167 : 28709 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9168 : 28709 : TREE_TYPE(dlen), dlen, slen);
9169 : 28709 : if (slength && TREE_CONSTANT (slength))
9170 : 25342 : tmp = gfc_evaluate_now (tmp, block);
9171 : :
9172 : 28709 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9173 : 28709 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9174 : :
9175 : 28709 : gfc_init_block (&tempblock);
9176 : 28709 : gfc_add_expr_to_block (&tempblock, tmp3);
9177 : 28709 : gfc_add_expr_to_block (&tempblock, tmp4);
9178 : 28709 : tmp3 = gfc_finish_block (&tempblock);
9179 : :
9180 : : /* The truncated memmove if the slen >= dlen. */
9181 : 28709 : tmp2 = build_call_expr_loc (input_location,
9182 : : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9183 : : 3, dest, src,
9184 : : fold_convert (size_type_node, dlen));
9185 : :
9186 : : /* The whole copy_string function is there. */
9187 : 28709 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9188 : : tmp3, tmp2);
9189 : 28709 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9190 : : build_empty_stmt (input_location));
9191 : 28709 : gfc_add_expr_to_block (block, tmp);
9192 : : }
9193 : :
9194 : :
9195 : : /* Translate a statement function.
9196 : : The value of a statement function reference is obtained by evaluating the
9197 : : expression using the values of the actual arguments for the values of the
9198 : : corresponding dummy arguments. */
9199 : :
9200 : : static void
9201 : 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9202 : : {
9203 : 269 : gfc_symbol *sym;
9204 : 269 : gfc_symbol *fsym;
9205 : 269 : gfc_formal_arglist *fargs;
9206 : 269 : gfc_actual_arglist *args;
9207 : 269 : gfc_se lse;
9208 : 269 : gfc_se rse;
9209 : 269 : gfc_saved_var *saved_vars;
9210 : 269 : tree *temp_vars;
9211 : 269 : tree type;
9212 : 269 : tree tmp;
9213 : 269 : int n;
9214 : :
9215 : 269 : sym = expr->symtree->n.sym;
9216 : 269 : args = expr->value.function.actual;
9217 : 269 : gfc_init_se (&lse, NULL);
9218 : 269 : gfc_init_se (&rse, NULL);
9219 : :
9220 : 269 : n = 0;
9221 : 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9222 : 458 : n++;
9223 : 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9224 : 269 : temp_vars = XCNEWVEC (tree, n);
9225 : :
9226 : 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9227 : 458 : fargs = fargs->next, n++)
9228 : : {
9229 : : /* Each dummy shall be specified, explicitly or implicitly, to be
9230 : : scalar. */
9231 : 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9232 : 458 : fsym = fargs->sym;
9233 : :
9234 : 458 : if (fsym->ts.type == BT_CHARACTER)
9235 : : {
9236 : : /* Copy string arguments. */
9237 : 48 : tree arglen;
9238 : :
9239 : 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9240 : : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9241 : :
9242 : : /* Create a temporary to hold the value. */
9243 : 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9244 : 1 : fsym->ts.u.cl->backend_decl
9245 : 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9246 : :
9247 : 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9248 : 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9249 : :
9250 : 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9251 : :
9252 : 48 : gfc_conv_expr (&rse, args->expr);
9253 : 48 : gfc_conv_string_parameter (&rse);
9254 : 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9255 : 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9256 : :
9257 : 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9258 : : rse.string_length, rse.expr, fsym->ts.kind);
9259 : 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9260 : 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9261 : : }
9262 : : else
9263 : : {
9264 : : /* For everything else, just evaluate the expression. */
9265 : :
9266 : : /* Create a temporary to hold the value. */
9267 : 410 : type = gfc_typenode_for_spec (&fsym->ts);
9268 : 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9269 : :
9270 : 410 : gfc_conv_expr (&lse, args->expr);
9271 : :
9272 : 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9273 : 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9274 : 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9275 : : }
9276 : :
9277 : 458 : args = args->next;
9278 : : }
9279 : :
9280 : : /* Use the temporary variables in place of the real ones. */
9281 : 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9282 : 458 : fargs = fargs->next, n++)
9283 : 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9284 : :
9285 : 269 : gfc_conv_expr (se, sym->value);
9286 : :
9287 : 269 : if (sym->ts.type == BT_CHARACTER)
9288 : : {
9289 : 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9290 : :
9291 : : /* Force the expression to the correct length. */
9292 : 55 : if (!INTEGER_CST_P (se->string_length)
9293 : 101 : || tree_int_cst_lt (se->string_length,
9294 : 46 : sym->ts.u.cl->backend_decl))
9295 : : {
9296 : 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9297 : 31 : tmp = gfc_create_var (type, sym->name);
9298 : 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9299 : 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9300 : : sym->ts.kind, se->string_length, se->expr,
9301 : : sym->ts.kind);
9302 : 31 : se->expr = tmp;
9303 : : }
9304 : 55 : se->string_length = sym->ts.u.cl->backend_decl;
9305 : : }
9306 : :
9307 : : /* Restore the original variables. */
9308 : 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9309 : 458 : fargs = fargs->next, n++)
9310 : 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9311 : 269 : free (temp_vars);
9312 : 269 : free (saved_vars);
9313 : 269 : }
9314 : :
9315 : :
9316 : : /* Translate a function expression. */
9317 : :
9318 : : static void
9319 : 298932 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9320 : : {
9321 : 298932 : gfc_symbol *sym;
9322 : :
9323 : 298932 : if (expr->value.function.isym)
9324 : : {
9325 : 249557 : gfc_conv_intrinsic_function (se, expr);
9326 : 249557 : return;
9327 : : }
9328 : :
9329 : : /* expr.value.function.esym is the resolved (specific) function symbol for
9330 : : most functions. However this isn't set for dummy procedures. */
9331 : 49375 : sym = expr->value.function.esym;
9332 : 49375 : if (!sym)
9333 : 1449 : sym = expr->symtree->n.sym;
9334 : :
9335 : : /* The IEEE_ARITHMETIC functions are caught here. */
9336 : 49375 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9337 : 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9338 : : return;
9339 : :
9340 : : /* We distinguish statement functions from general functions to improve
9341 : : runtime performance. */
9342 : 36918 : if (sym->attr.proc == PROC_ST_FUNCTION)
9343 : : {
9344 : 269 : gfc_conv_statement_function (se, expr);
9345 : 269 : return;
9346 : : }
9347 : :
9348 : 36649 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9349 : : NULL);
9350 : : }
9351 : :
9352 : :
9353 : : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9354 : :
9355 : : static bool
9356 : 38261 : is_zero_initializer_p (gfc_expr * expr)
9357 : : {
9358 : 38261 : if (expr->expr_type != EXPR_CONSTANT)
9359 : : return false;
9360 : :
9361 : : /* We ignore constants with prescribed memory representations for now. */
9362 : 11246 : if (expr->representation.string)
9363 : : return false;
9364 : :
9365 : 11228 : switch (expr->ts.type)
9366 : : {
9367 : 5115 : case BT_INTEGER:
9368 : 5115 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9369 : :
9370 : 4814 : case BT_REAL:
9371 : 4814 : return mpfr_zero_p (expr->value.real)
9372 : 4814 : && MPFR_SIGN (expr->value.real) >= 0;
9373 : :
9374 : 925 : case BT_LOGICAL:
9375 : 925 : return expr->value.logical == 0;
9376 : :
9377 : 240 : case BT_COMPLEX:
9378 : 240 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9379 : 154 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9380 : 154 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9381 : 382 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9382 : :
9383 : : default:
9384 : : break;
9385 : : }
9386 : : return false;
9387 : : }
9388 : :
9389 : :
9390 : : static void
9391 : 34688 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9392 : : {
9393 : 34688 : gfc_ss *ss;
9394 : :
9395 : 34688 : ss = se->ss;
9396 : 34688 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9397 : 34688 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9398 : :
9399 : 34688 : gfc_conv_tmp_array_ref (se);
9400 : 34688 : }
9401 : :
9402 : :
9403 : : /* Build a static initializer. EXPR is the expression for the initial value.
9404 : : The other parameters describe the variable of the component being
9405 : : initialized. EXPR may be null. */
9406 : :
9407 : : tree
9408 : 134241 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9409 : : bool array, bool pointer, bool procptr)
9410 : : {
9411 : 134241 : gfc_se se;
9412 : :
9413 : 134241 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9414 : 42796 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9415 : 165 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9416 : 57 : return build_constructor (type, NULL);
9417 : :
9418 : 134184 : if (!(expr || pointer || procptr))
9419 : : return NULL_TREE;
9420 : :
9421 : : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9422 : : (these are the only two iso_c_binding derived types that can be
9423 : : used as initialization expressions). If so, we need to modify
9424 : : the 'expr' to be that for a (void *). */
9425 : 126012 : if (expr != NULL && expr->ts.type == BT_DERIVED
9426 : 38572 : && expr->ts.is_iso_c && expr->ts.u.derived)
9427 : : {
9428 : 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9429 : 4 : return build_constructor (type, NULL);
9430 : 182 : else if (POINTER_TYPE_P (type))
9431 : 182 : return build_int_cst (type, 0);
9432 : : else
9433 : 0 : gcc_unreachable ();
9434 : : }
9435 : :
9436 : 125826 : if (array && !procptr)
9437 : : {
9438 : 8370 : tree ctor;
9439 : : /* Arrays need special handling. */
9440 : 8370 : if (pointer)
9441 : 711 : ctor = gfc_build_null_descriptor (type);
9442 : : /* Special case assigning an array to zero. */
9443 : 7659 : else if (is_zero_initializer_p (expr))
9444 : 215 : ctor = build_constructor (type, NULL);
9445 : : else
9446 : 7444 : ctor = gfc_conv_array_initializer (type, expr);
9447 : 8370 : TREE_STATIC (ctor) = 1;
9448 : 8370 : return ctor;
9449 : : }
9450 : 117456 : else if (pointer || procptr)
9451 : : {
9452 : 56827 : if (ts->type == BT_CLASS && !procptr)
9453 : : {
9454 : 1708 : gfc_init_se (&se, NULL);
9455 : 1708 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9456 : 1708 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9457 : 1708 : TREE_STATIC (se.expr) = 1;
9458 : 1708 : return se.expr;
9459 : : }
9460 : 55119 : else if (!expr || expr->expr_type == EXPR_NULL)
9461 : 30019 : return fold_convert (type, null_pointer_node);
9462 : : else
9463 : : {
9464 : 25100 : gfc_init_se (&se, NULL);
9465 : 25100 : se.want_pointer = 1;
9466 : 25100 : gfc_conv_expr (&se, expr);
9467 : 25100 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9468 : : return se.expr;
9469 : : }
9470 : : }
9471 : : else
9472 : : {
9473 : 60629 : switch (ts->type)
9474 : : {
9475 : 17998 : case_bt_struct:
9476 : 17998 : case BT_CLASS:
9477 : 17998 : gfc_init_se (&se, NULL);
9478 : 17998 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9479 : 739 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9480 : : else
9481 : 17259 : gfc_conv_structure (&se, expr, 1);
9482 : 17998 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9483 : 17998 : TREE_STATIC (se.expr) = 1;
9484 : 17998 : return se.expr;
9485 : :
9486 : 2595 : case BT_CHARACTER:
9487 : 2595 : if (expr->expr_type == EXPR_CONSTANT)
9488 : : {
9489 : 2594 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9490 : 2594 : TREE_STATIC (ctor) = 1;
9491 : 2594 : return ctor;
9492 : : }
9493 : :
9494 : : /* Fallthrough. */
9495 : 40037 : default:
9496 : 40037 : gfc_init_se (&se, NULL);
9497 : 40037 : gfc_conv_constant (&se, expr);
9498 : 40037 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9499 : : return se.expr;
9500 : : }
9501 : : }
9502 : : }
9503 : :
9504 : : static tree
9505 : 933 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9506 : : {
9507 : 933 : gfc_se rse;
9508 : 933 : gfc_se lse;
9509 : 933 : gfc_ss *rss;
9510 : 933 : gfc_ss *lss;
9511 : 933 : gfc_array_info *lss_array;
9512 : 933 : stmtblock_t body;
9513 : 933 : stmtblock_t block;
9514 : 933 : gfc_loopinfo loop;
9515 : 933 : int n;
9516 : 933 : tree tmp;
9517 : :
9518 : 933 : gfc_start_block (&block);
9519 : :
9520 : : /* Initialize the scalarizer. */
9521 : 933 : gfc_init_loopinfo (&loop);
9522 : :
9523 : 933 : gfc_init_se (&lse, NULL);
9524 : 933 : gfc_init_se (&rse, NULL);
9525 : :
9526 : : /* Walk the rhs. */
9527 : 933 : rss = gfc_walk_expr (expr);
9528 : 933 : if (rss == gfc_ss_terminator)
9529 : : /* The rhs is scalar. Add a ss for the expression. */
9530 : 201 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
9531 : :
9532 : : /* Create a SS for the destination. */
9533 : 933 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
9534 : : GFC_SS_COMPONENT);
9535 : 933 : lss_array = &lss->info->data.array;
9536 : 933 : lss_array->shape = gfc_get_shape (cm->as->rank);
9537 : 933 : lss_array->descriptor = dest;
9538 : 933 : lss_array->data = gfc_conv_array_data (dest);
9539 : 933 : lss_array->offset = gfc_conv_array_offset (dest);
9540 : 1923 : for (n = 0; n < cm->as->rank; n++)
9541 : : {
9542 : 990 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
9543 : 990 : lss_array->stride[n] = gfc_index_one_node;
9544 : :
9545 : 990 : mpz_init (lss_array->shape[n]);
9546 : 990 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
9547 : 990 : cm->as->lower[n]->value.integer);
9548 : 990 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
9549 : : }
9550 : :
9551 : : /* Associate the SS with the loop. */
9552 : 933 : gfc_add_ss_to_loop (&loop, lss);
9553 : 933 : gfc_add_ss_to_loop (&loop, rss);
9554 : :
9555 : : /* Calculate the bounds of the scalarization. */
9556 : 933 : gfc_conv_ss_startstride (&loop);
9557 : :
9558 : : /* Setup the scalarizing loops. */
9559 : 933 : gfc_conv_loop_setup (&loop, &expr->where);
9560 : :
9561 : : /* Setup the gfc_se structures. */
9562 : 933 : gfc_copy_loopinfo_to_se (&lse, &loop);
9563 : 933 : gfc_copy_loopinfo_to_se (&rse, &loop);
9564 : :
9565 : 933 : rse.ss = rss;
9566 : 933 : gfc_mark_ss_chain_used (rss, 1);
9567 : 933 : lse.ss = lss;
9568 : 933 : gfc_mark_ss_chain_used (lss, 1);
9569 : :
9570 : : /* Start the scalarized loop body. */
9571 : 933 : gfc_start_scalarized_body (&loop, &body);
9572 : :
9573 : 933 : gfc_conv_tmp_array_ref (&lse);
9574 : 933 : if (cm->ts.type == BT_CHARACTER)
9575 : 176 : lse.string_length = cm->ts.u.cl->backend_decl;
9576 : :
9577 : 933 : gfc_conv_expr (&rse, expr);
9578 : :
9579 : 933 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
9580 : 933 : gfc_add_expr_to_block (&body, tmp);
9581 : :
9582 : 933 : gcc_assert (rse.ss == gfc_ss_terminator);
9583 : :
9584 : : /* Generate the copying loops. */
9585 : 933 : gfc_trans_scalarizing_loops (&loop, &body);
9586 : :
9587 : : /* Wrap the whole thing up. */
9588 : 933 : gfc_add_block_to_block (&block, &loop.pre);
9589 : 933 : gfc_add_block_to_block (&block, &loop.post);
9590 : :
9591 : 933 : gcc_assert (lss_array->shape != NULL);
9592 : 933 : gfc_free_shape (&lss_array->shape, cm->as->rank);
9593 : 933 : gfc_cleanup_loop (&loop);
9594 : :
9595 : 933 : return gfc_finish_block (&block);
9596 : : }
9597 : :
9598 : :
9599 : : static tree
9600 : 968 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
9601 : : gfc_expr * expr)
9602 : : {
9603 : 968 : gfc_se se;
9604 : 968 : stmtblock_t block;
9605 : 968 : tree offset;
9606 : 968 : int n;
9607 : 968 : tree tmp;
9608 : 968 : tree tmp2;
9609 : 968 : gfc_array_spec *as;
9610 : 968 : gfc_expr *arg = NULL;
9611 : :
9612 : 968 : gfc_start_block (&block);
9613 : 968 : gfc_init_se (&se, NULL);
9614 : :
9615 : : /* Get the descriptor for the expressions. */
9616 : 968 : se.want_pointer = 0;
9617 : 968 : gfc_conv_expr_descriptor (&se, expr);
9618 : 968 : gfc_add_block_to_block (&block, &se.pre);
9619 : 968 : gfc_add_modify (&block, dest, se.expr);
9620 : 968 : if (cm->ts.type == BT_CHARACTER
9621 : 968 : && gfc_deferred_strlen (cm, &tmp))
9622 : : {
9623 : 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
9624 : 30 : TREE_TYPE (tmp),
9625 : 30 : TREE_OPERAND (dest, 0),
9626 : : tmp, NULL_TREE);
9627 : 30 : gfc_add_modify (&block, tmp,
9628 : 30 : fold_convert (TREE_TYPE (tmp),
9629 : : se.string_length));
9630 : 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
9631 : : "slen");
9632 : 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
9633 : : }
9634 : :
9635 : : /* Deal with arrays of derived types with allocatable components. */
9636 : 968 : if (gfc_bt_struct (cm->ts.type)
9637 : 150 : && cm->ts.u.derived->attr.alloc_comp)
9638 : : // TODO: Fix caf_mode
9639 : 106 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
9640 : : se.expr, dest,
9641 : 106 : cm->as->rank, 0);
9642 : 862 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
9643 : 36 : && CLASS_DATA(cm)->attr.allocatable)
9644 : : {
9645 : 36 : if (cm->ts.u.derived->attr.alloc_comp)
9646 : : // TODO: Fix caf_mode
9647 : 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
9648 : : se.expr, dest,
9649 : : expr->rank, 0);
9650 : : else
9651 : : {
9652 : 36 : tmp = TREE_TYPE (dest);
9653 : 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9654 : : tmp, expr->rank, NULL_TREE);
9655 : : }
9656 : : }
9657 : 826 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9658 : 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9659 : : gfc_typenode_for_spec (&cm->ts),
9660 : 30 : cm->as->rank, NULL_TREE);
9661 : : else
9662 : 796 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9663 : 796 : TREE_TYPE(cm->backend_decl),
9664 : 796 : cm->as->rank, NULL_TREE);
9665 : :
9666 : :
9667 : 968 : gfc_add_expr_to_block (&block, tmp);
9668 : 968 : gfc_add_block_to_block (&block, &se.post);
9669 : :
9670 : 968 : if (expr->expr_type != EXPR_VARIABLE)
9671 : 851 : gfc_conv_descriptor_data_set (&block, se.expr,
9672 : : null_pointer_node);
9673 : :
9674 : : /* We need to know if the argument of a conversion function is a
9675 : : variable, so that the correct lower bound can be used. */
9676 : 968 : if (expr->expr_type == EXPR_FUNCTION
9677 : 56 : && expr->value.function.isym
9678 : 44 : && expr->value.function.isym->conversion
9679 : 44 : && expr->value.function.actual->expr
9680 : 44 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
9681 : 44 : arg = expr->value.function.actual->expr;
9682 : :
9683 : : /* Obtain the array spec of full array references. */
9684 : 44 : if (arg)
9685 : 44 : as = gfc_get_full_arrayspec_from_expr (arg);
9686 : : else
9687 : 924 : as = gfc_get_full_arrayspec_from_expr (expr);
9688 : :
9689 : : /* Shift the lbound and ubound of temporaries to being unity,
9690 : : rather than zero, based. Always calculate the offset. */
9691 : 968 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
9692 : 968 : offset = gfc_conv_descriptor_offset_get (dest);
9693 : 968 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
9694 : :
9695 : 1992 : for (n = 0; n < expr->rank; n++)
9696 : : {
9697 : 1024 : tree span;
9698 : 1024 : tree lbound;
9699 : :
9700 : : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
9701 : : TODO It looks as if gfc_conv_expr_descriptor should return
9702 : : the correct bounds and that the following should not be
9703 : : necessary. This would simplify gfc_conv_intrinsic_bound
9704 : : as well. */
9705 : 1024 : if (as && as->lower[n])
9706 : : {
9707 : 66 : gfc_se lbse;
9708 : 66 : gfc_init_se (&lbse, NULL);
9709 : 66 : gfc_conv_expr (&lbse, as->lower[n]);
9710 : 66 : gfc_add_block_to_block (&block, &lbse.pre);
9711 : 66 : lbound = gfc_evaluate_now (lbse.expr, &block);
9712 : 66 : }
9713 : 958 : else if (as && arg)
9714 : : {
9715 : 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
9716 : 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
9717 : : gfc_rank_cst[n]);
9718 : : }
9719 : 924 : else if (as)
9720 : 75 : lbound = gfc_conv_descriptor_lbound_get (dest,
9721 : : gfc_rank_cst[n]);
9722 : : else
9723 : 849 : lbound = gfc_index_one_node;
9724 : :
9725 : 1024 : lbound = fold_convert (gfc_array_index_type, lbound);
9726 : :
9727 : : /* Shift the bounds and set the offset accordingly. */
9728 : 1024 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
9729 : 1024 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9730 : : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
9731 : 1024 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9732 : : span, lbound);
9733 : 1024 : gfc_conv_descriptor_ubound_set (&block, dest,
9734 : : gfc_rank_cst[n], tmp);
9735 : 1024 : gfc_conv_descriptor_lbound_set (&block, dest,
9736 : : gfc_rank_cst[n], lbound);
9737 : :
9738 : 1024 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9739 : : gfc_conv_descriptor_lbound_get (dest,
9740 : : gfc_rank_cst[n]),
9741 : : gfc_conv_descriptor_stride_get (dest,
9742 : : gfc_rank_cst[n]));
9743 : 1024 : gfc_add_modify (&block, tmp2, tmp);
9744 : 1024 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9745 : : offset, tmp2);
9746 : 1024 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
9747 : : }
9748 : :
9749 : 968 : if (arg)
9750 : : {
9751 : : /* If a conversion expression has a null data pointer
9752 : : argument, nullify the allocatable component. */
9753 : 44 : tree non_null_expr;
9754 : 44 : tree null_expr;
9755 : :
9756 : 44 : if (arg->symtree->n.sym->attr.allocatable
9757 : 12 : || arg->symtree->n.sym->attr.pointer)
9758 : : {
9759 : 32 : non_null_expr = gfc_finish_block (&block);
9760 : 32 : gfc_start_block (&block);
9761 : 32 : gfc_conv_descriptor_data_set (&block, dest,
9762 : : null_pointer_node);
9763 : 32 : null_expr = gfc_finish_block (&block);
9764 : 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
9765 : 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
9766 : 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9767 : 32 : return build3_v (COND_EXPR, tmp,
9768 : : null_expr, non_null_expr);
9769 : : }
9770 : : }
9771 : :
9772 : 936 : return gfc_finish_block (&block);
9773 : : }
9774 : :
9775 : :
9776 : : /* Allocate or reallocate scalar component, as necessary. */
9777 : :
9778 : : static void
9779 : 381 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
9780 : : gfc_component *cm, gfc_expr *expr2,
9781 : : tree slen)
9782 : : {
9783 : 381 : tree tmp;
9784 : 381 : tree ptr;
9785 : 381 : tree size;
9786 : 381 : tree size_in_bytes;
9787 : 381 : tree lhs_cl_size = NULL_TREE;
9788 : 381 : gfc_se se;
9789 : :
9790 : 381 : if (!comp)
9791 : 0 : return;
9792 : :
9793 : 381 : if (!expr2 || expr2->rank)
9794 : : return;
9795 : :
9796 : 381 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9797 : :
9798 : 381 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9799 : : {
9800 : 127 : gcc_assert (expr2->ts.type == BT_CHARACTER);
9801 : 127 : size = expr2->ts.u.cl->backend_decl;
9802 : 127 : if (!size || !VAR_P (size))
9803 : 127 : size = gfc_create_var (TREE_TYPE (slen), "slen");
9804 : 127 : gfc_add_modify (block, size, slen);
9805 : :
9806 : 127 : gfc_deferred_strlen (cm, &tmp);
9807 : 127 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
9808 : : gfc_charlen_type_node,
9809 : 127 : TREE_OPERAND (comp, 0),
9810 : : tmp, NULL_TREE);
9811 : :
9812 : 127 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
9813 : 127 : tmp = TYPE_SIZE_UNIT (tmp);
9814 : 254 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9815 : 127 : TREE_TYPE (tmp), tmp,
9816 : 127 : fold_convert (TREE_TYPE (tmp), size));
9817 : : }
9818 : 254 : else if (cm->ts.type == BT_CLASS)
9819 : : {
9820 : 102 : if (expr2->ts.type != BT_CLASS)
9821 : : {
9822 : 102 : if (expr2->ts.type == BT_CHARACTER)
9823 : : {
9824 : 24 : gfc_init_se (&se, NULL);
9825 : 24 : gfc_conv_expr (&se, expr2);
9826 : 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
9827 : 24 : size = fold_build2_loc (input_location, MULT_EXPR,
9828 : : gfc_charlen_type_node,
9829 : : se.string_length, size);
9830 : 24 : size = fold_convert (size_type_node, size);
9831 : : }
9832 : : else
9833 : : {
9834 : 78 : if (expr2->ts.type == BT_DERIVED)
9835 : 48 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
9836 : : else
9837 : 30 : tmp = gfc_typenode_for_spec (&expr2->ts);
9838 : 78 : size = TYPE_SIZE_UNIT (tmp);
9839 : : }
9840 : : }
9841 : : else
9842 : : {
9843 : 0 : gfc_expr *e2vtab;
9844 : 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
9845 : 0 : gfc_add_vptr_component (e2vtab);
9846 : 0 : gfc_add_size_component (e2vtab);
9847 : 0 : gfc_init_se (&se, NULL);
9848 : 0 : gfc_conv_expr (&se, e2vtab);
9849 : 0 : gfc_add_block_to_block (block, &se.pre);
9850 : 0 : size = fold_convert (size_type_node, se.expr);
9851 : 0 : gfc_free_expr (e2vtab);
9852 : : }
9853 : : size_in_bytes = size;
9854 : : }
9855 : : else
9856 : : {
9857 : : /* Otherwise use the length in bytes of the rhs. */
9858 : 152 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
9859 : 152 : size_in_bytes = size;
9860 : : }
9861 : :
9862 : 381 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9863 : : size_in_bytes, size_one_node);
9864 : :
9865 : 381 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
9866 : : {
9867 : 0 : tmp = build_call_expr_loc (input_location,
9868 : : builtin_decl_explicit (BUILT_IN_CALLOC),
9869 : : 2, build_one_cst (size_type_node),
9870 : : size_in_bytes);
9871 : 0 : tmp = fold_convert (TREE_TYPE (comp), tmp);
9872 : 0 : gfc_add_modify (block, comp, tmp);
9873 : : }
9874 : : else
9875 : : {
9876 : 381 : tmp = build_call_expr_loc (input_location,
9877 : : builtin_decl_explicit (BUILT_IN_MALLOC),
9878 : : 1, size_in_bytes);
9879 : 381 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
9880 : 102 : ptr = gfc_class_data_get (comp);
9881 : : else
9882 : : ptr = comp;
9883 : 381 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
9884 : 381 : gfc_add_modify (block, ptr, tmp);
9885 : : }
9886 : :
9887 : 381 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9888 : : /* Update the lhs character length. */
9889 : 127 : gfc_add_modify (block, lhs_cl_size,
9890 : 127 : fold_convert (TREE_TYPE (lhs_cl_size), size));
9891 : : }
9892 : :
9893 : :
9894 : : /* Assign a single component of a derived type constructor. */
9895 : :
9896 : : static tree
9897 : 27321 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
9898 : : gfc_expr * expr, bool init)
9899 : : {
9900 : 27321 : gfc_se se;
9901 : 27321 : gfc_se lse;
9902 : 27321 : stmtblock_t block;
9903 : 27321 : tree tmp;
9904 : 27321 : tree vtab;
9905 : :
9906 : 27321 : gfc_start_block (&block);
9907 : :
9908 : 27321 : if (cm->attr.pointer || cm->attr.proc_pointer)
9909 : : {
9910 : : /* Only care about pointers here, not about allocatables. */
9911 : 2541 : gfc_init_se (&se, NULL);
9912 : : /* Pointer component. */
9913 : 2541 : if ((cm->attr.dimension || cm->attr.codimension)
9914 : 646 : && !cm->attr.proc_pointer)
9915 : : {
9916 : : /* Array pointer. */
9917 : 630 : if (expr->expr_type == EXPR_NULL)
9918 : 624 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9919 : : else
9920 : : {
9921 : 6 : se.direct_byref = 1;
9922 : 6 : se.expr = dest;
9923 : 6 : gfc_conv_expr_descriptor (&se, expr);
9924 : 6 : gfc_add_block_to_block (&block, &se.pre);
9925 : 6 : gfc_add_block_to_block (&block, &se.post);
9926 : : }
9927 : : }
9928 : : else
9929 : : {
9930 : : /* Scalar pointers. */
9931 : 1911 : se.want_pointer = 1;
9932 : 1911 : gfc_conv_expr (&se, expr);
9933 : 1911 : gfc_add_block_to_block (&block, &se.pre);
9934 : :
9935 : 1911 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
9936 : 12 : && expr->symtree->n.sym->attr.dummy)
9937 : 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
9938 : :
9939 : 1911 : gfc_add_modify (&block, dest,
9940 : 1911 : fold_convert (TREE_TYPE (dest), se.expr));
9941 : 1911 : gfc_add_block_to_block (&block, &se.post);
9942 : : }
9943 : : }
9944 : 24780 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
9945 : : {
9946 : : /* NULL initialization for CLASS components. */
9947 : 922 : tmp = gfc_trans_structure_assign (dest,
9948 : : gfc_class_initializer (&cm->ts, expr),
9949 : : false);
9950 : 922 : gfc_add_expr_to_block (&block, tmp);
9951 : : }
9952 : 23858 : else if ((cm->attr.dimension || cm->attr.codimension)
9953 : : && !cm->attr.proc_pointer)
9954 : : {
9955 : 4211 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
9956 : : {
9957 : 2346 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9958 : 2346 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
9959 : 1 : gfc_add_modify (&block, gfc_conv_descriptor_token (dest),
9960 : : null_pointer_node);
9961 : : }
9962 : 1865 : else if (cm->attr.allocatable || cm->attr.pdt_array)
9963 : : {
9964 : 932 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
9965 : 932 : gfc_add_expr_to_block (&block, tmp);
9966 : : }
9967 : : else
9968 : : {
9969 : 933 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
9970 : 933 : gfc_add_expr_to_block (&block, tmp);
9971 : : }
9972 : : }
9973 : 19647 : else if (cm->ts.type == BT_CLASS
9974 : 144 : && CLASS_DATA (cm)->attr.dimension
9975 : 36 : && CLASS_DATA (cm)->attr.allocatable
9976 : 36 : && expr->ts.type == BT_DERIVED)
9977 : : {
9978 : 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
9979 : 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
9980 : 36 : tmp = gfc_class_vptr_get (dest);
9981 : 36 : gfc_add_modify (&block, tmp,
9982 : 36 : fold_convert (TREE_TYPE (tmp), vtab));
9983 : 36 : tmp = gfc_class_data_get (dest);
9984 : 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
9985 : 36 : gfc_add_expr_to_block (&block, tmp);
9986 : : }
9987 : 19611 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
9988 : 1649 : && (init
9989 : 1522 : || (cm->ts.type == BT_CHARACTER
9990 : 125 : && !(cm->ts.deferred || cm->attr.pdt_string))))
9991 : : {
9992 : : /* NULL initialization for allocatable components.
9993 : : Deferred-length character is dealt with later. */
9994 : 145 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
9995 : : null_pointer_node));
9996 : : }
9997 : 19466 : else if (init && (cm->attr.allocatable
9998 : 12924 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
9999 : 108 : && expr->ts.type != BT_CLASS)))
10000 : : {
10001 : 381 : tree size;
10002 : :
10003 : 381 : gfc_init_se (&se, NULL);
10004 : 381 : gfc_conv_expr (&se, expr);
10005 : :
10006 : : /* The remainder of these instructions follow the if (cm->attr.pointer)
10007 : : if (!cm->attr.dimension) part above. */
10008 : 381 : gfc_add_block_to_block (&block, &se.pre);
10009 : : /* Take care about non-array allocatable components here. The alloc_*
10010 : : routine below is motivated by the alloc_scalar_allocatable_for_
10011 : : assignment() routine, but with the realloc portions removed and
10012 : : different input. */
10013 : 381 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10014 : : se.string_length);
10015 : :
10016 : 381 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10017 : 0 : && expr->symtree->n.sym->attr.dummy)
10018 : 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10019 : :
10020 : 381 : if (cm->ts.type == BT_CLASS)
10021 : : {
10022 : 102 : tmp = gfc_class_data_get (dest);
10023 : 102 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10024 : 102 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10025 : 102 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10026 : 102 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10027 : 102 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10028 : : }
10029 : : else
10030 : 279 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10031 : :
10032 : : /* For deferred strings insert a memcpy. */
10033 : 381 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10034 : : {
10035 : 127 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10036 : 127 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10037 : : ? se.string_length
10038 : 0 : : expr->ts.u.cl->backend_decl);
10039 : 127 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10040 : 127 : gfc_add_expr_to_block (&block, tmp);
10041 : : }
10042 : 254 : else if (cm->ts.type == BT_CLASS)
10043 : : {
10044 : : /* Fix the expression for memcpy. */
10045 : 102 : if (expr->expr_type != EXPR_VARIABLE)
10046 : 72 : se.expr = gfc_evaluate_now (se.expr, &block);
10047 : :
10048 : 102 : if (expr->ts.type == BT_CHARACTER)
10049 : : {
10050 : 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10051 : 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10052 : : gfc_charlen_type_node,
10053 : : se.string_length, size);
10054 : 24 : size = fold_convert (size_type_node, size);
10055 : : }
10056 : : else
10057 : 78 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10058 : :
10059 : : /* Now copy the expression to the constructor component _data. */
10060 : 102 : gfc_add_expr_to_block (&block,
10061 : : gfc_build_memcpy_call (tmp, se.expr, size));
10062 : :
10063 : : /* Fill the unlimited polymorphic _len field. */
10064 : 102 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10065 : : {
10066 : 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10067 : 24 : gfc_add_modify (&block, tmp,
10068 : 24 : fold_convert (TREE_TYPE (tmp),
10069 : : se.string_length));
10070 : : }
10071 : : }
10072 : : else
10073 : 152 : gfc_add_modify (&block, tmp,
10074 : 152 : fold_convert (TREE_TYPE (tmp), se.expr));
10075 : 381 : gfc_add_block_to_block (&block, &se.post);
10076 : 381 : }
10077 : 19085 : else if (expr->ts.type == BT_UNION)
10078 : : {
10079 : 13 : tree tmp;
10080 : 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10081 : : /* We mark that the entire union should be initialized with a contrived
10082 : : EXPR_NULL expression at the beginning. */
10083 : 13 : if (c != NULL && c->n.component == NULL
10084 : 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10085 : : {
10086 : 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10087 : 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10088 : 6 : gfc_add_expr_to_block (&block, tmp);
10089 : 6 : c = gfc_constructor_next (c);
10090 : : }
10091 : : /* The following constructor expression, if any, represents a specific
10092 : : map intializer, as given by the user. */
10093 : 13 : if (c != NULL && c->expr != NULL)
10094 : : {
10095 : 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10096 : 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10097 : 6 : gfc_add_expr_to_block (&block, tmp);
10098 : : }
10099 : : }
10100 : 19072 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10101 : : {
10102 : 2961 : if (expr->expr_type != EXPR_STRUCTURE)
10103 : : {
10104 : 373 : tree dealloc = NULL_TREE;
10105 : 373 : gfc_init_se (&se, NULL);
10106 : 373 : gfc_conv_expr (&se, expr);
10107 : 373 : gfc_add_block_to_block (&block, &se.pre);
10108 : : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10109 : : expression in a temporary variable and deallocate the allocatable
10110 : : components. Then we can the copy the expression to the result. */
10111 : 373 : if (cm->ts.u.derived->attr.alloc_comp
10112 : 251 : && expr->expr_type != EXPR_VARIABLE)
10113 : : {
10114 : 221 : se.expr = gfc_evaluate_now (se.expr, &block);
10115 : 221 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10116 : : expr->rank);
10117 : : }
10118 : 373 : gfc_add_modify (&block, dest,
10119 : 373 : fold_convert (TREE_TYPE (dest), se.expr));
10120 : 373 : if (cm->ts.u.derived->attr.alloc_comp
10121 : 251 : && expr->expr_type != EXPR_NULL)
10122 : : {
10123 : : // TODO: Fix caf_mode
10124 : 48 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10125 : : dest, expr->rank, 0);
10126 : 48 : gfc_add_expr_to_block (&block, tmp);
10127 : 48 : if (dealloc != NULL_TREE)
10128 : 18 : gfc_add_expr_to_block (&block, dealloc);
10129 : : }
10130 : 373 : gfc_add_block_to_block (&block, &se.post);
10131 : : }
10132 : : else
10133 : : {
10134 : : /* Nested constructors. */
10135 : 2588 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10136 : 2588 : gfc_add_expr_to_block (&block, tmp);
10137 : : }
10138 : : }
10139 : 16111 : else if (gfc_deferred_strlen (cm, &tmp))
10140 : : {
10141 : 119 : tree strlen;
10142 : 119 : strlen = tmp;
10143 : 119 : gcc_assert (strlen);
10144 : 119 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10145 : 119 : TREE_TYPE (strlen),
10146 : 119 : TREE_OPERAND (dest, 0),
10147 : : strlen, NULL_TREE);
10148 : :
10149 : 119 : if (expr->expr_type == EXPR_NULL)
10150 : : {
10151 : 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10152 : 107 : gfc_add_modify (&block, dest, tmp);
10153 : 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10154 : 107 : gfc_add_modify (&block, strlen, tmp);
10155 : : }
10156 : : else
10157 : : {
10158 : 12 : tree size;
10159 : 12 : gfc_init_se (&se, NULL);
10160 : 12 : gfc_conv_expr (&se, expr);
10161 : 12 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10162 : 12 : size = fold_convert (size_type_node, size);
10163 : 12 : tmp = build_call_expr_loc (input_location,
10164 : : builtin_decl_explicit (BUILT_IN_MALLOC),
10165 : : 1, size);
10166 : 12 : gfc_add_modify (&block, dest,
10167 : 12 : fold_convert (TREE_TYPE (dest), tmp));
10168 : 12 : gfc_add_modify (&block, strlen,
10169 : 12 : fold_convert (TREE_TYPE (strlen), se.string_length));
10170 : 12 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10171 : 12 : gfc_add_expr_to_block (&block, tmp);
10172 : : }
10173 : : }
10174 : 15992 : else if (!cm->attr.artificial)
10175 : : {
10176 : : /* Scalar component (excluding deferred parameters). */
10177 : 15877 : gfc_init_se (&se, NULL);
10178 : 15877 : gfc_init_se (&lse, NULL);
10179 : :
10180 : 15877 : gfc_conv_expr (&se, expr);
10181 : 15877 : if (cm->ts.type == BT_CHARACTER)
10182 : 1047 : lse.string_length = cm->ts.u.cl->backend_decl;
10183 : 15877 : lse.expr = dest;
10184 : 15877 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10185 : 15877 : gfc_add_expr_to_block (&block, tmp);
10186 : : }
10187 : 27321 : return gfc_finish_block (&block);
10188 : : }
10189 : :
10190 : : /* Assign a derived type constructor to a variable. */
10191 : :
10192 : : tree
10193 : 19295 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10194 : : {
10195 : 19295 : gfc_constructor *c;
10196 : 19295 : gfc_component *cm;
10197 : 19295 : stmtblock_t block;
10198 : 19295 : tree field;
10199 : 19295 : tree tmp;
10200 : 19295 : gfc_se se;
10201 : :
10202 : 19295 : gfc_start_block (&block);
10203 : :
10204 : 19295 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10205 : 172 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10206 : 9 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10207 : : {
10208 : 172 : gfc_se lse;
10209 : :
10210 : 172 : gfc_init_se (&se, NULL);
10211 : 172 : gfc_init_se (&lse, NULL);
10212 : 172 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10213 : 172 : lse.expr = dest;
10214 : 172 : gfc_add_modify (&block, lse.expr,
10215 : 172 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10216 : :
10217 : 172 : return gfc_finish_block (&block);
10218 : : }
10219 : :
10220 : : /* Make sure that the derived type has been completely built. */
10221 : 19123 : if (!expr->ts.u.derived->backend_decl
10222 : 19123 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10223 : : {
10224 : 223 : tmp = gfc_typenode_for_spec (&expr->ts);
10225 : 223 : gcc_assert (tmp);
10226 : : }
10227 : :
10228 : 19123 : cm = expr->ts.u.derived->components;
10229 : :
10230 : :
10231 : 19123 : if (coarray)
10232 : 169 : gfc_init_se (&se, NULL);
10233 : :
10234 : 19123 : for (c = gfc_constructor_first (expr->value.constructor);
10235 : 49420 : c; c = gfc_constructor_next (c), cm = cm->next)
10236 : : {
10237 : : /* Skip absent members in default initializers. */
10238 : 30297 : if (!c->expr && !cm->attr.allocatable)
10239 : 2976 : continue;
10240 : :
10241 : : /* Register the component with the caf-lib before it is initialized.
10242 : : Register only allocatable components, that are not coarray'ed
10243 : : components (%comp[*]). Only register when the constructor is the
10244 : : null-expression. */
10245 : 27321 : if (coarray && !cm->attr.codimension
10246 : 386 : && (cm->attr.allocatable || cm->attr.pointer)
10247 : 169 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10248 : : {
10249 : 168 : tree token, desc, size;
10250 : 336 : bool is_array = cm->ts.type == BT_CLASS
10251 : 168 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10252 : :
10253 : 168 : field = cm->backend_decl;
10254 : 168 : field = fold_build3_loc (input_location, COMPONENT_REF,
10255 : 168 : TREE_TYPE (field), dest, field, NULL_TREE);
10256 : 168 : if (cm->ts.type == BT_CLASS)
10257 : 0 : field = gfc_class_data_get (field);
10258 : :
10259 : 168 : token
10260 : : = is_array
10261 : 168 : ? gfc_conv_descriptor_token (field)
10262 : 49 : : fold_build3_loc (input_location, COMPONENT_REF,
10263 : 49 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10264 : 49 : gfc_comp_caf_token (cm), NULL_TREE);
10265 : :
10266 : 168 : if (is_array)
10267 : : {
10268 : : /* The _caf_register routine looks at the rank of the array
10269 : : descriptor to decide whether the data registered is an array
10270 : : or not. */
10271 : 119 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10272 : 119 : : cm->as->rank;
10273 : : /* When the rank is not known just set a positive rank, which
10274 : : suffices to recognize the data as array. */
10275 : 119 : if (rank < 0)
10276 : 0 : rank = 1;
10277 : 119 : size = build_zero_cst (size_type_node);
10278 : 119 : desc = field;
10279 : 119 : gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
10280 : 119 : build_int_cst (signed_char_type_node, rank));
10281 : : }
10282 : : else
10283 : : {
10284 : 49 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10285 : 49 : cm->ts.type == BT_CLASS
10286 : 49 : ? CLASS_DATA (cm)->attr
10287 : : : cm->attr);
10288 : 49 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10289 : : }
10290 : 168 : gfc_add_block_to_block (&block, &se.pre);
10291 : 168 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10292 : : 7, size, build_int_cst (
10293 : : integer_type_node,
10294 : : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10295 : : gfc_build_addr_expr (pvoid_type_node,
10296 : : token),
10297 : : gfc_build_addr_expr (NULL_TREE, desc),
10298 : : null_pointer_node, null_pointer_node,
10299 : : integer_zero_node);
10300 : 168 : gfc_add_expr_to_block (&block, tmp);
10301 : : }
10302 : 27321 : field = cm->backend_decl;
10303 : 27321 : gcc_assert(field);
10304 : 27321 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10305 : : dest, field, NULL_TREE);
10306 : 27321 : if (!c->expr)
10307 : : {
10308 : 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10309 : 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10310 : 0 : gfc_free_expr (e);
10311 : : }
10312 : : else
10313 : 27321 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10314 : 27321 : gfc_add_expr_to_block (&block, tmp);
10315 : : }
10316 : 19123 : return gfc_finish_block (&block);
10317 : : }
10318 : :
10319 : : static void
10320 : 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10321 : : gfc_component *un, gfc_expr *init)
10322 : : {
10323 : 21 : gfc_constructor *ctor;
10324 : :
10325 : 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
10326 : : return;
10327 : :
10328 : 21 : ctor = gfc_constructor_first (init->value.constructor);
10329 : :
10330 : 21 : if (ctor == NULL || ctor->expr == NULL)
10331 : : return;
10332 : :
10333 : 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
10334 : :
10335 : : /* If we have an 'initialize all' constructor, do it first. */
10336 : 21 : if (ctor->expr->expr_type == EXPR_NULL)
10337 : : {
10338 : 9 : tree union_type = TREE_TYPE (un->backend_decl);
10339 : 9 : tree val = build_constructor (union_type, NULL);
10340 : 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10341 : 9 : ctor = gfc_constructor_next (ctor);
10342 : : }
10343 : :
10344 : : /* Add the map initializer on top. */
10345 : 21 : if (ctor != NULL && ctor->expr != NULL)
10346 : : {
10347 : 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
10348 : 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
10349 : 12 : TREE_TYPE (un->backend_decl),
10350 : 12 : un->attr.dimension, un->attr.pointer,
10351 : 12 : un->attr.proc_pointer);
10352 : 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10353 : : }
10354 : : }
10355 : :
10356 : : /* Build an expression for a constructor. If init is nonzero then
10357 : : this is part of a static variable initializer. */
10358 : :
10359 : : void
10360 : 36876 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
10361 : : {
10362 : 36876 : gfc_constructor *c;
10363 : 36876 : gfc_component *cm;
10364 : 36876 : tree val;
10365 : 36876 : tree type;
10366 : 36876 : tree tmp;
10367 : 36876 : vec<constructor_elt, va_gc> *v = NULL;
10368 : :
10369 : 36876 : gcc_assert (se->ss == NULL);
10370 : 36876 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10371 : 36876 : type = gfc_typenode_for_spec (&expr->ts);
10372 : :
10373 : 36876 : if (!init)
10374 : : {
10375 : : /* Create a temporary variable and fill it in. */
10376 : 15172 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
10377 : : /* The symtree in expr is NULL, if the code to generate is for
10378 : : initializing the static members only. */
10379 : 30344 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
10380 : 15172 : se->want_coarray);
10381 : 15172 : gfc_add_expr_to_block (&se->pre, tmp);
10382 : 15172 : return;
10383 : : }
10384 : :
10385 : 21704 : cm = expr->ts.u.derived->components;
10386 : :
10387 : 21704 : for (c = gfc_constructor_first (expr->value.constructor);
10388 : 114665 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
10389 : : {
10390 : : /* Skip absent members in default initializers and allocatable
10391 : : components. Although the latter have a default initializer
10392 : : of EXPR_NULL,... by default, the static nullify is not needed
10393 : : since this is done every time we come into scope. */
10394 : 92961 : if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
10395 : 7800 : continue;
10396 : :
10397 : 85161 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
10398 : 49089 : && strcmp (cm->name, "_extends") == 0
10399 : 1260 : && cm->initializer->symtree)
10400 : : {
10401 : 1260 : tree vtab;
10402 : 1260 : gfc_symbol *vtabs;
10403 : 1260 : vtabs = cm->initializer->symtree->n.sym;
10404 : 1260 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
10405 : 1260 : vtab = unshare_expr_without_location (vtab);
10406 : 1260 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
10407 : 1260 : }
10408 : 83901 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
10409 : : {
10410 : 9275 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
10411 : 9275 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10412 : : fold_convert (TREE_TYPE (cm->backend_decl),
10413 : : val));
10414 : 9275 : }
10415 : 74626 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
10416 : 395 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10417 : : fold_convert (TREE_TYPE (cm->backend_decl),
10418 : 395 : integer_zero_node));
10419 : 74231 : else if (cm->ts.type == BT_UNION)
10420 : 21 : gfc_conv_union_initializer (v, cm, c->expr);
10421 : : else
10422 : : {
10423 : 74210 : val = gfc_conv_initializer (c->expr, &cm->ts,
10424 : 74210 : TREE_TYPE (cm->backend_decl),
10425 : : cm->attr.dimension, cm->attr.pointer,
10426 : 74210 : cm->attr.proc_pointer);
10427 : 74210 : val = unshare_expr_without_location (val);
10428 : :
10429 : : /* Append it to the constructor list. */
10430 : 167171 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
10431 : : }
10432 : : }
10433 : :
10434 : 21704 : se->expr = build_constructor (type, v);
10435 : 21704 : if (init)
10436 : 21704 : TREE_CONSTANT (se->expr) = 1;
10437 : : }
10438 : :
10439 : :
10440 : : /* Translate a substring expression. */
10441 : :
10442 : : static void
10443 : 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
10444 : : {
10445 : 258 : gfc_ref *ref;
10446 : :
10447 : 258 : ref = expr->ref;
10448 : :
10449 : 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
10450 : :
10451 : 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
10452 : 258 : expr->value.character.length,
10453 : 258 : expr->value.character.string);
10454 : :
10455 : 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
10456 : 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
10457 : :
10458 : 258 : if (ref)
10459 : 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
10460 : 258 : }
10461 : :
10462 : :
10463 : : /* Entry point for expression translation. Evaluates a scalar quantity.
10464 : : EXPR is the expression to be translated, and SE is the state structure if
10465 : : called from within the scalarized. */
10466 : :
10467 : : void
10468 : 3518546 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
10469 : : {
10470 : 3518546 : gfc_ss *ss;
10471 : :
10472 : 3518546 : ss = se->ss;
10473 : 3518546 : if (ss && ss->info->expr == expr
10474 : 230513 : && (ss->info->type == GFC_SS_SCALAR
10475 : : || ss->info->type == GFC_SS_REFERENCE))
10476 : : {
10477 : 38849 : gfc_ss_info *ss_info;
10478 : :
10479 : 38849 : ss_info = ss->info;
10480 : : /* Substitute a scalar expression evaluated outside the scalarization
10481 : : loop. */
10482 : 38849 : se->expr = ss_info->data.scalar.value;
10483 : 38849 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
10484 : 824 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
10485 : :
10486 : 38849 : se->string_length = ss_info->string_length;
10487 : 38849 : gfc_advance_se_ss_chain (se);
10488 : 38849 : return;
10489 : : }
10490 : :
10491 : : /* We need to convert the expressions for the iso_c_binding derived types.
10492 : : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
10493 : : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
10494 : : typespec for the C_PTR and C_FUNPTR symbols, which has already been
10495 : : updated to be an integer with a kind equal to the size of a (void *). */
10496 : 3479697 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
10497 : 15733 : && expr->ts.u.derived->attr.is_bind_c)
10498 : : {
10499 : 14896 : if (expr->expr_type == EXPR_VARIABLE
10500 : 10668 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
10501 : 10668 : || expr->symtree->n.sym->intmod_sym_id
10502 : : == ISOCBINDING_NULL_FUNPTR))
10503 : : {
10504 : : /* Set expr_type to EXPR_NULL, which will result in
10505 : : null_pointer_node being used below. */
10506 : 0 : expr->expr_type = EXPR_NULL;
10507 : : }
10508 : : else
10509 : : {
10510 : : /* Update the type/kind of the expression to be what the new
10511 : : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
10512 : 14896 : expr->ts.type = BT_INTEGER;
10513 : 14896 : expr->ts.f90_type = BT_VOID;
10514 : 14896 : expr->ts.kind = gfc_index_integer_kind;
10515 : : }
10516 : : }
10517 : :
10518 : 3479697 : gfc_fix_class_refs (expr);
10519 : :
10520 : 3479697 : switch (expr->expr_type)
10521 : : {
10522 : 491493 : case EXPR_OP:
10523 : 491493 : gfc_conv_expr_op (se, expr);
10524 : 491493 : break;
10525 : :
10526 : 79 : case EXPR_CONDITIONAL:
10527 : 79 : gfc_conv_conditional_expr (se, expr);
10528 : 79 : break;
10529 : :
10530 : 291808 : case EXPR_FUNCTION:
10531 : 291808 : gfc_conv_function_expr (se, expr);
10532 : 291808 : break;
10533 : :
10534 : 1098659 : case EXPR_CONSTANT:
10535 : 1098659 : gfc_conv_constant (se, expr);
10536 : 1098659 : break;
10537 : :
10538 : 1543533 : case EXPR_VARIABLE:
10539 : 1543533 : gfc_conv_variable (se, expr);
10540 : 1543533 : break;
10541 : :
10542 : 4007 : case EXPR_NULL:
10543 : 4007 : se->expr = null_pointer_node;
10544 : 4007 : break;
10545 : :
10546 : 258 : case EXPR_SUBSTRING:
10547 : 258 : gfc_conv_substring_expr (se, expr);
10548 : 258 : break;
10549 : :
10550 : 15172 : case EXPR_STRUCTURE:
10551 : 15172 : gfc_conv_structure (se, expr, 0);
10552 : : /* F2008 4.5.6.3 para 5: If an executable construct references a
10553 : : structure constructor or array constructor, the entity created by
10554 : : the constructor is finalized after execution of the innermost
10555 : : executable construct containing the reference. This, in fact,
10556 : : was later deleted by the Combined Techical Corrigenda 1 TO 4 for
10557 : : fortran 2008 (f08/0011). */
10558 : 15172 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
10559 : 15172 : && !(gfc_option.allow_std & GFC_STD_GNU)
10560 : 139 : && expr->must_finalize
10561 : 15184 : && gfc_may_be_finalized (expr->ts))
10562 : : {
10563 : 12 : locus loc;
10564 : 12 : gfc_locus_from_location (&loc, input_location);
10565 : 12 : gfc_warning (0, "The structure constructor at %L has been"
10566 : : " finalized. This feature was removed by f08/0011."
10567 : : " Use -std=f2018 or -std=gnu to eliminate the"
10568 : : " finalization.", &loc);
10569 : 12 : symbol_attribute attr;
10570 : 12 : attr.allocatable = attr.pointer = 0;
10571 : 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
10572 : 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
10573 : : }
10574 : : break;
10575 : :
10576 : 34688 : case EXPR_ARRAY:
10577 : 34688 : gfc_conv_array_constructor_expr (se, expr);
10578 : 34688 : gfc_add_block_to_block (&se->post, &se->finalblock);
10579 : 34688 : break;
10580 : :
10581 : 0 : default:
10582 : 0 : gcc_unreachable ();
10583 : 3518546 : break;
10584 : : }
10585 : : }
10586 : :
10587 : : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
10588 : : of an assignment. */
10589 : : void
10590 : 358164 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
10591 : : {
10592 : 358164 : gfc_conv_expr (se, expr);
10593 : : /* All numeric lvalues should have empty post chains. If not we need to
10594 : : figure out a way of rewriting an lvalue so that it has no post chain. */
10595 : 358164 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
10596 : 358164 : }
10597 : :
10598 : : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
10599 : : numeric expressions. Used for scalar values where inserting cleanup code
10600 : : is inconvenient. */
10601 : : void
10602 : 996409 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
10603 : : {
10604 : 996409 : tree val;
10605 : :
10606 : 996409 : gcc_assert (expr->ts.type != BT_CHARACTER);
10607 : 996409 : gfc_conv_expr (se, expr);
10608 : 996409 : if (se->post.head)
10609 : : {
10610 : 2437 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
10611 : 2437 : gfc_add_modify (&se->pre, val, se->expr);
10612 : 2437 : se->expr = val;
10613 : 2437 : gfc_add_block_to_block (&se->pre, &se->post);
10614 : : }
10615 : 996409 : }
10616 : :
10617 : : /* Helper to translate an expression and convert it to a particular type. */
10618 : : void
10619 : 276054 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
10620 : : {
10621 : 276054 : gfc_conv_expr_val (se, expr);
10622 : 276054 : se->expr = convert (type, se->expr);
10623 : 276054 : }
10624 : :
10625 : :
10626 : : /* Converts an expression so that it can be passed by reference. Scalar
10627 : : values only. */
10628 : :
10629 : : void
10630 : 221347 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
10631 : : {
10632 : 221347 : gfc_ss *ss;
10633 : 221347 : tree var;
10634 : :
10635 : 221347 : ss = se->ss;
10636 : 221347 : if (ss && ss->info->expr == expr
10637 : 7178 : && ss->info->type == GFC_SS_REFERENCE)
10638 : : {
10639 : : /* Returns a reference to the scalar evaluated outside the loop
10640 : : for this case. */
10641 : 906 : gfc_conv_expr (se, expr);
10642 : :
10643 : 906 : if (expr->ts.type == BT_CHARACTER
10644 : 114 : && expr->expr_type != EXPR_FUNCTION)
10645 : 102 : gfc_conv_string_parameter (se);
10646 : : else
10647 : 804 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10648 : :
10649 : 906 : return;
10650 : : }
10651 : :
10652 : 220441 : if (expr->ts.type == BT_CHARACTER)
10653 : : {
10654 : 48728 : gfc_conv_expr (se, expr);
10655 : 48728 : gfc_conv_string_parameter (se);
10656 : 48728 : return;
10657 : : }
10658 : :
10659 : 171713 : if (expr->expr_type == EXPR_VARIABLE)
10660 : : {
10661 : 68258 : se->want_pointer = 1;
10662 : 68258 : gfc_conv_expr (se, expr);
10663 : 68258 : if (se->post.head)
10664 : : {
10665 : 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10666 : 0 : gfc_add_modify (&se->pre, var, se->expr);
10667 : 0 : gfc_add_block_to_block (&se->pre, &se->post);
10668 : 0 : se->expr = var;
10669 : : }
10670 : 68258 : return;
10671 : : }
10672 : :
10673 : 103455 : if (expr->expr_type == EXPR_CONDITIONAL)
10674 : : {
10675 : 12 : se->want_pointer = 1;
10676 : 12 : gfc_conv_expr (se, expr);
10677 : 12 : return;
10678 : : }
10679 : :
10680 : 103443 : if (expr->expr_type == EXPR_FUNCTION
10681 : 13032 : && ((expr->value.function.esym
10682 : 2044 : && expr->value.function.esym->result
10683 : 2043 : && expr->value.function.esym->result->attr.pointer
10684 : 71 : && !expr->value.function.esym->result->attr.dimension)
10685 : 12967 : || (!expr->value.function.esym && !expr->ref
10686 : 10882 : && expr->symtree->n.sym->attr.pointer
10687 : 0 : && !expr->symtree->n.sym->attr.dimension)))
10688 : : {
10689 : 65 : se->want_pointer = 1;
10690 : 65 : gfc_conv_expr (se, expr);
10691 : 65 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10692 : 65 : gfc_add_modify (&se->pre, var, se->expr);
10693 : 65 : se->expr = var;
10694 : 65 : return;
10695 : : }
10696 : :
10697 : 103378 : gfc_conv_expr (se, expr);
10698 : :
10699 : : /* Create a temporary var to hold the value. */
10700 : 103378 : if (TREE_CONSTANT (se->expr))
10701 : : {
10702 : : tree tmp = se->expr;
10703 : 82447 : STRIP_TYPE_NOPS (tmp);
10704 : 82447 : var = build_decl (input_location,
10705 : 82447 : CONST_DECL, NULL, TREE_TYPE (tmp));
10706 : 82447 : DECL_INITIAL (var) = tmp;
10707 : 82447 : TREE_STATIC (var) = 1;
10708 : 82447 : pushdecl (var);
10709 : : }
10710 : : else
10711 : : {
10712 : 20931 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10713 : 20931 : gfc_add_modify (&se->pre, var, se->expr);
10714 : : }
10715 : :
10716 : 103378 : if (!expr->must_finalize)
10717 : 103282 : gfc_add_block_to_block (&se->pre, &se->post);
10718 : :
10719 : : /* Take the address of that value. */
10720 : 103378 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
10721 : : }
10722 : :
10723 : :
10724 : : /* Get the _len component for an unlimited polymorphic expression. */
10725 : :
10726 : : static tree
10727 : 1690 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
10728 : : {
10729 : 1690 : gfc_se se;
10730 : 1690 : gfc_ref *ref = expr->ref;
10731 : :
10732 : 1690 : gfc_init_se (&se, NULL);
10733 : 3494 : while (ref && ref->next)
10734 : : ref = ref->next;
10735 : 1690 : gfc_add_len_component (expr);
10736 : 1690 : gfc_conv_expr (&se, expr);
10737 : 1690 : gfc_add_block_to_block (block, &se.pre);
10738 : 1690 : gcc_assert (se.post.head == NULL_TREE);
10739 : 1690 : if (ref)
10740 : : {
10741 : 262 : gfc_free_ref_list (ref->next);
10742 : 262 : ref->next = NULL;
10743 : : }
10744 : : else
10745 : : {
10746 : 1428 : gfc_free_ref_list (expr->ref);
10747 : 1428 : expr->ref = NULL;
10748 : : }
10749 : 1690 : return se.expr;
10750 : : }
10751 : :
10752 : :
10753 : : /* Assign _vptr and _len components as appropriate. BLOCK should be a
10754 : : statement-list outside of the scalarizer-loop. When code is generated, that
10755 : : depends on the scalarized expression, it is added to RSE.PRE.
10756 : : Returns le's _vptr tree and when set the len expressions in to_lenp and
10757 : : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
10758 : : expression. */
10759 : :
10760 : : static tree
10761 : 4375 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
10762 : : gfc_expr * re, gfc_se *rse,
10763 : : tree * to_lenp, tree * from_lenp,
10764 : : tree * from_vptrp)
10765 : : {
10766 : 4375 : gfc_se se;
10767 : 4375 : gfc_expr * vptr_expr;
10768 : 4375 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
10769 : 4375 : bool set_vptr = false, temp_rhs = false;
10770 : 4375 : stmtblock_t *pre = block;
10771 : 4375 : tree class_expr = NULL_TREE;
10772 : 4375 : tree from_vptr = NULL_TREE;
10773 : :
10774 : : /* Create a temporary for complicated expressions. */
10775 : 4375 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
10776 : 1202 : && rse->expr != NULL_TREE)
10777 : : {
10778 : 1202 : if (!DECL_P (rse->expr))
10779 : : {
10780 : 354 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10781 : 37 : class_expr = gfc_get_class_from_expr (rse->expr);
10782 : :
10783 : 354 : if (rse->loop)
10784 : 111 : pre = &rse->loop->pre;
10785 : : else
10786 : 243 : pre = &rse->pre;
10787 : :
10788 : 354 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
10789 : 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
10790 : : else
10791 : 317 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
10792 : :
10793 : 354 : rse->expr = tmp;
10794 : : }
10795 : : else
10796 : 848 : pre = &rse->pre;
10797 : :
10798 : : temp_rhs = true;
10799 : : }
10800 : :
10801 : : /* Get the _vptr for the left-hand side expression. */
10802 : 4375 : gfc_init_se (&se, NULL);
10803 : 4375 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
10804 : 4375 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
10805 : : {
10806 : : /* Care about _len for unlimited polymorphic entities. */
10807 : 4357 : if (UNLIMITED_POLY (vptr_expr)
10808 : 3435 : || (vptr_expr->ts.type == BT_DERIVED
10809 : 2433 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10810 : 1406 : to_len = trans_get_upoly_len (block, vptr_expr);
10811 : 4357 : gfc_add_vptr_component (vptr_expr);
10812 : 4357 : set_vptr = true;
10813 : : }
10814 : : else
10815 : 18 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10816 : 4375 : se.want_pointer = 1;
10817 : 4375 : gfc_conv_expr (&se, vptr_expr);
10818 : 4375 : gfc_free_expr (vptr_expr);
10819 : 4375 : gfc_add_block_to_block (block, &se.pre);
10820 : 4375 : gcc_assert (se.post.head == NULL_TREE);
10821 : 4375 : lhs_vptr = se.expr;
10822 : 4375 : STRIP_NOPS (lhs_vptr);
10823 : :
10824 : : /* Set the _vptr only when the left-hand side of the assignment is a
10825 : : class-object. */
10826 : 4375 : if (set_vptr)
10827 : : {
10828 : : /* Get the vptr from the rhs expression only, when it is variable.
10829 : : Functions are expected to be assigned to a temporary beforehand. */
10830 : 3041 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
10831 : 5118 : ? gfc_find_and_cut_at_last_class_ref (re)
10832 : : : NULL;
10833 : 761 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
10834 : : {
10835 : 761 : if (to_len != NULL_TREE)
10836 : : {
10837 : : /* Get the _len information from the rhs. */
10838 : 299 : if (UNLIMITED_POLY (vptr_expr)
10839 : : || (vptr_expr->ts.type == BT_DERIVED
10840 : : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10841 : 272 : from_len = trans_get_upoly_len (block, vptr_expr);
10842 : : }
10843 : 761 : gfc_add_vptr_component (vptr_expr);
10844 : : }
10845 : : else
10846 : : {
10847 : 3596 : if (re->expr_type == EXPR_VARIABLE
10848 : 2280 : && DECL_P (re->symtree->n.sym->backend_decl)
10849 : 2280 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
10850 : 819 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
10851 : 3663 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
10852 : : re->symtree->n.sym->backend_decl))))
10853 : : {
10854 : 43 : vptr_expr = NULL;
10855 : 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
10856 : : re->symtree->n.sym->backend_decl));
10857 : 43 : if (to_len && UNLIMITED_POLY (re))
10858 : 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
10859 : : re->symtree->n.sym->backend_decl));
10860 : : }
10861 : 3553 : else if (temp_rhs && re->ts.type == BT_CLASS)
10862 : : {
10863 : 213 : vptr_expr = NULL;
10864 : 213 : if (class_expr)
10865 : : tmp = class_expr;
10866 : 176 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10867 : 0 : tmp = gfc_get_class_from_expr (rse->expr);
10868 : : else
10869 : : tmp = rse->expr;
10870 : :
10871 : 213 : se.expr = gfc_class_vptr_get (tmp);
10872 : 213 : from_vptr = se.expr;
10873 : 213 : if (UNLIMITED_POLY (re))
10874 : 73 : from_len = gfc_class_len_get (tmp);
10875 : :
10876 : : }
10877 : 3340 : else if (re->expr_type != EXPR_NULL)
10878 : : /* Only when rhs is non-NULL use its declared type for vptr
10879 : : initialisation. */
10880 : 3214 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
10881 : : else
10882 : : /* When the rhs is NULL use the vtab of lhs' declared type. */
10883 : 126 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10884 : : }
10885 : :
10886 : 4174 : if (vptr_expr)
10887 : : {
10888 : 4101 : gfc_init_se (&se, NULL);
10889 : 4101 : se.want_pointer = 1;
10890 : 4101 : gfc_conv_expr (&se, vptr_expr);
10891 : 4101 : gfc_free_expr (vptr_expr);
10892 : 4101 : gfc_add_block_to_block (block, &se.pre);
10893 : 4101 : gcc_assert (se.post.head == NULL_TREE);
10894 : 4101 : from_vptr = se.expr;
10895 : : }
10896 : 4357 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
10897 : : se.expr));
10898 : :
10899 : 4357 : if (to_len != NULL_TREE)
10900 : : {
10901 : : /* The _len component needs to be set. Figure how to get the
10902 : : value of the right-hand side. */
10903 : 1406 : if (from_len == NULL_TREE)
10904 : : {
10905 : 1061 : if (rse->string_length != NULL_TREE)
10906 : : from_len = rse->string_length;
10907 : 615 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
10908 : : {
10909 : 0 : gfc_init_se (&se, NULL);
10910 : 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
10911 : 0 : gfc_add_block_to_block (block, &se.pre);
10912 : 0 : gcc_assert (se.post.head == NULL_TREE);
10913 : 0 : from_len = gfc_evaluate_now (se.expr, block);
10914 : : }
10915 : : else
10916 : 615 : from_len = build_zero_cst (gfc_charlen_type_node);
10917 : : }
10918 : 1406 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
10919 : : from_len));
10920 : : }
10921 : : }
10922 : :
10923 : : /* Return the _len and _vptr trees only, when requested. */
10924 : 4375 : if (to_lenp)
10925 : 3225 : *to_lenp = to_len;
10926 : 4375 : if (from_lenp)
10927 : 3225 : *from_lenp = from_len;
10928 : 4375 : if (from_vptrp)
10929 : 3225 : *from_vptrp = from_vptr;
10930 : 4375 : return lhs_vptr;
10931 : : }
10932 : :
10933 : :
10934 : : /* Assign tokens for pointer components. */
10935 : :
10936 : : static void
10937 : 6 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
10938 : : gfc_expr *expr2)
10939 : : {
10940 : 6 : symbol_attribute lhs_attr, rhs_attr;
10941 : 6 : tree tmp, lhs_tok, rhs_tok;
10942 : : /* Flag to indicated component refs on the rhs. */
10943 : 6 : bool rhs_cr;
10944 : :
10945 : 6 : lhs_attr = gfc_caf_attr (expr1);
10946 : 6 : if (expr2->expr_type != EXPR_NULL)
10947 : : {
10948 : 4 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
10949 : 4 : if (lhs_attr.codimension && rhs_attr.codimension)
10950 : : {
10951 : 2 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
10952 : 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
10953 : :
10954 : 2 : if (rhs_cr)
10955 : 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
10956 : : else
10957 : : {
10958 : 2 : tree caf_decl;
10959 : 2 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
10960 : 2 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
10961 : : NULL_TREE, NULL);
10962 : : }
10963 : 2 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10964 : : lhs_tok,
10965 : 2 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
10966 : 2 : gfc_prepend_expr_to_block (&lse->post, tmp);
10967 : : }
10968 : : }
10969 : 2 : else if (lhs_attr.codimension)
10970 : : {
10971 : 2 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
10972 : 2 : if (!lhs_tok)
10973 : : {
10974 : 1 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
10975 : 1 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
10976 : : }
10977 : : else
10978 : 1 : lhs_tok = build_fold_indirect_ref (lhs_tok);
10979 : 2 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10980 : : lhs_tok, null_pointer_node);
10981 : 2 : gfc_prepend_expr_to_block (&lse->post, tmp);
10982 : : }
10983 : 6 : }
10984 : :
10985 : :
10986 : : /* Do everything that is needed for a CLASS function expr2. */
10987 : :
10988 : : static tree
10989 : 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
10990 : : gfc_expr *expr1, gfc_expr *expr2)
10991 : : {
10992 : 18 : tree expr1_vptr = NULL_TREE;
10993 : 18 : tree tmp;
10994 : :
10995 : 18 : gfc_conv_function_expr (rse, expr2);
10996 : 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
10997 : :
10998 : 18 : if (expr1->ts.type != BT_CLASS)
10999 : 12 : rse->expr = gfc_class_data_get (rse->expr);
11000 : : else
11001 : : {
11002 : 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11003 : : expr2, rse,
11004 : : NULL, NULL, NULL);
11005 : 6 : gfc_add_block_to_block (block, &rse->pre);
11006 : 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11007 : 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11008 : :
11009 : 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11010 : 6 : fold_convert (TREE_TYPE (expr1_vptr),
11011 : : gfc_class_vptr_get (tmp)));
11012 : 6 : rse->expr = gfc_class_data_get (tmp);
11013 : : }
11014 : :
11015 : 18 : return expr1_vptr;
11016 : : }
11017 : :
11018 : :
11019 : : tree
11020 : 9698 : gfc_trans_pointer_assign (gfc_code * code)
11021 : : {
11022 : 9698 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11023 : : }
11024 : :
11025 : :
11026 : : /* Generate code for a pointer assignment. */
11027 : :
11028 : : tree
11029 : 9753 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11030 : : {
11031 : 9753 : gfc_se lse;
11032 : 9753 : gfc_se rse;
11033 : 9753 : stmtblock_t block;
11034 : 9753 : tree desc;
11035 : 9753 : tree tmp;
11036 : 9753 : tree expr1_vptr = NULL_TREE;
11037 : 9753 : bool scalar, non_proc_ptr_assign;
11038 : 9753 : gfc_ss *ss;
11039 : :
11040 : 9753 : gfc_start_block (&block);
11041 : :
11042 : 9753 : gfc_init_se (&lse, NULL);
11043 : :
11044 : : /* Usually testing whether this is not a proc pointer assignment. */
11045 : 9753 : non_proc_ptr_assign
11046 : 9753 : = !(gfc_expr_attr (expr1).proc_pointer
11047 : 1177 : && ((expr2->expr_type == EXPR_VARIABLE
11048 : 946 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11049 : 281 : || expr2->expr_type == EXPR_NULL));
11050 : :
11051 : : /* Check whether the expression is a scalar or not; we cannot use
11052 : : expr1->rank as it can be nonzero for proc pointers. */
11053 : 9753 : ss = gfc_walk_expr (expr1);
11054 : 9753 : scalar = ss == gfc_ss_terminator;
11055 : 9753 : if (!scalar)
11056 : 4233 : gfc_free_ss_chain (ss);
11057 : :
11058 : 9753 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11059 : 90 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11060 : : {
11061 : 66 : gfc_add_data_component (expr2);
11062 : : /* The following is required as gfc_add_data_component doesn't
11063 : : update ts.type if there is a trailing REF_ARRAY. */
11064 : 66 : expr2->ts.type = BT_DERIVED;
11065 : : }
11066 : :
11067 : 9753 : if (scalar)
11068 : : {
11069 : : /* Scalar pointers. */
11070 : 5520 : lse.want_pointer = 1;
11071 : 5520 : gfc_conv_expr (&lse, expr1);
11072 : 5520 : gfc_init_se (&rse, NULL);
11073 : 5520 : rse.want_pointer = 1;
11074 : 5520 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11075 : 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11076 : : else
11077 : 5514 : gfc_conv_expr (&rse, expr2);
11078 : :
11079 : 5520 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11080 : : {
11081 : 763 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11082 : : NULL, NULL);
11083 : 763 : lse.expr = gfc_class_data_get (lse.expr);
11084 : : }
11085 : :
11086 : 5520 : if (expr1->symtree->n.sym->attr.proc_pointer
11087 : 850 : && expr1->symtree->n.sym->attr.dummy)
11088 : 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11089 : : lse.expr);
11090 : :
11091 : 5520 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11092 : 47 : && expr2->symtree->n.sym->attr.dummy)
11093 : 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11094 : : rse.expr);
11095 : :
11096 : 5520 : gfc_add_block_to_block (&block, &lse.pre);
11097 : 5520 : gfc_add_block_to_block (&block, &rse.pre);
11098 : :
11099 : : /* Check character lengths if character expression. The test is only
11100 : : really added if -fbounds-check is enabled. Exclude deferred
11101 : : character length lefthand sides. */
11102 : 921 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11103 : 747 : && !expr1->ts.deferred
11104 : 333 : && !expr1->symtree->n.sym->attr.proc_pointer
11105 : 5846 : && !gfc_is_proc_ptr_comp (expr1))
11106 : : {
11107 : 307 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11108 : 307 : gcc_assert (lse.string_length && rse.string_length);
11109 : 307 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11110 : : lse.string_length, rse.string_length,
11111 : : &block);
11112 : : }
11113 : :
11114 : : /* The assignment to an deferred character length sets the string
11115 : : length to that of the rhs. */
11116 : 5520 : if (expr1->ts.deferred)
11117 : : {
11118 : 529 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11119 : 412 : gfc_add_modify (&block, lse.string_length,
11120 : 412 : fold_convert (TREE_TYPE (lse.string_length),
11121 : : rse.string_length));
11122 : 117 : else if (lse.string_length != NULL)
11123 : 115 : gfc_add_modify (&block, lse.string_length,
11124 : 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11125 : : }
11126 : :
11127 : 5520 : gfc_add_modify (&block, lse.expr,
11128 : 5520 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11129 : :
11130 : 5520 : if (flag_coarray == GFC_FCOARRAY_LIB)
11131 : : {
11132 : 250 : if (expr1->ref)
11133 : : /* Also set the tokens for pointer components in derived typed
11134 : : coarrays. */
11135 : 6 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11136 : 244 : else if (gfc_caf_attr (expr1).codimension)
11137 : : {
11138 : 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11139 : :
11140 : 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11141 : 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11142 : 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11143 : : NULL_TREE, expr1);
11144 : 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11145 : : NULL_TREE, expr2);
11146 : 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11147 : : }
11148 : : }
11149 : :
11150 : 5520 : gfc_add_block_to_block (&block, &rse.post);
11151 : 5520 : gfc_add_block_to_block (&block, &lse.post);
11152 : : }
11153 : : else
11154 : : {
11155 : 4233 : gfc_ref* remap;
11156 : 4233 : bool rank_remap;
11157 : 4233 : tree strlen_lhs;
11158 : 4233 : tree strlen_rhs = NULL_TREE;
11159 : :
11160 : : /* Array pointer. Find the last reference on the LHS and if it is an
11161 : : array section ref, we're dealing with bounds remapping. In this case,
11162 : : set it to AR_FULL so that gfc_conv_expr_descriptor does
11163 : : not see it and process the bounds remapping afterwards explicitly. */
11164 : 13656 : for (remap = expr1->ref; remap; remap = remap->next)
11165 : 5521 : if (!remap->next && remap->type == REF_ARRAY
11166 : 4233 : && remap->u.ar.type == AR_SECTION)
11167 : : break;
11168 : 4233 : rank_remap = (remap && remap->u.ar.end[0]);
11169 : :
11170 : 331 : if (remap && expr2->expr_type == EXPR_NULL)
11171 : : {
11172 : 2 : gfc_error ("If bounds remapping is specified at %L, "
11173 : : "the pointer target shall not be NULL", &expr1->where);
11174 : 2 : return NULL_TREE;
11175 : : }
11176 : :
11177 : 4231 : gfc_init_se (&lse, NULL);
11178 : 4231 : if (remap)
11179 : 329 : lse.descriptor_only = 1;
11180 : 4231 : gfc_conv_expr_descriptor (&lse, expr1);
11181 : 4231 : strlen_lhs = lse.string_length;
11182 : 4231 : desc = lse.expr;
11183 : :
11184 : 4231 : if (expr2->expr_type == EXPR_NULL)
11185 : : {
11186 : : /* Just set the data pointer to null. */
11187 : 679 : gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
11188 : : }
11189 : 3552 : else if (rank_remap)
11190 : : {
11191 : : /* If we are rank-remapping, just get the RHS's descriptor and
11192 : : process this later on. */
11193 : 206 : gfc_init_se (&rse, NULL);
11194 : 206 : rse.direct_byref = 1;
11195 : 206 : rse.byref_noassign = 1;
11196 : :
11197 : 206 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11198 : 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11199 : : expr1, expr2);
11200 : 194 : else if (expr2->expr_type == EXPR_FUNCTION)
11201 : : {
11202 : : tree bound[GFC_MAX_DIMENSIONS];
11203 : : int i;
11204 : :
11205 : 26 : for (i = 0; i < expr2->rank; i++)
11206 : 13 : bound[i] = NULL_TREE;
11207 : 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11208 : 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11209 : : bound, bound, 0,
11210 : : GFC_ARRAY_POINTER_CONT, false);
11211 : 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11212 : 13 : rse.descriptor_only = 0;
11213 : 13 : rse.expr = tmp;
11214 : 13 : rse.direct_byref = 1;
11215 : 13 : gfc_conv_expr_descriptor (&rse, expr2);
11216 : 13 : strlen_rhs = rse.string_length;
11217 : 13 : rse.expr = tmp;
11218 : : }
11219 : : else
11220 : : {
11221 : 181 : gfc_conv_expr_descriptor (&rse, expr2);
11222 : 181 : strlen_rhs = rse.string_length;
11223 : 181 : if (expr1->ts.type == BT_CLASS)
11224 : 36 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11225 : : expr2, &rse,
11226 : : NULL, NULL,
11227 : : NULL);
11228 : : }
11229 : : }
11230 : 3346 : else if (expr2->expr_type == EXPR_VARIABLE)
11231 : : {
11232 : : /* Assign directly to the LHS's descriptor. */
11233 : 3214 : lse.descriptor_only = 0;
11234 : 3214 : lse.direct_byref = 1;
11235 : 3214 : gfc_conv_expr_descriptor (&lse, expr2);
11236 : 3214 : strlen_rhs = lse.string_length;
11237 : 3214 : gfc_init_se (&rse, NULL);
11238 : :
11239 : 3214 : if (expr1->ts.type == BT_CLASS)
11240 : : {
11241 : 332 : rse.expr = NULL_TREE;
11242 : 332 : rse.string_length = strlen_rhs;
11243 : 332 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11244 : : NULL, NULL, NULL);
11245 : : }
11246 : :
11247 : 3214 : if (remap == NULL)
11248 : : {
11249 : : /* If the target is not a whole array, use the target array
11250 : : reference for remap. */
11251 : 6649 : for (remap = expr2->ref; remap; remap = remap->next)
11252 : 3659 : if (remap->type == REF_ARRAY
11253 : 3151 : && remap->u.ar.type == AR_FULL
11254 : 2483 : && remap->next)
11255 : : break;
11256 : : }
11257 : : }
11258 : 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11259 : : {
11260 : 25 : gfc_init_se (&rse, NULL);
11261 : 25 : rse.want_pointer = 1;
11262 : 25 : gfc_conv_function_expr (&rse, expr2);
11263 : 25 : if (expr1->ts.type != BT_CLASS)
11264 : : {
11265 : 12 : rse.expr = gfc_class_data_get (rse.expr);
11266 : 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11267 : : }
11268 : : else
11269 : : {
11270 : 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11271 : : expr2, &rse, NULL,
11272 : : NULL, NULL);
11273 : 13 : gfc_add_block_to_block (&block, &rse.pre);
11274 : 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11275 : 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11276 : :
11277 : 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11278 : 13 : fold_convert (TREE_TYPE (expr1_vptr),
11279 : : gfc_class_vptr_get (tmp)));
11280 : 13 : rse.expr = gfc_class_data_get (tmp);
11281 : 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11282 : : }
11283 : : }
11284 : : else
11285 : : {
11286 : : /* Assign to a temporary descriptor and then copy that
11287 : : temporary to the pointer. */
11288 : 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11289 : 107 : lse.descriptor_only = 0;
11290 : 107 : lse.expr = tmp;
11291 : 107 : lse.direct_byref = 1;
11292 : 107 : gfc_conv_expr_descriptor (&lse, expr2);
11293 : 107 : strlen_rhs = lse.string_length;
11294 : 107 : gfc_add_modify (&lse.pre, desc, tmp);
11295 : : }
11296 : :
11297 : 4231 : if (expr1->ts.type == BT_CHARACTER
11298 : 572 : && expr1->ts.deferred)
11299 : : {
11300 : 326 : gfc_symbol *psym = expr1->symtree->n.sym;
11301 : 326 : tmp = NULL_TREE;
11302 : 326 : if (psym->ts.type == BT_CHARACTER
11303 : 325 : && psym->ts.u.cl->backend_decl)
11304 : 325 : tmp = psym->ts.u.cl->backend_decl;
11305 : 1 : else if (expr1->ts.u.cl->backend_decl
11306 : 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11307 : 0 : tmp = expr1->ts.u.cl->backend_decl;
11308 : 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11309 : : {
11310 : 1 : gfc_ref *ref = expr1->ref;
11311 : 3 : for (;ref; ref = ref->next)
11312 : : {
11313 : 2 : if (ref->type == REF_COMPONENT
11314 : 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11315 : 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11316 : 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11317 : 1 : TREE_TYPE (tmp),
11318 : 1 : TREE_OPERAND (lse.expr, 0),
11319 : : tmp, NULL_TREE);
11320 : : }
11321 : : }
11322 : :
11323 : 326 : gcc_assert (tmp);
11324 : :
11325 : 326 : if (expr2->expr_type != EXPR_NULL)
11326 : 314 : gfc_add_modify (&block, tmp,
11327 : 314 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
11328 : : else
11329 : 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
11330 : : }
11331 : :
11332 : 4231 : gfc_add_block_to_block (&block, &lse.pre);
11333 : 4231 : if (rank_remap)
11334 : 206 : gfc_add_block_to_block (&block, &rse.pre);
11335 : :
11336 : : /* If we do bounds remapping, update LHS descriptor accordingly. */
11337 : 4231 : if (remap)
11338 : : {
11339 : 430 : int dim;
11340 : 430 : gcc_assert (remap->u.ar.dimen == expr1->rank);
11341 : :
11342 : 430 : if (rank_remap)
11343 : : {
11344 : : /* Do rank remapping. We already have the RHS's descriptor
11345 : : converted in rse and now have to build the correct LHS
11346 : : descriptor for it. */
11347 : :
11348 : 206 : tree dtype, data, span;
11349 : 206 : tree offs, stride;
11350 : 206 : tree lbound, ubound;
11351 : :
11352 : : /* Set dtype. */
11353 : 206 : dtype = gfc_conv_descriptor_dtype (desc);
11354 : 206 : tmp = gfc_get_dtype (TREE_TYPE (desc));
11355 : 206 : gfc_add_modify (&block, dtype, tmp);
11356 : :
11357 : : /* Copy data pointer. */
11358 : 206 : data = gfc_conv_descriptor_data_get (rse.expr);
11359 : 206 : gfc_conv_descriptor_data_set (&block, desc, data);
11360 : :
11361 : : /* Copy the span. */
11362 : 206 : if (VAR_P (rse.expr)
11363 : 206 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
11364 : 12 : span = gfc_conv_descriptor_span_get (rse.expr);
11365 : : else
11366 : : {
11367 : 194 : tmp = TREE_TYPE (rse.expr);
11368 : 194 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
11369 : 194 : span = fold_convert (gfc_array_index_type, tmp);
11370 : : }
11371 : 206 : gfc_conv_descriptor_span_set (&block, desc, span);
11372 : :
11373 : : /* Copy offset but adjust it such that it would correspond
11374 : : to a lbound of zero. */
11375 : 206 : if (expr2->rank == -1)
11376 : 42 : gfc_conv_descriptor_offset_set (&block, desc,
11377 : : gfc_index_zero_node);
11378 : : else
11379 : : {
11380 : 164 : offs = gfc_conv_descriptor_offset_get (rse.expr);
11381 : 510 : for (dim = 0; dim < expr2->rank; ++dim)
11382 : : {
11383 : 182 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11384 : : gfc_rank_cst[dim]);
11385 : 182 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
11386 : : gfc_rank_cst[dim]);
11387 : 182 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11388 : : gfc_array_index_type, stride,
11389 : : lbound);
11390 : 182 : offs = fold_build2_loc (input_location, PLUS_EXPR,
11391 : : gfc_array_index_type, offs, tmp);
11392 : : }
11393 : 164 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11394 : : }
11395 : : /* Set the bounds as declared for the LHS and calculate strides as
11396 : : well as another offset update accordingly. */
11397 : 206 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11398 : : gfc_rank_cst[0]);
11399 : 545 : for (dim = 0; dim < expr1->rank; ++dim)
11400 : : {
11401 : 339 : gfc_se lower_se;
11402 : 339 : gfc_se upper_se;
11403 : :
11404 : 339 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
11405 : :
11406 : 339 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
11407 : : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
11408 : 339 : gfc_resolve_expr (remap->u.ar.start[dim]);
11409 : 339 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
11410 : : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
11411 : 339 : gfc_resolve_expr (remap->u.ar.end[dim]);
11412 : :
11413 : : /* Convert declared bounds. */
11414 : 339 : gfc_init_se (&lower_se, NULL);
11415 : 339 : gfc_init_se (&upper_se, NULL);
11416 : 339 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
11417 : 339 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
11418 : :
11419 : 339 : gfc_add_block_to_block (&block, &lower_se.pre);
11420 : 339 : gfc_add_block_to_block (&block, &upper_se.pre);
11421 : :
11422 : 339 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
11423 : 339 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
11424 : :
11425 : 339 : lbound = gfc_evaluate_now (lbound, &block);
11426 : 339 : ubound = gfc_evaluate_now (ubound, &block);
11427 : :
11428 : 339 : gfc_add_block_to_block (&block, &lower_se.post);
11429 : 339 : gfc_add_block_to_block (&block, &upper_se.post);
11430 : :
11431 : : /* Set bounds in descriptor. */
11432 : 339 : gfc_conv_descriptor_lbound_set (&block, desc,
11433 : : gfc_rank_cst[dim], lbound);
11434 : 339 : gfc_conv_descriptor_ubound_set (&block, desc,
11435 : : gfc_rank_cst[dim], ubound);
11436 : :
11437 : : /* Set stride. */
11438 : 339 : stride = gfc_evaluate_now (stride, &block);
11439 : 339 : gfc_conv_descriptor_stride_set (&block, desc,
11440 : : gfc_rank_cst[dim], stride);
11441 : :
11442 : : /* Update offset. */
11443 : 339 : offs = gfc_conv_descriptor_offset_get (desc);
11444 : 339 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11445 : : gfc_array_index_type, lbound, stride);
11446 : 339 : offs = fold_build2_loc (input_location, MINUS_EXPR,
11447 : : gfc_array_index_type, offs, tmp);
11448 : 339 : offs = gfc_evaluate_now (offs, &block);
11449 : 339 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11450 : :
11451 : : /* Update stride. */
11452 : 339 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11453 : 339 : stride = fold_build2_loc (input_location, MULT_EXPR,
11454 : : gfc_array_index_type, stride, tmp);
11455 : : }
11456 : : }
11457 : : else
11458 : : {
11459 : : /* Bounds remapping. Just shift the lower bounds. */
11460 : :
11461 : 224 : gcc_assert (expr1->rank == expr2->rank);
11462 : :
11463 : 556 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
11464 : : {
11465 : 332 : gfc_se lbound_se;
11466 : :
11467 : 332 : gcc_assert (!remap->u.ar.end[dim]);
11468 : 332 : gfc_init_se (&lbound_se, NULL);
11469 : 332 : if (remap->u.ar.start[dim])
11470 : : {
11471 : 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
11472 : 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
11473 : : }
11474 : : else
11475 : : /* This remap arises from a target that is not a whole
11476 : : array. The start expressions will be NULL but we need
11477 : : the lbounds to be one. */
11478 : 107 : lbound_se.expr = gfc_index_one_node;
11479 : 332 : gfc_conv_shift_descriptor_lbound (&block, desc,
11480 : : dim, lbound_se.expr);
11481 : 332 : gfc_add_block_to_block (&block, &lbound_se.post);
11482 : : }
11483 : : }
11484 : : }
11485 : :
11486 : : /* If rank remapping was done, check with -fcheck=bounds that
11487 : : the target is at least as large as the pointer. */
11488 : 4231 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
11489 : 72 : && expr2->rank != -1)
11490 : : {
11491 : 54 : tree lsize, rsize;
11492 : 54 : tree fault;
11493 : 54 : const char* msg;
11494 : :
11495 : 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
11496 : 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
11497 : :
11498 : 54 : lsize = gfc_evaluate_now (lsize, &block);
11499 : 54 : rsize = gfc_evaluate_now (rsize, &block);
11500 : 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11501 : : rsize, lsize);
11502 : :
11503 : 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
11504 : 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
11505 : : msg, rsize, lsize);
11506 : : }
11507 : :
11508 : : /* Check string lengths if applicable. The check is only really added
11509 : : to the output code if -fbounds-check is enabled. */
11510 : 4231 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
11511 : : {
11512 : 506 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11513 : 506 : gcc_assert (strlen_lhs && strlen_rhs);
11514 : 506 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11515 : : strlen_lhs, strlen_rhs, &block);
11516 : : }
11517 : :
11518 : 4231 : gfc_add_block_to_block (&block, &lse.post);
11519 : 4231 : if (rank_remap)
11520 : 206 : gfc_add_block_to_block (&block, &rse.post);
11521 : : }
11522 : :
11523 : 9751 : return gfc_finish_block (&block);
11524 : : }
11525 : :
11526 : :
11527 : : /* Makes sure se is suitable for passing as a function string parameter. */
11528 : : /* TODO: Need to check all callers of this function. It may be abused. */
11529 : :
11530 : : void
11531 : 232422 : gfc_conv_string_parameter (gfc_se * se)
11532 : : {
11533 : 232422 : tree type;
11534 : :
11535 : 232422 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
11536 : 232422 : && integer_onep (se->string_length))
11537 : : {
11538 : 667 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11539 : 667 : return;
11540 : : }
11541 : :
11542 : 231755 : if (TREE_CODE (se->expr) == STRING_CST)
11543 : : {
11544 : 97457 : type = TREE_TYPE (TREE_TYPE (se->expr));
11545 : 97457 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11546 : 97457 : return;
11547 : : }
11548 : :
11549 : 134298 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
11550 : 52225 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
11551 : 134394 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
11552 : : {
11553 : 82169 : type = TREE_TYPE (se->expr);
11554 : 82169 : if (TREE_CODE (se->expr) != INDIRECT_REF)
11555 : 77294 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11556 : : else
11557 : : {
11558 : 4875 : if (TREE_CODE (type) == ARRAY_TYPE)
11559 : 4875 : type = TREE_TYPE (type);
11560 : 4875 : type = gfc_get_character_type_len_for_eltype (type,
11561 : : se->string_length);
11562 : 4875 : type = build_pointer_type (type);
11563 : 4875 : se->expr = gfc_build_addr_expr (type, se->expr);
11564 : : }
11565 : : }
11566 : :
11567 : 134298 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
11568 : : }
11569 : :
11570 : :
11571 : : /* Generate code for assignment of scalar variables. Includes character
11572 : : strings and derived types with allocatable components.
11573 : : If you know that the LHS has no allocations, set dealloc to false.
11574 : :
11575 : : DEEP_COPY has no effect if the typespec TS is not a derived type with
11576 : : allocatable components. Otherwise, if it is set, an explicit copy of each
11577 : : allocatable component is made. This is necessary as a simple copy of the
11578 : : whole object would copy array descriptors as is, so that the lhs's
11579 : : allocatable components would point to the rhs's after the assignment.
11580 : : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
11581 : : necessary if the rhs is a non-pointer function, as the allocatable components
11582 : : are not accessible by other means than the function's result after the
11583 : : function has returned. It is even more subtle when temporaries are involved,
11584 : : as the two following examples show:
11585 : : 1. When we evaluate an array constructor, a temporary is created. Thus
11586 : : there is theoretically no alias possible. However, no deep copy is
11587 : : made for this temporary, so that if the constructor is made of one or
11588 : : more variable with allocatable components, those components still point
11589 : : to the variable's: DEEP_COPY should be set for the assignment from the
11590 : : temporary to the lhs in that case.
11591 : : 2. When assigning a scalar to an array, we evaluate the scalar value out
11592 : : of the loop, store it into a temporary variable, and assign from that.
11593 : : In that case, deep copying when assigning to the temporary would be a
11594 : : waste of resources; however deep copies should happen when assigning from
11595 : : the temporary to each array element: again DEEP_COPY should be set for
11596 : : the assignment from the temporary to the lhs. */
11597 : :
11598 : : tree
11599 : 325202 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
11600 : : bool deep_copy, bool dealloc, bool in_coarray,
11601 : : bool assoc_assign)
11602 : : {
11603 : 325202 : stmtblock_t block;
11604 : 325202 : tree tmp;
11605 : 325202 : tree cond;
11606 : :
11607 : 325202 : gfc_init_block (&block);
11608 : :
11609 : 325202 : if (ts.type == BT_CHARACTER)
11610 : : {
11611 : 31376 : tree rlen = NULL;
11612 : 31376 : tree llen = NULL;
11613 : :
11614 : 31376 : if (lse->string_length != NULL_TREE)
11615 : : {
11616 : 31376 : gfc_conv_string_parameter (lse);
11617 : 31376 : gfc_add_block_to_block (&block, &lse->pre);
11618 : 31376 : llen = lse->string_length;
11619 : : }
11620 : :
11621 : 31376 : if (rse->string_length != NULL_TREE)
11622 : : {
11623 : 31376 : gfc_conv_string_parameter (rse);
11624 : 31376 : gfc_add_block_to_block (&block, &rse->pre);
11625 : 31376 : rlen = rse->string_length;
11626 : : }
11627 : :
11628 : 31376 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
11629 : : rse->expr, ts.kind);
11630 : : }
11631 : 293826 : else if (gfc_bt_struct (ts.type)
11632 : 17349 : && (ts.u.derived->attr.alloc_comp
11633 : 11736 : || (deep_copy && ts.u.derived->attr.pdt_type)))
11634 : : {
11635 : 5757 : tree tmp_var = NULL_TREE;
11636 : 5757 : cond = NULL_TREE;
11637 : :
11638 : : /* Are the rhs and the lhs the same? */
11639 : 5757 : if (deep_copy)
11640 : : {
11641 : 3337 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11642 : : gfc_build_addr_expr (NULL_TREE, lse->expr),
11643 : : gfc_build_addr_expr (NULL_TREE, rse->expr));
11644 : 3337 : cond = gfc_evaluate_now (cond, &lse->pre);
11645 : : }
11646 : :
11647 : : /* Deallocate the lhs allocated components as long as it is not
11648 : : the same as the rhs. This must be done following the assignment
11649 : : to prevent deallocating data that could be used in the rhs
11650 : : expression. */
11651 : 5757 : if (dealloc)
11652 : : {
11653 : 1614 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
11654 : 1614 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
11655 : 1614 : 0, gfc_may_be_finalized (ts));
11656 : 1614 : if (deep_copy)
11657 : 647 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11658 : : tmp);
11659 : 1614 : gfc_add_expr_to_block (&lse->post, tmp);
11660 : : }
11661 : :
11662 : 5757 : gfc_add_block_to_block (&block, &rse->pre);
11663 : 5757 : gfc_add_block_to_block (&block, &lse->finalblock);
11664 : 5757 : gfc_add_block_to_block (&block, &lse->pre);
11665 : :
11666 : 5757 : gfc_add_modify (&block, lse->expr,
11667 : 5757 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11668 : :
11669 : : /* Restore pointer address of coarray components. */
11670 : 5757 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
11671 : : {
11672 : 4 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
11673 : 4 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11674 : : tmp);
11675 : 4 : gfc_add_expr_to_block (&block, tmp);
11676 : : }
11677 : :
11678 : : /* Do a deep copy if the rhs is a variable, if it is not the
11679 : : same as the lhs. */
11680 : 5757 : if (deep_copy)
11681 : : {
11682 : 3337 : int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11683 : : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
11684 : 3337 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
11685 : : caf_mode);
11686 : 3337 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11687 : : tmp);
11688 : 3337 : gfc_add_expr_to_block (&block, tmp);
11689 : : }
11690 : : }
11691 : 288069 : else if (gfc_bt_struct (ts.type))
11692 : : {
11693 : 11592 : gfc_add_block_to_block (&block, &rse->pre);
11694 : 11592 : gfc_add_block_to_block (&block, &lse->finalblock);
11695 : 11592 : gfc_add_block_to_block (&block, &lse->pre);
11696 : 11592 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11697 : 11592 : TREE_TYPE (lse->expr), rse->expr);
11698 : 11592 : gfc_add_modify (&block, lse->expr, tmp);
11699 : : }
11700 : : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
11701 : 276477 : else if (ts.type == BT_CLASS)
11702 : : {
11703 : 758 : gfc_add_block_to_block (&block, &lse->pre);
11704 : 758 : gfc_add_block_to_block (&block, &rse->pre);
11705 : 758 : gfc_add_block_to_block (&block, &lse->finalblock);
11706 : :
11707 : 758 : if (!trans_scalar_class_assign (&block, lse, rse))
11708 : : {
11709 : : /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
11710 : : for the lhs which ensures that class data rhs cast as a string assigns
11711 : : correctly. */
11712 : 624 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11713 : 624 : TREE_TYPE (rse->expr), lse->expr);
11714 : 624 : gfc_add_modify (&block, tmp, rse->expr);
11715 : : }
11716 : : }
11717 : 275719 : else if (ts.type != BT_CLASS)
11718 : : {
11719 : 275719 : gfc_add_block_to_block (&block, &lse->pre);
11720 : 275719 : gfc_add_block_to_block (&block, &rse->pre);
11721 : :
11722 : 275719 : if (in_coarray)
11723 : : {
11724 : 683 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
11725 : : {
11726 : 0 : gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr),
11727 : 0 : TYPE_LANG_SPECIFIC (
11728 : : TREE_TYPE (TREE_TYPE (rse->expr)))
11729 : : ->caf_token);
11730 : : }
11731 : 683 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
11732 : 0 : lse->expr = gfc_conv_array_data (lse->expr);
11733 : 270 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
11734 : 683 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
11735 : 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
11736 : : }
11737 : 275719 : gfc_add_modify (&block, lse->expr,
11738 : 275719 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11739 : : }
11740 : :
11741 : 325202 : gfc_add_block_to_block (&block, &lse->post);
11742 : 325202 : gfc_add_block_to_block (&block, &rse->post);
11743 : :
11744 : 325202 : return gfc_finish_block (&block);
11745 : : }
11746 : :
11747 : :
11748 : : /* There are quite a lot of restrictions on the optimisation in using an
11749 : : array function assign without a temporary. */
11750 : :
11751 : : static bool
11752 : 14602 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
11753 : : {
11754 : 14602 : gfc_ref * ref;
11755 : 14602 : bool seen_array_ref;
11756 : 14602 : bool c = false;
11757 : 14602 : gfc_symbol *sym = expr1->symtree->n.sym;
11758 : :
11759 : : /* Play it safe with class functions assigned to a derived type. */
11760 : 14602 : if (gfc_is_class_array_function (expr2)
11761 : 14602 : && expr1->ts.type == BT_DERIVED)
11762 : : return true;
11763 : :
11764 : : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
11765 : 14578 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
11766 : : return true;
11767 : :
11768 : : /* Elemental functions are scalarized so that they don't need a
11769 : : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
11770 : : they would need special treatment in gfc_trans_arrayfunc_assign. */
11771 : 8718 : if (expr2->value.function.esym != NULL
11772 : 1514 : && expr2->value.function.esym->attr.elemental)
11773 : : return true;
11774 : :
11775 : : /* Need a temporary if rhs is not FULL or a contiguous section. */
11776 : 8378 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
11777 : : return true;
11778 : :
11779 : : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
11780 : 8135 : if (gfc_ref_needs_temporary_p (expr1->ref))
11781 : : return true;
11782 : :
11783 : : /* Functions returning pointers or allocatables need temporaries. */
11784 : 8123 : if (gfc_expr_attr (expr2).pointer
11785 : 8123 : || gfc_expr_attr (expr2).allocatable)
11786 : 381 : return true;
11787 : :
11788 : : /* Character array functions need temporaries unless the
11789 : : character lengths are the same. */
11790 : 7742 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
11791 : : {
11792 : 562 : if (UNLIMITED_POLY (expr1))
11793 : : return true;
11794 : :
11795 : 556 : if (expr1->ts.u.cl->length == NULL
11796 : 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11797 : : return true;
11798 : :
11799 : 493 : if (expr2->ts.u.cl->length == NULL
11800 : 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11801 : : return true;
11802 : :
11803 : 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
11804 : 475 : expr2->ts.u.cl->length->value.integer) != 0)
11805 : : return true;
11806 : : }
11807 : :
11808 : : /* Check that no LHS component references appear during an array
11809 : : reference. This is needed because we do not have the means to
11810 : : span any arbitrary stride with an array descriptor. This check
11811 : : is not needed for the rhs because the function result has to be
11812 : : a complete type. */
11813 : 7649 : seen_array_ref = false;
11814 : 15298 : for (ref = expr1->ref; ref; ref = ref->next)
11815 : : {
11816 : 7662 : if (ref->type == REF_ARRAY)
11817 : : seen_array_ref= true;
11818 : 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
11819 : : return true;
11820 : : }
11821 : :
11822 : : /* Check for a dependency. */
11823 : 7636 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
11824 : : expr2->value.function.esym,
11825 : : expr2->value.function.actual,
11826 : : NOT_ELEMENTAL))
11827 : : return true;
11828 : :
11829 : : /* If we have reached here with an intrinsic function, we do not
11830 : : need a temporary except in the particular case that reallocation
11831 : : on assignment is active and the lhs is allocatable and a target,
11832 : : or a pointer which may be a subref pointer. FIXME: The last
11833 : : condition can go away when we use span in the intrinsics
11834 : : directly.*/
11835 : 7199 : if (expr2->value.function.isym)
11836 : 6364 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
11837 : 12815 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
11838 : :
11839 : : /* If the LHS is a dummy, we need a temporary if it is not
11840 : : INTENT(OUT). */
11841 : 760 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
11842 : : return true;
11843 : :
11844 : : /* If the lhs has been host_associated, is in common, a pointer or is
11845 : : a target and the function is not using a RESULT variable, aliasing
11846 : : can occur and a temporary is needed. */
11847 : 754 : if ((sym->attr.host_assoc
11848 : 700 : || sym->attr.in_common
11849 : 694 : || sym->attr.pointer
11850 : 688 : || sym->attr.cray_pointee
11851 : 688 : || sym->attr.target)
11852 : 66 : && expr2->symtree != NULL
11853 : 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
11854 : : return true;
11855 : :
11856 : : /* A PURE function can unconditionally be called without a temporary. */
11857 : 712 : if (expr2->value.function.esym != NULL
11858 : 687 : && expr2->value.function.esym->attr.pure)
11859 : : return false;
11860 : :
11861 : : /* Implicit_pure functions are those which could legally be declared
11862 : : to be PURE. */
11863 : 684 : if (expr2->value.function.esym != NULL
11864 : 659 : && expr2->value.function.esym->attr.implicit_pure)
11865 : : return false;
11866 : :
11867 : 408 : if (!sym->attr.use_assoc
11868 : 408 : && !sym->attr.in_common
11869 : 408 : && !sym->attr.pointer
11870 : 402 : && !sym->attr.target
11871 : 402 : && !sym->attr.cray_pointee
11872 : 402 : && expr2->value.function.esym)
11873 : : {
11874 : : /* A temporary is not needed if the function is not contained and
11875 : : the variable is local or host associated and not a pointer or
11876 : : a target. */
11877 : 377 : if (!expr2->value.function.esym->attr.contained)
11878 : : return false;
11879 : :
11880 : : /* A temporary is not needed if the lhs has never been host
11881 : : associated and the procedure is contained. */
11882 : 146 : else if (!sym->attr.host_assoc)
11883 : : return false;
11884 : :
11885 : : /* A temporary is not needed if the variable is local and not
11886 : : a pointer, a target or a result. */
11887 : 6 : if (sym->ns->parent
11888 : 0 : && expr2->value.function.esym->ns == sym->ns->parent)
11889 : : return false;
11890 : : }
11891 : :
11892 : : /* Default to temporary use. */
11893 : : return true;
11894 : : }
11895 : :
11896 : :
11897 : : /* Provide the loop info so that the lhs descriptor can be built for
11898 : : reallocatable assignments from extrinsic function calls. */
11899 : :
11900 : : static void
11901 : 166 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
11902 : : gfc_loopinfo *loop)
11903 : : {
11904 : : /* Signal that the function call should not be made by
11905 : : gfc_conv_loop_setup. */
11906 : 166 : se->ss->is_alloc_lhs = 1;
11907 : 166 : gfc_init_loopinfo (loop);
11908 : 166 : gfc_add_ss_to_loop (loop, *ss);
11909 : 166 : gfc_add_ss_to_loop (loop, se->ss);
11910 : 166 : gfc_conv_ss_startstride (loop);
11911 : 166 : gfc_conv_loop_setup (loop, where);
11912 : 166 : gfc_copy_loopinfo_to_se (se, loop);
11913 : 166 : gfc_add_block_to_block (&se->pre, &loop->pre);
11914 : 166 : gfc_add_block_to_block (&se->pre, &loop->post);
11915 : 166 : se->ss->is_alloc_lhs = 0;
11916 : 166 : }
11917 : :
11918 : :
11919 : : /* For assignment to a reallocatable lhs from intrinsic functions,
11920 : : replace the se.expr (ie. the result) with a temporary descriptor.
11921 : : Null the data field so that the library allocates space for the
11922 : : result. Free the data of the original descriptor after the function,
11923 : : in case it appears in an argument expression and transfer the
11924 : : result to the original descriptor. */
11925 : :
11926 : : static void
11927 : 2109 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
11928 : : {
11929 : 2109 : tree desc;
11930 : 2109 : tree res_desc;
11931 : 2109 : tree tmp;
11932 : 2109 : tree offset;
11933 : 2109 : tree zero_cond;
11934 : 2109 : tree not_same_shape;
11935 : 2109 : stmtblock_t shape_block;
11936 : 2109 : int n;
11937 : :
11938 : : /* Use the allocation done by the library. Substitute the lhs
11939 : : descriptor with a copy, whose data field is nulled.*/
11940 : 2109 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
11941 : 2109 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
11942 : 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
11943 : :
11944 : : /* Unallocated, the descriptor does not have a dtype. */
11945 : 2109 : tmp = gfc_conv_descriptor_dtype (desc);
11946 : 2109 : if (dtype != NULL_TREE)
11947 : 13 : gfc_add_modify (&se->pre, tmp, dtype);
11948 : : else
11949 : 2096 : gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
11950 : :
11951 : 2109 : res_desc = gfc_evaluate_now (desc, &se->pre);
11952 : 2109 : gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
11953 : 2109 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
11954 : :
11955 : : /* Free the lhs after the function call and copy the result data to
11956 : : the lhs descriptor. */
11957 : 2109 : tmp = gfc_conv_descriptor_data_get (desc);
11958 : 2109 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
11959 : : logical_type_node, tmp,
11960 : 2109 : build_int_cst (TREE_TYPE (tmp), 0));
11961 : 2109 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
11962 : 2109 : tmp = gfc_call_free (tmp);
11963 : 2109 : gfc_add_expr_to_block (&se->post, tmp);
11964 : :
11965 : 2109 : tmp = gfc_conv_descriptor_data_get (res_desc);
11966 : 2109 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
11967 : :
11968 : : /* Check that the shapes are the same between lhs and expression.
11969 : : The evaluation of the shape is done in 'shape_block' to avoid
11970 : : unitialized warnings from the lhs bounds. */
11971 : 2109 : not_same_shape = boolean_false_node;
11972 : 2109 : gfc_start_block (&shape_block);
11973 : 6801 : for (n = 0 ; n < rank; n++)
11974 : : {
11975 : 4692 : tree tmp1;
11976 : 4692 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11977 : 4692 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
11978 : 4692 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11979 : : gfc_array_index_type, tmp, tmp1);
11980 : 4692 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
11981 : 4692 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11982 : : gfc_array_index_type, tmp, tmp1);
11983 : 4692 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
11984 : 4692 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11985 : : gfc_array_index_type, tmp, tmp1);
11986 : 4692 : tmp = fold_build2_loc (input_location, NE_EXPR,
11987 : : logical_type_node, tmp,
11988 : : gfc_index_zero_node);
11989 : 4692 : tmp = gfc_evaluate_now (tmp, &shape_block);
11990 : 4692 : if (n == 0)
11991 : : not_same_shape = tmp;
11992 : : else
11993 : 2583 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11994 : : logical_type_node, tmp,
11995 : : not_same_shape);
11996 : : }
11997 : :
11998 : : /* 'zero_cond' being true is equal to lhs not being allocated or the
11999 : : shapes being different. */
12000 : 2109 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12001 : : zero_cond, not_same_shape);
12002 : 2109 : gfc_add_modify (&shape_block, zero_cond, tmp);
12003 : 2109 : tmp = gfc_finish_block (&shape_block);
12004 : 2109 : tmp = build3_v (COND_EXPR, zero_cond,
12005 : : build_empty_stmt (input_location), tmp);
12006 : 2109 : gfc_add_expr_to_block (&se->post, tmp);
12007 : :
12008 : : /* Now reset the bounds returned from the function call to bounds based
12009 : : on the lhs lbounds, except where the lhs is not allocated or the shapes
12010 : : of 'variable and 'expr' are different. Set the offset accordingly. */
12011 : 2109 : offset = gfc_index_zero_node;
12012 : 6801 : for (n = 0 ; n < rank; n++)
12013 : : {
12014 : 4692 : tree lbound;
12015 : :
12016 : 4692 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12017 : 4692 : lbound = fold_build3_loc (input_location, COND_EXPR,
12018 : : gfc_array_index_type, zero_cond,
12019 : : gfc_index_one_node, lbound);
12020 : 4692 : lbound = gfc_evaluate_now (lbound, &se->post);
12021 : :
12022 : 4692 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12023 : 4692 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12024 : : gfc_array_index_type, tmp, lbound);
12025 : 4692 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12026 : : gfc_rank_cst[n], lbound);
12027 : 4692 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12028 : : gfc_rank_cst[n], tmp);
12029 : :
12030 : : /* Set stride and accumulate the offset. */
12031 : 4692 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12032 : 4692 : gfc_conv_descriptor_stride_set (&se->post, desc,
12033 : : gfc_rank_cst[n], tmp);
12034 : 4692 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12035 : : gfc_array_index_type, lbound, tmp);
12036 : 4692 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12037 : : gfc_array_index_type, offset, tmp);
12038 : 4692 : offset = gfc_evaluate_now (offset, &se->post);
12039 : : }
12040 : :
12041 : 2109 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12042 : 2109 : }
12043 : :
12044 : :
12045 : :
12046 : : /* Try to translate array(:) = func (...), where func is a transformational
12047 : : array function, without using a temporary. Returns NULL if this isn't the
12048 : : case. */
12049 : :
12050 : : static tree
12051 : 14602 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12052 : : {
12053 : 14602 : gfc_se se;
12054 : 14602 : gfc_ss *ss = NULL;
12055 : 14602 : gfc_component *comp = NULL;
12056 : 14602 : gfc_loopinfo loop;
12057 : 14602 : tree tmp;
12058 : 14602 : tree lhs;
12059 : 14602 : gfc_se final_se;
12060 : 14602 : gfc_symbol *sym = expr1->symtree->n.sym;
12061 : 14602 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12062 : :
12063 : 14602 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12064 : : return NULL;
12065 : :
12066 : : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12067 : : functions. */
12068 : 7081 : comp = gfc_get_proc_ptr_comp (expr2);
12069 : :
12070 : 7081 : if (!(expr2->value.function.isym
12071 : 675 : || (comp && comp->attr.dimension)
12072 : 675 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12073 : 675 : && expr2->value.function.esym->result->attr.dimension)))
12074 : 0 : return NULL;
12075 : :
12076 : 7081 : gfc_init_se (&se, NULL);
12077 : 7081 : gfc_start_block (&se.pre);
12078 : 7081 : se.want_pointer = 1;
12079 : :
12080 : : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12081 : : backend decl, stash the original away for the finalization so that the
12082 : : value used is that before the assignment. This is necessary because
12083 : : evaluation of the rhs expression using direct by reference can change
12084 : : the value. However, the standard mandates that the finalization must occur
12085 : : after evaluation of the rhs. */
12086 : 7081 : gfc_init_se (&final_se, NULL);
12087 : :
12088 : 7081 : if (finalizable)
12089 : : {
12090 : 33 : tmp = sym->backend_decl;
12091 : 33 : lhs = sym->backend_decl;
12092 : 33 : if (INDIRECT_REF_P (tmp))
12093 : 0 : tmp = TREE_OPERAND (tmp, 0);
12094 : 33 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12095 : 33 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12096 : 33 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12097 : : {
12098 : 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12099 : : expr1->rank, 0);
12100 : 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12101 : : }
12102 : : }
12103 : :
12104 : 33 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12105 : : {
12106 : 33 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12107 : 33 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12108 : : }
12109 : :
12110 : 7081 : if (finalizable)
12111 : 33 : sym->backend_decl = lhs;
12112 : :
12113 : 7081 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12114 : :
12115 : 7081 : if (expr1->ts.type == BT_DERIVED
12116 : 228 : && expr1->ts.u.derived->attr.alloc_comp)
12117 : : {
12118 : 80 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12119 : 80 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12120 : : expr1->rank);
12121 : 80 : gfc_add_expr_to_block (&se.pre, tmp);
12122 : : }
12123 : :
12124 : 7081 : se.direct_byref = 1;
12125 : 7081 : se.ss = gfc_walk_expr (expr2);
12126 : 7081 : gcc_assert (se.ss != gfc_ss_terminator);
12127 : :
12128 : : /* Since this is a direct by reference call, references to the lhs can be
12129 : : used for finalization of the function result just as long as the blocks
12130 : : from final_se are added at the right time. */
12131 : 7081 : gfc_init_se (&final_se, NULL);
12132 : 7081 : if (finalizable && expr2->value.function.esym)
12133 : : {
12134 : 20 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12135 : 20 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12136 : 20 : expr2->value.function.esym->attr,
12137 : : expr2->rank);
12138 : : }
12139 : :
12140 : : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12141 : : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12142 : : Clearly, this cannot be done for an allocatable function result, since
12143 : : the shape of the result is unknown and, in any case, the function must
12144 : : correctly take care of the reallocation internally. For intrinsic
12145 : : calls, the array data is freed and the library takes care of allocation.
12146 : : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12147 : : to the library. */
12148 : 7081 : if (flag_realloc_lhs
12149 : 7006 : && gfc_is_reallocatable_lhs (expr1)
12150 : 9356 : && !gfc_expr_attr (expr1).codimension
12151 : 2275 : && !gfc_is_coindexed (expr1)
12152 : 9356 : && !(expr2->value.function.esym
12153 : 166 : && expr2->value.function.esym->result->attr.allocatable))
12154 : : {
12155 : 2275 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12156 : :
12157 : 2275 : if (!expr2->value.function.isym)
12158 : : {
12159 : 166 : ss = gfc_walk_expr (expr1);
12160 : 166 : gcc_assert (ss != gfc_ss_terminator);
12161 : :
12162 : 166 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12163 : 166 : ss->is_alloc_lhs = 1;
12164 : : }
12165 : : else
12166 : : {
12167 : 2109 : tree dtype = NULL_TREE;
12168 : 2109 : tree type = gfc_typenode_for_spec (&expr2->ts);
12169 : 2109 : if (expr1->ts.type == BT_CLASS)
12170 : : {
12171 : 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12172 : 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12173 : 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12174 : 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12175 : 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12176 : : }
12177 : 2109 : fcncall_realloc_result (&se, expr1->rank, dtype);
12178 : : }
12179 : : }
12180 : :
12181 : 7081 : gfc_conv_function_expr (&se, expr2);
12182 : :
12183 : : /* Fix the result. */
12184 : 7081 : gfc_add_block_to_block (&se.pre, &se.post);
12185 : 7081 : if (finalizable)
12186 : 33 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12187 : :
12188 : : /* Do the finalization, including final calls from function arguments. */
12189 : 33 : if (finalizable)
12190 : : {
12191 : 33 : gfc_add_block_to_block (&se.pre, &final_se.post);
12192 : 33 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12193 : 33 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12194 : : }
12195 : :
12196 : 7081 : if (ss)
12197 : 166 : gfc_cleanup_loop (&loop);
12198 : : else
12199 : 6915 : gfc_free_ss_chain (se.ss);
12200 : :
12201 : 7081 : return gfc_finish_block (&se.pre);
12202 : : }
12203 : :
12204 : :
12205 : : /* Try to efficiently translate array(:) = 0. Return NULL if this
12206 : : can't be done. */
12207 : :
12208 : : static tree
12209 : 3925 : gfc_trans_zero_assign (gfc_expr * expr)
12210 : : {
12211 : 3925 : tree dest, len, type;
12212 : 3925 : tree tmp;
12213 : 3925 : gfc_symbol *sym;
12214 : :
12215 : 3925 : sym = expr->symtree->n.sym;
12216 : 3925 : dest = gfc_get_symbol_decl (sym);
12217 : :
12218 : 3925 : type = TREE_TYPE (dest);
12219 : 3925 : if (POINTER_TYPE_P (type))
12220 : 248 : type = TREE_TYPE (type);
12221 : 3925 : if (GFC_ARRAY_TYPE_P (type))
12222 : : {
12223 : : /* Determine the length of the array. */
12224 : 2750 : len = GFC_TYPE_ARRAY_SIZE (type);
12225 : 2750 : if (!len || TREE_CODE (len) != INTEGER_CST)
12226 : : return NULL_TREE;
12227 : : }
12228 : 1175 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12229 : 1175 : && gfc_is_simply_contiguous (expr, false, false))
12230 : : {
12231 : 1075 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12232 : 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12233 : 1075 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12234 : 1075 : dest = gfc_conv_descriptor_data_get (dest);
12235 : : }
12236 : : else
12237 : 100 : return NULL_TREE;
12238 : :
12239 : : /* If we are zeroing a local array avoid taking its address by emitting
12240 : : a = {} instead. */
12241 : 3646 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12242 : 2529 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12243 : 2529 : dest, build_constructor (TREE_TYPE (dest),
12244 : 2529 : NULL));
12245 : :
12246 : : /* Multiply len by element size. */
12247 : 1117 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12248 : 1117 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12249 : : len, fold_convert (gfc_array_index_type, tmp));
12250 : :
12251 : : /* Convert arguments to the correct types. */
12252 : 1117 : dest = fold_convert (pvoid_type_node, dest);
12253 : 1117 : len = fold_convert (size_type_node, len);
12254 : :
12255 : : /* Construct call to __builtin_memset. */
12256 : 1117 : tmp = build_call_expr_loc (input_location,
12257 : : builtin_decl_explicit (BUILT_IN_MEMSET),
12258 : : 3, dest, integer_zero_node, len);
12259 : 1117 : return fold_convert (void_type_node, tmp);
12260 : : }
12261 : :
12262 : :
12263 : : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
12264 : : that constructs the call to __builtin_memcpy. */
12265 : :
12266 : : tree
12267 : 7086 : gfc_build_memcpy_call (tree dst, tree src, tree len)
12268 : : {
12269 : 7086 : tree tmp;
12270 : :
12271 : : /* Convert arguments to the correct types. */
12272 : 7086 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
12273 : 6853 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
12274 : : else
12275 : 233 : dst = fold_convert (pvoid_type_node, dst);
12276 : :
12277 : 7086 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
12278 : 6752 : src = gfc_build_addr_expr (pvoid_type_node, src);
12279 : : else
12280 : 334 : src = fold_convert (pvoid_type_node, src);
12281 : :
12282 : 7086 : len = fold_convert (size_type_node, len);
12283 : :
12284 : : /* Construct call to __builtin_memcpy. */
12285 : 7086 : tmp = build_call_expr_loc (input_location,
12286 : : builtin_decl_explicit (BUILT_IN_MEMCPY),
12287 : : 3, dst, src, len);
12288 : 7086 : return fold_convert (void_type_node, tmp);
12289 : : }
12290 : :
12291 : :
12292 : : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
12293 : : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
12294 : : source/rhs, both are gfc_full_array_ref_p which have been checked for
12295 : : dependencies. */
12296 : :
12297 : : static tree
12298 : 2503 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
12299 : : {
12300 : 2503 : tree dst, dlen, dtype;
12301 : 2503 : tree src, slen, stype;
12302 : 2503 : tree tmp;
12303 : :
12304 : 2503 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12305 : 2503 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
12306 : :
12307 : 2503 : dtype = TREE_TYPE (dst);
12308 : 2503 : if (POINTER_TYPE_P (dtype))
12309 : 223 : dtype = TREE_TYPE (dtype);
12310 : 2503 : stype = TREE_TYPE (src);
12311 : 2503 : if (POINTER_TYPE_P (stype))
12312 : 265 : stype = TREE_TYPE (stype);
12313 : :
12314 : 2503 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
12315 : : return NULL_TREE;
12316 : :
12317 : : /* Determine the lengths of the arrays. */
12318 : 1533 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
12319 : 1533 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
12320 : : return NULL_TREE;
12321 : 1444 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12322 : 1444 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12323 : : dlen, fold_convert (gfc_array_index_type, tmp));
12324 : :
12325 : 1444 : slen = GFC_TYPE_ARRAY_SIZE (stype);
12326 : 1444 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
12327 : : return NULL_TREE;
12328 : 1438 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
12329 : 1438 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12330 : : slen, fold_convert (gfc_array_index_type, tmp));
12331 : :
12332 : : /* Sanity check that they are the same. This should always be
12333 : : the case, as we should already have checked for conformance. */
12334 : 1438 : if (!tree_int_cst_equal (slen, dlen))
12335 : : return NULL_TREE;
12336 : :
12337 : 1438 : return gfc_build_memcpy_call (dst, src, dlen);
12338 : : }
12339 : :
12340 : :
12341 : : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
12342 : : this can't be done. EXPR1 is the destination/lhs for which
12343 : : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
12344 : :
12345 : : static tree
12346 : 7520 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
12347 : : {
12348 : 7520 : unsigned HOST_WIDE_INT nelem;
12349 : 7520 : tree dst, dtype;
12350 : 7520 : tree src, stype;
12351 : 7520 : tree len;
12352 : 7520 : tree tmp;
12353 : :
12354 : 7520 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
12355 : 7520 : if (nelem == 0)
12356 : : return NULL_TREE;
12357 : :
12358 : 5890 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12359 : 5890 : dtype = TREE_TYPE (dst);
12360 : 5890 : if (POINTER_TYPE_P (dtype))
12361 : 252 : dtype = TREE_TYPE (dtype);
12362 : 5890 : if (!GFC_ARRAY_TYPE_P (dtype))
12363 : : return NULL_TREE;
12364 : :
12365 : : /* Determine the lengths of the array. */
12366 : 5202 : len = GFC_TYPE_ARRAY_SIZE (dtype);
12367 : 5202 : if (!len || TREE_CODE (len) != INTEGER_CST)
12368 : : return NULL_TREE;
12369 : :
12370 : : /* Confirm that the constructor is the same size. */
12371 : 5104 : if (compare_tree_int (len, nelem) != 0)
12372 : : return NULL_TREE;
12373 : :
12374 : 5104 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12375 : 5104 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
12376 : : fold_convert (gfc_array_index_type, tmp));
12377 : :
12378 : 5104 : stype = gfc_typenode_for_spec (&expr2->ts);
12379 : 5104 : src = gfc_build_constant_array_constructor (expr2, stype);
12380 : :
12381 : 5104 : return gfc_build_memcpy_call (dst, src, len);
12382 : : }
12383 : :
12384 : :
12385 : : /* Tells whether the expression is to be treated as a variable reference. */
12386 : :
12387 : : bool
12388 : 301849 : gfc_expr_is_variable (gfc_expr *expr)
12389 : : {
12390 : 302109 : gfc_expr *arg;
12391 : 302109 : gfc_component *comp;
12392 : 302109 : gfc_symbol *func_ifc;
12393 : :
12394 : 302109 : if (expr->expr_type == EXPR_VARIABLE)
12395 : : return true;
12396 : :
12397 : 268921 : arg = gfc_get_noncopying_intrinsic_argument (expr);
12398 : 268921 : if (arg)
12399 : : {
12400 : 260 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
12401 : : return gfc_expr_is_variable (arg);
12402 : : }
12403 : :
12404 : : /* A data-pointer-returning function should be considered as a variable
12405 : : too. */
12406 : 268661 : if (expr->expr_type == EXPR_FUNCTION
12407 : 35559 : && expr->ref == NULL)
12408 : : {
12409 : 35192 : if (expr->value.function.isym != NULL)
12410 : : return false;
12411 : :
12412 : 9117 : if (expr->value.function.esym != NULL)
12413 : : {
12414 : 9108 : func_ifc = expr->value.function.esym;
12415 : 9108 : goto found_ifc;
12416 : : }
12417 : 9 : gcc_assert (expr->symtree);
12418 : 9 : func_ifc = expr->symtree->n.sym;
12419 : 9 : goto found_ifc;
12420 : : }
12421 : :
12422 : 233469 : comp = gfc_get_proc_ptr_comp (expr);
12423 : 233469 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
12424 : 367 : && comp)
12425 : : {
12426 : 265 : func_ifc = comp->ts.interface;
12427 : 265 : goto found_ifc;
12428 : : }
12429 : :
12430 : 233204 : if (expr->expr_type == EXPR_COMPCALL)
12431 : : {
12432 : 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
12433 : 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
12434 : 0 : goto found_ifc;
12435 : : }
12436 : :
12437 : : return false;
12438 : :
12439 : 9382 : found_ifc:
12440 : 9382 : gcc_assert (func_ifc->attr.function
12441 : : && func_ifc->result != NULL);
12442 : 9382 : return func_ifc->result->attr.pointer;
12443 : : }
12444 : :
12445 : :
12446 : : /* Is the lhs OK for automatic reallocation? */
12447 : :
12448 : : static bool
12449 : 256649 : is_scalar_reallocatable_lhs (gfc_expr *expr)
12450 : : {
12451 : 256649 : gfc_ref * ref;
12452 : :
12453 : : /* An allocatable variable with no reference. */
12454 : 256649 : if (expr->symtree->n.sym->attr.allocatable
12455 : 6615 : && !expr->ref)
12456 : : return true;
12457 : :
12458 : : /* All that can be left are allocatable components. However, we do
12459 : : not check for allocatable components here because the expression
12460 : : could be an allocatable component of a pointer component. */
12461 : 253961 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
12462 : 232942 : && expr->symtree->n.sym->ts.type != BT_CLASS)
12463 : : return false;
12464 : :
12465 : : /* Find an allocatable component ref last. */
12466 : 37418 : for (ref = expr->ref; ref; ref = ref->next)
12467 : 15406 : if (ref->type == REF_COMPONENT
12468 : 11471 : && !ref->next
12469 : 8968 : && ref->u.c.component->attr.allocatable)
12470 : : return true;
12471 : :
12472 : : return false;
12473 : : }
12474 : :
12475 : :
12476 : : /* Allocate or reallocate scalar lhs, as necessary. */
12477 : :
12478 : : static void
12479 : 3427 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
12480 : : tree string_length,
12481 : : gfc_expr *expr1,
12482 : : gfc_expr *expr2)
12483 : :
12484 : : {
12485 : 3427 : tree cond;
12486 : 3427 : tree tmp;
12487 : 3427 : tree size;
12488 : 3427 : tree size_in_bytes;
12489 : 3427 : tree jump_label1;
12490 : 3427 : tree jump_label2;
12491 : 3427 : gfc_se lse;
12492 : 3427 : gfc_ref *ref;
12493 : :
12494 : 3427 : if (!expr1 || expr1->rank)
12495 : 0 : return;
12496 : :
12497 : 3427 : if (!expr2 || expr2->rank)
12498 : : return;
12499 : :
12500 : 4654 : for (ref = expr1->ref; ref; ref = ref->next)
12501 : 1227 : if (ref->type == REF_SUBSTRING)
12502 : : return;
12503 : :
12504 : 3427 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
12505 : :
12506 : : /* Since this is a scalar lhs, we can afford to do this. That is,
12507 : : there is no risk of side effects being repeated. */
12508 : 3427 : gfc_init_se (&lse, NULL);
12509 : 3427 : lse.want_pointer = 1;
12510 : 3427 : gfc_conv_expr (&lse, expr1);
12511 : :
12512 : 3427 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12513 : 3427 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12514 : :
12515 : : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
12516 : 3427 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
12517 : 3427 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
12518 : : lse.expr, tmp);
12519 : 3427 : tmp = build3_v (COND_EXPR, cond,
12520 : : build1_v (GOTO_EXPR, jump_label1),
12521 : : build_empty_stmt (input_location));
12522 : 3427 : gfc_add_expr_to_block (block, tmp);
12523 : :
12524 : 3427 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12525 : : {
12526 : : /* Use the rhs string length and the lhs element size. Note that 'size' is
12527 : : used below for the string-length comparison, only. */
12528 : 1395 : size = string_length;
12529 : 1395 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12530 : 2790 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
12531 : 1395 : TREE_TYPE (tmp), tmp,
12532 : 1395 : fold_convert (TREE_TYPE (tmp), size));
12533 : : }
12534 : : else
12535 : : {
12536 : : /* Otherwise use the length in bytes of the rhs. */
12537 : 2032 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
12538 : 2032 : size_in_bytes = size;
12539 : : }
12540 : :
12541 : 3427 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12542 : : size_in_bytes, size_one_node);
12543 : :
12544 : 3427 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
12545 : : {
12546 : 31 : tree caf_decl, token;
12547 : 31 : gfc_se caf_se;
12548 : 31 : symbol_attribute attr;
12549 : :
12550 : 31 : gfc_clear_attr (&attr);
12551 : 31 : gfc_init_se (&caf_se, NULL);
12552 : :
12553 : 31 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
12554 : 31 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
12555 : : NULL);
12556 : 31 : gfc_add_block_to_block (block, &caf_se.pre);
12557 : 31 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
12558 : : gfc_build_addr_expr (NULL_TREE, token),
12559 : : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
12560 : : expr1, 1);
12561 : : }
12562 : 3396 : else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
12563 : : {
12564 : 36 : tmp = build_call_expr_loc (input_location,
12565 : : builtin_decl_explicit (BUILT_IN_CALLOC),
12566 : : 2, build_one_cst (size_type_node),
12567 : : size_in_bytes);
12568 : 36 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12569 : 36 : gfc_add_modify (block, lse.expr, tmp);
12570 : : }
12571 : : else
12572 : : {
12573 : 3360 : tmp = build_call_expr_loc (input_location,
12574 : : builtin_decl_explicit (BUILT_IN_MALLOC),
12575 : : 1, size_in_bytes);
12576 : 3360 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12577 : 3360 : gfc_add_modify (block, lse.expr, tmp);
12578 : : }
12579 : :
12580 : 3427 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12581 : : {
12582 : : /* Deferred characters need checking for lhs and rhs string
12583 : : length. Other deferred parameter variables will have to
12584 : : come here too. */
12585 : 1395 : tmp = build1_v (GOTO_EXPR, jump_label2);
12586 : 1395 : gfc_add_expr_to_block (block, tmp);
12587 : : }
12588 : 3427 : tmp = build1_v (LABEL_EXPR, jump_label1);
12589 : 3427 : gfc_add_expr_to_block (block, tmp);
12590 : :
12591 : : /* For a deferred length character, reallocate if lengths of lhs and
12592 : : rhs are different. */
12593 : 3427 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12594 : : {
12595 : 1395 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12596 : : lse.string_length,
12597 : 1395 : fold_convert (TREE_TYPE (lse.string_length),
12598 : : size));
12599 : : /* Jump past the realloc if the lengths are the same. */
12600 : 1395 : tmp = build3_v (COND_EXPR, cond,
12601 : : build1_v (GOTO_EXPR, jump_label2),
12602 : : build_empty_stmt (input_location));
12603 : 1395 : gfc_add_expr_to_block (block, tmp);
12604 : 1395 : tmp = build_call_expr_loc (input_location,
12605 : : builtin_decl_explicit (BUILT_IN_REALLOC),
12606 : : 2, fold_convert (pvoid_type_node, lse.expr),
12607 : : size_in_bytes);
12608 : 1395 : tree omp_cond = NULL_TREE;
12609 : 1395 : if (flag_openmp_allocators)
12610 : : {
12611 : 1 : tree omp_tmp;
12612 : 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
12613 : 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
12614 : :
12615 : 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12616 : 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12617 : : fold_convert (pvoid_type_node,
12618 : : lse.expr), size_in_bytes,
12619 : : build_zero_cst (ptr_type_node),
12620 : : build_zero_cst (ptr_type_node));
12621 : 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
12622 : : omp_cond, omp_tmp, tmp);
12623 : : }
12624 : 1395 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12625 : 1395 : gfc_add_modify (block, lse.expr, tmp);
12626 : 1395 : if (omp_cond)
12627 : 1 : gfc_add_expr_to_block (block,
12628 : : build3_loc (input_location, COND_EXPR,
12629 : : void_type_node, omp_cond,
12630 : : gfc_omp_call_add_alloc (lse.expr),
12631 : : build_empty_stmt (input_location)));
12632 : 1395 : tmp = build1_v (LABEL_EXPR, jump_label2);
12633 : 1395 : gfc_add_expr_to_block (block, tmp);
12634 : :
12635 : : /* Update the lhs character length. */
12636 : 1395 : size = string_length;
12637 : 1395 : gfc_add_modify (block, lse.string_length,
12638 : 1395 : fold_convert (TREE_TYPE (lse.string_length), size));
12639 : : }
12640 : : }
12641 : :
12642 : : /* Check for assignments of the type
12643 : :
12644 : : a = a + 4
12645 : :
12646 : : to make sure we do not check for reallocation unneccessarily. */
12647 : :
12648 : :
12649 : : static bool
12650 : 6529 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
12651 : : {
12652 : 6842 : gfc_actual_arglist *a;
12653 : 6842 : gfc_expr *e1, *e2;
12654 : :
12655 : 6842 : switch (expr2->expr_type)
12656 : : {
12657 : 1807 : case EXPR_VARIABLE:
12658 : 1807 : return gfc_dep_compare_expr (expr1, expr2) == 0;
12659 : :
12660 : 2796 : case EXPR_FUNCTION:
12661 : 2796 : if (expr2->value.function.esym
12662 : 269 : && expr2->value.function.esym->attr.elemental)
12663 : : {
12664 : 51 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12665 : : {
12666 : 50 : e1 = a->expr;
12667 : 50 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12668 : : return false;
12669 : : }
12670 : : return true;
12671 : : }
12672 : 2758 : else if (expr2->value.function.isym
12673 : 2513 : && expr2->value.function.isym->elemental)
12674 : : {
12675 : 330 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12676 : : {
12677 : 320 : e1 = a->expr;
12678 : 320 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12679 : : return false;
12680 : : }
12681 : : return true;
12682 : : }
12683 : :
12684 : : break;
12685 : :
12686 : 507 : case EXPR_OP:
12687 : 507 : switch (expr2->value.op.op)
12688 : : {
12689 : 34 : case INTRINSIC_NOT:
12690 : 34 : case INTRINSIC_UPLUS:
12691 : 34 : case INTRINSIC_UMINUS:
12692 : 34 : case INTRINSIC_PARENTHESES:
12693 : 34 : return is_runtime_conformable (expr1, expr2->value.op.op1);
12694 : :
12695 : 448 : case INTRINSIC_PLUS:
12696 : 448 : case INTRINSIC_MINUS:
12697 : 448 : case INTRINSIC_TIMES:
12698 : 448 : case INTRINSIC_DIVIDE:
12699 : 448 : case INTRINSIC_POWER:
12700 : 448 : case INTRINSIC_AND:
12701 : 448 : case INTRINSIC_OR:
12702 : 448 : case INTRINSIC_EQV:
12703 : 448 : case INTRINSIC_NEQV:
12704 : 448 : case INTRINSIC_EQ:
12705 : 448 : case INTRINSIC_NE:
12706 : 448 : case INTRINSIC_GT:
12707 : 448 : case INTRINSIC_GE:
12708 : 448 : case INTRINSIC_LT:
12709 : 448 : case INTRINSIC_LE:
12710 : 448 : case INTRINSIC_EQ_OS:
12711 : 448 : case INTRINSIC_NE_OS:
12712 : 448 : case INTRINSIC_GT_OS:
12713 : 448 : case INTRINSIC_GE_OS:
12714 : 448 : case INTRINSIC_LT_OS:
12715 : 448 : case INTRINSIC_LE_OS:
12716 : :
12717 : 448 : e1 = expr2->value.op.op1;
12718 : 448 : e2 = expr2->value.op.op2;
12719 : :
12720 : 448 : if (e1->rank == 0 && e2->rank > 0)
12721 : : return is_runtime_conformable (expr1, e2);
12722 : 390 : else if (e1->rank > 0 && e2->rank == 0)
12723 : : return is_runtime_conformable (expr1, e1);
12724 : 169 : else if (e1->rank > 0 && e2->rank > 0)
12725 : 169 : return is_runtime_conformable (expr1, e1)
12726 : 169 : && is_runtime_conformable (expr1, e2);
12727 : : break;
12728 : :
12729 : : default:
12730 : : break;
12731 : :
12732 : : }
12733 : :
12734 : : break;
12735 : :
12736 : : default:
12737 : : break;
12738 : : }
12739 : : return false;
12740 : : }
12741 : :
12742 : :
12743 : : static tree
12744 : 3225 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
12745 : : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
12746 : : bool class_realloc)
12747 : : {
12748 : 3225 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
12749 : 3225 : vec<tree, va_gc> *args = NULL;
12750 : 3225 : bool final_expr;
12751 : :
12752 : 3225 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
12753 : 3225 : if (final_expr)
12754 : : {
12755 : 438 : if (rse->loop)
12756 : 178 : gfc_prepend_expr_to_block (&rse->loop->pre,
12757 : : gfc_finish_block (&lse->finalblock));
12758 : : else
12759 : 260 : gfc_add_block_to_block (block, &lse->finalblock);
12760 : : }
12761 : :
12762 : : /* Store the old vptr so that dynamic types can be compared for
12763 : : reallocation to occur or not. */
12764 : 3225 : if (class_realloc)
12765 : : {
12766 : 302 : tmp = lse->expr;
12767 : 302 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
12768 : 18 : tmp = gfc_get_class_from_expr (tmp);
12769 : : }
12770 : :
12771 : 3225 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
12772 : : &from_len, &rhs_vptr);
12773 : 3225 : if (rhs_vptr == NULL_TREE)
12774 : 61 : rhs_vptr = vptr;
12775 : :
12776 : : /* Generate (re)allocation of the lhs. */
12777 : 3225 : if (class_realloc)
12778 : : {
12779 : 302 : stmtblock_t alloc, re_alloc;
12780 : 302 : tree class_han, re, size;
12781 : :
12782 : 302 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
12783 : 284 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
12784 : : else
12785 : 18 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
12786 : :
12787 : 302 : size = gfc_vptr_size_get (rhs_vptr);
12788 : :
12789 : : /* Take into account _len of unlimited polymorphic entities.
12790 : : TODO: handle class(*) allocatable function results on rhs. */
12791 : 302 : if (UNLIMITED_POLY (rhs))
12792 : : {
12793 : 18 : tree len;
12794 : 18 : if (rhs->expr_type == EXPR_VARIABLE)
12795 : 12 : len = trans_get_upoly_len (block, rhs);
12796 : : else
12797 : 6 : len = gfc_class_len_get (tmp);
12798 : 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12799 : : fold_convert (size_type_node, len),
12800 : : size_one_node);
12801 : 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
12802 : 18 : size, fold_convert (TREE_TYPE (size), len));
12803 : 18 : }
12804 : 284 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
12805 : 27 : size = fold_build2_loc (input_location, MULT_EXPR,
12806 : : gfc_charlen_type_node, size,
12807 : : rse->string_length);
12808 : :
12809 : :
12810 : 302 : tmp = lse->expr;
12811 : 302 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
12812 : 302 : ? gfc_class_data_get (tmp) : tmp;
12813 : :
12814 : 302 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
12815 : 18 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
12816 : :
12817 : : /* Allocate block. */
12818 : 302 : gfc_init_block (&alloc);
12819 : 302 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
12820 : :
12821 : : /* Reallocate if dynamic types are different. */
12822 : 302 : gfc_init_block (&re_alloc);
12823 : 302 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
12824 : : {
12825 : 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
12826 : 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
12827 : : }
12828 : : else
12829 : : {
12830 : 275 : tmp = fold_convert (pvoid_type_node, class_han);
12831 : 275 : re = build_call_expr_loc (input_location,
12832 : : builtin_decl_explicit (BUILT_IN_REALLOC),
12833 : : 2, tmp, size);
12834 : 275 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
12835 : : tmp, re);
12836 : 275 : tmp = fold_build2_loc (input_location, NE_EXPR,
12837 : : logical_type_node, rhs_vptr, old_vptr);
12838 : 275 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
12839 : : tmp, re, build_empty_stmt (input_location));
12840 : 275 : gfc_add_expr_to_block (&re_alloc, re);
12841 : : }
12842 : 302 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
12843 : 284 : gfc_finish_block (&re_alloc) :
12844 : 18 : build_empty_stmt (input_location);
12845 : :
12846 : : /* Allocate if _data is NULL, reallocate otherwise. */
12847 : 302 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12848 : : logical_type_node, class_han,
12849 : : build_int_cst (prvoid_type_node, 0));
12850 : 302 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
12851 : : gfc_unlikely (tmp,
12852 : : PRED_FORTRAN_FAIL_ALLOC),
12853 : : gfc_finish_block (&alloc),
12854 : : realloc_expr);
12855 : 302 : gfc_add_expr_to_block (&lse->pre, tmp);
12856 : : }
12857 : :
12858 : 3225 : fcn = gfc_vptr_copy_get (vptr);
12859 : :
12860 : 3225 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
12861 : 3225 : ? gfc_class_data_get (rse->expr) : rse->expr;
12862 : 3225 : if (use_vptr_copy)
12863 : : {
12864 : 5428 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
12865 : 524 : || INDIRECT_REF_P (tmp)
12866 : 403 : || (rhs->ts.type == BT_DERIVED
12867 : 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
12868 : 0 : && !rhs->ts.u.derived->attr.pointer
12869 : 0 : && !rhs->ts.u.derived->attr.allocatable)
12870 : 3376 : || (UNLIMITED_POLY (rhs)
12871 : 134 : && !CLASS_DATA (rhs)->attr.pointer
12872 : 43 : && !CLASS_DATA (rhs)->attr.allocatable))
12873 : 2570 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
12874 : : else
12875 : 403 : vec_safe_push (args, tmp);
12876 : 2973 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
12877 : 2973 : ? gfc_class_data_get (lse->expr) : lse->expr;
12878 : 5213 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
12879 : 733 : || INDIRECT_REF_P (tmp)
12880 : 284 : || (lhs->ts.type == BT_DERIVED
12881 : 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
12882 : 0 : && !lhs->ts.u.derived->attr.pointer
12883 : 0 : && !lhs->ts.u.derived->attr.allocatable)
12884 : 3257 : || (UNLIMITED_POLY (lhs)
12885 : 119 : && !CLASS_DATA (lhs)->attr.pointer
12886 : 119 : && !CLASS_DATA (lhs)->attr.allocatable))
12887 : 2689 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
12888 : : else
12889 : 284 : vec_safe_push (args, tmp);
12890 : :
12891 : 2973 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
12892 : :
12893 : 2973 : if (to_len != NULL_TREE && !integer_zerop (from_len))
12894 : : {
12895 : 406 : tree extcopy;
12896 : 406 : vec_safe_push (args, from_len);
12897 : 406 : vec_safe_push (args, to_len);
12898 : 406 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
12899 : :
12900 : 406 : tmp = fold_build2_loc (input_location, GT_EXPR,
12901 : : logical_type_node, from_len,
12902 : 406 : build_zero_cst (TREE_TYPE (from_len)));
12903 : 406 : return fold_build3_loc (input_location, COND_EXPR,
12904 : : void_type_node, tmp,
12905 : 406 : extcopy, stdcopy);
12906 : : }
12907 : : else
12908 : 2567 : return stdcopy;
12909 : : }
12910 : : else
12911 : : {
12912 : 252 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
12913 : 252 : ? gfc_class_data_get (lse->expr) : lse->expr;
12914 : 252 : stmtblock_t tblock;
12915 : 252 : gfc_init_block (&tblock);
12916 : 252 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
12917 : 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
12918 : 252 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
12919 : 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
12920 : : /* When coming from a ptr_copy lhs and rhs are swapped. */
12921 : 252 : gfc_add_modify_loc (input_location, &tblock, rhst,
12922 : 252 : fold_convert (TREE_TYPE (rhst), tmp));
12923 : 252 : return gfc_finish_block (&tblock);
12924 : : }
12925 : : }
12926 : :
12927 : : bool
12928 : 297134 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
12929 : : {
12930 : 297134 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
12931 : : return false;
12932 : :
12933 : 30345 : return lhs->symtree->n.sym->assoc
12934 : 30345 : && lhs->symtree->n.sym->assoc->target == rhs;
12935 : : }
12936 : :
12937 : : /* Subroutine of gfc_trans_assignment that actually scalarizes the
12938 : : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
12939 : : init_flag indicates initialization expressions and dealloc that no
12940 : : deallocate prior assignment is needed (if in doubt, set true).
12941 : : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
12942 : : routine instead of a pointer assignment. Alias resolution is only done,
12943 : : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
12944 : : where it is known, that newly allocated memory on the lhs can never be
12945 : : an alias of the rhs. */
12946 : :
12947 : : static tree
12948 : 297134 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
12949 : : bool dealloc, bool use_vptr_copy, bool may_alias)
12950 : : {
12951 : 297134 : gfc_se lse;
12952 : 297134 : gfc_se rse;
12953 : 297134 : gfc_ss *lss;
12954 : 297134 : gfc_ss *lss_section;
12955 : 297134 : gfc_ss *rss;
12956 : 297134 : gfc_loopinfo loop;
12957 : 297134 : tree tmp;
12958 : 297134 : stmtblock_t block;
12959 : 297134 : stmtblock_t body;
12960 : 297134 : bool final_expr;
12961 : 297134 : bool l_is_temp;
12962 : 297134 : bool scalar_to_array;
12963 : 297134 : tree string_length;
12964 : 297134 : int n;
12965 : 297134 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
12966 : 297134 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
12967 : 297134 : bool is_poly_assign;
12968 : 297134 : bool realloc_flag;
12969 : 297134 : bool assoc_assign = false;
12970 : :
12971 : : /* Assignment of the form lhs = rhs. */
12972 : 297134 : gfc_start_block (&block);
12973 : :
12974 : 297134 : gfc_init_se (&lse, NULL);
12975 : 297134 : gfc_init_se (&rse, NULL);
12976 : :
12977 : 297134 : gfc_fix_class_refs (expr1);
12978 : :
12979 : 594268 : realloc_flag = flag_realloc_lhs
12980 : 291372 : && gfc_is_reallocatable_lhs (expr1)
12981 : 7311 : && expr2->rank
12982 : 303029 : && !is_runtime_conformable (expr1, expr2);
12983 : :
12984 : : /* Walk the lhs. */
12985 : 297134 : lss = gfc_walk_expr (expr1);
12986 : 297134 : if (realloc_flag)
12987 : : {
12988 : 5691 : lss->no_bounds_check = 1;
12989 : 5691 : lss->is_alloc_lhs = 1;
12990 : : }
12991 : : else
12992 : 291443 : lss->no_bounds_check = expr1->no_bounds_check;
12993 : :
12994 : 297134 : rss = NULL;
12995 : :
12996 : 297134 : if (expr2->expr_type != EXPR_VARIABLE
12997 : 297134 : && expr2->expr_type != EXPR_CONSTANT
12998 : 297134 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
12999 : : {
13000 : 719 : expr2->must_finalize = 1;
13001 : : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13002 : : function, the result is finalized after execution of the innermost
13003 : : executable construct containing the reference. */
13004 : 719 : if (expr2->expr_type == EXPR_FUNCTION
13005 : 719 : && (gfc_expr_attr (expr2).pointer
13006 : 291 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13007 : 145 : expr2->must_finalize = 0;
13008 : : /* F2008 4.5.6.3 para 5: If an executable construct references a
13009 : : structure constructor or array constructor, the entity created by
13010 : : the constructor is finalized after execution of the innermost
13011 : : executable construct containing the reference.
13012 : : These finalizations were later deleted by the Combined Techical
13013 : : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13014 : 574 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13015 : 574 : && (expr2->expr_type == EXPR_STRUCTURE
13016 : 531 : || expr2->expr_type == EXPR_ARRAY))
13017 : 251 : expr2->must_finalize = 0;
13018 : : }
13019 : :
13020 : :
13021 : : /* Checking whether a class assignment is desired is quite complicated and
13022 : : needed at two locations, so do it once only before the information is
13023 : : needed. */
13024 : 297134 : lhs_attr = gfc_expr_attr (expr1);
13025 : :
13026 : 297134 : is_poly_assign
13027 : 297134 : = (use_vptr_copy
13028 : 281445 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13029 : 21314 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13030 : 19336 : || gfc_is_class_scalar_expr (expr1)
13031 : 18040 : || gfc_is_class_array_ref (expr2, NULL)
13032 : 18040 : || gfc_is_class_scalar_expr (expr2))
13033 : 300426 : && lhs_attr.flavor != FL_PROCEDURE;
13034 : :
13035 : 297134 : assoc_assign = is_assoc_assign (expr1, expr2);
13036 : :
13037 : : /* Only analyze the expressions for coarray properties, when in coarray-lib
13038 : : mode. Avoid false-positive uninitialized diagnostics with initializing
13039 : : the codimension flag unconditionally. */
13040 : 297134 : lhs_caf_attr.codimension = false;
13041 : 297134 : rhs_caf_attr.codimension = false;
13042 : 297134 : if (flag_coarray == GFC_FCOARRAY_LIB)
13043 : : {
13044 : 4512 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13045 : 4512 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13046 : : }
13047 : :
13048 : 297134 : tree reallocation = NULL_TREE;
13049 : 297134 : if (lss != gfc_ss_terminator)
13050 : : {
13051 : : /* The assignment needs scalarization. */
13052 : : lss_section = lss;
13053 : :
13054 : : /* Find a non-scalar SS from the lhs. */
13055 : : while (lss_section != gfc_ss_terminator
13056 : 37827 : && lss_section->info->type != GFC_SS_SECTION)
13057 : 0 : lss_section = lss_section->next;
13058 : :
13059 : 37827 : gcc_assert (lss_section != gfc_ss_terminator);
13060 : :
13061 : : /* Initialize the scalarizer. */
13062 : 37827 : gfc_init_loopinfo (&loop);
13063 : :
13064 : : /* Walk the rhs. */
13065 : 37827 : rss = gfc_walk_expr (expr2);
13066 : 37827 : if (rss == gfc_ss_terminator)
13067 : : {
13068 : : /* The rhs is scalar. Add a ss for the expression. */
13069 : 14104 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13070 : 14104 : lss->is_alloc_lhs = 0;
13071 : : }
13072 : :
13073 : : /* When doing a class assign, then the handle to the rhs needs to be a
13074 : : pointer to allow for polymorphism. */
13075 : 37827 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13076 : 484 : rss->info->type = GFC_SS_REFERENCE;
13077 : :
13078 : 37827 : rss->no_bounds_check = expr2->no_bounds_check;
13079 : : /* Associate the SS with the loop. */
13080 : 37827 : gfc_add_ss_to_loop (&loop, lss);
13081 : 37827 : gfc_add_ss_to_loop (&loop, rss);
13082 : :
13083 : : /* Calculate the bounds of the scalarization. */
13084 : 37827 : gfc_conv_ss_startstride (&loop);
13085 : : /* Enable loop reversal. */
13086 : 643059 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13087 : 567405 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13088 : : /* Resolve any data dependencies in the statement. */
13089 : 37827 : if (may_alias)
13090 : 35647 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13091 : : /* Setup the scalarizing loops. */
13092 : 37827 : gfc_conv_loop_setup (&loop, &expr2->where);
13093 : :
13094 : : /* Setup the gfc_se structures. */
13095 : 37827 : gfc_copy_loopinfo_to_se (&lse, &loop);
13096 : 37827 : gfc_copy_loopinfo_to_se (&rse, &loop);
13097 : :
13098 : 37827 : rse.ss = rss;
13099 : 37827 : gfc_mark_ss_chain_used (rss, 1);
13100 : 37827 : if (loop.temp_ss == NULL)
13101 : : {
13102 : 36813 : lse.ss = lss;
13103 : 36813 : gfc_mark_ss_chain_used (lss, 1);
13104 : : }
13105 : : else
13106 : : {
13107 : 1014 : lse.ss = loop.temp_ss;
13108 : 1014 : gfc_mark_ss_chain_used (lss, 3);
13109 : 1014 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13110 : : }
13111 : :
13112 : : /* Allow the scalarizer to workshare array assignments. */
13113 : 37827 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13114 : : == OMPWS_WORKSHARE_FLAG
13115 : 85 : && loop.temp_ss == NULL)
13116 : : {
13117 : 73 : maybe_workshare = true;
13118 : 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13119 : : }
13120 : :
13121 : : /* F2003: Allocate or reallocate lhs of allocatable array. */
13122 : 37827 : if (realloc_flag)
13123 : : {
13124 : 5691 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13125 : 5691 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13126 : 5691 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13127 : : expr2);
13128 : : }
13129 : :
13130 : : /* Start the scalarized loop body. */
13131 : 37827 : gfc_start_scalarized_body (&loop, &body);
13132 : : }
13133 : : else
13134 : 259307 : gfc_init_block (&body);
13135 : :
13136 : 297134 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13137 : :
13138 : : /* Translate the expression. */
13139 : 594268 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13140 : 297134 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13141 : 297134 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13142 : 297134 : gfc_conv_expr (&rse, expr2);
13143 : :
13144 : : /* Deal with the case of a scalar class function assigned to a derived type.
13145 : : */
13146 : 297134 : if (gfc_is_alloc_class_scalar_function (expr2)
13147 : 297134 : && expr1->ts.type == BT_DERIVED)
13148 : : {
13149 : 60 : rse.expr = gfc_class_data_get (rse.expr);
13150 : 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13151 : : }
13152 : :
13153 : : /* Stabilize a string length for temporaries. */
13154 : 297134 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13155 : 23039 : && !(VAR_P (rse.string_length)
13156 : : || TREE_CODE (rse.string_length) == PARM_DECL
13157 : : || INDIRECT_REF_P (rse.string_length)))
13158 : 22263 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13159 : 274871 : else if (expr2->ts.type == BT_CHARACTER)
13160 : : {
13161 : 3977 : if (expr1->ts.deferred
13162 : 6193 : && gfc_expr_attr (expr1).allocatable
13163 : 6307 : && gfc_check_dependency (expr1, expr2, true))
13164 : 114 : rse.string_length =
13165 : 114 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13166 : 3977 : string_length = rse.string_length;
13167 : : }
13168 : : else
13169 : : string_length = NULL_TREE;
13170 : :
13171 : 297134 : if (l_is_temp)
13172 : : {
13173 : 1014 : gfc_conv_tmp_array_ref (&lse);
13174 : 1014 : if (expr2->ts.type == BT_CHARACTER)
13175 : 123 : lse.string_length = string_length;
13176 : : }
13177 : : else
13178 : : {
13179 : 296120 : gfc_conv_expr (&lse, expr1);
13180 : : /* For some expression (e.g. complex numbers) fold_convert uses a
13181 : : SAVE_EXPR, which is hazardous on the lhs, because the value is
13182 : : not updated when assigned to. */
13183 : 296120 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13184 : 5 : lse.expr = TREE_OPERAND (lse.expr, 0);
13185 : :
13186 : 6138 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13187 : 302258 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13188 : : {
13189 : 36 : tree cond;
13190 : 36 : const char* msg;
13191 : :
13192 : 36 : tmp = INDIRECT_REF_P (lse.expr)
13193 : 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13194 : 36 : STRIP_NOPS (tmp);
13195 : :
13196 : : /* We should only get array references here. */
13197 : 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13198 : : || TREE_CODE (tmp) == ARRAY_REF);
13199 : :
13200 : : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13201 : : or the array itself(ARRAY_REF). */
13202 : 36 : tmp = TREE_OPERAND (tmp, 0);
13203 : :
13204 : : /* Provide the address of the array. */
13205 : 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13206 : 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13207 : :
13208 : 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13209 : 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13210 : 36 : msg = _("Assignment of scalar to unallocated array");
13211 : 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13212 : : &expr1->where, msg);
13213 : : }
13214 : :
13215 : : /* Deallocate the lhs parameterized components if required. */
13216 : 296120 : if (dealloc
13217 : 278913 : && !expr1->symtree->n.sym->attr.associate_var
13218 : 277170 : && ((expr1->ts.type == BT_DERIVED
13219 : 4918 : && expr1->ts.u.derived
13220 : 4918 : && expr1->ts.u.derived->attr.pdt_type)
13221 : 277086 : || (expr1->ts.type == BT_CLASS
13222 : 931 : && CLASS_DATA (expr1)->ts.u.derived
13223 : 931 : && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)))
13224 : : {
13225 : 84 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
13226 : :
13227 : 84 : tmp = lse.expr;
13228 : 84 : if (pdt_dep)
13229 : : {
13230 : : /* Create a temporary for deallocation after assignment. */
13231 : 42 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
13232 : 42 : gfc_add_modify (&lse.pre, tmp, lse.expr);
13233 : : }
13234 : :
13235 : 84 : if (expr1->ts.type == BT_DERIVED)
13236 : 84 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
13237 : : expr1->rank);
13238 : 0 : else if (expr1->ts.type == BT_CLASS)
13239 : : {
13240 : 0 : tmp = gfc_class_data_get (tmp);
13241 : 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
13242 : : tmp, expr1->rank);
13243 : : }
13244 : :
13245 : 84 : if (tmp && pdt_dep)
13246 : 42 : gfc_add_expr_to_block (&rse.post, tmp);
13247 : 42 : else if (tmp)
13248 : 42 : gfc_add_expr_to_block (&lse.pre, tmp);
13249 : : }
13250 : : }
13251 : :
13252 : : /* Assignments of scalar derived types with allocatable components
13253 : : to arrays must be done with a deep copy and the rhs temporary
13254 : : must have its components deallocated afterwards. */
13255 : 594268 : scalar_to_array = (expr2->ts.type == BT_DERIVED
13256 : 17774 : && expr2->ts.u.derived->attr.alloc_comp
13257 : 5722 : && !gfc_expr_is_variable (expr2)
13258 : 300325 : && expr1->rank && !expr2->rank);
13259 : 594268 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
13260 : 18053 : && expr1->rank
13261 : 3376 : && expr1->ts.u.derived->attr.alloc_comp
13262 : 298299 : && gfc_is_alloc_class_scalar_function (expr2));
13263 : 297134 : if (scalar_to_array && dealloc)
13264 : : {
13265 : 52 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
13266 : 52 : gfc_prepend_expr_to_block (&loop.post, tmp);
13267 : : }
13268 : :
13269 : : /* When assigning a character function result to a deferred-length variable,
13270 : : the function call must happen before the (re)allocation of the lhs -
13271 : : otherwise the character length of the result is not known.
13272 : : NOTE 1: This relies on having the exact dependence of the length type
13273 : : parameter available to the caller; gfortran saves it in the .mod files.
13274 : : NOTE 2: Vector array references generate an index temporary that must
13275 : : not go outside the loop. Otherwise, variables should not generate
13276 : : a pre block.
13277 : : NOTE 3: The concatenation operation generates a temporary pointer,
13278 : : whose allocation must go to the innermost loop.
13279 : : NOTE 4: Elemental functions may generate a temporary, too. */
13280 : 297134 : if (flag_realloc_lhs
13281 : 291372 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
13282 : 2701 : && !(lss != gfc_ss_terminator
13283 : 794 : && rss != gfc_ss_terminator
13284 : 794 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
13285 : 619 : || (expr2->expr_type == EXPR_FUNCTION
13286 : 142 : && expr2->value.function.esym != NULL
13287 : 26 : && expr2->value.function.esym->attr.elemental)
13288 : 606 : || (expr2->expr_type == EXPR_FUNCTION
13289 : 129 : && expr2->value.function.isym != NULL
13290 : 116 : && expr2->value.function.isym->elemental)
13291 : 568 : || (expr2->expr_type == EXPR_OP
13292 : 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
13293 : 2450 : gfc_add_block_to_block (&block, &rse.pre);
13294 : :
13295 : : /* Nullify the allocatable components corresponding to those of the lhs
13296 : : derived type, so that the finalization of the function result does not
13297 : : affect the lhs of the assignment. Prepend is used to ensure that the
13298 : : nullification occurs before the call to the finalizer. In the case of
13299 : : a scalar to array assignment, this is done in gfc_trans_scalar_assign
13300 : : as part of the deep copy. */
13301 : 296459 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
13302 : 314512 : && (gfc_is_class_array_function (expr2)
13303 : 17354 : || gfc_is_alloc_class_scalar_function (expr2)))
13304 : : {
13305 : 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
13306 : 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
13307 : 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
13308 : 0 : gfc_add_block_to_block (&loop.post, &rse.post);
13309 : : }
13310 : :
13311 : 297134 : tmp = NULL_TREE;
13312 : :
13313 : 297134 : if (is_poly_assign)
13314 : : {
13315 : 3225 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
13316 : 3225 : use_vptr_copy || (lhs_attr.allocatable
13317 : 302 : && !lhs_attr.dimension),
13318 : 3017 : !realloc_flag && flag_realloc_lhs
13319 : 3779 : && !lhs_attr.pointer);
13320 : 3225 : if (expr2->expr_type == EXPR_FUNCTION
13321 : 230 : && expr2->ts.type == BT_DERIVED
13322 : 30 : && expr2->ts.u.derived->attr.alloc_comp)
13323 : : {
13324 : 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
13325 : : rse.expr, expr2->rank);
13326 : 18 : if (lss == gfc_ss_terminator)
13327 : 18 : gfc_add_expr_to_block (&rse.post, tmp2);
13328 : : else
13329 : 0 : gfc_add_expr_to_block (&loop.post, tmp2);
13330 : : }
13331 : :
13332 : 3225 : expr1->must_finalize = 0;
13333 : : }
13334 : 293909 : else if (!is_poly_assign && expr2->must_finalize
13335 : 348 : && expr1->ts.type == BT_CLASS
13336 : 126 : && expr2->ts.type == BT_CLASS)
13337 : : {
13338 : : /* This case comes about when the scalarizer provides array element
13339 : : references. Use the vptr copy function, since this does a deep
13340 : : copy of allocatable components, without which the finalizer call
13341 : : will deallocate the components. */
13342 : 120 : tmp = gfc_get_vptr_from_expr (rse.expr);
13343 : 120 : if (tmp != NULL_TREE)
13344 : : {
13345 : 120 : tree fcn = gfc_vptr_copy_get (tmp);
13346 : 120 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
13347 : 120 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
13348 : 120 : tmp = build_call_expr_loc (input_location,
13349 : : fcn, 2,
13350 : : gfc_build_addr_expr (NULL, rse.expr),
13351 : : gfc_build_addr_expr (NULL, lse.expr));
13352 : : }
13353 : : }
13354 : :
13355 : : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
13356 : : after evaluation of the rhs and before reallocation. */
13357 : 297134 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
13358 : 297134 : if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
13359 : 169 : && expr2->symtree->n.sym->attr.artificial))
13360 : : {
13361 : 557 : if (lss == gfc_ss_terminator)
13362 : : {
13363 : 164 : gfc_add_block_to_block (&block, &rse.pre);
13364 : 164 : gfc_add_block_to_block (&block, &lse.finalblock);
13365 : : }
13366 : : else
13367 : : {
13368 : 393 : gfc_add_block_to_block (&body, &rse.pre);
13369 : 393 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
13370 : : &lse.finalblock);
13371 : : }
13372 : : }
13373 : : else
13374 : 296577 : gfc_add_block_to_block (&body, &rse.pre);
13375 : :
13376 : 297134 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
13377 : 2001 : && assoc_assign)
13378 : 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
13379 : :
13380 : : /* If nothing else works, do it the old fashioned way! */
13381 : 297134 : if (tmp == NULL_TREE)
13382 : 293789 : tmp
13383 : 293789 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13384 : 558998 : gfc_expr_is_variable (expr2) || scalar_to_array
13385 : 558407 : || expr2->expr_type == EXPR_ARRAY,
13386 : 293789 : !(l_is_temp || init_flag) && dealloc,
13387 : 293789 : expr1->symtree->n.sym->attr.codimension,
13388 : : assoc_assign);
13389 : :
13390 : : /* Add the lse pre block to the body */
13391 : 297134 : gfc_add_block_to_block (&body, &lse.pre);
13392 : 297134 : gfc_add_expr_to_block (&body, tmp);
13393 : :
13394 : : /* Add the post blocks to the body. Scalar finalization must appear before
13395 : : the post block in case any dellocations are done. */
13396 : 297134 : if (rse.finalblock.head
13397 : 297134 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
13398 : 14 : && gfc_expr_attr (expr2).elemental)))
13399 : : {
13400 : 135 : gfc_add_block_to_block (&body, &rse.finalblock);
13401 : 135 : gfc_add_block_to_block (&body, &rse.post);
13402 : : }
13403 : : else
13404 : 296999 : gfc_add_block_to_block (&body, &rse.post);
13405 : :
13406 : 297134 : gfc_add_block_to_block (&body, &lse.post);
13407 : :
13408 : 297134 : if (lss == gfc_ss_terminator)
13409 : : {
13410 : : /* F2003: Add the code for reallocation on assignment. */
13411 : 256649 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
13412 : 262752 : && !is_poly_assign)
13413 : 3427 : alloc_scalar_allocatable_for_assignment (&block, string_length,
13414 : : expr1, expr2);
13415 : :
13416 : : /* Use the scalar assignment as is. */
13417 : 259307 : gfc_add_block_to_block (&block, &body);
13418 : : }
13419 : : else
13420 : : {
13421 : 37827 : gcc_assert (lse.ss == gfc_ss_terminator
13422 : : && rse.ss == gfc_ss_terminator);
13423 : :
13424 : 37827 : if (l_is_temp)
13425 : : {
13426 : 1014 : gfc_trans_scalarized_loop_boundary (&loop, &body);
13427 : :
13428 : : /* We need to copy the temporary to the actual lhs. */
13429 : 1014 : gfc_init_se (&lse, NULL);
13430 : 1014 : gfc_init_se (&rse, NULL);
13431 : 1014 : gfc_copy_loopinfo_to_se (&lse, &loop);
13432 : 1014 : gfc_copy_loopinfo_to_se (&rse, &loop);
13433 : :
13434 : 1014 : rse.ss = loop.temp_ss;
13435 : 1014 : lse.ss = lss;
13436 : :
13437 : 1014 : gfc_conv_tmp_array_ref (&rse);
13438 : 1014 : gfc_conv_expr (&lse, expr1);
13439 : :
13440 : 1014 : gcc_assert (lse.ss == gfc_ss_terminator
13441 : : && rse.ss == gfc_ss_terminator);
13442 : :
13443 : 1014 : if (expr2->ts.type == BT_CHARACTER)
13444 : 123 : rse.string_length = string_length;
13445 : :
13446 : 1014 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13447 : : false, dealloc);
13448 : 1014 : gfc_add_expr_to_block (&body, tmp);
13449 : : }
13450 : :
13451 : 37827 : if (reallocation != NULL_TREE)
13452 : 5691 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
13453 : :
13454 : 37827 : if (maybe_workshare)
13455 : 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
13456 : :
13457 : : /* Generate the copying loops. */
13458 : 37827 : gfc_trans_scalarizing_loops (&loop, &body);
13459 : :
13460 : : /* Wrap the whole thing up. */
13461 : 37827 : gfc_add_block_to_block (&block, &loop.pre);
13462 : 37827 : gfc_add_block_to_block (&block, &loop.post);
13463 : :
13464 : 37827 : gfc_cleanup_loop (&loop);
13465 : : }
13466 : :
13467 : : /* Since parameterized components cannot have default initializers,
13468 : : the default PDT constructor leaves them unallocated. Do the
13469 : : allocation now. */
13470 : 297134 : if (init_flag && expr1->ts.type == BT_DERIVED
13471 : 11631 : && expr1->ts.u.derived->attr.pdt_type
13472 : 145 : && !expr1->symtree->n.sym->attr.allocatable
13473 : 145 : && !expr1->symtree->n.sym->attr.dummy)
13474 : : {
13475 : 18 : gfc_symbol *sym = expr1->symtree->n.sym;
13476 : 18 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
13477 : : sym->backend_decl,
13478 : 18 : sym->as ? sym->as->rank : 0,
13479 : 18 : sym->param_list);
13480 : 18 : gfc_add_expr_to_block (&block, tmp);
13481 : : }
13482 : :
13483 : 297134 : return gfc_finish_block (&block);
13484 : : }
13485 : :
13486 : :
13487 : : /* Check whether EXPR is a copyable array. */
13488 : :
13489 : : static bool
13490 : 940192 : copyable_array_p (gfc_expr * expr)
13491 : : {
13492 : 940192 : if (expr->expr_type != EXPR_VARIABLE)
13493 : : return false;
13494 : :
13495 : : /* First check it's an array. */
13496 : 917464 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
13497 : : return false;
13498 : :
13499 : 137341 : if (!gfc_full_array_ref_p (expr->ref, NULL))
13500 : : return false;
13501 : :
13502 : : /* Next check that it's of a simple enough type. */
13503 : 110086 : switch (expr->ts.type)
13504 : : {
13505 : : case BT_INTEGER:
13506 : : case BT_REAL:
13507 : : case BT_COMPLEX:
13508 : : case BT_LOGICAL:
13509 : : return true;
13510 : :
13511 : : case BT_CHARACTER:
13512 : : return false;
13513 : :
13514 : 5872 : case_bt_struct:
13515 : 5872 : return !expr->ts.u.derived->attr.alloc_comp;
13516 : :
13517 : : default:
13518 : : break;
13519 : : }
13520 : :
13521 : : return false;
13522 : : }
13523 : :
13524 : : /* Translate an assignment. */
13525 : :
13526 : : tree
13527 : 314403 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13528 : : bool dealloc, bool use_vptr_copy, bool may_alias)
13529 : : {
13530 : 314403 : tree tmp;
13531 : :
13532 : : /* Special case a single function returning an array. */
13533 : 314403 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
13534 : : {
13535 : 14602 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
13536 : 14602 : if (tmp)
13537 : : return tmp;
13538 : : }
13539 : :
13540 : : /* Special case assigning an array to zero. */
13541 : 307322 : if (copyable_array_p (expr1)
13542 : 307322 : && is_zero_initializer_p (expr2))
13543 : : {
13544 : 3925 : tmp = gfc_trans_zero_assign (expr1);
13545 : 3925 : if (tmp)
13546 : : return tmp;
13547 : : }
13548 : :
13549 : : /* Special case copying one array to another. */
13550 : 303676 : if (copyable_array_p (expr1)
13551 : 26956 : && copyable_array_p (expr2)
13552 : 2599 : && gfc_compare_types (&expr1->ts, &expr2->ts)
13553 : 306275 : && !gfc_check_dependency (expr1, expr2, 0))
13554 : : {
13555 : 2503 : tmp = gfc_trans_array_copy (expr1, expr2);
13556 : 2503 : if (tmp)
13557 : : return tmp;
13558 : : }
13559 : :
13560 : : /* Special case initializing an array from a constant array constructor. */
13561 : 302238 : if (copyable_array_p (expr1)
13562 : 25518 : && expr2->expr_type == EXPR_ARRAY
13563 : 309758 : && gfc_compare_types (&expr1->ts, &expr2->ts))
13564 : : {
13565 : 7520 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
13566 : 7520 : if (tmp)
13567 : : return tmp;
13568 : : }
13569 : :
13570 : 297134 : if (UNLIMITED_POLY (expr1) && expr1->rank)
13571 : 297134 : use_vptr_copy = true;
13572 : :
13573 : : /* Fallback to the scalarizer to generate explicit loops. */
13574 : 297134 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
13575 : 297134 : use_vptr_copy, may_alias);
13576 : : }
13577 : :
13578 : : tree
13579 : 12046 : gfc_trans_init_assign (gfc_code * code)
13580 : : {
13581 : 12046 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
13582 : : }
13583 : :
13584 : : tree
13585 : 294410 : gfc_trans_assign (gfc_code * code)
13586 : : {
13587 : 294410 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
13588 : : }
13589 : :
13590 : : /* Generate a simple loop for internal use of the form
13591 : : for (var = begin; var <cond> end; var += step)
13592 : : body; */
13593 : : void
13594 : 12144 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
13595 : : enum tree_code cond, tree step, tree body)
13596 : : {
13597 : 12144 : tree tmp;
13598 : :
13599 : : /* var = begin. */
13600 : 12144 : gfc_add_modify (block, var, begin);
13601 : :
13602 : : /* Loop: for (var = begin; var <cond> end; var += step). */
13603 : 12144 : tree label_loop = gfc_build_label_decl (NULL_TREE);
13604 : 12144 : tree label_cond = gfc_build_label_decl (NULL_TREE);
13605 : 12144 : TREE_USED (label_loop) = 1;
13606 : 12144 : TREE_USED (label_cond) = 1;
13607 : :
13608 : 12144 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
13609 : 12144 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
13610 : :
13611 : : /* Loop body. */
13612 : 12144 : gfc_add_expr_to_block (block, body);
13613 : :
13614 : : /* End of loop body. */
13615 : 12144 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
13616 : 12144 : gfc_add_modify (block, var, tmp);
13617 : 12144 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
13618 : 12144 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
13619 : 12144 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
13620 : : build_empty_stmt (input_location));
13621 : 12144 : gfc_add_expr_to_block (block, tmp);
13622 : 12144 : }
|
