Line data Source code
1 : /* Expression translation
2 : Copyright (C) 2002-2026 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 : #include "trans-descriptor.h"
42 : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 : #include "trans-stmt.h"
44 : #include "dependency.h"
45 : #include "gimplify.h"
46 : #include "tm.h" /* For CHAR_TYPE_SIZE. */
47 :
48 :
49 : /* Calculate the number of characters in a string. */
50 :
51 : static tree
52 36172 : gfc_get_character_len (tree type)
53 : {
54 36172 : tree len;
55 :
56 36172 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
57 : && TYPE_STRING_FLAG (type));
58 :
59 36172 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
60 36172 : len = (len) ? (len) : (integer_zero_node);
61 36172 : return fold_convert (gfc_charlen_type_node, len);
62 : }
63 :
64 :
65 :
66 : /* Calculate the number of bytes in a string. */
67 :
68 : tree
69 36172 : gfc_get_character_len_in_bytes (tree type)
70 : {
71 36172 : tree tmp, len;
72 :
73 36172 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
74 : && TYPE_STRING_FLAG (type));
75 :
76 36172 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
77 72344 : tmp = (tmp && !integer_zerop (tmp))
78 72344 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
79 36172 : len = gfc_get_character_len (type);
80 36172 : if (tmp && len && !integer_zerop (len))
81 35412 : len = fold_build2_loc (input_location, MULT_EXPR,
82 : gfc_charlen_type_node, len, tmp);
83 36172 : return len;
84 : }
85 :
86 :
87 : /* Convert a scalar to an array descriptor. To be used for assumed-rank
88 : arrays. */
89 :
90 : static tree
91 6342 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
92 : {
93 6342 : enum gfc_array_kind akind;
94 6342 : tree *lbound = NULL, *ubound = NULL;
95 6342 : int codim = 0;
96 :
97 6342 : if (attr.pointer)
98 : akind = GFC_ARRAY_POINTER_CONT;
99 5990 : else if (attr.allocatable)
100 : akind = GFC_ARRAY_ALLOCATABLE;
101 : else
102 5221 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
103 :
104 6342 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
105 5377 : scalar = TREE_TYPE (scalar);
106 6342 : if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
107 : {
108 4800 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
109 4800 : codim = lang_specific->corank;
110 4800 : lbound = lang_specific->lbound;
111 4800 : ubound = lang_specific->ubound;
112 : }
113 6342 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
114 : ubound, 1, akind,
115 6342 : !(attr.pointer || attr.target));
116 : }
117 :
118 : tree
119 5664 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
120 : {
121 5664 : tree desc, type, etype;
122 :
123 5664 : type = get_scalar_to_descriptor_type (scalar, attr);
124 5664 : etype = TREE_TYPE (scalar);
125 5664 : desc = gfc_create_var (type, "desc");
126 5664 : DECL_ARTIFICIAL (desc) = 1;
127 :
128 5664 : if (CONSTANT_CLASS_P (scalar))
129 : {
130 54 : tree tmp;
131 54 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
132 54 : gfc_add_modify (&se->pre, tmp, scalar);
133 54 : scalar = tmp;
134 : }
135 5664 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
136 965 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
137 4699 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
138 158 : etype = TREE_TYPE (etype);
139 5664 : gfc_conv_descriptor_dtype_set (&se->pre, desc,
140 : gfc_get_dtype_rank_type (0, etype));
141 5664 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
142 5664 : gfc_conv_descriptor_span_set (&se->pre, desc,
143 : gfc_conv_descriptor_elem_len_get (desc));
144 :
145 : /* Copy pointer address back - but only if it could have changed and
146 : if the actual argument is a pointer and not, e.g., NULL(). */
147 5664 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
148 846 : gfc_add_modify (&se->post, scalar,
149 423 : fold_convert (TREE_TYPE (scalar),
150 : gfc_conv_descriptor_data_get (desc)));
151 5664 : return desc;
152 : }
153 :
154 :
155 : /* Get the coarray token from the ultimate array or component ref.
156 : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
157 :
158 : tree
159 540 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
160 : {
161 540 : gfc_symbol *sym = expr->symtree->n.sym;
162 1080 : bool is_coarray = sym->ts.type == BT_CLASS
163 540 : ? CLASS_DATA (sym)->attr.codimension
164 495 : : sym->attr.codimension;
165 540 : gfc_expr *caf_expr = gfc_copy_expr (expr);
166 540 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
167 :
168 1692 : while (ref)
169 : {
170 1152 : if (ref->type == REF_COMPONENT
171 431 : && (ref->u.c.component->attr.allocatable
172 104 : || ref->u.c.component->attr.pointer)
173 429 : && (is_coarray || ref->u.c.component->attr.codimension))
174 1152 : last_caf_ref = ref;
175 1152 : ref = ref->next;
176 : }
177 :
178 540 : if (last_caf_ref == NULL)
179 : {
180 194 : gfc_free_expr (caf_expr);
181 194 : return NULL_TREE;
182 : }
183 :
184 143 : tree comp = last_caf_ref->u.c.component->caf_token
185 346 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
186 : : NULL_TREE,
187 : caf;
188 346 : gfc_se se;
189 346 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
190 346 : if (comp == NULL_TREE && comp_ref)
191 : {
192 60 : gfc_free_expr (caf_expr);
193 60 : return NULL_TREE;
194 : }
195 286 : gfc_init_se (&se, outerse);
196 286 : gfc_free_ref_list (last_caf_ref->next);
197 286 : last_caf_ref->next = NULL;
198 286 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
199 572 : caf_expr->corank = last_caf_ref->u.c.component->as
200 286 : ? last_caf_ref->u.c.component->as->corank
201 : : expr->corank;
202 286 : se.want_pointer = comp_ref;
203 286 : gfc_conv_expr (&se, caf_expr);
204 286 : gfc_add_block_to_block (&outerse->pre, &se.pre);
205 :
206 286 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
207 143 : se.expr = TREE_OPERAND (se.expr, 0);
208 286 : gfc_free_expr (caf_expr);
209 :
210 286 : if (comp_ref)
211 143 : caf = fold_build3_loc (input_location, COMPONENT_REF,
212 143 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
213 : else
214 143 : caf = gfc_conv_descriptor_token (se.expr);
215 286 : return gfc_build_addr_expr (NULL_TREE, caf);
216 : }
217 :
218 :
219 : /* This is the seed for an eventual trans-class.c
220 :
221 : The following parameters should not be used directly since they might
222 : in future implementations. Use the corresponding APIs. */
223 : #define CLASS_DATA_FIELD 0
224 : #define CLASS_VPTR_FIELD 1
225 : #define CLASS_LEN_FIELD 2
226 : #define VTABLE_HASH_FIELD 0
227 : #define VTABLE_SIZE_FIELD 1
228 : #define VTABLE_EXTENDS_FIELD 2
229 : #define VTABLE_DEF_INIT_FIELD 3
230 : #define VTABLE_COPY_FIELD 4
231 : #define VTABLE_FINAL_FIELD 5
232 : #define VTABLE_DEALLOCATE_FIELD 6
233 :
234 :
235 : tree
236 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
237 : {
238 40 : tree tmp;
239 40 : tree field;
240 40 : vec<constructor_elt, va_gc> *init = NULL;
241 :
242 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
243 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
244 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
245 :
246 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
247 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
248 :
249 40 : return build_constructor (TREE_TYPE (decl), init);
250 : }
251 :
252 :
253 : tree
254 32510 : gfc_class_data_get (tree decl)
255 : {
256 32510 : tree data;
257 32510 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
258 5441 : decl = build_fold_indirect_ref_loc (input_location, decl);
259 32510 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
260 : CLASS_DATA_FIELD);
261 32510 : return fold_build3_loc (input_location, COMPONENT_REF,
262 32510 : TREE_TYPE (data), decl, data,
263 32510 : NULL_TREE);
264 : }
265 :
266 :
267 : tree
268 46061 : gfc_class_vptr_get (tree decl)
269 : {
270 46061 : tree vptr;
271 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
272 : then available through the saved descriptor. */
273 28442 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
274 47867 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
275 1303 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
276 46061 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
277 2369 : decl = build_fold_indirect_ref_loc (input_location, decl);
278 46061 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
279 : CLASS_VPTR_FIELD);
280 46061 : return fold_build3_loc (input_location, COMPONENT_REF,
281 46061 : TREE_TYPE (vptr), decl, vptr,
282 46061 : NULL_TREE);
283 : }
284 :
285 :
286 : tree
287 6805 : gfc_class_len_get (tree decl)
288 : {
289 6805 : tree len;
290 : /* For class arrays decl may be a temporary descriptor handle, the len is
291 : then available through the saved descriptor. */
292 4859 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
293 7060 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
294 91 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
295 6805 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
296 668 : decl = build_fold_indirect_ref_loc (input_location, decl);
297 6805 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
298 : CLASS_LEN_FIELD);
299 6805 : return fold_build3_loc (input_location, COMPONENT_REF,
300 6805 : TREE_TYPE (len), decl, len,
301 6805 : NULL_TREE);
302 : }
303 :
304 :
305 : /* Try to get the _len component of a class. When the class is not unlimited
306 : poly, i.e. no _len field exists, then return a zero node. */
307 :
308 : static tree
309 8374 : gfc_class_len_or_zero_get (tree decl)
310 : {
311 8374 : tree len;
312 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
313 : then available through the saved descriptor. */
314 4138 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
315 8440 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
316 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
317 8374 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
318 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
319 8374 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
320 : CLASS_LEN_FIELD);
321 10698 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
322 2324 : TREE_TYPE (len), decl, len,
323 : NULL_TREE)
324 6050 : : build_zero_cst (gfc_charlen_type_node);
325 : }
326 :
327 :
328 : tree
329 8204 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
330 : {
331 8204 : tree tmp;
332 8204 : tree tmp2;
333 8204 : tree type;
334 :
335 8204 : tmp = gfc_class_len_or_zero_get (class_expr);
336 :
337 : /* Include the len value in the element size if present. */
338 8204 : if (!integer_zerop (tmp))
339 : {
340 2154 : type = TREE_TYPE (size);
341 2154 : if (block)
342 : {
343 996 : size = gfc_evaluate_now (size, block);
344 996 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
345 : }
346 : else
347 1158 : tmp = fold_convert (type , tmp);
348 2154 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
349 : type, size, tmp);
350 2154 : tmp = fold_build2_loc (input_location, GT_EXPR,
351 : logical_type_node, tmp,
352 : build_zero_cst (type));
353 2154 : size = fold_build3_loc (input_location, COND_EXPR,
354 : type, tmp, tmp2, size);
355 : }
356 : else
357 : return size;
358 :
359 2154 : if (block)
360 996 : size = gfc_evaluate_now (size, block);
361 :
362 : return size;
363 : }
364 :
365 :
366 : /* Get the specified FIELD from the VPTR. */
367 :
368 : static tree
369 21406 : vptr_field_get (tree vptr, int fieldno)
370 : {
371 21406 : tree field;
372 21406 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
373 21406 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
374 : fieldno);
375 21406 : field = fold_build3_loc (input_location, COMPONENT_REF,
376 21406 : TREE_TYPE (field), vptr, field,
377 : NULL_TREE);
378 21406 : gcc_assert (field);
379 21406 : return field;
380 : }
381 :
382 :
383 : /* Get the field from the class' vptr. */
384 :
385 : static tree
386 9984 : class_vtab_field_get (tree decl, int fieldno)
387 : {
388 9984 : tree vptr;
389 9984 : vptr = gfc_class_vptr_get (decl);
390 9984 : return vptr_field_get (vptr, fieldno);
391 : }
392 :
393 :
394 : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
395 : unison. */
396 : #define VTAB_GET_FIELD_GEN(name, field) tree \
397 : gfc_class_vtab_## name ##_get (tree cl) \
398 : { \
399 : return class_vtab_field_get (cl, field); \
400 : } \
401 : \
402 : tree \
403 : gfc_vptr_## name ##_get (tree vptr) \
404 : { \
405 : return vptr_field_get (vptr, field); \
406 : }
407 :
408 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
409 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
410 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
411 4377 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
412 1836 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
413 1023 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
414 : #undef VTAB_GET_FIELD_GEN
415 :
416 : /* The size field is returned as an array index type. Therefore treat
417 : it and only it specially. */
418 :
419 : tree
420 7970 : gfc_class_vtab_size_get (tree cl)
421 : {
422 7970 : tree size;
423 7970 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
424 : /* Always return size as an array index type. */
425 7970 : size = fold_convert (gfc_array_index_type, size);
426 7970 : gcc_assert (size);
427 7970 : return size;
428 : }
429 :
430 : tree
431 6017 : gfc_vptr_size_get (tree vptr)
432 : {
433 6017 : tree size;
434 6017 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
435 : /* Always return size as an array index type. */
436 6017 : size = fold_convert (gfc_array_index_type, size);
437 6017 : gcc_assert (size);
438 6017 : return size;
439 : }
440 :
441 :
442 : #undef CLASS_DATA_FIELD
443 : #undef CLASS_VPTR_FIELD
444 : #undef CLASS_LEN_FIELD
445 : #undef VTABLE_HASH_FIELD
446 : #undef VTABLE_SIZE_FIELD
447 : #undef VTABLE_EXTENDS_FIELD
448 : #undef VTABLE_DEF_INIT_FIELD
449 : #undef VTABLE_COPY_FIELD
450 : #undef VTABLE_FINAL_FIELD
451 :
452 :
453 : /* IF ts is null (default), search for the last _class ref in the chain
454 : of references of the expression and cut the chain there. Although
455 : this routine is similar to class.cc:gfc_add_component_ref (), there
456 : is a significant difference: gfc_add_component_ref () concentrates
457 : on an array ref that is the last ref in the chain and is oblivious
458 : to the kind of refs following.
459 : ELSE IF ts is non-null the cut is at the class entity or component
460 : that is followed by an array reference, which is not an element.
461 : These calls come from trans-array.cc:build_class_array_ref, which
462 : handles scalarized class array references.*/
463 :
464 : gfc_expr *
465 9493 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
466 : gfc_typespec **ts)
467 : {
468 9493 : gfc_expr *base_expr;
469 9493 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
470 :
471 : /* Find the last class reference. */
472 9493 : class_ref = NULL;
473 9493 : array_ref = NULL;
474 :
475 9493 : if (ts)
476 : {
477 435 : if (e->symtree
478 410 : && e->symtree->n.sym->ts.type == BT_CLASS)
479 410 : *ts = &e->symtree->n.sym->ts;
480 : else
481 25 : *ts = NULL;
482 : }
483 :
484 23893 : for (ref = e->ref; ref; ref = ref->next)
485 : {
486 14820 : if (ts)
487 : {
488 1038 : if (ref->type == REF_COMPONENT
489 490 : && ref->u.c.component->ts.type == BT_CLASS
490 0 : && ref->next && ref->next->type == REF_COMPONENT
491 0 : && !strcmp (ref->next->u.c.component->name, "_data")
492 0 : && ref->next->next
493 0 : && ref->next->next->type == REF_ARRAY
494 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
495 : {
496 0 : *ts = &ref->u.c.component->ts;
497 0 : class_ref = ref;
498 0 : break;
499 : }
500 :
501 1038 : if (ref->next == NULL)
502 : break;
503 : }
504 : else
505 : {
506 13782 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
507 13782 : array_ref = ref;
508 :
509 13782 : if (ref->type == REF_COMPONENT
510 8289 : && ref->u.c.component->ts.type == BT_CLASS)
511 : {
512 : /* Component to the right of a part reference with nonzero
513 : rank must not have the ALLOCATABLE attribute. If attempts
514 : are made to reference such a component reference, an error
515 : results followed by an ICE. */
516 1618 : if (array_ref
517 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
518 : return NULL;
519 : class_ref = ref;
520 : }
521 : }
522 : }
523 :
524 9483 : if (ts && *ts == NULL)
525 : return NULL;
526 :
527 : /* Remove and store all subsequent references after the
528 : CLASS reference. */
529 9458 : if (class_ref)
530 : {
531 1416 : tail = class_ref->next;
532 1416 : class_ref->next = NULL;
533 : }
534 8042 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
535 : {
536 8042 : tail = e->ref;
537 8042 : e->ref = NULL;
538 : }
539 :
540 9458 : if (is_mold)
541 61 : base_expr = gfc_expr_to_initialize (e);
542 : else
543 9397 : base_expr = gfc_copy_expr (e);
544 :
545 : /* Restore the original tail expression. */
546 9458 : if (class_ref)
547 : {
548 1416 : gfc_free_ref_list (class_ref->next);
549 1416 : class_ref->next = tail;
550 : }
551 8042 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
552 : {
553 8042 : gfc_free_ref_list (e->ref);
554 8042 : e->ref = tail;
555 : }
556 : return base_expr;
557 : }
558 :
559 : /* Reset the vptr to the declared type, e.g. after deallocation.
560 : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
561 : one with e or class_type. At least one of the two has to be set. The
562 : generated assignment code is added at the end of BLOCK. */
563 :
564 : void
565 11290 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
566 : gfc_symbol *class_type)
567 : {
568 11290 : tree vptr = NULL_TREE;
569 :
570 11290 : if (class_container != NULL_TREE)
571 6764 : vptr = gfc_get_vptr_from_expr (class_container);
572 :
573 6764 : if (vptr == NULL_TREE)
574 : {
575 4533 : gfc_se se;
576 4533 : gcc_assert (e);
577 :
578 : /* Evaluate the expression and obtain the vptr from it. */
579 4533 : gfc_init_se (&se, NULL);
580 4533 : if (e->rank)
581 2261 : gfc_conv_expr_descriptor (&se, e);
582 : else
583 2272 : gfc_conv_expr (&se, e);
584 4533 : gfc_add_block_to_block (block, &se.pre);
585 :
586 4533 : vptr = gfc_get_vptr_from_expr (se.expr);
587 : }
588 :
589 : /* If a vptr is not found, we can do nothing more. */
590 4533 : if (vptr == NULL_TREE)
591 : return;
592 :
593 11280 : if (UNLIMITED_POLY (e)
594 10244 : || UNLIMITED_POLY (class_type)
595 : /* When the class_type's source is not a symbol (e.g. a component's ts),
596 : then look at the _data-components type. */
597 1529 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
598 1529 : && class_type->components && class_type->components->ts.u.derived
599 1523 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
600 1204 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
601 : else
602 : {
603 10076 : gfc_symbol *vtab, *type = nullptr;
604 10076 : tree vtable;
605 :
606 10076 : if (e)
607 8715 : type = e->ts.u.derived;
608 1361 : else if (class_type)
609 : {
610 1361 : if (class_type->ts.type == BT_CLASS)
611 0 : type = CLASS_DATA (class_type)->ts.u.derived;
612 : else
613 : type = class_type;
614 : }
615 8715 : gcc_assert (type);
616 : /* Return the vptr to the address of the declared type. */
617 10076 : vtab = gfc_find_derived_vtab (type);
618 10076 : vtable = vtab->backend_decl;
619 10076 : if (vtable == NULL_TREE)
620 100 : vtable = gfc_get_symbol_decl (vtab);
621 10076 : vtable = gfc_build_addr_expr (NULL, vtable);
622 10076 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
623 10076 : gfc_add_modify (block, vptr, vtable);
624 : }
625 : }
626 :
627 : /* Set the vptr of a class in to from the type given in from. If from is NULL,
628 : then reset the vptr to the default or to. */
629 :
630 : void
631 228 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
632 : {
633 228 : tree tmp, vptr_ref;
634 228 : gfc_symbol *type;
635 :
636 228 : vptr_ref = gfc_get_vptr_from_expr (to);
637 264 : if (POINTER_TYPE_P (TREE_TYPE (from))
638 228 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
639 : {
640 44 : gfc_add_modify (block, vptr_ref,
641 22 : fold_convert (TREE_TYPE (vptr_ref),
642 : gfc_get_vptr_from_expr (from)));
643 250 : return;
644 : }
645 206 : tmp = gfc_get_vptr_from_expr (from);
646 206 : if (tmp)
647 : {
648 170 : gfc_add_modify (block, vptr_ref,
649 170 : fold_convert (TREE_TYPE (vptr_ref), tmp));
650 170 : return;
651 : }
652 36 : if (VAR_P (from)
653 36 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
654 : {
655 36 : gfc_add_modify (block, vptr_ref,
656 36 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
657 36 : return;
658 : }
659 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
660 0 : && GFC_CLASS_TYPE_P (
661 : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
662 : {
663 0 : gfc_add_modify (block, vptr_ref,
664 0 : fold_convert (TREE_TYPE (vptr_ref),
665 : gfc_get_vptr_from_expr (TREE_OPERAND (
666 : TREE_OPERAND (from, 0), 0))));
667 0 : return;
668 : }
669 :
670 : /* If nothing of the above matches, set the vtype according to the type. */
671 0 : tmp = TREE_TYPE (from);
672 0 : if (POINTER_TYPE_P (tmp))
673 0 : tmp = TREE_TYPE (tmp);
674 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
675 : &type);
676 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
677 0 : gcc_assert (tmp);
678 0 : gfc_add_modify (block, vptr_ref,
679 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
680 : }
681 :
682 : /* Reset the len for unlimited polymorphic objects. */
683 :
684 : void
685 639 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
686 : {
687 639 : gfc_expr *e;
688 639 : gfc_se se_len;
689 639 : e = gfc_find_and_cut_at_last_class_ref (expr);
690 639 : if (e == NULL)
691 0 : return;
692 639 : gfc_add_len_component (e);
693 639 : gfc_init_se (&se_len, NULL);
694 639 : gfc_conv_expr (&se_len, e);
695 639 : gfc_add_modify (block, se_len.expr,
696 639 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
697 639 : gfc_free_expr (e);
698 : }
699 :
700 :
701 : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
702 : reference is found. Note that it is up to the caller to avoid using this
703 : for expressions other than variables. */
704 :
705 : tree
706 1451 : gfc_get_class_from_gfc_expr (gfc_expr *e)
707 : {
708 1451 : gfc_expr *class_expr;
709 1451 : gfc_se cse;
710 1451 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
711 1451 : if (class_expr == NULL)
712 : return NULL_TREE;
713 1451 : gfc_init_se (&cse, NULL);
714 1451 : gfc_conv_expr (&cse, class_expr);
715 1451 : gfc_free_expr (class_expr);
716 1451 : return cse.expr;
717 : }
718 :
719 :
720 : /* Obtain the last class reference in an expression.
721 : Return NULL_TREE if no class reference is found. */
722 :
723 : tree
724 108545 : gfc_get_class_from_expr (tree expr)
725 : {
726 108545 : tree tmp;
727 108545 : tree type;
728 108545 : bool array_descr_found = false;
729 108545 : bool comp_after_descr_found = false;
730 :
731 279687 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
732 : {
733 279687 : if (CONSTANT_CLASS_P (tmp))
734 : return NULL_TREE;
735 :
736 279650 : type = TREE_TYPE (tmp);
737 324205 : while (type)
738 : {
739 316363 : if (GFC_CLASS_TYPE_P (type))
740 : return tmp;
741 296301 : if (GFC_DESCRIPTOR_TYPE_P (type))
742 35416 : array_descr_found = true;
743 296301 : if (type != TYPE_CANONICAL (type))
744 44555 : type = TYPE_CANONICAL (type);
745 : else
746 : type = NULL_TREE;
747 : }
748 259588 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
749 : break;
750 :
751 : /* Avoid walking up the reference chain too far. For class arrays, the
752 : array descriptor is a direct component (through a pointer) of the class
753 : container. So there is exactly one COMPONENT_REF between a class
754 : container and its child array descriptor. After seeing an array
755 : descriptor, we can give up on the second COMPONENT_REF we see, if no
756 : class container was found until that point. */
757 171142 : if (array_descr_found)
758 : {
759 7467 : if (comp_after_descr_found)
760 : {
761 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
762 : return NULL_TREE;
763 : }
764 7455 : else if (TREE_CODE (tmp) == COMPONENT_REF)
765 7467 : comp_after_descr_found = true;
766 : }
767 : }
768 :
769 88446 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
770 59342 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
771 :
772 88446 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
773 : return tmp;
774 :
775 : return NULL_TREE;
776 : }
777 :
778 :
779 : /* Obtain the vptr of the last class reference in an expression.
780 : Return NULL_TREE if no class reference is found. */
781 :
782 : tree
783 11945 : gfc_get_vptr_from_expr (tree expr)
784 : {
785 11945 : tree tmp;
786 :
787 11945 : tmp = gfc_get_class_from_expr (expr);
788 :
789 11945 : if (tmp != NULL_TREE)
790 11880 : return gfc_class_vptr_get (tmp);
791 :
792 : return NULL_TREE;
793 : }
794 :
795 : static void
796 2287 : copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
797 : {
798 2287 : tree src_type = TREE_TYPE (src);
799 2287 : if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
800 : {
801 135 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
802 270 : for (int c = 0; c < lang_specific->corank; ++c)
803 : {
804 135 : int dim = lang_specific->rank + c;
805 135 : tree codim = gfc_rank_cst[dim];
806 :
807 135 : if (lang_specific->lbound[dim])
808 54 : gfc_conv_descriptor_lbound_set (block, dest, codim,
809 : lang_specific->lbound[dim]);
810 : else
811 81 : gfc_conv_descriptor_lbound_set (
812 : block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
813 135 : if (dim + 1 < lang_specific->corank)
814 : {
815 0 : if (lang_specific->ubound[dim])
816 0 : gfc_conv_descriptor_ubound_set (block, dest, codim,
817 : lang_specific->ubound[dim]);
818 : else
819 0 : gfc_conv_descriptor_ubound_set (
820 : block, dest, codim,
821 : gfc_conv_descriptor_ubound_get (src, codim));
822 : }
823 : }
824 : }
825 2287 : }
826 :
827 : void
828 1965 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
829 : bool lhs_type)
830 : {
831 1965 : tree lhs_dim, rhs_dim, type;
832 :
833 1965 : gfc_conv_descriptor_data_set (block, lhs_desc,
834 : gfc_conv_descriptor_data_get (rhs_desc));
835 1965 : gfc_conv_descriptor_offset_set (block, lhs_desc,
836 : gfc_conv_descriptor_offset_get (rhs_desc));
837 :
838 1965 : gfc_conv_descriptor_dtype_set (block, lhs_desc,
839 : gfc_conv_descriptor_dtype_get (rhs_desc));
840 :
841 : /* Assign the dimension as range-ref. */
842 1965 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
843 1965 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
844 :
845 1965 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
846 1965 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
847 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
848 1965 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
849 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
850 1965 : gfc_add_modify (block, lhs_dim, rhs_dim);
851 :
852 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
853 1965 : copy_coarray_desc_part (block, lhs_desc, rhs_desc);
854 1965 : }
855 :
856 : /* Takes a derived type expression and returns the address of a temporary
857 : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
858 : used for the temporary class object.
859 : optional_alloc_ptr is false when the dummy is neither allocatable
860 : nor a pointer; that's only relevant for the optional handling.
861 : The optional argument 'derived_array' is used to preserve the parmse
862 : expression for deallocation of allocatable components. Assumed rank
863 : formal arguments made this necessary. */
864 : void
865 5253 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
866 : tree opt_vptr_src, bool optional,
867 : bool optional_alloc_ptr, const char *proc_name,
868 : tree *derived_array)
869 : {
870 5253 : tree cond_optional = NULL_TREE;
871 5253 : gfc_ss *ss;
872 5253 : tree ctree;
873 5253 : tree var;
874 5253 : tree tmp;
875 5253 : tree packed = NULL_TREE;
876 :
877 : /* The derived type needs to be converted to a temporary CLASS object. */
878 5253 : tmp = gfc_typenode_for_spec (&fsym->ts);
879 5253 : var = gfc_create_var (tmp, "class");
880 :
881 : /* Set the vptr. */
882 5253 : if (opt_vptr_src)
883 128 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
884 : else
885 5125 : gfc_reset_vptr (&parmse->pre, e, var);
886 :
887 : /* Now set the data field. */
888 5253 : ctree = gfc_class_data_get (var);
889 :
890 5253 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
891 : {
892 4 : tree token;
893 4 : tmp = gfc_get_tree_for_caf_expr (e);
894 4 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
895 2 : tmp = build_fold_indirect_ref (tmp);
896 4 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
897 4 : gfc_conv_descriptor_token_set (&parmse->pre, ctree, token);
898 : }
899 :
900 5253 : if (optional)
901 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
902 :
903 : /* Set the _len as early as possible. */
904 5253 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
905 5253 : && fsym->ts.u.derived->components->ts.u.derived->attr
906 5253 : .unlimited_polymorphic)
907 : {
908 : /* Take care about initializing the _len component correctly. */
909 386 : tree len_tree = gfc_class_len_get (var);
910 386 : if (UNLIMITED_POLY (e))
911 : {
912 12 : gfc_expr *len;
913 12 : gfc_se se;
914 :
915 12 : len = gfc_find_and_cut_at_last_class_ref (e);
916 12 : gfc_add_len_component (len);
917 12 : gfc_init_se (&se, NULL);
918 12 : gfc_conv_expr (&se, len);
919 12 : if (optional)
920 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
921 : cond_optional, se.expr,
922 0 : fold_convert (TREE_TYPE (se.expr),
923 : integer_zero_node));
924 : else
925 12 : tmp = se.expr;
926 12 : gfc_free_expr (len);
927 12 : }
928 : else
929 374 : tmp = integer_zero_node;
930 386 : gfc_add_modify (&parmse->pre, len_tree,
931 386 : fold_convert (TREE_TYPE (len_tree), tmp));
932 : }
933 :
934 5253 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
935 : {
936 : /* If there is a ready made pointer to a derived type, use it
937 : rather than evaluating the expression again. */
938 535 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
939 535 : gfc_add_modify (&parmse->pre, ctree, tmp);
940 : }
941 4718 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
942 : {
943 : /* For an array reference in an elemental procedure call we need
944 : to retain the ss to provide the scalarized array reference. */
945 445 : gfc_conv_expr_reference (parmse, e);
946 445 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
947 445 : if (optional)
948 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
949 : cond_optional, tmp,
950 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
951 445 : gfc_add_modify (&parmse->pre, ctree, tmp);
952 : }
953 : else
954 : {
955 4273 : ss = gfc_walk_expr (e);
956 4273 : if (ss == gfc_ss_terminator)
957 : {
958 3019 : parmse->ss = NULL;
959 3019 : gfc_conv_expr_reference (parmse, e);
960 :
961 : /* Scalar to an assumed-rank array. */
962 3019 : if (fsym->ts.u.derived->components->as)
963 : {
964 322 : tree type;
965 322 : type = get_scalar_to_descriptor_type (parmse->expr,
966 : gfc_expr_attr (e));
967 322 : gfc_conv_descriptor_dtype_set (&parmse->pre, ctree,
968 : gfc_get_dtype (type));
969 322 : copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
970 322 : if (optional)
971 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
972 96 : TREE_TYPE (parmse->expr),
973 : cond_optional, parmse->expr,
974 96 : fold_convert (TREE_TYPE (parmse->expr),
975 : null_pointer_node));
976 322 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
977 : }
978 : else
979 : {
980 2697 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
981 2697 : if (optional)
982 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
983 : cond_optional, tmp,
984 132 : fold_convert (TREE_TYPE (tmp),
985 : null_pointer_node));
986 2697 : gfc_add_modify (&parmse->pre, ctree, tmp);
987 : }
988 : }
989 : else
990 : {
991 1254 : stmtblock_t block;
992 1254 : gfc_init_block (&block);
993 1254 : gfc_ref *ref;
994 1254 : int dim;
995 1254 : tree lbshift = NULL_TREE;
996 :
997 : /* Array refs with sections indicate, that a for a formal argument
998 : expecting contiguous repacking needs to be done. */
999 2357 : for (ref = e->ref; ref; ref = ref->next)
1000 1253 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1001 : break;
1002 1254 : if (IS_CLASS_ARRAY (fsym)
1003 1146 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
1004 888 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
1005 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
1006 144 : fsym->attr.contiguous = 1;
1007 :
1008 : /* Detect any array references with vector subscripts. */
1009 2501 : for (ref = e->ref; ref; ref = ref->next)
1010 1253 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
1011 1211 : && ref->u.ar.type != AR_FULL)
1012 : {
1013 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
1014 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
1015 : break;
1016 150 : if (dim < ref->u.ar.dimen)
1017 : break;
1018 : }
1019 : /* Array references with vector subscripts and non-variable
1020 : expressions need be converted to a one-based descriptor. */
1021 1254 : if (ref || e->expr_type != EXPR_VARIABLE)
1022 49 : lbshift = gfc_index_one_node;
1023 :
1024 1254 : parmse->expr = var;
1025 1254 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
1026 : &lbshift, &packed);
1027 :
1028 1254 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
1029 : {
1030 1158 : *derived_array
1031 1158 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
1032 1158 : if (e->rank == -1)
1033 : {
1034 : /* Assumed-rank actual: parmse->expr physically holds only
1035 : dtype.rank dims; a full struct assign reads past the end.
1036 : Copy field-by-field with a runtime-sized dim[] memcpy.
1037 : PR fortran/60576. */
1038 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
1039 :
1040 78 : gfc_conv_descriptor_data_set
1041 78 : (&block, *derived_array,
1042 : gfc_conv_descriptor_data_get (parmse->expr));
1043 78 : gfc_conv_descriptor_offset_set
1044 78 : (&block, *derived_array,
1045 : gfc_conv_descriptor_offset_get (parmse->expr));
1046 78 : tree dtype_val = gfc_conv_descriptor_dtype_get (parmse->expr);
1047 78 : gfc_conv_descriptor_dtype_set (&block, *derived_array,
1048 : dtype_val);
1049 78 : rank = gfc_conv_descriptor_rank_get (parmse->expr);
1050 78 : rank = fold_convert (size_type_node, rank);
1051 78 : dim_field = gfc_get_descriptor_dimension (parmse->expr);
1052 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
1053 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
1054 : size_type_node, rank, dim_size);
1055 78 : dst_ptr = gfc_build_addr_expr
1056 78 : (pvoid_type_node, gfc_get_descriptor_dimension (*derived_array));
1057 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
1058 78 : gfc_add_expr_to_block (&block,
1059 : build_call_expr_loc (input_location,
1060 : builtin_decl_explicit (BUILT_IN_MEMCPY),
1061 : 3, dst_ptr, src_ptr, copy_size));
1062 : }
1063 : else
1064 1080 : gfc_add_modify (&block, *derived_array, parmse->expr);
1065 : }
1066 :
1067 1254 : if (optional)
1068 : {
1069 348 : tmp = gfc_finish_block (&block);
1070 :
1071 348 : gfc_init_block (&block);
1072 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
1073 348 : if (derived_array && *derived_array != NULL_TREE)
1074 348 : gfc_conv_descriptor_data_set (&block, *derived_array,
1075 : null_pointer_node);
1076 :
1077 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
1078 : gfc_finish_block (&block));
1079 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
1080 : }
1081 : else
1082 906 : gfc_add_block_to_block (&parmse->pre, &block);
1083 : }
1084 : }
1085 :
1086 : /* Pass the address of the class object. */
1087 5253 : if (packed)
1088 96 : parmse->expr = packed;
1089 : else
1090 5157 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1091 :
1092 5253 : if (optional && optional_alloc_ptr)
1093 84 : parmse->expr
1094 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1095 : cond_optional, parmse->expr,
1096 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1097 5253 : }
1098 :
1099 : /* Create a new class container, which is required as scalar coarrays
1100 : have an array descriptor while normal scalars haven't. Optionally,
1101 : NULL pointer checks are added if the argument is OPTIONAL. */
1102 :
1103 : static void
1104 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1105 : gfc_typespec class_ts, bool optional)
1106 : {
1107 48 : tree var, ctree, tmp;
1108 48 : stmtblock_t block;
1109 48 : gfc_ref *ref;
1110 48 : gfc_ref *class_ref;
1111 :
1112 48 : gfc_init_block (&block);
1113 :
1114 48 : class_ref = NULL;
1115 144 : for (ref = e->ref; ref; ref = ref->next)
1116 : {
1117 96 : if (ref->type == REF_COMPONENT
1118 48 : && ref->u.c.component->ts.type == BT_CLASS)
1119 96 : class_ref = ref;
1120 : }
1121 :
1122 48 : if (class_ref == NULL
1123 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1124 48 : tmp = e->symtree->n.sym->backend_decl;
1125 : else
1126 : {
1127 : /* Remove everything after the last class reference, convert the
1128 : expression and then recover its tailend once more. */
1129 0 : gfc_se tmpse;
1130 0 : ref = class_ref->next;
1131 0 : class_ref->next = NULL;
1132 0 : gfc_init_se (&tmpse, NULL);
1133 0 : gfc_conv_expr (&tmpse, e);
1134 0 : class_ref->next = ref;
1135 0 : tmp = tmpse.expr;
1136 : }
1137 :
1138 48 : var = gfc_typenode_for_spec (&class_ts);
1139 48 : var = gfc_create_var (var, "class");
1140 :
1141 48 : ctree = gfc_class_vptr_get (var);
1142 96 : gfc_add_modify (&block, ctree,
1143 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1144 :
1145 48 : ctree = gfc_class_data_get (var);
1146 48 : tmp = gfc_conv_descriptor_data_get (
1147 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1148 : ? tmp
1149 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1150 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1151 :
1152 : /* Pass the address of the class object. */
1153 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1154 :
1155 48 : if (optional)
1156 : {
1157 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1158 48 : tree tmp2;
1159 :
1160 48 : tmp = gfc_finish_block (&block);
1161 :
1162 48 : gfc_init_block (&block);
1163 48 : tmp2 = gfc_class_data_get (var);
1164 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1165 : null_pointer_node));
1166 48 : tmp2 = gfc_finish_block (&block);
1167 :
1168 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1169 : cond, tmp, tmp2);
1170 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1171 : }
1172 : else
1173 0 : gfc_add_block_to_block (&parmse->pre, &block);
1174 48 : }
1175 :
1176 :
1177 : /* Takes an intrinsic type expression and returns the address of a temporary
1178 : class object of the 'declared' type. */
1179 : void
1180 882 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1181 : gfc_typespec class_ts)
1182 : {
1183 882 : gfc_symbol *vtab;
1184 882 : gfc_ss *ss;
1185 882 : tree ctree;
1186 882 : tree var;
1187 882 : tree tmp;
1188 882 : int dim;
1189 882 : bool unlimited_poly;
1190 :
1191 1764 : unlimited_poly = class_ts.type == BT_CLASS
1192 882 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1193 882 : && class_ts.u.derived->components->ts.u.derived
1194 882 : ->attr.unlimited_polymorphic;
1195 :
1196 : /* The intrinsic type needs to be converted to a temporary
1197 : CLASS object. */
1198 882 : tmp = gfc_typenode_for_spec (&class_ts);
1199 882 : var = gfc_create_var (tmp, "class");
1200 :
1201 : /* Force a temporary for component or substring references. */
1202 882 : if (unlimited_poly
1203 882 : && class_ts.u.derived->components->attr.dimension
1204 623 : && !class_ts.u.derived->components->attr.allocatable
1205 623 : && !class_ts.u.derived->components->attr.class_pointer
1206 1505 : && is_subref_array (e))
1207 17 : parmse->force_tmp = 1;
1208 :
1209 : /* Set the vptr. */
1210 882 : ctree = gfc_class_vptr_get (var);
1211 :
1212 882 : vtab = gfc_find_vtab (&e->ts);
1213 882 : gcc_assert (vtab);
1214 882 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1215 882 : gfc_add_modify (&parmse->pre, ctree,
1216 882 : fold_convert (TREE_TYPE (ctree), tmp));
1217 :
1218 : /* Now set the data field. */
1219 882 : ctree = gfc_class_data_get (var);
1220 882 : if (parmse->ss && parmse->ss->info->useflags)
1221 : {
1222 : /* For an array reference in an elemental procedure call we need
1223 : to retain the ss to provide the scalarized array reference. */
1224 36 : gfc_conv_expr_reference (parmse, e);
1225 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1226 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1227 : }
1228 : else
1229 : {
1230 846 : ss = gfc_walk_expr (e);
1231 846 : if (ss == gfc_ss_terminator)
1232 : {
1233 247 : parmse->ss = NULL;
1234 247 : gfc_conv_expr_reference (parmse, e);
1235 247 : if (class_ts.u.derived->components->as
1236 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1237 : {
1238 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1239 : gfc_expr_attr (e));
1240 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1241 24 : TREE_TYPE (ctree), tmp);
1242 : }
1243 : else
1244 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1245 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1246 : }
1247 : else
1248 : {
1249 599 : parmse->ss = ss;
1250 599 : gfc_conv_expr_descriptor (parmse, e);
1251 :
1252 : /* Array references with vector subscripts and non-variable expressions
1253 : need be converted to a one-based descriptor. */
1254 599 : if (e->expr_type != EXPR_VARIABLE)
1255 : {
1256 368 : for (dim = 0; dim < e->rank; ++dim)
1257 193 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1258 : dim, gfc_index_one_node);
1259 : }
1260 :
1261 599 : if (class_ts.u.derived->components->as->rank != e->rank)
1262 : {
1263 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1264 49 : TREE_TYPE (ctree), parmse->expr);
1265 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1266 : }
1267 : else
1268 550 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1269 : }
1270 : }
1271 :
1272 882 : gcc_assert (class_ts.type == BT_CLASS);
1273 882 : if (unlimited_poly)
1274 : {
1275 882 : ctree = gfc_class_len_get (var);
1276 : /* When the actual arg is a char array, then set the _len component of the
1277 : unlimited polymorphic entity to the length of the string. */
1278 882 : if (e->ts.type == BT_CHARACTER)
1279 : {
1280 : /* Start with parmse->string_length because this seems to be set to a
1281 : correct value more often. */
1282 175 : if (parmse->string_length)
1283 : tmp = parmse->string_length;
1284 : /* When the string_length is not yet set, then try the backend_decl of
1285 : the cl. */
1286 0 : else if (e->ts.u.cl->backend_decl)
1287 : tmp = e->ts.u.cl->backend_decl;
1288 : /* If both of the above approaches fail, then try to generate an
1289 : expression from the input, which is only feasible currently, when the
1290 : expression can be evaluated to a constant one. */
1291 : else
1292 : {
1293 : /* Try to simplify the expression. */
1294 0 : gfc_simplify_expr (e, 0);
1295 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1296 : {
1297 : /* Amazingly all data is present to compute the length of a
1298 : constant string, but the expression is not yet there. */
1299 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1300 : gfc_charlen_int_kind,
1301 : &e->where);
1302 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1303 0 : e->value.character.length);
1304 0 : gfc_conv_const_charlen (e->ts.u.cl);
1305 0 : e->ts.u.cl->resolved = 1;
1306 0 : tmp = e->ts.u.cl->backend_decl;
1307 : }
1308 : else
1309 : {
1310 0 : gfc_error ("Cannot compute the length of the char array "
1311 : "at %L.", &e->where);
1312 : }
1313 : }
1314 : }
1315 : else
1316 707 : tmp = integer_zero_node;
1317 :
1318 882 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1319 : }
1320 :
1321 : /* Pass the address of the class object. */
1322 882 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1323 882 : }
1324 :
1325 :
1326 : /* Takes a scalarized class array expression and returns the
1327 : address of a temporary scalar class object of the 'declared'
1328 : type.
1329 : OOP-TODO: This could be improved by adding code that branched on
1330 : the dynamic type being the same as the declared type. In this case
1331 : the original class expression can be passed directly.
1332 : optional_alloc_ptr is false when the dummy is neither allocatable
1333 : nor a pointer; that's relevant for the optional handling.
1334 : Set copyback to true if class container's _data and _vtab pointers
1335 : might get modified. */
1336 :
1337 : void
1338 3654 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1339 : bool elemental, bool copyback, bool optional,
1340 : bool optional_alloc_ptr)
1341 : {
1342 3654 : tree ctree;
1343 3654 : tree var;
1344 3654 : tree tmp;
1345 3654 : tree vptr;
1346 3654 : tree cond = NULL_TREE;
1347 3654 : tree slen = NULL_TREE;
1348 3654 : gfc_ref *ref;
1349 3654 : gfc_ref *class_ref;
1350 3654 : stmtblock_t block;
1351 3654 : bool full_array = false;
1352 :
1353 : /* If this is the data field of a class temporary, the class expression
1354 : can be obtained and returned directly. */
1355 3654 : if (e->expr_type != EXPR_VARIABLE
1356 180 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1357 36 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))
1358 3690 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse->expr, 0))))
1359 : {
1360 36 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1361 36 : if (!VAR_P (parmse->expr))
1362 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1363 36 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1364 174 : return;
1365 : }
1366 :
1367 3618 : gfc_init_block (&block);
1368 :
1369 3618 : class_ref = NULL;
1370 7273 : for (ref = e->ref; ref; ref = ref->next)
1371 : {
1372 6897 : if (ref->type == REF_COMPONENT
1373 3688 : && ref->u.c.component->ts.type == BT_CLASS)
1374 6897 : class_ref = ref;
1375 :
1376 6897 : if (ref->next == NULL)
1377 : break;
1378 : }
1379 :
1380 3618 : if ((ref == NULL || class_ref == ref)
1381 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1382 4088 : && (!class_ts.u.derived->components->as
1383 379 : || class_ts.u.derived->components->as->rank != -1))
1384 : return;
1385 :
1386 : /* Test for FULL_ARRAY. */
1387 3480 : if (e->rank == 0
1388 3480 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1389 494 : || (class_ts.u.derived->components->as
1390 366 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1391 411 : full_array = true;
1392 : else
1393 3069 : gfc_is_class_array_ref (e, &full_array);
1394 :
1395 : /* The derived type needs to be converted to a temporary
1396 : CLASS object. */
1397 3480 : tmp = gfc_typenode_for_spec (&class_ts);
1398 3480 : var = gfc_create_var (tmp, "class");
1399 :
1400 : /* Set the data. */
1401 3480 : ctree = gfc_class_data_get (var);
1402 3480 : if (class_ts.u.derived->components->as
1403 3196 : && e->rank != class_ts.u.derived->components->as->rank)
1404 : {
1405 977 : if (e->rank == 0)
1406 : {
1407 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1408 : gfc_expr_attr (e));
1409 356 : gfc_conv_descriptor_dtype_set (&block, ctree,
1410 : gfc_get_dtype (type));
1411 :
1412 356 : tmp = gfc_class_data_get (parmse->expr);
1413 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1414 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1415 :
1416 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1417 : }
1418 : else
1419 621 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1420 : }
1421 : else
1422 : {
1423 2503 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1424 1451 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1425 1451 : TREE_TYPE (ctree), parmse->expr);
1426 2503 : gfc_add_modify (&block, ctree, parmse->expr);
1427 : }
1428 :
1429 : /* Return the data component, except in the case of scalarized array
1430 : references, where nullification of the cannot occur and so there
1431 : is no need. */
1432 3480 : if (!elemental && full_array && copyback)
1433 : {
1434 1164 : if (class_ts.u.derived->components->as
1435 1164 : && e->rank != class_ts.u.derived->components->as->rank)
1436 : {
1437 270 : if (e->rank == 0)
1438 : {
1439 102 : tmp = gfc_class_data_get (parmse->expr);
1440 204 : gfc_add_modify (&parmse->post, tmp,
1441 102 : fold_convert (TREE_TYPE (tmp),
1442 : gfc_conv_descriptor_data_get (ctree)));
1443 : }
1444 : else
1445 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1446 : true);
1447 : }
1448 : else
1449 894 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1450 : }
1451 :
1452 : /* Set the vptr. */
1453 3480 : ctree = gfc_class_vptr_get (var);
1454 :
1455 : /* The vptr is the second field of the actual argument.
1456 : First we have to find the corresponding class reference. */
1457 :
1458 3480 : tmp = NULL_TREE;
1459 3480 : if (gfc_is_class_array_function (e)
1460 3480 : && parmse->class_vptr != NULL_TREE)
1461 : tmp = parmse->class_vptr;
1462 3462 : else if (class_ref == NULL
1463 2999 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1464 : {
1465 2999 : tmp = e->symtree->n.sym->backend_decl;
1466 :
1467 2999 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1468 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1469 :
1470 2999 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1471 397 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1472 :
1473 2999 : slen = build_zero_cst (size_type_node);
1474 : }
1475 463 : else if (parmse->class_container != NULL_TREE)
1476 : /* Don't redundantly evaluate the expression if the required information
1477 : is already available. */
1478 : tmp = parmse->class_container;
1479 : else
1480 : {
1481 : /* Remove everything after the last class reference, convert the
1482 : expression and then recover its tailend once more. */
1483 18 : gfc_se tmpse;
1484 18 : ref = class_ref->next;
1485 18 : class_ref->next = NULL;
1486 18 : gfc_init_se (&tmpse, NULL);
1487 18 : gfc_conv_expr (&tmpse, e);
1488 18 : class_ref->next = ref;
1489 18 : tmp = tmpse.expr;
1490 18 : slen = tmpse.string_length;
1491 : }
1492 :
1493 3480 : gcc_assert (tmp != NULL_TREE);
1494 :
1495 : /* Dereference if needs be. */
1496 3480 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1497 345 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1498 :
1499 3480 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1500 3462 : vptr = gfc_class_vptr_get (tmp);
1501 : else
1502 : vptr = tmp;
1503 :
1504 3480 : gfc_add_modify (&block, ctree,
1505 3480 : fold_convert (TREE_TYPE (ctree), vptr));
1506 :
1507 : /* Return the vptr component, except in the case of scalarized array
1508 : references, where the dynamic type cannot change. */
1509 3480 : if (!elemental && full_array && copyback)
1510 1164 : gfc_add_modify (&parmse->post, vptr,
1511 1164 : fold_convert (TREE_TYPE (vptr), ctree));
1512 :
1513 : /* For unlimited polymorphic objects also set the _len component. */
1514 3480 : if (class_ts.type == BT_CLASS
1515 3480 : && class_ts.u.derived->components
1516 3480 : && class_ts.u.derived->components->ts.u
1517 3480 : .derived->attr.unlimited_polymorphic)
1518 : {
1519 1146 : ctree = gfc_class_len_get (var);
1520 1146 : if (UNLIMITED_POLY (e))
1521 943 : tmp = gfc_class_len_get (tmp);
1522 203 : else if (e->ts.type == BT_CHARACTER)
1523 : {
1524 0 : gcc_assert (slen != NULL_TREE);
1525 : tmp = slen;
1526 : }
1527 : else
1528 203 : tmp = build_zero_cst (size_type_node);
1529 1146 : gfc_add_modify (&parmse->pre, ctree,
1530 1146 : fold_convert (TREE_TYPE (ctree), tmp));
1531 :
1532 : /* Return the len component, except in the case of scalarized array
1533 : references, where the dynamic type cannot change. */
1534 1146 : if (!elemental && full_array && copyback
1535 447 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1536 434 : gfc_add_modify (&parmse->post, tmp,
1537 434 : fold_convert (TREE_TYPE (tmp), ctree));
1538 : }
1539 :
1540 3480 : if (optional)
1541 : {
1542 510 : tree tmp2;
1543 :
1544 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1545 : /* parmse->pre may contain some preparatory instructions for the
1546 : temporary array descriptor. Those may only be executed when the
1547 : optional argument is set, therefore add parmse->pre's instructions
1548 : to block, which is later guarded by an if (optional_arg_given). */
1549 510 : gfc_add_block_to_block (&parmse->pre, &block);
1550 510 : block.head = parmse->pre.head;
1551 510 : parmse->pre.head = NULL_TREE;
1552 510 : tmp = gfc_finish_block (&block);
1553 :
1554 510 : if (optional_alloc_ptr)
1555 102 : tmp2 = build_empty_stmt (input_location);
1556 : else
1557 : {
1558 408 : gfc_init_block (&block);
1559 408 : gfc_conv_descriptor_data_set (&block, gfc_class_data_get (var),
1560 : null_pointer_node);
1561 408 : tmp2 = gfc_finish_block (&block);
1562 : }
1563 :
1564 510 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1565 : cond, tmp, tmp2);
1566 510 : gfc_add_expr_to_block (&parmse->pre, tmp);
1567 :
1568 510 : if (!elemental && full_array && copyback)
1569 : {
1570 30 : tmp2 = build_empty_stmt (input_location);
1571 30 : tmp = gfc_finish_block (&parmse->post);
1572 30 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1573 : cond, tmp, tmp2);
1574 30 : gfc_add_expr_to_block (&parmse->post, tmp);
1575 : }
1576 : }
1577 : else
1578 2970 : gfc_add_block_to_block (&parmse->pre, &block);
1579 :
1580 : /* Pass the address of the class object. */
1581 3480 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1582 :
1583 3480 : if (optional && optional_alloc_ptr)
1584 204 : parmse->expr = build3_loc (input_location, COND_EXPR,
1585 102 : TREE_TYPE (parmse->expr),
1586 : cond, parmse->expr,
1587 102 : fold_convert (TREE_TYPE (parmse->expr),
1588 : null_pointer_node));
1589 : }
1590 :
1591 :
1592 : /* Given a class array declaration and an index, returns the address
1593 : of the referenced element. */
1594 :
1595 : static tree
1596 744 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1597 : bool unlimited)
1598 : {
1599 744 : tree data, size, tmp, ctmp, offset, ptr;
1600 :
1601 744 : data = data_comp != NULL_TREE ? data_comp :
1602 0 : gfc_class_data_get (class_decl);
1603 744 : size = gfc_class_vtab_size_get (class_decl);
1604 :
1605 744 : if (unlimited)
1606 : {
1607 220 : tmp = fold_convert (gfc_array_index_type,
1608 : gfc_class_len_get (class_decl));
1609 220 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1610 : gfc_array_index_type, size, tmp);
1611 220 : tmp = fold_build2_loc (input_location, GT_EXPR,
1612 : logical_type_node, tmp,
1613 220 : build_zero_cst (TREE_TYPE (tmp)));
1614 220 : size = fold_build3_loc (input_location, COND_EXPR,
1615 : gfc_array_index_type, tmp, ctmp, size);
1616 : }
1617 :
1618 744 : offset = fold_build2_loc (input_location, MULT_EXPR,
1619 : gfc_array_index_type,
1620 : index, size);
1621 :
1622 744 : data = gfc_conv_descriptor_data_get (data);
1623 744 : ptr = fold_convert (pvoid_type_node, data);
1624 744 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1625 744 : return fold_convert (TREE_TYPE (data), ptr);
1626 : }
1627 :
1628 :
1629 : /* Copies one class expression to another, assuming that if either
1630 : 'to' or 'from' are arrays they are packed. Should 'from' be
1631 : NULL_TREE, the initialization expression for 'to' is used, assuming
1632 : that the _vptr is set. */
1633 :
1634 : tree
1635 780 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1636 : {
1637 780 : tree fcn;
1638 780 : tree fcn_type;
1639 780 : tree from_data;
1640 780 : tree from_len;
1641 780 : tree to_data;
1642 780 : tree to_len;
1643 780 : tree to_ref;
1644 780 : tree from_ref;
1645 780 : vec<tree, va_gc> *args;
1646 780 : tree tmp;
1647 780 : tree stdcopy;
1648 780 : tree extcopy;
1649 780 : tree index;
1650 780 : bool is_from_desc = false, is_to_class = false;
1651 :
1652 780 : args = NULL;
1653 : /* To prevent warnings on uninitialized variables. */
1654 780 : from_len = to_len = NULL_TREE;
1655 :
1656 780 : if (from != NULL_TREE)
1657 780 : fcn = gfc_class_vtab_copy_get (from);
1658 : else
1659 0 : fcn = gfc_class_vtab_copy_get (to);
1660 :
1661 780 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1662 :
1663 780 : if (from != NULL_TREE)
1664 : {
1665 780 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1666 780 : if (is_from_desc)
1667 : {
1668 0 : from_data = from;
1669 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1670 : }
1671 : else
1672 : {
1673 : /* Check that from is a class. When the class is part of a coarray,
1674 : then from is a common pointer and is to be used as is. */
1675 1560 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1676 780 : ? build_fold_indirect_ref (from) : from;
1677 1560 : from_data =
1678 780 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1679 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1680 780 : ? gfc_class_data_get (from) : from;
1681 780 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1682 : }
1683 : }
1684 : else
1685 0 : from_data = gfc_class_vtab_def_init_get (to);
1686 :
1687 780 : if (unlimited)
1688 : {
1689 170 : if (from != NULL_TREE && unlimited)
1690 170 : from_len = gfc_class_len_or_zero_get (from);
1691 : else
1692 0 : from_len = build_zero_cst (size_type_node);
1693 : }
1694 :
1695 780 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1696 : {
1697 780 : is_to_class = true;
1698 780 : to_data = gfc_class_data_get (to);
1699 780 : if (unlimited)
1700 170 : to_len = gfc_class_len_get (to);
1701 : }
1702 : else
1703 : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1704 0 : to_data = to;
1705 :
1706 780 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1707 : {
1708 372 : stmtblock_t loopbody;
1709 372 : stmtblock_t body;
1710 372 : stmtblock_t ifbody;
1711 372 : gfc_loopinfo loop;
1712 :
1713 372 : gfc_init_block (&body);
1714 372 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1715 : gfc_array_index_type, nelems,
1716 : gfc_index_one_node);
1717 372 : nelems = gfc_evaluate_now (tmp, &body);
1718 372 : index = gfc_create_var (gfc_array_index_type, "S");
1719 :
1720 372 : if (is_from_desc)
1721 : {
1722 372 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1723 : unlimited);
1724 372 : vec_safe_push (args, from_ref);
1725 : }
1726 : else
1727 0 : vec_safe_push (args, from_data);
1728 :
1729 372 : if (is_to_class)
1730 372 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1731 : else
1732 : {
1733 0 : tmp = gfc_conv_array_data (to);
1734 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1735 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1736 : gfc_build_array_ref (tmp, index, to));
1737 : }
1738 372 : vec_safe_push (args, to_ref);
1739 :
1740 : /* Add bounds check. */
1741 372 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1742 : {
1743 25 : const char *name = "<<unknown>>";
1744 25 : int dim, rank;
1745 :
1746 25 : if (DECL_P (to))
1747 0 : name = IDENTIFIER_POINTER (DECL_NAME (to));
1748 :
1749 25 : rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
1750 55 : for (dim = 1; dim <= rank; dim++)
1751 : {
1752 30 : tree from_len, to_len, cond;
1753 30 : char *msg;
1754 :
1755 30 : from_len = gfc_conv_descriptor_size (from_data, dim);
1756 30 : from_len = fold_convert (long_integer_type_node, from_len);
1757 30 : to_len = gfc_conv_descriptor_size (to_data, dim);
1758 30 : to_len = fold_convert (long_integer_type_node, to_len);
1759 30 : msg = xasprintf ("Array bound mismatch for dimension %d "
1760 : "of array '%s' (%%ld/%%ld)",
1761 : dim, name);
1762 30 : cond = fold_build2_loc (input_location, NE_EXPR,
1763 : logical_type_node, from_len, to_len);
1764 30 : gfc_trans_runtime_check (true, false, cond, &body,
1765 : NULL, msg, to_len, from_len);
1766 30 : free (msg);
1767 : }
1768 : }
1769 :
1770 372 : tmp = build_call_vec (fcn_type, fcn, args);
1771 :
1772 : /* Build the body of the loop. */
1773 372 : gfc_init_block (&loopbody);
1774 372 : gfc_add_expr_to_block (&loopbody, tmp);
1775 :
1776 : /* Build the loop and return. */
1777 372 : gfc_init_loopinfo (&loop);
1778 372 : loop.dimen = 1;
1779 372 : loop.from[0] = gfc_index_zero_node;
1780 372 : loop.loopvar[0] = index;
1781 372 : loop.to[0] = nelems;
1782 372 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1783 372 : gfc_init_block (&ifbody);
1784 372 : gfc_add_block_to_block (&ifbody, &loop.pre);
1785 372 : stdcopy = gfc_finish_block (&ifbody);
1786 : /* In initialization mode from_len is a constant zero. */
1787 372 : if (unlimited && !integer_zerop (from_len))
1788 : {
1789 110 : vec_safe_push (args, from_len);
1790 110 : vec_safe_push (args, to_len);
1791 110 : tmp = build_call_vec (fcn_type, fcn, args);
1792 : /* Build the body of the loop. */
1793 110 : gfc_init_block (&loopbody);
1794 110 : gfc_add_expr_to_block (&loopbody, tmp);
1795 :
1796 : /* Build the loop and return. */
1797 110 : gfc_init_loopinfo (&loop);
1798 110 : loop.dimen = 1;
1799 110 : loop.from[0] = gfc_index_zero_node;
1800 110 : loop.loopvar[0] = index;
1801 110 : loop.to[0] = nelems;
1802 110 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1803 110 : gfc_init_block (&ifbody);
1804 110 : gfc_add_block_to_block (&ifbody, &loop.pre);
1805 110 : extcopy = gfc_finish_block (&ifbody);
1806 :
1807 110 : tmp = fold_build2_loc (input_location, GT_EXPR,
1808 : logical_type_node, from_len,
1809 110 : build_zero_cst (TREE_TYPE (from_len)));
1810 110 : tmp = fold_build3_loc (input_location, COND_EXPR,
1811 : void_type_node, tmp, extcopy, stdcopy);
1812 110 : gfc_add_expr_to_block (&body, tmp);
1813 110 : tmp = gfc_finish_block (&body);
1814 : }
1815 : else
1816 : {
1817 262 : gfc_add_expr_to_block (&body, stdcopy);
1818 262 : tmp = gfc_finish_block (&body);
1819 : }
1820 372 : gfc_cleanup_loop (&loop);
1821 : }
1822 : else
1823 : {
1824 408 : gcc_assert (!is_from_desc);
1825 408 : vec_safe_push (args, from_data);
1826 408 : vec_safe_push (args, to_data);
1827 408 : stdcopy = build_call_vec (fcn_type, fcn, args);
1828 :
1829 : /* In initialization mode from_len is a constant zero. */
1830 408 : if (unlimited && !integer_zerop (from_len))
1831 : {
1832 60 : vec_safe_push (args, from_len);
1833 60 : vec_safe_push (args, to_len);
1834 60 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1835 60 : tmp = fold_build2_loc (input_location, GT_EXPR,
1836 : logical_type_node, from_len,
1837 60 : build_zero_cst (TREE_TYPE (from_len)));
1838 60 : tmp = fold_build3_loc (input_location, COND_EXPR,
1839 : void_type_node, tmp, extcopy, stdcopy);
1840 : }
1841 : else
1842 : tmp = stdcopy;
1843 : }
1844 :
1845 : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1846 780 : if (from == NULL_TREE)
1847 : {
1848 0 : tree cond;
1849 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1850 : logical_type_node,
1851 : from_data, null_pointer_node);
1852 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1853 : void_type_node, cond,
1854 : tmp, build_empty_stmt (input_location));
1855 : }
1856 :
1857 780 : return tmp;
1858 : }
1859 :
1860 :
1861 : static tree
1862 106 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1863 : {
1864 106 : gfc_actual_arglist *actual;
1865 106 : gfc_expr *ppc;
1866 106 : gfc_code *ppc_code;
1867 106 : tree res;
1868 :
1869 106 : actual = gfc_get_actual_arglist ();
1870 106 : actual->expr = gfc_copy_expr (rhs);
1871 106 : actual->next = gfc_get_actual_arglist ();
1872 106 : actual->next->expr = gfc_copy_expr (lhs);
1873 106 : ppc = gfc_copy_expr (obj);
1874 106 : gfc_add_vptr_component (ppc);
1875 106 : gfc_add_component_ref (ppc, "_copy");
1876 106 : ppc_code = gfc_get_code (EXEC_CALL);
1877 106 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1878 : /* Although '_copy' is set to be elemental in class.cc, it is
1879 : not staying that way. Find out why, sometime.... */
1880 106 : ppc_code->resolved_sym->attr.elemental = 1;
1881 106 : ppc_code->ext.actual = actual;
1882 106 : ppc_code->expr1 = ppc;
1883 : /* Since '_copy' is elemental, the scalarizer will take care
1884 : of arrays in gfc_trans_call. */
1885 106 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1886 106 : gfc_free_statements (ppc_code);
1887 :
1888 106 : if (UNLIMITED_POLY(obj))
1889 : {
1890 : /* Check if rhs is non-NULL. */
1891 24 : gfc_se src;
1892 24 : gfc_init_se (&src, NULL);
1893 24 : gfc_conv_expr (&src, rhs);
1894 24 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1895 24 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1896 24 : src.expr, fold_convert (TREE_TYPE (src.expr),
1897 : null_pointer_node));
1898 24 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1899 : build_empty_stmt (input_location));
1900 : }
1901 :
1902 106 : return res;
1903 : }
1904 :
1905 : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1906 : A MEMCPY is needed to copy the full data from the default initializer
1907 : of the dynamic type. */
1908 :
1909 : tree
1910 461 : gfc_trans_class_init_assign (gfc_code *code)
1911 : {
1912 461 : stmtblock_t block;
1913 461 : tree tmp;
1914 461 : bool cmp_flag = true;
1915 461 : gfc_se dst,src,memsz;
1916 461 : gfc_expr *lhs, *rhs, *sz;
1917 461 : gfc_component *cmp;
1918 461 : gfc_symbol *sym;
1919 461 : gfc_ref *ref;
1920 :
1921 461 : gfc_start_block (&block);
1922 :
1923 461 : lhs = gfc_copy_expr (code->expr1);
1924 :
1925 461 : rhs = gfc_copy_expr (code->expr1);
1926 461 : gfc_add_vptr_component (rhs);
1927 :
1928 : /* Make sure that the component backend_decls have been built, which
1929 : will not have happened if the derived types concerned have not
1930 : been referenced. */
1931 461 : gfc_get_derived_type (rhs->ts.u.derived);
1932 461 : gfc_add_def_init_component (rhs);
1933 : /* The _def_init is always scalar. */
1934 461 : rhs->rank = 0;
1935 :
1936 : /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
1937 : default initializer components NULL, use the passed value even though
1938 : F2018(8.5.10) asserts that it should considered to be undefined. This is
1939 : needed for consistency with other brands. */
1940 461 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1941 : : NULL;
1942 461 : if (code->op != EXEC_ALLOCATE
1943 400 : && sym && sym->attr.dummy
1944 400 : && sym->attr.intent == INTENT_OUT)
1945 : {
1946 400 : ref = rhs->ref;
1947 800 : while (ref && ref->next)
1948 : ref = ref->next;
1949 400 : cmp = ref->u.c.component->ts.u.derived->components;
1950 611 : for (; cmp; cmp = cmp->next)
1951 : {
1952 428 : if (cmp->initializer)
1953 : break;
1954 211 : else if (!cmp->next)
1955 146 : cmp_flag = false;
1956 : }
1957 : }
1958 :
1959 461 : if (code->expr1->ts.type == BT_CLASS
1960 438 : && CLASS_DATA (code->expr1)->attr.dimension)
1961 : {
1962 106 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1963 106 : *tmparr = *CLASS_DATA (code->expr1)->as;
1964 : /* Adding the array ref to the class expression results in correct
1965 : indexing to the dynamic type. */
1966 106 : gfc_add_full_array_ref (lhs, tmparr);
1967 106 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1968 106 : }
1969 355 : else if (cmp_flag)
1970 : {
1971 : /* Scalar initialization needs the _data component. */
1972 222 : gfc_add_data_component (lhs);
1973 222 : sz = gfc_copy_expr (code->expr1);
1974 222 : gfc_add_vptr_component (sz);
1975 222 : gfc_add_size_component (sz);
1976 :
1977 222 : gfc_init_se (&dst, NULL);
1978 222 : gfc_init_se (&src, NULL);
1979 222 : gfc_init_se (&memsz, NULL);
1980 222 : gfc_conv_expr (&dst, lhs);
1981 222 : gfc_conv_expr (&src, rhs);
1982 222 : gfc_conv_expr (&memsz, sz);
1983 222 : gfc_add_block_to_block (&block, &src.pre);
1984 222 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1985 :
1986 222 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1987 :
1988 222 : if (UNLIMITED_POLY(code->expr1))
1989 : {
1990 : /* Check if _def_init is non-NULL. */
1991 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1992 : logical_type_node, src.expr,
1993 7 : fold_convert (TREE_TYPE (src.expr),
1994 : null_pointer_node));
1995 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1996 : tmp, build_empty_stmt (input_location));
1997 : }
1998 : }
1999 : else
2000 133 : tmp = build_empty_stmt (input_location);
2001 :
2002 461 : if (code->expr1->symtree->n.sym->attr.dummy
2003 410 : && (code->expr1->symtree->n.sym->attr.optional
2004 404 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
2005 : {
2006 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
2007 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2008 : present, tmp,
2009 : build_empty_stmt (input_location));
2010 : }
2011 :
2012 461 : gfc_add_expr_to_block (&block, tmp);
2013 461 : gfc_free_expr (lhs);
2014 461 : gfc_free_expr (rhs);
2015 :
2016 461 : return gfc_finish_block (&block);
2017 : }
2018 :
2019 :
2020 : /* Class valued elemental function calls or class array elements arriving
2021 : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
2022 : is used to ensure that the rhs dynamic type is assigned to the lhs. */
2023 :
2024 : static bool
2025 788 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
2026 : {
2027 788 : tree fcn;
2028 788 : tree rse_expr;
2029 788 : tree class_data;
2030 788 : tree tmp;
2031 788 : tree zero;
2032 788 : tree cond;
2033 788 : tree final_cond;
2034 788 : stmtblock_t inner_block;
2035 788 : bool is_descriptor;
2036 788 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
2037 788 : bool not_lhs_array_type;
2038 :
2039 : /* Temporaries arising from dependencies in assignment get cast as a
2040 : character type of the dynamic size of the rhs. Use the vptr copy
2041 : for this case. */
2042 788 : tmp = TREE_TYPE (lse->expr);
2043 788 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
2044 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
2045 :
2046 : /* Use ordinary assignment if the rhs is not a call expression or
2047 : the lhs is not a class entity or an array(ie. character) type. */
2048 740 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
2049 1061 : && not_lhs_array_type)
2050 : return false;
2051 :
2052 : /* Ordinary assignment can be used if both sides are class expressions
2053 : since the dynamic type is preserved by copying the vptr. This
2054 : should only occur, where temporaries are involved. */
2055 515 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
2056 515 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
2057 : return false;
2058 :
2059 : /* Fix the class expression and the class data of the rhs. */
2060 454 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
2061 454 : || not_call_expr)
2062 : {
2063 454 : tmp = gfc_get_class_from_expr (rse->expr);
2064 454 : if (tmp == NULL_TREE)
2065 : return false;
2066 146 : rse_expr = gfc_evaluate_now (tmp, block);
2067 : }
2068 : else
2069 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
2070 :
2071 146 : class_data = gfc_class_data_get (rse_expr);
2072 :
2073 : /* Check that the rhs data is not null. */
2074 146 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
2075 146 : if (is_descriptor)
2076 146 : class_data = gfc_conv_descriptor_data_get (class_data);
2077 146 : class_data = gfc_evaluate_now (class_data, block);
2078 :
2079 146 : zero = build_int_cst (TREE_TYPE (class_data), 0);
2080 146 : cond = fold_build2_loc (input_location, NE_EXPR,
2081 : logical_type_node,
2082 : class_data, zero);
2083 :
2084 : /* Copy the rhs to the lhs. */
2085 146 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
2086 146 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2087 146 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
2088 146 : tmp = is_descriptor ? tmp : class_data;
2089 146 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
2090 : gfc_build_addr_expr (NULL, lse->expr));
2091 146 : gfc_add_expr_to_block (block, tmp);
2092 :
2093 : /* Only elemental function results need to be finalised and freed. */
2094 146 : if (not_call_expr)
2095 : return true;
2096 :
2097 : /* Finalize the class data if needed. */
2098 0 : gfc_init_block (&inner_block);
2099 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
2100 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
2101 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
2102 : logical_type_node, fcn, zero);
2103 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2104 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
2105 0 : tmp = build3_v (COND_EXPR, final_cond,
2106 : tmp, build_empty_stmt (input_location));
2107 0 : gfc_add_expr_to_block (&inner_block, tmp);
2108 :
2109 : /* Free the class data. */
2110 0 : tmp = gfc_call_free (class_data);
2111 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2112 : build_empty_stmt (input_location));
2113 0 : gfc_add_expr_to_block (&inner_block, tmp);
2114 :
2115 : /* Finish the inner block and subject it to the condition on the
2116 : class data being non-zero. */
2117 0 : tmp = gfc_finish_block (&inner_block);
2118 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2119 : build_empty_stmt (input_location));
2120 0 : gfc_add_expr_to_block (block, tmp);
2121 :
2122 0 : return true;
2123 : }
2124 :
2125 : /* End of prototype trans-class.c */
2126 :
2127 :
2128 : static void
2129 12865 : realloc_lhs_warning (bt type, bool array, locus *where)
2130 : {
2131 12865 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
2132 25 : gfc_warning (OPT_Wrealloc_lhs,
2133 : "Code for reallocating the allocatable array at %L will "
2134 : "be added", where);
2135 12840 : else if (warn_realloc_lhs_all)
2136 4 : gfc_warning (OPT_Wrealloc_lhs_all,
2137 : "Code for reallocating the allocatable variable at %L "
2138 : "will be added", where);
2139 12865 : }
2140 :
2141 :
2142 : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
2143 : gfc_expr *);
2144 :
2145 : /* Copy the scalarization loop variables. */
2146 :
2147 : static void
2148 1287296 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2149 : {
2150 1287296 : dest->ss = src->ss;
2151 1287296 : dest->loop = src->loop;
2152 1287296 : }
2153 :
2154 :
2155 : /* Initialize a simple expression holder.
2156 :
2157 : Care must be taken when multiple se are created with the same parent.
2158 : The child se must be kept in sync. The easiest way is to delay creation
2159 : of a child se until after the previous se has been translated. */
2160 :
2161 : void
2162 4670121 : gfc_init_se (gfc_se * se, gfc_se * parent)
2163 : {
2164 4670121 : memset (se, 0, sizeof (gfc_se));
2165 4670121 : gfc_init_block (&se->pre);
2166 4670121 : gfc_init_block (&se->finalblock);
2167 4670121 : gfc_init_block (&se->post);
2168 :
2169 4670121 : se->parent = parent;
2170 :
2171 4670121 : if (parent)
2172 1287296 : gfc_copy_se_loopvars (se, parent);
2173 4670121 : }
2174 :
2175 :
2176 : /* Advances to the next SS in the chain. Use this rather than setting
2177 : se->ss = se->ss->next because all the parents needs to be kept in sync.
2178 : See gfc_init_se. */
2179 :
2180 : void
2181 243839 : gfc_advance_se_ss_chain (gfc_se * se)
2182 : {
2183 243839 : gfc_se *p;
2184 :
2185 243839 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2186 :
2187 : p = se;
2188 : /* Walk down the parent chain. */
2189 640246 : while (p != NULL)
2190 : {
2191 : /* Simple consistency check. */
2192 396407 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2193 : || p->parent->ss->nested_ss == p->ss);
2194 :
2195 396407 : p->ss = p->ss->next;
2196 :
2197 396407 : p = p->parent;
2198 : }
2199 243839 : }
2200 :
2201 :
2202 : /* Ensures the result of the expression as either a temporary variable
2203 : or a constant so that it can be used repeatedly. */
2204 :
2205 : void
2206 8136 : gfc_make_safe_expr (gfc_se * se)
2207 : {
2208 8136 : tree var;
2209 :
2210 8136 : if (CONSTANT_CLASS_P (se->expr))
2211 : return;
2212 :
2213 : /* We need a temporary for this result. */
2214 274 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2215 274 : gfc_add_modify (&se->pre, var, se->expr);
2216 274 : se->expr = var;
2217 : }
2218 :
2219 :
2220 : /* Return an expression which determines if a dummy parameter is present.
2221 : Also used for arguments to procedures with multiple entry points. */
2222 :
2223 : tree
2224 11610 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2225 : {
2226 11610 : tree decl, orig_decl, cond;
2227 :
2228 11610 : gcc_assert (sym->attr.dummy);
2229 11610 : orig_decl = decl = gfc_get_symbol_decl (sym);
2230 :
2231 : /* Intrinsic scalars and derived types with VALUE attribute which are passed
2232 : by value use a hidden argument to denote the presence status. */
2233 11610 : if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
2234 : {
2235 1052 : char name[GFC_MAX_SYMBOL_LEN + 2];
2236 1052 : tree tree_name;
2237 :
2238 1052 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2239 1052 : name[0] = '.';
2240 1052 : strcpy (&name[1], sym->name);
2241 1052 : tree_name = get_identifier (name);
2242 :
2243 : /* Walk function argument list to find hidden arg. */
2244 1052 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2245 5320 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2246 5320 : if (DECL_NAME (cond) == tree_name
2247 5320 : && DECL_ARTIFICIAL (cond))
2248 : break;
2249 :
2250 1052 : gcc_assert (cond);
2251 1052 : return cond;
2252 : }
2253 :
2254 : /* Assumed-shape arrays use a local variable for the array data;
2255 : the actual PARAM_DECL is in a saved decl. As the local variable
2256 : is NULL, it can be checked instead, unless use_saved_desc is
2257 : requested. */
2258 :
2259 10558 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2260 : {
2261 822 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2262 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2263 822 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2264 : }
2265 :
2266 10558 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2267 10558 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2268 :
2269 : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2270 : as actual argument to denote absent dummies. For array descriptors,
2271 : we thus also need to check the array descriptor. For BT_CLASS, it
2272 : can also occur for scalars and F2003 due to type->class wrapping and
2273 : class->class wrapping. Note further that BT_CLASS always uses an
2274 : array descriptor for arrays, also for explicit-shape/assumed-size.
2275 : For assumed-rank arrays, no local variable is generated, hence,
2276 : the following also applies with !use_saved_desc. */
2277 :
2278 10558 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2279 7517 : && !sym->attr.allocatable
2280 6305 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2281 2296 : || (sym->ts.type == BT_CLASS
2282 1041 : && !CLASS_DATA (sym)->attr.allocatable
2283 567 : && !CLASS_DATA (sym)->attr.class_pointer))
2284 4216 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2285 6 : || sym->ts.type == BT_CLASS))
2286 : {
2287 4210 : tree tmp;
2288 :
2289 4210 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2290 1495 : || sym->as->type == AS_ASSUMED_RANK
2291 1407 : || sym->attr.codimension))
2292 3342 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2293 : {
2294 1039 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2295 1039 : if (sym->ts.type == BT_CLASS)
2296 171 : tmp = gfc_class_data_get (tmp);
2297 1039 : tmp = gfc_conv_array_data (tmp);
2298 : }
2299 3171 : else if (sym->ts.type == BT_CLASS)
2300 36 : tmp = gfc_class_data_get (decl);
2301 : else
2302 : tmp = NULL_TREE;
2303 :
2304 1075 : if (tmp != NULL_TREE)
2305 : {
2306 1075 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2307 1075 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2308 1075 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2309 : logical_type_node, cond, tmp);
2310 : }
2311 : }
2312 :
2313 : return cond;
2314 : }
2315 :
2316 :
2317 : /* Converts a missing, dummy argument into a null or zero. */
2318 :
2319 : void
2320 844 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2321 : {
2322 844 : tree present;
2323 844 : tree tmp;
2324 :
2325 844 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2326 :
2327 844 : if (kind > 0)
2328 : {
2329 : /* Create a temporary and convert it to the correct type. */
2330 54 : tmp = gfc_get_int_type (kind);
2331 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2332 : se->expr));
2333 :
2334 : /* Test for a NULL value. */
2335 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2336 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2337 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2338 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2339 : }
2340 : else
2341 : {
2342 790 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2343 : present, se->expr,
2344 790 : build_zero_cst (TREE_TYPE (se->expr)));
2345 790 : tmp = gfc_evaluate_now (tmp, &se->pre);
2346 790 : se->expr = tmp;
2347 : }
2348 :
2349 844 : if (ts.type == BT_CHARACTER)
2350 : {
2351 : /* Handle deferred-length dummies that pass the character length by
2352 : reference so that the value can be returned. */
2353 244 : if (ts.deferred && INDIRECT_REF_P (se->string_length))
2354 : {
2355 18 : tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
2356 18 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2357 : present, tmp, null_pointer_node);
2358 18 : tmp = gfc_evaluate_now (tmp, &se->pre);
2359 18 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2360 : }
2361 : else
2362 : {
2363 226 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2364 226 : tmp = fold_build3_loc (input_location, COND_EXPR,
2365 : gfc_charlen_type_node,
2366 : present, se->string_length, tmp);
2367 226 : tmp = gfc_evaluate_now (tmp, &se->pre);
2368 : }
2369 244 : se->string_length = tmp;
2370 : }
2371 844 : return;
2372 : }
2373 :
2374 :
2375 : /* Get the character length of an expression, looking through gfc_refs
2376 : if necessary. */
2377 :
2378 : tree
2379 20135 : gfc_get_expr_charlen (gfc_expr *e)
2380 : {
2381 20135 : gfc_ref *r;
2382 20135 : tree length;
2383 20135 : tree previous = NULL_TREE;
2384 20135 : gfc_se se;
2385 :
2386 20135 : gcc_assert (e->expr_type == EXPR_VARIABLE
2387 : && e->ts.type == BT_CHARACTER);
2388 :
2389 20135 : length = NULL; /* To silence compiler warning. */
2390 :
2391 20135 : if (is_subref_array (e) && e->ts.u.cl->length)
2392 : {
2393 761 : gfc_se tmpse;
2394 761 : gfc_init_se (&tmpse, NULL);
2395 761 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2396 761 : e->ts.u.cl->backend_decl = tmpse.expr;
2397 761 : return tmpse.expr;
2398 : }
2399 :
2400 : /* First candidate: if the variable is of type CHARACTER, the
2401 : expression's length could be the length of the character
2402 : variable. */
2403 19374 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2404 19074 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2405 :
2406 : /* Look through the reference chain for component references. */
2407 38891 : for (r = e->ref; r; r = r->next)
2408 : {
2409 19517 : previous = length;
2410 19517 : switch (r->type)
2411 : {
2412 300 : case REF_COMPONENT:
2413 300 : if (r->u.c.component->ts.type == BT_CHARACTER)
2414 300 : length = r->u.c.component->ts.u.cl->backend_decl;
2415 : break;
2416 :
2417 : case REF_ARRAY:
2418 : /* Do nothing. */
2419 : break;
2420 :
2421 20 : case REF_SUBSTRING:
2422 20 : gfc_init_se (&se, NULL);
2423 20 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2424 20 : length = se.expr;
2425 20 : if (r->u.ss.end)
2426 0 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2427 : else
2428 20 : se.expr = previous;
2429 20 : length = fold_build2_loc (input_location, MINUS_EXPR,
2430 : gfc_charlen_type_node,
2431 : se.expr, length);
2432 20 : length = fold_build2_loc (input_location, PLUS_EXPR,
2433 : gfc_charlen_type_node, length,
2434 : gfc_index_one_node);
2435 20 : break;
2436 :
2437 0 : default:
2438 0 : gcc_unreachable ();
2439 19517 : break;
2440 : }
2441 : }
2442 :
2443 19374 : gcc_assert (length != NULL);
2444 : return length;
2445 : }
2446 :
2447 :
2448 : /* Return for an expression the backend decl of the coarray. */
2449 :
2450 : tree
2451 2124 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2452 : {
2453 2124 : tree caf_decl;
2454 2124 : bool found = false;
2455 2124 : gfc_ref *ref;
2456 :
2457 2124 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2458 :
2459 : /* Not-implemented diagnostic. */
2460 2124 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2461 39 : && UNLIMITED_POLY (expr->symtree->n.sym)
2462 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2463 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2464 : "%L is not supported", &expr->where);
2465 :
2466 4509 : for (ref = expr->ref; ref; ref = ref->next)
2467 2385 : if (ref->type == REF_COMPONENT)
2468 : {
2469 225 : if (ref->u.c.component->ts.type == BT_CLASS
2470 0 : && UNLIMITED_POLY (ref->u.c.component)
2471 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2472 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2473 : "component at %L is not supported", &expr->where);
2474 : }
2475 :
2476 : /* Make sure the backend_decl is present before accessing it. */
2477 2124 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2478 2124 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2479 : : expr->symtree->n.sym->backend_decl;
2480 :
2481 2124 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2482 : {
2483 39 : if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2484 45 : && GFC_DECL_SAVED_DESCRIPTOR (caf_decl))
2485 6 : caf_decl = GFC_DECL_SAVED_DESCRIPTOR (caf_decl);
2486 :
2487 39 : if (expr->ref && expr->ref->type == REF_ARRAY)
2488 : {
2489 28 : caf_decl = gfc_class_data_get (caf_decl);
2490 28 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2491 : return caf_decl;
2492 : }
2493 11 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2494 2 : && GFC_DECL_TOKEN (caf_decl)
2495 13 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2496 : return caf_decl;
2497 :
2498 23 : for (ref = expr->ref; ref; ref = ref->next)
2499 : {
2500 18 : if (ref->type == REF_COMPONENT
2501 9 : && strcmp (ref->u.c.component->name, "_data") != 0)
2502 : {
2503 0 : caf_decl = gfc_class_data_get (caf_decl);
2504 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2505 : return caf_decl;
2506 : break;
2507 : }
2508 18 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2509 : break;
2510 : }
2511 : }
2512 2094 : if (expr->symtree->n.sym->attr.codimension)
2513 : return caf_decl;
2514 :
2515 : /* The following code assumes that the coarray is a component reachable via
2516 : only scalar components/variables; the Fortran standard guarantees this. */
2517 :
2518 76 : for (ref = expr->ref; ref; ref = ref->next)
2519 76 : if (ref->type == REF_COMPONENT)
2520 : {
2521 76 : gfc_component *comp = ref->u.c.component;
2522 :
2523 76 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2524 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2525 76 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2526 76 : TREE_TYPE (comp->backend_decl), caf_decl,
2527 : comp->backend_decl, NULL_TREE);
2528 76 : if (comp->ts.type == BT_CLASS)
2529 : {
2530 0 : caf_decl = gfc_class_data_get (caf_decl);
2531 0 : if (CLASS_DATA (comp)->attr.codimension)
2532 : {
2533 : found = true;
2534 : break;
2535 : }
2536 : }
2537 76 : if (comp->attr.codimension)
2538 : {
2539 : found = true;
2540 : break;
2541 : }
2542 : }
2543 76 : gcc_assert (found && caf_decl);
2544 : return caf_decl;
2545 : }
2546 :
2547 :
2548 : /* Obtain the Coarray token - and optionally also the offset. */
2549 :
2550 : void
2551 1995 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2552 : tree se_expr, gfc_expr *expr)
2553 : {
2554 1995 : tree tmp;
2555 :
2556 1995 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2557 :
2558 : /* Coarray token. */
2559 1995 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2560 620 : *token = gfc_conv_descriptor_token (caf_decl);
2561 1373 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2562 1574 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2563 6 : *token = GFC_DECL_TOKEN (caf_decl);
2564 : else
2565 : {
2566 1369 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2567 : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2568 1369 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2569 : }
2570 :
2571 1995 : if (offset == NULL)
2572 : return;
2573 :
2574 : /* Offset between the coarray base address and the address wanted. */
2575 179 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2576 179 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2577 0 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2578 0 : *offset = build_int_cst (gfc_array_index_type, 0);
2579 179 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2580 179 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2581 0 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2582 179 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2583 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2584 : else
2585 179 : *offset = build_int_cst (gfc_array_index_type, 0);
2586 :
2587 179 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2588 179 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2589 : {
2590 0 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2591 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2592 : }
2593 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2594 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2595 : else
2596 : {
2597 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2598 : tmp = se_expr;
2599 : }
2600 :
2601 179 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2602 : *offset, fold_convert (gfc_array_index_type, tmp));
2603 :
2604 179 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2605 0 : && expr->symtree->n.sym->attr.codimension
2606 0 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2607 : {
2608 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2609 0 : gfc_ref *ref = base_expr->ref;
2610 0 : gfc_se base_se;
2611 :
2612 : // Iterate through the refs until the last one.
2613 0 : while (ref->next)
2614 : ref = ref->next;
2615 :
2616 0 : if (ref->type == REF_ARRAY
2617 0 : && ref->u.ar.type != AR_FULL)
2618 : {
2619 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2620 0 : int i;
2621 0 : for (i = 0; i < ranksum; ++i)
2622 : {
2623 0 : ref->u.ar.start[i] = NULL;
2624 0 : ref->u.ar.end[i] = NULL;
2625 : }
2626 0 : ref->u.ar.type = AR_FULL;
2627 : }
2628 0 : gfc_init_se (&base_se, NULL);
2629 0 : if (gfc_caf_attr (base_expr).dimension)
2630 : {
2631 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2632 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2633 : }
2634 : else
2635 : {
2636 0 : gfc_conv_expr (&base_se, base_expr);
2637 0 : tmp = base_se.expr;
2638 : }
2639 :
2640 0 : gfc_free_expr (base_expr);
2641 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2642 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2643 0 : }
2644 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2645 0 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2646 179 : else if (INDIRECT_REF_P (caf_decl))
2647 0 : tmp = TREE_OPERAND (caf_decl, 0);
2648 : else
2649 : {
2650 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2651 : tmp = caf_decl;
2652 : }
2653 :
2654 179 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2655 : fold_convert (gfc_array_index_type, *offset),
2656 : fold_convert (gfc_array_index_type, tmp));
2657 : }
2658 :
2659 :
2660 : /* Convert the coindex of a coarray into an image index; the result is
2661 : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2662 : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2663 :
2664 : tree
2665 1706 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2666 : {
2667 1706 : gfc_ref *ref;
2668 1706 : tree lbound, ubound, extent, tmp, img_idx;
2669 1706 : gfc_se se;
2670 1706 : int i;
2671 :
2672 1767 : for (ref = e->ref; ref; ref = ref->next)
2673 1767 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2674 : break;
2675 1706 : gcc_assert (ref != NULL);
2676 :
2677 1706 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2678 167 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2679 167 : null_pointer_node);
2680 :
2681 1539 : img_idx = build_zero_cst (gfc_array_index_type);
2682 1539 : extent = build_one_cst (gfc_array_index_type);
2683 1539 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2684 630 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2685 : {
2686 321 : gfc_init_se (&se, NULL);
2687 321 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2688 321 : gfc_add_block_to_block (block, &se.pre);
2689 321 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2690 321 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2691 321 : TREE_TYPE (lbound), se.expr, lbound);
2692 321 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2693 : extent, tmp);
2694 321 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2695 321 : TREE_TYPE (tmp), img_idx, tmp);
2696 321 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2697 : {
2698 12 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2699 12 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2700 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
2701 12 : TREE_TYPE (tmp), extent, tmp);
2702 : }
2703 : }
2704 : else
2705 2476 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2706 : {
2707 1246 : gfc_init_se (&se, NULL);
2708 1246 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2709 1246 : gfc_add_block_to_block (block, &se.pre);
2710 1246 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2711 1246 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2712 1246 : TREE_TYPE (lbound), se.expr, lbound);
2713 1246 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2714 : extent, tmp);
2715 1246 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2716 : img_idx, tmp);
2717 1246 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2718 : {
2719 16 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2720 16 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2721 16 : TREE_TYPE (ubound), ubound, lbound);
2722 16 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2723 16 : tmp, build_one_cst (TREE_TYPE (tmp)));
2724 16 : extent = fold_build2_loc (input_location, MULT_EXPR,
2725 16 : TREE_TYPE (tmp), extent, tmp);
2726 : }
2727 : }
2728 1539 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2729 1539 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2730 1539 : return fold_convert (integer_type_node, img_idx);
2731 : }
2732 :
2733 :
2734 : /* For each character array constructor subexpression without a ts.u.cl->length,
2735 : replace it by its first element (if there aren't any elements, the length
2736 : should already be set to zero). */
2737 :
2738 : static void
2739 110 : flatten_array_ctors_without_strlen (gfc_expr* e)
2740 : {
2741 110 : gfc_actual_arglist* arg;
2742 110 : gfc_constructor* c;
2743 :
2744 110 : if (!e)
2745 : return;
2746 :
2747 110 : switch (e->expr_type)
2748 : {
2749 :
2750 0 : case EXPR_OP:
2751 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2752 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2753 0 : break;
2754 :
2755 0 : case EXPR_COMPCALL:
2756 : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2757 0 : gcc_unreachable ();
2758 :
2759 13 : case EXPR_FUNCTION:
2760 40 : for (arg = e->value.function.actual; arg; arg = arg->next)
2761 27 : flatten_array_ctors_without_strlen (arg->expr);
2762 : break;
2763 :
2764 0 : case EXPR_ARRAY:
2765 :
2766 : /* We've found what we're looking for. */
2767 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2768 : {
2769 0 : gfc_constructor *c;
2770 0 : gfc_expr* new_expr;
2771 :
2772 0 : gcc_assert (e->value.constructor);
2773 :
2774 0 : c = gfc_constructor_first (e->value.constructor);
2775 0 : new_expr = c->expr;
2776 0 : c->expr = NULL;
2777 :
2778 0 : flatten_array_ctors_without_strlen (new_expr);
2779 0 : gfc_replace_expr (e, new_expr);
2780 0 : break;
2781 : }
2782 :
2783 : /* Otherwise, fall through to handle constructor elements. */
2784 0 : gcc_fallthrough ();
2785 0 : case EXPR_STRUCTURE:
2786 0 : for (c = gfc_constructor_first (e->value.constructor);
2787 0 : c; c = gfc_constructor_next (c))
2788 0 : flatten_array_ctors_without_strlen (c->expr);
2789 : break;
2790 :
2791 : default:
2792 : break;
2793 :
2794 : }
2795 : }
2796 :
2797 :
2798 : /* Generate code to initialize a string length variable. Returns the
2799 : value. For array constructors, cl->length might be NULL and in this case,
2800 : the first element of the constructor is needed. expr is the original
2801 : expression so we can access it but can be NULL if this is not needed. */
2802 :
2803 : void
2804 3849 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2805 : {
2806 3849 : gfc_se se;
2807 :
2808 3849 : gfc_init_se (&se, NULL);
2809 :
2810 3849 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2811 1361 : return;
2812 :
2813 : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2814 : "flatten" array constructors by taking their first element; all elements
2815 : should be the same length or a cl->length should be present. */
2816 2581 : if (!cl->length)
2817 : {
2818 176 : gfc_expr* expr_flat;
2819 176 : if (!expr)
2820 : return;
2821 83 : expr_flat = gfc_copy_expr (expr);
2822 83 : flatten_array_ctors_without_strlen (expr_flat);
2823 83 : gfc_resolve_expr (expr_flat);
2824 83 : if (expr_flat->rank)
2825 13 : gfc_conv_expr_descriptor (&se, expr_flat);
2826 : else
2827 70 : gfc_conv_expr (&se, expr_flat);
2828 83 : if (expr_flat->expr_type != EXPR_VARIABLE)
2829 77 : gfc_add_block_to_block (pblock, &se.pre);
2830 83 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2831 83 : gfc_add_block_to_block (pblock, &se.post);
2832 83 : gfc_free_expr (expr_flat);
2833 : }
2834 : else
2835 : {
2836 : /* Convert cl->length. */
2837 2405 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2838 2405 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2839 : gfc_charlen_type_node, se.expr,
2840 2405 : build_zero_cst (TREE_TYPE (se.expr)));
2841 2405 : gfc_add_block_to_block (pblock, &se.pre);
2842 : }
2843 :
2844 2488 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2845 1570 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2846 : else
2847 918 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2848 : }
2849 :
2850 :
2851 : static void
2852 7300 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2853 : const char *name, locus *where)
2854 : {
2855 7300 : tree tmp;
2856 7300 : tree type;
2857 7300 : tree fault;
2858 7300 : gfc_se start;
2859 7300 : gfc_se end;
2860 7300 : char *msg;
2861 7300 : mpz_t length;
2862 :
2863 7300 : type = gfc_get_character_type (kind, ref->u.ss.length);
2864 7300 : type = build_pointer_type (type);
2865 :
2866 7300 : gfc_init_se (&start, se);
2867 7300 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2868 7300 : gfc_add_block_to_block (&se->pre, &start.pre);
2869 :
2870 7300 : if (integer_onep (start.expr))
2871 2768 : gfc_conv_string_parameter (se);
2872 : else
2873 : {
2874 4532 : tmp = start.expr;
2875 4532 : STRIP_NOPS (tmp);
2876 : /* Avoid multiple evaluation of substring start. */
2877 4532 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2878 1697 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2879 :
2880 : /* Change the start of the string. */
2881 4532 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2882 1194 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2883 3458 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2884 5606 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2885 1074 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2886 : tmp = se->expr;
2887 : else
2888 1066 : tmp = build_fold_indirect_ref_loc (input_location,
2889 : se->expr);
2890 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2891 4532 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2892 : {
2893 4404 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2894 4404 : se->expr = gfc_build_addr_expr (type, tmp);
2895 : }
2896 128 : else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2897 : {
2898 8 : tree diff;
2899 8 : diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr,
2900 : build_one_cst (gfc_charlen_type_node));
2901 8 : diff = fold_convert (size_type_node, diff);
2902 8 : se->expr
2903 8 : = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff);
2904 : }
2905 : }
2906 :
2907 : /* Length = end + 1 - start. */
2908 7300 : gfc_init_se (&end, se);
2909 7300 : if (ref->u.ss.end == NULL)
2910 202 : end.expr = se->string_length;
2911 : else
2912 : {
2913 7098 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2914 7098 : gfc_add_block_to_block (&se->pre, &end.pre);
2915 : }
2916 7300 : tmp = end.expr;
2917 7300 : STRIP_NOPS (tmp);
2918 7300 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2919 2301 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2920 :
2921 7300 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2922 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2923 7755 : && !gfc_contains_implied_index_p (ref->u.ss.end))
2924 : {
2925 455 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2926 : logical_type_node, start.expr,
2927 : end.expr);
2928 :
2929 : /* Check lower bound. */
2930 455 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2931 : start.expr,
2932 455 : build_one_cst (TREE_TYPE (start.expr)));
2933 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2934 : logical_type_node, nonempty, fault);
2935 455 : if (name)
2936 454 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2937 : "is less than one", name);
2938 : else
2939 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2940 : "is less than one");
2941 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2942 : fold_convert (long_integer_type_node,
2943 : start.expr));
2944 455 : free (msg);
2945 :
2946 : /* Check upper bound. */
2947 455 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2948 : end.expr, se->string_length);
2949 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2950 : logical_type_node, nonempty, fault);
2951 455 : if (name)
2952 454 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2953 : "exceeds string length (%%ld)", name);
2954 : else
2955 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2956 : "exceeds string length (%%ld)");
2957 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2958 : fold_convert (long_integer_type_node, end.expr),
2959 : fold_convert (long_integer_type_node,
2960 : se->string_length));
2961 455 : free (msg);
2962 : }
2963 :
2964 : /* Try to calculate the length from the start and end expressions. */
2965 7300 : if (ref->u.ss.end
2966 7300 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2967 : {
2968 6081 : HOST_WIDE_INT i_len;
2969 :
2970 6081 : i_len = gfc_mpz_get_hwi (length) + 1;
2971 6081 : if (i_len < 0)
2972 : i_len = 0;
2973 :
2974 6081 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2975 6081 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2976 : }
2977 : else
2978 : {
2979 1219 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2980 : fold_convert (gfc_charlen_type_node, end.expr),
2981 : fold_convert (gfc_charlen_type_node, start.expr));
2982 1219 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2983 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2984 1219 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2985 : tmp, build_int_cst (gfc_charlen_type_node, 0));
2986 : }
2987 :
2988 7300 : se->string_length = tmp;
2989 7300 : }
2990 :
2991 :
2992 : /* Convert a derived type component reference. */
2993 :
2994 : void
2995 177737 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2996 : {
2997 177737 : gfc_component *c;
2998 177737 : tree tmp;
2999 177737 : tree decl;
3000 177737 : tree field;
3001 177737 : tree context;
3002 :
3003 177737 : c = ref->u.c.component;
3004 :
3005 177737 : if (c->backend_decl == NULL_TREE
3006 6 : && ref->u.c.sym != NULL)
3007 6 : gfc_get_derived_type (ref->u.c.sym);
3008 :
3009 177737 : field = c->backend_decl;
3010 177737 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
3011 177737 : decl = se->expr;
3012 177737 : context = DECL_FIELD_CONTEXT (field);
3013 :
3014 : /* Components can correspond to fields of different containing
3015 : types, as components are created without context, whereas
3016 : a concrete use of a component has the type of decl as context.
3017 : So, if the type doesn't match, we search the corresponding
3018 : FIELD_DECL in the parent type. To not waste too much time
3019 : we cache this result in norestrict_decl.
3020 : On the other hand, if the context is a UNION or a MAP (a
3021 : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
3022 :
3023 177737 : if (context != TREE_TYPE (decl)
3024 177737 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
3025 12778 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
3026 : {
3027 12778 : tree f2 = c->norestrict_decl;
3028 21600 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
3029 7855 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
3030 7855 : if (TREE_CODE (f2) == FIELD_DECL
3031 7855 : && DECL_NAME (f2) == DECL_NAME (field))
3032 : break;
3033 12778 : gcc_assert (f2);
3034 12778 : c->norestrict_decl = f2;
3035 12778 : field = f2;
3036 : }
3037 :
3038 177737 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
3039 0 : && strcmp ("_data", c->name) == 0)
3040 : {
3041 : /* Found a ref to the _data component. Store the associated ref to
3042 : the vptr in se->class_vptr. */
3043 0 : se->class_vptr = gfc_class_vptr_get (decl);
3044 : }
3045 : else
3046 177737 : se->class_vptr = NULL_TREE;
3047 :
3048 177737 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
3049 : decl, field, NULL_TREE);
3050 :
3051 177737 : se->expr = tmp;
3052 :
3053 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
3054 : strlen () conditional below. */
3055 177737 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
3056 8802 : && !c->ts.deferred
3057 5644 : && !c->attr.pdt_string)
3058 : {
3059 5470 : tmp = c->ts.u.cl->backend_decl;
3060 : /* Components must always be constant length. */
3061 5470 : gcc_assert (tmp && INTEGER_CST_P (tmp));
3062 5470 : se->string_length = tmp;
3063 : }
3064 :
3065 177737 : if (gfc_deferred_strlen (c, &field))
3066 : {
3067 3332 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
3068 3332 : TREE_TYPE (field),
3069 : decl, field, NULL_TREE);
3070 3332 : se->string_length = tmp;
3071 : }
3072 :
3073 177737 : if (((c->attr.pointer || c->attr.allocatable)
3074 104104 : && (!c->attr.dimension && !c->attr.codimension)
3075 55870 : && c->ts.type != BT_CHARACTER)
3076 124090 : || c->attr.proc_pointer)
3077 59989 : se->expr = build_fold_indirect_ref_loc (input_location,
3078 : se->expr);
3079 177737 : }
3080 :
3081 :
3082 : /* This function deals with component references to components of the
3083 : parent type for derived type extensions. */
3084 : void
3085 64383 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
3086 : {
3087 64383 : gfc_component *c;
3088 64383 : gfc_component *cmp;
3089 64383 : gfc_symbol *dt;
3090 64383 : gfc_ref parent;
3091 :
3092 64383 : dt = ref->u.c.sym;
3093 64383 : c = ref->u.c.component;
3094 :
3095 : /* Return if the component is in this type, i.e. not in the parent type. */
3096 110838 : for (cmp = dt->components; cmp; cmp = cmp->next)
3097 100308 : if (c == cmp)
3098 53853 : return;
3099 :
3100 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3101 10530 : parent.type = REF_COMPONENT;
3102 10530 : parent.next = NULL;
3103 10530 : parent.u.c.sym = dt;
3104 10530 : parent.u.c.component = dt->components;
3105 :
3106 10530 : if (dt->backend_decl == NULL)
3107 0 : gfc_get_derived_type (dt);
3108 :
3109 : /* Build the reference and call self. */
3110 10530 : gfc_conv_component_ref (se, &parent);
3111 10530 : parent.u.c.sym = dt->components->ts.u.derived;
3112 10530 : parent.u.c.component = c;
3113 10530 : conv_parent_component_references (se, &parent);
3114 : }
3115 :
3116 :
3117 : static void
3118 549 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
3119 : {
3120 549 : tree res = se->expr;
3121 :
3122 549 : switch (ref->u.i)
3123 : {
3124 265 : case INQUIRY_RE:
3125 530 : res = fold_build1_loc (input_location, REALPART_EXPR,
3126 265 : TREE_TYPE (TREE_TYPE (res)), res);
3127 265 : break;
3128 :
3129 239 : case INQUIRY_IM:
3130 478 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
3131 239 : TREE_TYPE (TREE_TYPE (res)), res);
3132 239 : break;
3133 :
3134 7 : case INQUIRY_KIND:
3135 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
3136 7 : ts->kind);
3137 7 : se->string_length = NULL_TREE;
3138 7 : break;
3139 :
3140 38 : case INQUIRY_LEN:
3141 38 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
3142 : se->string_length);
3143 38 : se->string_length = NULL_TREE;
3144 38 : break;
3145 :
3146 0 : default:
3147 0 : gcc_unreachable ();
3148 : }
3149 549 : se->expr = res;
3150 549 : }
3151 :
3152 : /* Dereference VAR where needed if it is a pointer, reference, etc.
3153 : according to Fortran semantics. */
3154 :
3155 : tree
3156 1458093 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3157 : bool is_classarray)
3158 : {
3159 1458093 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3160 : return var;
3161 294606 : if (is_CFI_desc (sym, NULL))
3162 11892 : return build_fold_indirect_ref_loc (input_location, var);
3163 :
3164 : /* Characters are entirely different from other types, they are treated
3165 : separately. */
3166 282714 : if (sym->ts.type == BT_CHARACTER)
3167 : {
3168 : /* Dereference character pointer dummy arguments
3169 : or results. */
3170 32911 : if ((sym->attr.pointer || sym->attr.allocatable
3171 19013 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3172 14234 : && (sym->attr.dummy
3173 10918 : || sym->attr.function
3174 10544 : || sym->attr.result))
3175 4375 : var = build_fold_indirect_ref_loc (input_location, var);
3176 : }
3177 249803 : else if (!sym->attr.value)
3178 : {
3179 : /* Dereference temporaries for class array dummy arguments. */
3180 172772 : if (sym->attr.dummy && is_classarray
3181 256698 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3182 : {
3183 5343 : if (!descriptor_only_p)
3184 2722 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3185 :
3186 5343 : var = build_fold_indirect_ref_loc (input_location, var);
3187 : }
3188 :
3189 : /* Dereference non-character scalar dummy arguments. */
3190 248999 : if (sym->attr.dummy && !sym->attr.dimension
3191 104842 : && !(sym->attr.codimension && sym->attr.allocatable)
3192 104776 : && (sym->ts.type != BT_CLASS
3193 19595 : || (!CLASS_DATA (sym)->attr.dimension
3194 11426 : && !(CLASS_DATA (sym)->attr.codimension
3195 283 : && CLASS_DATA (sym)->attr.allocatable))))
3196 96466 : var = build_fold_indirect_ref_loc (input_location, var);
3197 :
3198 : /* Dereference scalar hidden result. */
3199 248999 : if (flag_f2c && sym->ts.type == BT_COMPLEX
3200 286 : && (sym->attr.function || sym->attr.result)
3201 108 : && !sym->attr.dimension && !sym->attr.pointer
3202 60 : && !sym->attr.always_explicit)
3203 36 : var = build_fold_indirect_ref_loc (input_location, var);
3204 :
3205 : /* Dereference non-character, non-class pointer variables.
3206 : These must be dummies, results, or scalars. */
3207 248999 : if (!is_classarray
3208 240854 : && (sym->attr.pointer || sym->attr.allocatable
3209 191445 : || gfc_is_associate_pointer (sym)
3210 186704 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3211 326093 : && (sym->attr.dummy
3212 36228 : || sym->attr.function
3213 35298 : || sym->attr.result
3214 34192 : || (!sym->attr.dimension
3215 34187 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3216 77089 : var = build_fold_indirect_ref_loc (input_location, var);
3217 : /* Now treat the class array pointer variables accordingly. */
3218 171910 : else if (sym->ts.type == BT_CLASS
3219 20041 : && sym->attr.dummy
3220 19595 : && (CLASS_DATA (sym)->attr.dimension
3221 11426 : || CLASS_DATA (sym)->attr.codimension)
3222 8452 : && ((CLASS_DATA (sym)->as
3223 8452 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3224 7401 : || CLASS_DATA (sym)->attr.allocatable
3225 6076 : || CLASS_DATA (sym)->attr.class_pointer))
3226 2967 : var = build_fold_indirect_ref_loc (input_location, var);
3227 : /* And the case where a non-dummy, non-result, non-function,
3228 : non-allocable and non-pointer classarray is present. This case was
3229 : previously covered by the first if, but with introducing the
3230 : condition !is_classarray there, that case has to be covered
3231 : explicitly. */
3232 168943 : else if (sym->ts.type == BT_CLASS
3233 17074 : && !sym->attr.dummy
3234 446 : && !sym->attr.function
3235 446 : && !sym->attr.result
3236 446 : && (CLASS_DATA (sym)->attr.dimension
3237 4 : || CLASS_DATA (sym)->attr.codimension)
3238 446 : && (sym->assoc
3239 0 : || !CLASS_DATA (sym)->attr.allocatable)
3240 446 : && !CLASS_DATA (sym)->attr.class_pointer)
3241 446 : var = build_fold_indirect_ref_loc (input_location, var);
3242 : }
3243 :
3244 : return var;
3245 : }
3246 :
3247 : /* Return the contents of a variable. Also handles reference/pointer
3248 : variables (all Fortran pointer references are implicit). */
3249 :
3250 : static void
3251 1611256 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3252 : {
3253 1611256 : gfc_ss *ss;
3254 1611256 : gfc_ref *ref;
3255 1611256 : gfc_symbol *sym;
3256 1611256 : tree parent_decl = NULL_TREE;
3257 1611256 : int parent_flag;
3258 1611256 : bool return_value;
3259 1611256 : bool alternate_entry;
3260 1611256 : bool entry_master;
3261 1611256 : bool is_classarray;
3262 1611256 : bool first_time = true;
3263 :
3264 1611256 : sym = expr->symtree->n.sym;
3265 1611256 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3266 1611256 : ss = se->ss;
3267 1611256 : if (ss != NULL)
3268 : {
3269 133482 : gfc_ss_info *ss_info = ss->info;
3270 :
3271 : /* Check that something hasn't gone horribly wrong. */
3272 133482 : gcc_assert (ss != gfc_ss_terminator);
3273 133482 : gcc_assert (ss_info->expr == expr);
3274 :
3275 : /* A scalarized term. We already know the descriptor. */
3276 133482 : se->expr = ss_info->data.array.descriptor;
3277 133482 : se->string_length = ss_info->string_length;
3278 133482 : ref = ss_info->data.array.ref;
3279 133482 : if (ref)
3280 133128 : gcc_assert (ref->type == REF_ARRAY
3281 : && ref->u.ar.type != AR_ELEMENT);
3282 : else
3283 354 : gfc_conv_tmp_array_ref (se);
3284 : }
3285 : else
3286 : {
3287 1477774 : tree se_expr = NULL_TREE;
3288 :
3289 1477774 : se->expr = gfc_get_symbol_decl (sym);
3290 :
3291 : /* Deal with references to a parent results or entries by storing
3292 : the current_function_decl and moving to the parent_decl. */
3293 1477774 : return_value = sym->attr.function && sym->result == sym;
3294 19303 : alternate_entry = sym->attr.function && sym->attr.entry
3295 1478913 : && sym->result == sym;
3296 2955548 : entry_master = sym->attr.result
3297 14578 : && sym->ns->proc_name->attr.entry_master
3298 1478155 : && !gfc_return_by_reference (sym->ns->proc_name);
3299 1477774 : if (current_function_decl)
3300 1459601 : parent_decl = DECL_CONTEXT (current_function_decl);
3301 :
3302 1477774 : if ((se->expr == parent_decl && return_value)
3303 1477663 : || (sym->ns && sym->ns->proc_name
3304 1472735 : && parent_decl
3305 1454562 : && sym->ns->proc_name->backend_decl == parent_decl
3306 38176 : && (alternate_entry || entry_master)))
3307 : parent_flag = 1;
3308 : else
3309 1477630 : parent_flag = 0;
3310 :
3311 : /* Special case for assigning the return value of a function.
3312 : Self recursive functions must have an explicit return value. */
3313 1477774 : if (return_value && (se->expr == current_function_decl || parent_flag))
3314 10424 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3315 :
3316 : /* Similarly for alternate entry points. */
3317 1467350 : else if (alternate_entry
3318 1106 : && (sym->ns->proc_name->backend_decl == current_function_decl
3319 0 : || parent_flag))
3320 : {
3321 1106 : gfc_entry_list *el = NULL;
3322 :
3323 1705 : for (el = sym->ns->entries; el; el = el->next)
3324 1705 : if (sym == el->sym)
3325 : {
3326 1106 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3327 1106 : break;
3328 : }
3329 : }
3330 :
3331 1466244 : else if (entry_master
3332 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3333 0 : || parent_flag))
3334 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3335 :
3336 11825 : if (se_expr)
3337 11825 : se->expr = se_expr;
3338 :
3339 : /* Procedure actual arguments. Look out for temporary variables
3340 : with the same attributes as function values. */
3341 1465949 : else if (!sym->attr.temporary
3342 1465881 : && sym->attr.flavor == FL_PROCEDURE
3343 21826 : && se->expr != current_function_decl)
3344 : {
3345 21759 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3346 : {
3347 20047 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3348 20047 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3349 : }
3350 21759 : return;
3351 : }
3352 :
3353 1456015 : if (sym->ts.type == BT_CLASS
3354 72588 : && sym->attr.class_ok
3355 72346 : && sym->ts.u.derived->attr.is_class)
3356 : {
3357 28075 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3358 79844 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3359 5485 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3360 : else
3361 66861 : se->class_container = se->expr;
3362 : }
3363 :
3364 : /* Dereference the expression, where needed. */
3365 1456015 : if (se->class_container && CLASS_DATA (sym)->attr.codimension
3366 2042 : && !CLASS_DATA (sym)->attr.dimension)
3367 877 : se->expr
3368 877 : = gfc_maybe_dereference_var (sym, se->class_container,
3369 877 : se->descriptor_only, is_classarray);
3370 : else
3371 1455138 : se->expr
3372 1455138 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3373 : is_classarray);
3374 :
3375 1456015 : ref = expr->ref;
3376 : }
3377 :
3378 : /* For character variables, also get the length. */
3379 1589497 : if (sym->ts.type == BT_CHARACTER)
3380 : {
3381 : /* If the character length of an entry isn't set, get the length from
3382 : the master function instead. */
3383 166706 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3384 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3385 : else
3386 166706 : se->string_length = sym->ts.u.cl->backend_decl;
3387 166706 : gcc_assert (se->string_length);
3388 :
3389 : /* For coarray strings return the pointer to the data and not the
3390 : descriptor. */
3391 5143 : if (sym->attr.codimension && sym->attr.associate_var
3392 6 : && !se->descriptor_only
3393 166712 : && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
3394 6 : se->expr = gfc_conv_descriptor_data_get (se->expr);
3395 : }
3396 :
3397 : /* F202Y: Runtime warning that an assumed rank object is associated
3398 : with an assumed size object. */
3399 1589497 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3400 90708 : && (gfc_option.allow_std & GFC_STD_F202Y)
3401 1589731 : && expr->rank == -1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3402 : {
3403 60 : tree dim, lower, upper, cond;
3404 60 : char *msg;
3405 :
3406 60 : dim = fold_convert (gfc_array_dim_rank_type,
3407 : gfc_conv_descriptor_rank_get (se->expr));
3408 60 : dim = fold_build2_loc (input_location, MINUS_EXPR,
3409 : gfc_array_dim_rank_type, dim, gfc_rank_cst[1]);
3410 60 : lower = gfc_conv_descriptor_lbound_get (se->expr, dim);
3411 60 : upper = gfc_conv_descriptor_ubound_get (se->expr, dim);
3412 :
3413 60 : msg = xasprintf ("Assumed rank object %s is associated with an "
3414 : "assumed size object", sym->name);
3415 60 : cond = fold_build2_loc (input_location, LT_EXPR,
3416 : logical_type_node, upper, lower);
3417 60 : gfc_trans_runtime_check (false, true, cond, &se->pre,
3418 : &gfc_current_locus, msg);
3419 60 : free (msg);
3420 : }
3421 :
3422 : /* Some expressions leak through that haven't been fixed up. */
3423 1589497 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3424 418 : gfc_fixup_inferred_type_refs (expr);
3425 :
3426 1589497 : gfc_typespec *ts = &sym->ts;
3427 2026339 : while (ref)
3428 : {
3429 787872 : switch (ref->type)
3430 : {
3431 613272 : case REF_ARRAY:
3432 : /* Return the descriptor if that's what we want and this is an array
3433 : section reference. */
3434 613272 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3435 : return;
3436 : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3437 : /* Return the descriptor for array pointers and allocations. */
3438 271705 : if (se->want_pointer
3439 24207 : && ref->next == NULL && (se->descriptor_only))
3440 : return;
3441 :
3442 262242 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3443 : /* Return a pointer to an element. */
3444 262242 : break;
3445 :
3446 167009 : case REF_COMPONENT:
3447 167009 : ts = &ref->u.c.component->ts;
3448 167009 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3449 5835 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3450 3142 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3451 3142 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3452 2621 : && strcmp ("_data", ref->u.c.component->name) == 0)
3453 : /* Skip the first ref of a _data component, because for class
3454 : arrays that one is already done by introducing a temporary
3455 : array descriptor. */
3456 : break;
3457 :
3458 164388 : if (ref->u.c.sym->attr.extension)
3459 53762 : conv_parent_component_references (se, ref);
3460 :
3461 164388 : gfc_conv_component_ref (se, ref);
3462 :
3463 164388 : if (ref->u.c.component->ts.type == BT_CLASS
3464 12023 : && ref->u.c.component->attr.class_ok
3465 12023 : && ref->u.c.component->ts.u.derived->attr.is_class)
3466 12023 : se->class_container = se->expr;
3467 152365 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3468 149871 : && ref->u.c.sym->attr.is_class))
3469 84234 : se->class_container = NULL_TREE;
3470 :
3471 164388 : if (!ref->next && ref->u.c.sym->attr.codimension
3472 0 : && se->want_pointer && se->descriptor_only)
3473 : return;
3474 :
3475 : break;
3476 :
3477 7042 : case REF_SUBSTRING:
3478 7042 : gfc_conv_substring (se, ref, expr->ts.kind,
3479 7042 : expr->symtree->name, &expr->where);
3480 7042 : break;
3481 :
3482 549 : case REF_INQUIRY:
3483 549 : conv_inquiry (se, ref, expr, ts);
3484 549 : break;
3485 :
3486 0 : default:
3487 0 : gcc_unreachable ();
3488 436842 : break;
3489 : }
3490 436842 : first_time = false;
3491 436842 : ref = ref->next;
3492 : }
3493 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3494 : separately. */
3495 1238467 : if (se->want_pointer)
3496 : {
3497 133923 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3498 8048 : gfc_conv_string_parameter (se);
3499 : else
3500 125875 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3501 : }
3502 : }
3503 :
3504 :
3505 : /* Unary ops are easy... Or they would be if ! was a valid op. */
3506 :
3507 : static void
3508 28863 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3509 : {
3510 28863 : gfc_se operand;
3511 28863 : tree type;
3512 :
3513 28863 : gcc_assert (expr->ts.type != BT_CHARACTER);
3514 : /* Initialize the operand. */
3515 28863 : gfc_init_se (&operand, se);
3516 28863 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3517 28863 : gfc_add_block_to_block (&se->pre, &operand.pre);
3518 :
3519 28863 : type = gfc_typenode_for_spec (&expr->ts);
3520 :
3521 : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3522 : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3523 : All other unary operators have an equivalent GIMPLE unary operator. */
3524 28863 : if (code == TRUTH_NOT_EXPR)
3525 20260 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3526 : build_int_cst (type, 0));
3527 : else
3528 8603 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3529 :
3530 28863 : }
3531 :
3532 : /* Expand power operator to optimal multiplications when a value is raised
3533 : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3534 : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3535 : Programming", 3rd Edition, 1998. */
3536 :
3537 : /* This code is mostly duplicated from expand_powi in the backend.
3538 : We establish the "optimal power tree" lookup table with the defined size.
3539 : The items in the table are the exponents used to calculate the index
3540 : exponents. Any integer n less than the value can get an "addition chain",
3541 : with the first node being one. */
3542 : #define POWI_TABLE_SIZE 256
3543 :
3544 : /* The table is from builtins.cc. */
3545 : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3546 : {
3547 : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3548 : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3549 : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3550 : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3551 : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3552 : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3553 : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3554 : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3555 : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3556 : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3557 : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3558 : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3559 : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3560 : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3561 : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3562 : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3563 : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3564 : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3565 : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3566 : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3567 : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3568 : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3569 : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3570 : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3571 : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3572 : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3573 : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3574 : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3575 : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3576 : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3577 : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3578 : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3579 : };
3580 :
3581 : /* If n is larger than lookup table's max index, we use the "window
3582 : method". */
3583 : #define POWI_WINDOW_SIZE 3
3584 :
3585 : /* Recursive function to expand the power operator. The temporary
3586 : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3587 : static tree
3588 178323 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3589 : {
3590 178323 : tree op0;
3591 178323 : tree op1;
3592 178323 : tree tmp;
3593 178323 : int digit;
3594 :
3595 178323 : if (n < POWI_TABLE_SIZE)
3596 : {
3597 137336 : if (tmpvar[n])
3598 : return tmpvar[n];
3599 :
3600 56612 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3601 56612 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3602 : }
3603 40987 : else if (n & 1)
3604 : {
3605 10015 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3606 10015 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3607 10015 : op1 = gfc_conv_powi (se, digit, tmpvar);
3608 : }
3609 : else
3610 : {
3611 30972 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3612 30972 : op1 = op0;
3613 : }
3614 :
3615 97599 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3616 97599 : tmp = gfc_evaluate_now (tmp, &se->pre);
3617 :
3618 97599 : if (n < POWI_TABLE_SIZE)
3619 56612 : tmpvar[n] = tmp;
3620 :
3621 : return tmp;
3622 : }
3623 :
3624 :
3625 : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3626 : return 1. Else return 0 and a call to runtime library functions
3627 : will have to be built. */
3628 : static int
3629 3305 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3630 : {
3631 3305 : tree cond;
3632 3305 : tree tmp;
3633 3305 : tree type;
3634 3305 : tree vartmp[POWI_TABLE_SIZE];
3635 3305 : HOST_WIDE_INT m;
3636 3305 : unsigned HOST_WIDE_INT n;
3637 3305 : int sgn;
3638 3305 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3639 :
3640 : /* If exponent is too large, we won't expand it anyway, so don't bother
3641 : with large integer values. */
3642 3305 : if (!wi::fits_shwi_p (wrhs))
3643 : return 0;
3644 :
3645 2945 : m = wrhs.to_shwi ();
3646 : /* Use the wide_int's routine to reliably get the absolute value on all
3647 : platforms. Then convert it to a HOST_WIDE_INT like above. */
3648 2945 : n = wi::abs (wrhs).to_shwi ();
3649 :
3650 2945 : type = TREE_TYPE (lhs);
3651 2945 : sgn = tree_int_cst_sgn (rhs);
3652 :
3653 2945 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3654 5890 : || optimize_size) && (m > 2 || m < -1))
3655 : return 0;
3656 :
3657 : /* rhs == 0 */
3658 1639 : if (sgn == 0)
3659 : {
3660 282 : se->expr = gfc_build_const (type, integer_one_node);
3661 282 : return 1;
3662 : }
3663 :
3664 : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3665 1357 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3666 : {
3667 220 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3668 220 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3669 220 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3670 220 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3671 :
3672 : /* If rhs is even,
3673 : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3674 220 : if ((n & 1) == 0)
3675 : {
3676 104 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3677 : logical_type_node, tmp, cond);
3678 104 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3679 : tmp, build_int_cst (type, 1),
3680 : build_int_cst (type, 0));
3681 104 : return 1;
3682 : }
3683 : /* If rhs is odd,
3684 : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3685 116 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3686 : build_int_cst (type, -1),
3687 : build_int_cst (type, 0));
3688 116 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3689 : cond, build_int_cst (type, 1), tmp);
3690 116 : return 1;
3691 : }
3692 :
3693 1137 : memset (vartmp, 0, sizeof (vartmp));
3694 1137 : vartmp[1] = lhs;
3695 1137 : if (sgn == -1)
3696 : {
3697 141 : tmp = gfc_build_const (type, integer_one_node);
3698 141 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3699 : vartmp[1]);
3700 : }
3701 :
3702 1137 : se->expr = gfc_conv_powi (se, n, vartmp);
3703 :
3704 1137 : return 1;
3705 : }
3706 :
3707 : /* Convert lhs**rhs, for constant rhs, when both are unsigned.
3708 : Method:
3709 : if (rhs == 0) ! Checked here.
3710 : return 1;
3711 : if (lhs & 1 == 1) ! odd_cnd
3712 : {
3713 : if (bit_size(rhs) < bit_size(lhs)) ! Checked here.
3714 : return lhs ** rhs;
3715 :
3716 : mask = 1 << (bit_size(a) - 1) / 2;
3717 : return lhs ** (n & rhs);
3718 : }
3719 : if (rhs > bit_size(lhs)) ! Checked here.
3720 : return 0;
3721 :
3722 : return lhs ** rhs;
3723 : */
3724 :
3725 : static int
3726 15120 : gfc_conv_cst_uint_power (gfc_se * se, tree lhs, tree rhs)
3727 : {
3728 15120 : tree type = TREE_TYPE (lhs);
3729 15120 : tree tmp, is_odd, odd_branch, even_branch;
3730 15120 : unsigned HOST_WIDE_INT lhs_prec, rhs_prec;
3731 15120 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3732 15120 : unsigned HOST_WIDE_INT n, n_odd;
3733 15120 : tree vartmp_odd[POWI_TABLE_SIZE], vartmp_even[POWI_TABLE_SIZE];
3734 :
3735 : /* Anything ** 0 is one. */
3736 15120 : if (integer_zerop (rhs))
3737 : {
3738 1800 : se->expr = build_int_cst (type, 1);
3739 1800 : return 1;
3740 : }
3741 :
3742 13320 : if (!wi::fits_uhwi_p (wrhs))
3743 : return 0;
3744 :
3745 12960 : n = wrhs.to_uhwi ();
3746 :
3747 : /* tmp = a & 1; . */
3748 12960 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3749 : lhs, build_int_cst (type, 1));
3750 12960 : is_odd = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3751 : tmp, build_int_cst (type, 1));
3752 :
3753 12960 : lhs_prec = TYPE_PRECISION (type);
3754 12960 : rhs_prec = TYPE_PRECISION (TREE_TYPE (rhs));
3755 :
3756 12960 : if (rhs_prec >= lhs_prec && lhs_prec <= HOST_BITS_PER_WIDE_INT)
3757 : {
3758 7044 : unsigned HOST_WIDE_INT mask = (HOST_WIDE_INT_1U << (lhs_prec - 1)) - 1;
3759 7044 : n_odd = n & mask;
3760 : }
3761 : else
3762 : n_odd = n;
3763 :
3764 12960 : memset (vartmp_odd, 0, sizeof (vartmp_odd));
3765 12960 : vartmp_odd[0] = build_int_cst (type, 1);
3766 12960 : vartmp_odd[1] = lhs;
3767 12960 : odd_branch = gfc_conv_powi (se, n_odd, vartmp_odd);
3768 12960 : even_branch = NULL_TREE;
3769 :
3770 12960 : if (n > lhs_prec)
3771 4260 : even_branch = build_int_cst (type, 0);
3772 : else
3773 : {
3774 8700 : if (n_odd != n)
3775 : {
3776 0 : memset (vartmp_even, 0, sizeof (vartmp_even));
3777 0 : vartmp_even[0] = build_int_cst (type, 1);
3778 0 : vartmp_even[1] = lhs;
3779 0 : even_branch = gfc_conv_powi (se, n, vartmp_even);
3780 : }
3781 : }
3782 4260 : if (even_branch != NULL_TREE)
3783 4260 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, is_odd,
3784 : odd_branch, even_branch);
3785 : else
3786 8700 : se->expr = odd_branch;
3787 :
3788 : return 1;
3789 : }
3790 :
3791 : /* Power op (**). Constant integer exponent and powers of 2 have special
3792 : handling. */
3793 :
3794 : static void
3795 49177 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3796 : {
3797 49177 : tree gfc_int4_type_node;
3798 49177 : int kind;
3799 49177 : int ikind;
3800 49177 : int res_ikind_1, res_ikind_2;
3801 49177 : gfc_se lse;
3802 49177 : gfc_se rse;
3803 49177 : tree fndecl = NULL;
3804 :
3805 49177 : gfc_init_se (&lse, se);
3806 49177 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3807 49177 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3808 49177 : gfc_add_block_to_block (&se->pre, &lse.pre);
3809 :
3810 49177 : gfc_init_se (&rse, se);
3811 49177 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3812 49177 : gfc_add_block_to_block (&se->pre, &rse.pre);
3813 :
3814 49177 : if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
3815 : {
3816 17563 : if (expr->value.op.op2->ts.type == BT_INTEGER)
3817 : {
3818 2292 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3819 20477 : return;
3820 : }
3821 15271 : else if (expr->value.op.op2->ts.type == BT_UNSIGNED)
3822 : {
3823 15120 : if (gfc_conv_cst_uint_power (se, lse.expr, rse.expr))
3824 : return;
3825 : }
3826 : }
3827 :
3828 32778 : if ((expr->value.op.op2->ts.type == BT_INTEGER
3829 31468 : || expr->value.op.op2->ts.type == BT_UNSIGNED)
3830 31910 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3831 1013 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3832 : return;
3833 :
3834 32778 : if (INTEGER_CST_P (lse.expr)
3835 15371 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE
3836 48149 : && expr->value.op.op2->ts.type == BT_INTEGER)
3837 : {
3838 251 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3839 251 : HOST_WIDE_INT v;
3840 251 : unsigned HOST_WIDE_INT w;
3841 251 : int kind, ikind, bit_size;
3842 :
3843 251 : v = wlhs.to_shwi ();
3844 251 : w = absu_hwi (v);
3845 :
3846 251 : kind = expr->value.op.op1->ts.kind;
3847 251 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3848 251 : bit_size = gfc_integer_kinds[ikind].bit_size;
3849 :
3850 251 : if (v == 1)
3851 : {
3852 : /* 1**something is always 1. */
3853 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3854 239 : return;
3855 : }
3856 216 : else if (v == -1)
3857 : {
3858 : /* (-1)**n is 1 - ((n & 1) << 1) */
3859 34 : tree type;
3860 34 : tree tmp;
3861 :
3862 34 : type = TREE_TYPE (lse.expr);
3863 34 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3864 : rse.expr, build_int_cst (type, 1));
3865 34 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3866 : tmp, build_int_cst (type, 1));
3867 34 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3868 : build_int_cst (type, 1), tmp);
3869 34 : se->expr = tmp;
3870 34 : return;
3871 : }
3872 182 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3873 : {
3874 : /* Here v is +/- 2**e. The further simplification uses
3875 : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3876 : 1<<(4*n), etc., but we have to make sure to return zero
3877 : if the number of bits is too large. */
3878 170 : tree lshift;
3879 170 : tree type;
3880 170 : tree shift;
3881 170 : tree ge;
3882 170 : tree cond;
3883 170 : tree num_bits;
3884 170 : tree cond2;
3885 170 : tree tmp1;
3886 :
3887 170 : type = TREE_TYPE (lse.expr);
3888 :
3889 170 : if (w == 2)
3890 110 : shift = rse.expr;
3891 60 : else if (w == 4)
3892 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3893 12 : TREE_TYPE (rse.expr),
3894 : rse.expr, rse.expr);
3895 : else
3896 : {
3897 : /* use popcount for fast log2(w) */
3898 48 : int e = wi::popcount (w-1);
3899 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3900 48 : TREE_TYPE (rse.expr),
3901 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3902 : rse.expr);
3903 : }
3904 :
3905 170 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3906 : build_int_cst (type, 1), shift);
3907 170 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3908 : rse.expr, build_int_cst (type, 0));
3909 170 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3910 : build_int_cst (type, 0));
3911 170 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3912 170 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3913 : rse.expr, num_bits);
3914 170 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3915 : build_int_cst (type, 0), cond);
3916 170 : if (v > 0)
3917 : {
3918 128 : se->expr = tmp1;
3919 : }
3920 : else
3921 : {
3922 : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3923 42 : tree tmp2;
3924 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3925 : rse.expr, build_int_cst (type, 1));
3926 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3927 : tmp2, build_int_cst (type, 1));
3928 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3929 : build_int_cst (type, 1), tmp2);
3930 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3931 : tmp1, tmp2);
3932 : }
3933 170 : return;
3934 : }
3935 : }
3936 : /* Handle unsigned separate from signed above, things would be too
3937 : complicated otherwise. */
3938 :
3939 32539 : if (INTEGER_CST_P (lse.expr) && expr->value.op.op1->ts.type == BT_UNSIGNED)
3940 : {
3941 15120 : gfc_expr * op1 = expr->value.op.op1;
3942 15120 : tree type;
3943 :
3944 15120 : type = TREE_TYPE (lse.expr);
3945 :
3946 15120 : if (mpz_cmp_ui (op1->value.integer, 1) == 0)
3947 : {
3948 : /* 1**something is always 1. */
3949 1260 : se->expr = build_int_cst (type, 1);
3950 1260 : return;
3951 : }
3952 :
3953 : /* Simplify 2u**x to a shift, with the value set to zero if it falls
3954 : outside the range. */
3955 26460 : if (mpz_popcount (op1->value.integer) == 1)
3956 : {
3957 2520 : tree prec_m1, lim, shift, lshift, cond, tmp;
3958 2520 : tree rtype = TREE_TYPE (rse.expr);
3959 2520 : int e = mpz_scan1 (op1->value.integer, 0);
3960 :
3961 2520 : shift = fold_build2_loc (input_location, MULT_EXPR,
3962 2520 : rtype, build_int_cst (rtype, e),
3963 : rse.expr);
3964 2520 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3965 : build_int_cst (type, 1), shift);
3966 5040 : prec_m1 = fold_build2_loc (input_location, MINUS_EXPR, rtype,
3967 2520 : build_int_cst (rtype, TYPE_PRECISION (type)),
3968 : build_int_cst (rtype, 1));
3969 2520 : lim = fold_build2_loc (input_location, TRUNC_DIV_EXPR, rtype,
3970 2520 : prec_m1, build_int_cst (rtype, e));
3971 2520 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3972 : rse.expr, lim);
3973 2520 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond,
3974 : build_int_cst (type, 0), lshift);
3975 2520 : se->expr = tmp;
3976 2520 : return;
3977 : }
3978 : }
3979 :
3980 28759 : gfc_int4_type_node = gfc_get_int_type (4);
3981 :
3982 : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3983 : library routine. But in the end, we have to convert the result back
3984 : if this case applies -- with res_ikind_K, we keep track whether operand K
3985 : falls into this case. */
3986 28759 : res_ikind_1 = -1;
3987 28759 : res_ikind_2 = -1;
3988 :
3989 28759 : kind = expr->value.op.op1->ts.kind;
3990 28759 : switch (expr->value.op.op2->ts.type)
3991 : {
3992 1071 : case BT_INTEGER:
3993 1071 : ikind = expr->value.op.op2->ts.kind;
3994 1071 : switch (ikind)
3995 : {
3996 168 : case 1:
3997 168 : case 2:
3998 168 : rse.expr = convert (gfc_int4_type_node, rse.expr);
3999 168 : res_ikind_2 = ikind;
4000 : /* Fall through. */
4001 :
4002 : case 4:
4003 : ikind = 0;
4004 : break;
4005 :
4006 : case 8:
4007 : ikind = 1;
4008 : break;
4009 :
4010 6 : case 16:
4011 6 : ikind = 2;
4012 6 : break;
4013 :
4014 0 : default:
4015 0 : gcc_unreachable ();
4016 : }
4017 1071 : switch (kind)
4018 : {
4019 0 : case 1:
4020 0 : case 2:
4021 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
4022 : {
4023 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
4024 0 : res_ikind_1 = kind;
4025 : }
4026 : else
4027 0 : gcc_unreachable ();
4028 : /* Fall through. */
4029 :
4030 : case 4:
4031 : kind = 0;
4032 : break;
4033 :
4034 : case 8:
4035 : kind = 1;
4036 : break;
4037 :
4038 6 : case 10:
4039 6 : kind = 2;
4040 6 : break;
4041 :
4042 18 : case 16:
4043 18 : kind = 3;
4044 18 : break;
4045 :
4046 0 : default:
4047 0 : gcc_unreachable ();
4048 : }
4049 :
4050 1071 : switch (expr->value.op.op1->ts.type)
4051 : {
4052 129 : case BT_INTEGER:
4053 129 : if (kind == 3) /* Case 16 was not handled properly above. */
4054 : kind = 2;
4055 129 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
4056 129 : break;
4057 :
4058 710 : case BT_REAL:
4059 : /* Use builtins for real ** int4. */
4060 :
4061 710 : if (real_minus_onep (lse.expr))
4062 : {
4063 : /* (-1.0)**n is (real) (1 - ((n & 1) << 1)), see the integer case
4064 : above. */
4065 :
4066 59 : tree lhs_type, rhs_type;
4067 59 : tree tmp;
4068 59 : lhs_type = TREE_TYPE (lse.expr);
4069 59 : rhs_type = TREE_TYPE (rse.expr);
4070 59 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, rhs_type,
4071 : rse.expr, build_int_cst (rhs_type, 1));
4072 59 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, rhs_type,
4073 : tmp, build_int_cst (rhs_type, 1));
4074 59 : tmp = fold_build2_loc (input_location, MINUS_EXPR, rhs_type,
4075 : build_int_cst (rhs_type, 1), tmp);
4076 59 : se->expr = fold_convert (lhs_type, tmp);
4077 59 : return;
4078 : }
4079 :
4080 651 : if (ikind == 0)
4081 : {
4082 555 : switch (kind)
4083 : {
4084 391 : case 0:
4085 391 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
4086 391 : break;
4087 :
4088 146 : case 1:
4089 146 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
4090 146 : break;
4091 :
4092 6 : case 2:
4093 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4094 6 : break;
4095 :
4096 12 : case 3:
4097 : /* Use the __builtin_powil() only if real(kind=16) is
4098 : actually the C long double type. */
4099 12 : if (!gfc_real16_is_float128)
4100 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4101 : break;
4102 :
4103 : default:
4104 : gcc_unreachable ();
4105 : }
4106 : }
4107 :
4108 : /* If we don't have a good builtin for this, go for the
4109 : library function. */
4110 543 : if (!fndecl)
4111 108 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
4112 : break;
4113 :
4114 232 : case BT_COMPLEX:
4115 232 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
4116 232 : break;
4117 :
4118 0 : default:
4119 0 : gcc_unreachable ();
4120 : }
4121 : break;
4122 :
4123 139 : case BT_REAL:
4124 139 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
4125 139 : break;
4126 :
4127 729 : case BT_COMPLEX:
4128 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
4129 729 : break;
4130 :
4131 26820 : case BT_UNSIGNED:
4132 26820 : {
4133 : /* Valid kinds for unsigned are 1, 2, 4, 8, 16. Instead of using a
4134 : large switch statement, let's just use __builtin_ctz. */
4135 26820 : int base = __builtin_ctz (expr->value.op.op1->ts.kind);
4136 26820 : int expon = __builtin_ctz (expr->value.op.op2->ts.kind);
4137 26820 : fndecl = gfor_fndecl_unsigned_pow_list[base][expon];
4138 : }
4139 26820 : break;
4140 :
4141 0 : default:
4142 0 : gcc_unreachable ();
4143 28700 : break;
4144 : }
4145 :
4146 28700 : se->expr = build_call_expr_loc (input_location,
4147 : fndecl, 2, lse.expr, rse.expr);
4148 :
4149 : /* Convert the result back if it is of wrong integer kind. */
4150 28700 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
4151 : {
4152 : /* We want the maximum of both operand kinds as result. */
4153 0 : if (res_ikind_1 < res_ikind_2)
4154 0 : res_ikind_1 = res_ikind_2;
4155 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
4156 : }
4157 : }
4158 :
4159 :
4160 : /* Generate code to allocate a string temporary. */
4161 :
4162 : tree
4163 4898 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4164 : {
4165 4898 : tree var;
4166 4898 : tree tmp;
4167 :
4168 4898 : if (gfc_can_put_var_on_stack (len))
4169 : {
4170 : /* Create a temporary variable to hold the result. */
4171 4622 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4172 2311 : TREE_TYPE (len), len,
4173 2311 : build_int_cst (TREE_TYPE (len), 1));
4174 2311 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4175 :
4176 2311 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4177 2311 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4178 : else
4179 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
4180 :
4181 2311 : var = gfc_create_var (tmp, "str");
4182 2311 : var = gfc_build_addr_expr (type, var);
4183 : }
4184 : else
4185 : {
4186 : /* Allocate a temporary to hold the result. */
4187 2587 : var = gfc_create_var (type, "pstr");
4188 2587 : gcc_assert (POINTER_TYPE_P (type));
4189 2587 : tmp = TREE_TYPE (type);
4190 2587 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4191 2587 : tmp = TREE_TYPE (tmp);
4192 2587 : tmp = TYPE_SIZE_UNIT (tmp);
4193 2587 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4194 : fold_convert (size_type_node, len),
4195 : fold_convert (size_type_node, tmp));
4196 2587 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4197 2587 : gfc_add_modify (&se->pre, var, tmp);
4198 :
4199 : /* Free the temporary afterwards. */
4200 2587 : tmp = gfc_call_free (var);
4201 2587 : gfc_add_expr_to_block (&se->post, tmp);
4202 : }
4203 :
4204 4898 : return var;
4205 : }
4206 :
4207 :
4208 : /* Handle a string concatenation operation. A temporary will be allocated to
4209 : hold the result. */
4210 :
4211 : static void
4212 1294 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4213 : {
4214 1294 : gfc_se lse, rse;
4215 1294 : tree len, type, var, tmp, fndecl;
4216 :
4217 1294 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4218 : && expr->value.op.op2->ts.type == BT_CHARACTER);
4219 1294 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4220 :
4221 1294 : gfc_init_se (&lse, se);
4222 1294 : gfc_conv_expr (&lse, expr->value.op.op1);
4223 1294 : gfc_conv_string_parameter (&lse);
4224 1294 : gfc_init_se (&rse, se);
4225 1294 : gfc_conv_expr (&rse, expr->value.op.op2);
4226 1294 : gfc_conv_string_parameter (&rse);
4227 :
4228 1294 : gfc_add_block_to_block (&se->pre, &lse.pre);
4229 1294 : gfc_add_block_to_block (&se->pre, &rse.pre);
4230 :
4231 1294 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4232 1294 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4233 1294 : if (len == NULL_TREE)
4234 : {
4235 1075 : len = fold_build2_loc (input_location, PLUS_EXPR,
4236 : gfc_charlen_type_node,
4237 : fold_convert (gfc_charlen_type_node,
4238 : lse.string_length),
4239 : fold_convert (gfc_charlen_type_node,
4240 : rse.string_length));
4241 : }
4242 :
4243 1294 : type = build_pointer_type (type);
4244 :
4245 1294 : var = gfc_conv_string_tmp (se, type, len);
4246 :
4247 : /* Do the actual concatenation. */
4248 1294 : if (expr->ts.kind == 1)
4249 1203 : fndecl = gfor_fndecl_concat_string;
4250 91 : else if (expr->ts.kind == 4)
4251 91 : fndecl = gfor_fndecl_concat_string_char4;
4252 : else
4253 0 : gcc_unreachable ();
4254 :
4255 1294 : tmp = build_call_expr_loc (input_location,
4256 : fndecl, 6, len, var, lse.string_length, lse.expr,
4257 : rse.string_length, rse.expr);
4258 1294 : gfc_add_expr_to_block (&se->pre, tmp);
4259 :
4260 : /* Add the cleanup for the operands. */
4261 1294 : gfc_add_block_to_block (&se->pre, &rse.post);
4262 1294 : gfc_add_block_to_block (&se->pre, &lse.post);
4263 :
4264 1294 : se->expr = var;
4265 1294 : se->string_length = len;
4266 1294 : }
4267 :
4268 : /* Translates an op expression. Common (binary) cases are handled by this
4269 : function, others are passed on. Recursion is used in either case.
4270 : We use the fact that (op1.ts == op2.ts) (except for the power
4271 : operator **).
4272 : Operators need no special handling for scalarized expressions as long as
4273 : they call gfc_conv_simple_val to get their operands.
4274 : Character strings get special handling. */
4275 :
4276 : static void
4277 509175 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4278 : {
4279 509175 : enum tree_code code;
4280 509175 : gfc_se lse;
4281 509175 : gfc_se rse;
4282 509175 : tree tmp, type;
4283 509175 : int lop;
4284 509175 : int checkstring;
4285 :
4286 509175 : checkstring = 0;
4287 509175 : lop = 0;
4288 509175 : switch (expr->value.op.op)
4289 : {
4290 15532 : case INTRINSIC_PARENTHESES:
4291 15532 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4292 3801 : && flag_protect_parens)
4293 : {
4294 3668 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
4295 3668 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
4296 91204 : return;
4297 : }
4298 :
4299 : /* Fallthrough. */
4300 11870 : case INTRINSIC_UPLUS:
4301 11870 : gfc_conv_expr (se, expr->value.op.op1);
4302 11870 : return;
4303 :
4304 4935 : case INTRINSIC_UMINUS:
4305 4935 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4306 4935 : return;
4307 :
4308 20260 : case INTRINSIC_NOT:
4309 20260 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4310 20260 : return;
4311 :
4312 : case INTRINSIC_PLUS:
4313 : code = PLUS_EXPR;
4314 : break;
4315 :
4316 29321 : case INTRINSIC_MINUS:
4317 29321 : code = MINUS_EXPR;
4318 29321 : break;
4319 :
4320 33025 : case INTRINSIC_TIMES:
4321 33025 : code = MULT_EXPR;
4322 33025 : break;
4323 :
4324 7011 : case INTRINSIC_DIVIDE:
4325 : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
4326 : an integer or unsigned, we must round towards zero, so we use a
4327 : TRUNC_DIV_EXPR. */
4328 7011 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4329 : code = TRUNC_DIV_EXPR;
4330 : else
4331 417971 : code = RDIV_EXPR;
4332 : break;
4333 :
4334 49177 : case INTRINSIC_POWER:
4335 49177 : gfc_conv_power_op (se, expr);
4336 49177 : return;
4337 :
4338 1294 : case INTRINSIC_CONCAT:
4339 1294 : gfc_conv_concat_op (se, expr);
4340 1294 : return;
4341 :
4342 4834 : case INTRINSIC_AND:
4343 4834 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4344 : lop = 1;
4345 : break;
4346 :
4347 56053 : case INTRINSIC_OR:
4348 56053 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
4349 : lop = 1;
4350 : break;
4351 :
4352 : /* EQV and NEQV only work on logicals, but since we represent them
4353 : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4354 12669 : case INTRINSIC_EQ:
4355 12669 : case INTRINSIC_EQ_OS:
4356 12669 : case INTRINSIC_EQV:
4357 12669 : code = EQ_EXPR;
4358 12669 : checkstring = 1;
4359 12669 : lop = 1;
4360 12669 : break;
4361 :
4362 207825 : case INTRINSIC_NE:
4363 207825 : case INTRINSIC_NE_OS:
4364 207825 : case INTRINSIC_NEQV:
4365 207825 : code = NE_EXPR;
4366 207825 : checkstring = 1;
4367 207825 : lop = 1;
4368 207825 : break;
4369 :
4370 12058 : case INTRINSIC_GT:
4371 12058 : case INTRINSIC_GT_OS:
4372 12058 : code = GT_EXPR;
4373 12058 : checkstring = 1;
4374 12058 : lop = 1;
4375 12058 : break;
4376 :
4377 1671 : case INTRINSIC_GE:
4378 1671 : case INTRINSIC_GE_OS:
4379 1671 : code = GE_EXPR;
4380 1671 : checkstring = 1;
4381 1671 : lop = 1;
4382 1671 : break;
4383 :
4384 4368 : case INTRINSIC_LT:
4385 4368 : case INTRINSIC_LT_OS:
4386 4368 : code = LT_EXPR;
4387 4368 : checkstring = 1;
4388 4368 : lop = 1;
4389 4368 : break;
4390 :
4391 2604 : case INTRINSIC_LE:
4392 2604 : case INTRINSIC_LE_OS:
4393 2604 : code = LE_EXPR;
4394 2604 : checkstring = 1;
4395 2604 : lop = 1;
4396 2604 : break;
4397 :
4398 0 : case INTRINSIC_USER:
4399 0 : case INTRINSIC_ASSIGN:
4400 : /* These should be converted into function calls by the frontend. */
4401 0 : gcc_unreachable ();
4402 :
4403 0 : default:
4404 0 : fatal_error (input_location, "Unknown intrinsic op");
4405 417971 : return;
4406 : }
4407 :
4408 : /* The only exception to this is **, which is handled separately anyway. */
4409 417971 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4410 :
4411 417971 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4412 383931 : checkstring = 0;
4413 :
4414 : /* lhs */
4415 417971 : gfc_init_se (&lse, se);
4416 417971 : gfc_conv_expr (&lse, expr->value.op.op1);
4417 417971 : gfc_add_block_to_block (&se->pre, &lse.pre);
4418 :
4419 : /* rhs */
4420 417971 : gfc_init_se (&rse, se);
4421 417971 : gfc_conv_expr (&rse, expr->value.op.op2);
4422 417971 : gfc_add_block_to_block (&se->pre, &rse.pre);
4423 :
4424 417971 : if (checkstring)
4425 : {
4426 34040 : gfc_conv_string_parameter (&lse);
4427 34040 : gfc_conv_string_parameter (&rse);
4428 :
4429 68080 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4430 : rse.string_length, rse.expr,
4431 34040 : expr->value.op.op1->ts.kind,
4432 : code);
4433 34040 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4434 34040 : gfc_add_block_to_block (&lse.post, &rse.post);
4435 : }
4436 :
4437 417971 : type = gfc_typenode_for_spec (&expr->ts);
4438 :
4439 417971 : if (lop)
4440 : {
4441 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4442 302082 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4443 170424 : && expr->value.op.op1->ts.type == BT_INTEGER
4444 73495 : && expr->value.op.op1->symtree
4445 73495 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4446 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4447 :
4448 302082 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4449 72364 : && expr->value.op.op2->ts.type == BT_INTEGER
4450 12985 : && expr->value.op.op2->symtree
4451 12985 : && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
4452 12 : TREE_THIS_VOLATILE (rse.expr) = 1;
4453 :
4454 : /* The result of logical ops is always logical_type_node. */
4455 302082 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4456 : lse.expr, rse.expr);
4457 302082 : se->expr = convert (type, tmp);
4458 : }
4459 : else
4460 115889 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4461 :
4462 : /* Add the post blocks. */
4463 417971 : gfc_add_block_to_block (&se->post, &rse.post);
4464 417971 : gfc_add_block_to_block (&se->post, &lse.post);
4465 : }
4466 :
4467 : static void
4468 159 : gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
4469 : {
4470 159 : gfc_se cond_se, true_se, false_se;
4471 159 : tree condition, true_val, false_val;
4472 159 : tree type;
4473 :
4474 159 : gfc_init_se (&cond_se, se);
4475 159 : gfc_init_se (&true_se, se);
4476 159 : gfc_init_se (&false_se, se);
4477 :
4478 159 : gfc_conv_expr (&cond_se, expr->value.conditional.condition);
4479 159 : gfc_add_block_to_block (&se->pre, &cond_se.pre);
4480 159 : condition = gfc_evaluate_now (cond_se.expr, &se->pre);
4481 :
4482 159 : true_se.want_pointer = se->want_pointer;
4483 159 : gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
4484 159 : true_val = true_se.expr;
4485 159 : false_se.want_pointer = se->want_pointer;
4486 159 : gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
4487 159 : false_val = false_se.expr;
4488 :
4489 159 : if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
4490 24 : gfc_add_expr_to_block (
4491 : &se->pre,
4492 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4493 24 : true_se.pre.head != NULL_TREE
4494 6 : ? gfc_finish_block (&true_se.pre)
4495 18 : : build_empty_stmt (input_location),
4496 24 : false_se.pre.head != NULL_TREE
4497 24 : ? gfc_finish_block (&false_se.pre)
4498 0 : : build_empty_stmt (input_location)));
4499 :
4500 159 : if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
4501 6 : gfc_add_expr_to_block (
4502 : &se->post,
4503 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4504 6 : true_se.post.head != NULL_TREE
4505 0 : ? gfc_finish_block (&true_se.post)
4506 6 : : build_empty_stmt (input_location),
4507 6 : false_se.post.head != NULL_TREE
4508 6 : ? gfc_finish_block (&false_se.post)
4509 0 : : build_empty_stmt (input_location)));
4510 :
4511 159 : type = gfc_typenode_for_spec (&expr->ts);
4512 159 : if (se->want_pointer)
4513 18 : type = build_pointer_type (type);
4514 :
4515 159 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
4516 : true_val, false_val);
4517 159 : if (expr->ts.type == BT_CHARACTER)
4518 66 : se->string_length
4519 66 : = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
4520 : condition, true_se.string_length,
4521 : false_se.string_length);
4522 159 : }
4523 :
4524 : /* If a string's length is one, we convert it to a single character. */
4525 :
4526 : tree
4527 140592 : gfc_string_to_single_character (tree len, tree str, int kind)
4528 : {
4529 :
4530 140592 : if (len == NULL
4531 140592 : || !tree_fits_uhwi_p (len)
4532 258412 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4533 : return NULL_TREE;
4534 :
4535 117768 : if (TREE_INT_CST_LOW (len) == 1)
4536 : {
4537 22565 : str = fold_convert (gfc_get_pchar_type (kind), str);
4538 22565 : return build_fold_indirect_ref_loc (input_location, str);
4539 : }
4540 :
4541 95203 : if (kind == 1
4542 77833 : && TREE_CODE (str) == ADDR_EXPR
4543 67145 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4544 47929 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4545 29499 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4546 29499 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4547 29499 : && TREE_INT_CST_LOW (len) > 1
4548 122874 : && TREE_INT_CST_LOW (len)
4549 : == (unsigned HOST_WIDE_INT)
4550 27671 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4551 : {
4552 27671 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4553 27671 : ret = build_fold_indirect_ref_loc (input_location, ret);
4554 27671 : if (TREE_CODE (ret) == INTEGER_CST)
4555 : {
4556 27671 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4557 27671 : int i, length = TREE_STRING_LENGTH (string_cst);
4558 27671 : const char *ptr = TREE_STRING_POINTER (string_cst);
4559 :
4560 41781 : for (i = 1; i < length; i++)
4561 41101 : if (ptr[i] != ' ')
4562 : return NULL_TREE;
4563 :
4564 : return ret;
4565 : }
4566 : }
4567 :
4568 : return NULL_TREE;
4569 : }
4570 :
4571 :
4572 : static void
4573 172 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4574 : {
4575 172 : gcc_assert (expr);
4576 :
4577 : /* We used to modify the tree here. Now it is done earlier in
4578 : the front-end, so we only check it here to avoid regressions. */
4579 172 : if (sym->backend_decl)
4580 : {
4581 67 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4582 67 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4583 67 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4584 67 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4585 : }
4586 :
4587 : /* If we have a constant character expression, make it into an
4588 : integer of type C char. */
4589 172 : if ((*expr)->expr_type == EXPR_CONSTANT)
4590 : {
4591 166 : gfc_typespec ts;
4592 166 : gfc_clear_ts (&ts);
4593 :
4594 332 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4595 166 : (*expr)->value.character.string[0]);
4596 166 : gfc_replace_expr (*expr, tmp);
4597 : }
4598 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4599 : {
4600 6 : if ((*expr)->ref == NULL)
4601 : {
4602 6 : se->expr = gfc_string_to_single_character
4603 6 : (integer_one_node,
4604 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4605 : gfc_get_symbol_decl
4606 6 : ((*expr)->symtree->n.sym)),
4607 : (*expr)->ts.kind);
4608 : }
4609 : else
4610 : {
4611 0 : gfc_conv_variable (se, *expr);
4612 0 : se->expr = gfc_string_to_single_character
4613 0 : (integer_one_node,
4614 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4615 : se->expr),
4616 0 : (*expr)->ts.kind);
4617 : }
4618 : }
4619 172 : }
4620 :
4621 : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4622 : if STR is a string literal, otherwise return -1. */
4623 :
4624 : static int
4625 32346 : gfc_optimize_len_trim (tree len, tree str, int kind)
4626 : {
4627 32346 : if (kind == 1
4628 27304 : && TREE_CODE (str) == ADDR_EXPR
4629 23966 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4630 15275 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4631 9839 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4632 9839 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4633 9839 : && tree_fits_uhwi_p (len)
4634 9839 : && tree_to_uhwi (len) >= 1
4635 32346 : && tree_to_uhwi (len)
4636 9795 : == (unsigned HOST_WIDE_INT)
4637 9795 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4638 : {
4639 9795 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4640 9795 : folded = build_fold_indirect_ref_loc (input_location, folded);
4641 9795 : if (TREE_CODE (folded) == INTEGER_CST)
4642 : {
4643 9795 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4644 9795 : int length = TREE_STRING_LENGTH (string_cst);
4645 9795 : const char *ptr = TREE_STRING_POINTER (string_cst);
4646 :
4647 14704 : for (; length > 0; length--)
4648 14704 : if (ptr[length - 1] != ' ')
4649 : break;
4650 :
4651 : return length;
4652 : }
4653 : }
4654 : return -1;
4655 : }
4656 :
4657 : /* Helper to build a call to memcmp. */
4658 :
4659 : static tree
4660 13129 : build_memcmp_call (tree s1, tree s2, tree n)
4661 : {
4662 13129 : tree tmp;
4663 :
4664 13129 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4665 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4666 : else
4667 13129 : s1 = fold_convert (pvoid_type_node, s1);
4668 :
4669 13129 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4670 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4671 : else
4672 13129 : s2 = fold_convert (pvoid_type_node, s2);
4673 :
4674 13129 : n = fold_convert (size_type_node, n);
4675 :
4676 13129 : tmp = build_call_expr_loc (input_location,
4677 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4678 : 3, s1, s2, n);
4679 :
4680 13129 : return fold_convert (integer_type_node, tmp);
4681 : }
4682 :
4683 : /* Compare two strings. If they are all single characters, the result is the
4684 : subtraction of them. Otherwise, we build a library call. */
4685 :
4686 : tree
4687 34139 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4688 : enum tree_code code)
4689 : {
4690 34139 : tree sc1;
4691 34139 : tree sc2;
4692 34139 : tree fndecl;
4693 :
4694 34139 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4695 34139 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4696 :
4697 34139 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4698 34139 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4699 :
4700 34139 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4701 : {
4702 : /* Deal with single character specially. */
4703 4839 : sc1 = fold_convert (integer_type_node, sc1);
4704 4839 : sc2 = fold_convert (integer_type_node, sc2);
4705 4839 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4706 4839 : sc1, sc2);
4707 : }
4708 :
4709 29300 : if ((code == EQ_EXPR || code == NE_EXPR)
4710 28738 : && optimize
4711 24072 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4712 : {
4713 : /* If one string is a string literal with LEN_TRIM longer
4714 : than the length of the second string, the strings
4715 : compare unequal. */
4716 16173 : int len = gfc_optimize_len_trim (len1, str1, kind);
4717 16173 : if (len > 0 && compare_tree_int (len2, len) < 0)
4718 0 : return integer_one_node;
4719 16173 : len = gfc_optimize_len_trim (len2, str2, kind);
4720 16173 : if (len > 0 && compare_tree_int (len1, len) < 0)
4721 0 : return integer_one_node;
4722 : }
4723 :
4724 : /* We can compare via memcpy if the strings are known to be equal
4725 : in length and they are
4726 : - kind=1
4727 : - kind=4 and the comparison is for (in)equality. */
4728 :
4729 19712 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4730 19374 : && tree_int_cst_equal (len1, len2)
4731 42489 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4732 : {
4733 13129 : tree tmp;
4734 13129 : tree chartype;
4735 :
4736 13129 : chartype = gfc_get_char_type (kind);
4737 13129 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4738 13129 : fold_convert (TREE_TYPE(len1),
4739 : TYPE_SIZE_UNIT(chartype)),
4740 : len1);
4741 13129 : return build_memcmp_call (str1, str2, tmp);
4742 : }
4743 :
4744 : /* Build a call for the comparison. */
4745 16171 : if (kind == 1)
4746 13328 : fndecl = gfor_fndecl_compare_string;
4747 2843 : else if (kind == 4)
4748 2843 : fndecl = gfor_fndecl_compare_string_char4;
4749 : else
4750 0 : gcc_unreachable ();
4751 :
4752 16171 : return build_call_expr_loc (input_location, fndecl, 4,
4753 16171 : len1, str1, len2, str2);
4754 : }
4755 :
4756 :
4757 : /* Return the backend_decl for a procedure pointer component. */
4758 :
4759 : static tree
4760 1914 : get_proc_ptr_comp (gfc_expr *e)
4761 : {
4762 1914 : gfc_se comp_se;
4763 1914 : gfc_expr *e2;
4764 1914 : expr_t old_type;
4765 :
4766 1914 : gfc_init_se (&comp_se, NULL);
4767 1914 : e2 = gfc_copy_expr (e);
4768 : /* We have to restore the expr type later so that gfc_free_expr frees
4769 : the exact same thing that was allocated.
4770 : TODO: This is ugly. */
4771 1914 : old_type = e2->expr_type;
4772 1914 : e2->expr_type = EXPR_VARIABLE;
4773 1914 : gfc_conv_expr (&comp_se, e2);
4774 1914 : e2->expr_type = old_type;
4775 1914 : gfc_free_expr (e2);
4776 1914 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4777 : }
4778 :
4779 :
4780 : /* Convert a typebound function reference from a class object. */
4781 : static void
4782 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4783 : {
4784 80 : gfc_ref *ref;
4785 80 : tree var;
4786 :
4787 80 : if (!VAR_P (base_object))
4788 : {
4789 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4790 0 : gfc_add_modify (&se->pre, var, base_object);
4791 : }
4792 80 : se->expr = gfc_class_vptr_get (base_object);
4793 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4794 80 : ref = expr->ref;
4795 308 : while (ref && ref->next)
4796 : ref = ref->next;
4797 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4798 80 : if (ref->u.c.sym->attr.extension)
4799 0 : conv_parent_component_references (se, ref);
4800 80 : gfc_conv_component_ref (se, ref);
4801 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4802 80 : }
4803 :
4804 : static tree
4805 128681 : get_builtin_fn (gfc_symbol * sym)
4806 : {
4807 128681 : if (!gfc_option.disable_omp_is_initial_device
4808 128677 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4809 631 : && !strcmp (sym->name, "omp_is_initial_device"))
4810 41 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4811 :
4812 128640 : if (!gfc_option.disable_omp_get_initial_device
4813 128633 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4814 4287 : && !strcmp (sym->name, "omp_get_initial_device"))
4815 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4816 :
4817 128611 : if (!gfc_option.disable_omp_get_num_devices
4818 128604 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4819 4258 : && !strcmp (sym->name, "omp_get_num_devices"))
4820 107 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4821 :
4822 128504 : if (!gfc_option.disable_acc_on_device
4823 128324 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4824 1169 : && !strcmp (sym->name, "acc_on_device_h"))
4825 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4826 :
4827 : return NULL_TREE;
4828 : }
4829 :
4830 : static tree
4831 567 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4832 : {
4833 567 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4834 :
4835 567 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4836 : /* In Fortran omp_is_initial_device returns logical(4)
4837 : but the builtin uses 'int'. */
4838 41 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4839 :
4840 526 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4841 : {
4842 : /* Likewise for the return type; additionally, the argument it a
4843 : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4844 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4845 390 : CALL_EXPR_ARG (fn_call, 0));
4846 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4847 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4848 : }
4849 : return fn_call;
4850 : }
4851 :
4852 : static void
4853 131411 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4854 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4855 : {
4856 131411 : tree tmp;
4857 :
4858 131411 : if (gfc_is_proc_ptr_comp (expr))
4859 1914 : tmp = get_proc_ptr_comp (expr);
4860 129497 : else if (sym->attr.dummy)
4861 : {
4862 816 : tmp = gfc_get_symbol_decl (sym);
4863 816 : if (sym->attr.proc_pointer)
4864 89 : tmp = build_fold_indirect_ref_loc (input_location,
4865 : tmp);
4866 816 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4867 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4868 : }
4869 : else
4870 : {
4871 128681 : if (!sym->backend_decl)
4872 32299 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4873 :
4874 128681 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4875 567 : *is_builtin = true;
4876 : else
4877 : {
4878 128114 : TREE_USED (sym->backend_decl) = 1;
4879 128114 : tmp = sym->backend_decl;
4880 : }
4881 :
4882 128681 : if (sym->attr.cray_pointee)
4883 : {
4884 : /* TODO - make the cray pointee a pointer to a procedure,
4885 : assign the pointer to it and use it for the call. This
4886 : will do for now! */
4887 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4888 19 : gfc_get_symbol_decl (sym->cp_pointer));
4889 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4890 : }
4891 :
4892 128681 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4893 : {
4894 128053 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4895 128053 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4896 : }
4897 : }
4898 131411 : se->expr = tmp;
4899 131411 : }
4900 :
4901 :
4902 : /* Initialize MAPPING. */
4903 :
4904 : void
4905 131528 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4906 : {
4907 131528 : mapping->syms = NULL;
4908 131528 : mapping->charlens = NULL;
4909 131528 : }
4910 :
4911 :
4912 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4913 :
4914 : void
4915 131528 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4916 : {
4917 131528 : gfc_interface_sym_mapping *sym;
4918 131528 : gfc_interface_sym_mapping *nextsym;
4919 131528 : gfc_charlen *cl;
4920 131528 : gfc_charlen *nextcl;
4921 :
4922 172130 : for (sym = mapping->syms; sym; sym = nextsym)
4923 : {
4924 40602 : nextsym = sym->next;
4925 40602 : sym->new_sym->n.sym->formal = NULL;
4926 40602 : gfc_free_symbol (sym->new_sym->n.sym);
4927 40602 : gfc_free_expr (sym->expr);
4928 40602 : free (sym->new_sym);
4929 40602 : free (sym);
4930 : }
4931 136204 : for (cl = mapping->charlens; cl; cl = nextcl)
4932 : {
4933 4676 : nextcl = cl->next;
4934 4676 : gfc_free_expr (cl->length);
4935 4676 : free (cl);
4936 : }
4937 131528 : }
4938 :
4939 :
4940 : /* Return a copy of gfc_charlen CL. Add the returned structure to
4941 : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4942 :
4943 : static gfc_charlen *
4944 4676 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4945 : gfc_charlen * cl)
4946 : {
4947 4676 : gfc_charlen *new_charlen;
4948 :
4949 4676 : new_charlen = gfc_get_charlen ();
4950 4676 : new_charlen->next = mapping->charlens;
4951 4676 : new_charlen->length = gfc_copy_expr (cl->length);
4952 :
4953 4676 : mapping->charlens = new_charlen;
4954 4676 : return new_charlen;
4955 : }
4956 :
4957 :
4958 : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4959 : array variable that can be used as the actual argument for dummy
4960 : argument SYM, except in the case of assumed rank dummies of
4961 : non-intrinsic functions where the descriptor must be passed. Add any
4962 : initialization code to BLOCK. PACKED is as for gfc_get_nodesc_array_type
4963 : and DATA points to the first element in the passed array. */
4964 :
4965 : static tree
4966 8394 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4967 : gfc_packed packed, tree data, tree len,
4968 : bool assumed_rank_formal)
4969 : {
4970 8394 : tree type;
4971 8394 : tree var;
4972 :
4973 8394 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4974 58 : type = gfc_get_character_type_len (sym->ts.kind, len);
4975 : else
4976 8336 : type = gfc_typenode_for_spec (&sym->ts);
4977 :
4978 8394 : if (assumed_rank_formal)
4979 13 : type = TREE_TYPE (data);
4980 : else
4981 8381 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4982 8357 : !sym->attr.target && !sym->attr.pointer
4983 16738 : && !sym->attr.proc_pointer);
4984 :
4985 8394 : var = gfc_create_var (type, "ifm");
4986 8394 : gfc_add_modify (block, var, fold_convert (type, data));
4987 :
4988 8394 : return var;
4989 : }
4990 :
4991 :
4992 : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4993 : and offset of descriptorless array type TYPE given that it has the same
4994 : size as DESC. Add any set-up code to BLOCK. */
4995 :
4996 : static void
4997 8124 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4998 : {
4999 8124 : int n;
5000 8124 : tree dim;
5001 8124 : tree offset;
5002 8124 : tree tmp;
5003 :
5004 8124 : offset = gfc_index_zero_node;
5005 9238 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
5006 : {
5007 1114 : dim = gfc_rank_cst[n];
5008 1114 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
5009 1114 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
5010 : {
5011 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
5012 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
5013 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
5014 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
5015 : }
5016 1113 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
5017 : {
5018 1087 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5019 : gfc_array_index_type,
5020 : gfc_conv_descriptor_ubound_get (desc, dim),
5021 : gfc_conv_descriptor_lbound_get (desc, dim));
5022 3261 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5023 : gfc_array_index_type,
5024 1087 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
5025 1087 : tmp = gfc_evaluate_now (tmp, block);
5026 1087 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
5027 : }
5028 4456 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5029 1114 : GFC_TYPE_ARRAY_LBOUND (type, n),
5030 1114 : GFC_TYPE_ARRAY_STRIDE (type, n));
5031 1114 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5032 : gfc_array_index_type, offset, tmp);
5033 : }
5034 8124 : offset = gfc_evaluate_now (offset, block);
5035 8124 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
5036 8124 : }
5037 :
5038 :
5039 : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
5040 : in SE. The caller may still use se->expr and se->string_length after
5041 : calling this function. */
5042 :
5043 : void
5044 40602 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
5045 : gfc_symbol * sym, gfc_se * se,
5046 : gfc_expr *expr)
5047 : {
5048 40602 : gfc_interface_sym_mapping *sm;
5049 40602 : tree desc;
5050 40602 : tree tmp;
5051 40602 : tree value;
5052 40602 : gfc_symbol *new_sym;
5053 40602 : gfc_symtree *root;
5054 40602 : gfc_symtree *new_symtree;
5055 :
5056 : /* Create a new symbol to represent the actual argument. */
5057 40602 : new_sym = gfc_new_symbol (sym->name, NULL);
5058 40602 : new_sym->ts = sym->ts;
5059 40602 : new_sym->as = gfc_copy_array_spec (sym->as);
5060 40602 : new_sym->attr.referenced = 1;
5061 40602 : new_sym->attr.dimension = sym->attr.dimension;
5062 40602 : new_sym->attr.contiguous = sym->attr.contiguous;
5063 40602 : new_sym->attr.codimension = sym->attr.codimension;
5064 40602 : new_sym->attr.pointer = sym->attr.pointer;
5065 40602 : new_sym->attr.allocatable = sym->attr.allocatable;
5066 40602 : new_sym->attr.flavor = sym->attr.flavor;
5067 40602 : new_sym->attr.function = sym->attr.function;
5068 40602 : new_sym->attr.dummy = 0;
5069 :
5070 : /* Ensure that the interface is available and that
5071 : descriptors are passed for array actual arguments. */
5072 40602 : if (sym->attr.flavor == FL_PROCEDURE)
5073 : {
5074 36 : new_sym->formal = expr->symtree->n.sym->formal;
5075 36 : new_sym->attr.always_explicit
5076 36 : = expr->symtree->n.sym->attr.always_explicit;
5077 : }
5078 :
5079 : /* Create a fake symtree for it. */
5080 40602 : root = NULL;
5081 40602 : new_symtree = gfc_new_symtree (&root, sym->name);
5082 40602 : new_symtree->n.sym = new_sym;
5083 40602 : gcc_assert (new_symtree == root);
5084 :
5085 : /* Create a dummy->actual mapping. */
5086 40602 : sm = XCNEW (gfc_interface_sym_mapping);
5087 40602 : sm->next = mapping->syms;
5088 40602 : sm->old = sym;
5089 40602 : sm->new_sym = new_symtree;
5090 40602 : sm->expr = gfc_copy_expr (expr);
5091 40602 : mapping->syms = sm;
5092 :
5093 : /* Stabilize the argument's value. */
5094 40602 : if (!sym->attr.function && se)
5095 40504 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5096 :
5097 40602 : if (sym->ts.type == BT_CHARACTER)
5098 : {
5099 : /* Create a copy of the dummy argument's length. */
5100 2874 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
5101 2874 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
5102 :
5103 : /* If the length is specified as "*", record the length that
5104 : the caller is passing. We should use the callee's length
5105 : in all other cases. */
5106 2874 : if (!new_sym->ts.u.cl->length && se)
5107 : {
5108 2646 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5109 2646 : new_sym->ts.u.cl->backend_decl = se->string_length;
5110 : }
5111 : }
5112 :
5113 40588 : if (!se)
5114 62 : return;
5115 :
5116 : /* Use the passed value as-is if the argument is a function. */
5117 40540 : if (sym->attr.flavor == FL_PROCEDURE)
5118 36 : value = se->expr;
5119 :
5120 : /* If the argument is a pass-by-value scalar, use the value as is. */
5121 40504 : else if (!sym->attr.dimension && sym->attr.value)
5122 78 : value = se->expr;
5123 :
5124 : /* If the argument is either a string or a pointer to a string,
5125 : convert it to a boundless character type. */
5126 40426 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5127 : {
5128 1305 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5129 1305 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5130 1305 : tmp = build_pointer_type (tmp);
5131 1305 : if (sym->attr.pointer)
5132 126 : value = build_fold_indirect_ref_loc (input_location,
5133 : se->expr);
5134 : else
5135 1179 : value = se->expr;
5136 1305 : value = fold_convert (tmp, value);
5137 : }
5138 :
5139 : /* If the argument is a scalar, a pointer to an array or an allocatable,
5140 : dereference it. */
5141 39121 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5142 29230 : value = build_fold_indirect_ref_loc (input_location,
5143 : se->expr);
5144 :
5145 : /* For character(*), use the actual argument's descriptor. */
5146 9891 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5147 1497 : value = build_fold_indirect_ref_loc (input_location,
5148 : se->expr);
5149 :
5150 : /* If the argument is an array descriptor, use it to determine
5151 : information about the actual argument's shape. */
5152 8394 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5153 8394 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5154 : {
5155 8124 : bool assumed_rank_formal = false;
5156 :
5157 : /* Get the actual argument's descriptor. */
5158 8124 : desc = build_fold_indirect_ref_loc (input_location,
5159 : se->expr);
5160 :
5161 : /* Create the replacement variable. */
5162 8124 : if (sym->as && sym->as->type == AS_ASSUMED_RANK
5163 7334 : && !(sym->ns && sym->ns->proc_name
5164 7334 : && sym->ns->proc_name->attr.proc == PROC_INTRINSIC))
5165 : {
5166 : assumed_rank_formal = true;
5167 : tmp = desc;
5168 : }
5169 : else
5170 8111 : tmp = gfc_conv_descriptor_data_get (desc);
5171 :
5172 8124 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5173 : PACKED_NO, tmp,
5174 : se->string_length,
5175 : assumed_rank_formal);
5176 :
5177 : /* Use DESC to work out the upper bounds, strides and offset. */
5178 8124 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5179 : }
5180 : else
5181 : /* Otherwise we have a packed array. */
5182 270 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5183 : PACKED_FULL, se->expr,
5184 : se->string_length,
5185 : false);
5186 :
5187 40540 : new_sym->backend_decl = value;
5188 : }
5189 :
5190 :
5191 : /* Called once all dummy argument mappings have been added to MAPPING,
5192 : but before the mapping is used to evaluate expressions. Pre-evaluate
5193 : the length of each argument, adding any initialization code to PRE and
5194 : any finalization code to POST. */
5195 :
5196 : static void
5197 131491 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5198 : stmtblock_t * pre, stmtblock_t * post)
5199 : {
5200 131491 : gfc_interface_sym_mapping *sym;
5201 131491 : gfc_expr *expr;
5202 131491 : gfc_se se;
5203 :
5204 172031 : for (sym = mapping->syms; sym; sym = sym->next)
5205 40540 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5206 2860 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5207 : {
5208 214 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5209 214 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5210 214 : gfc_init_se (&se, NULL);
5211 214 : gfc_conv_expr (&se, expr);
5212 214 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5213 214 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5214 214 : gfc_add_block_to_block (pre, &se.pre);
5215 214 : gfc_add_block_to_block (post, &se.post);
5216 :
5217 214 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5218 : }
5219 131491 : }
5220 :
5221 :
5222 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5223 : constructor C. */
5224 :
5225 : static void
5226 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5227 : gfc_constructor_base base)
5228 : {
5229 47 : gfc_constructor *c;
5230 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5231 : {
5232 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5233 381 : if (c->iterator)
5234 : {
5235 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5236 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5237 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5238 : }
5239 : }
5240 47 : }
5241 :
5242 :
5243 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5244 : reference REF. */
5245 :
5246 : static void
5247 12621 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5248 : gfc_ref * ref)
5249 : {
5250 12621 : int n;
5251 :
5252 14106 : for (; ref; ref = ref->next)
5253 1485 : switch (ref->type)
5254 : {
5255 : case REF_ARRAY:
5256 2915 : for (n = 0; n < ref->u.ar.dimen; n++)
5257 : {
5258 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5259 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5260 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5261 : }
5262 : break;
5263 :
5264 : case REF_COMPONENT:
5265 : case REF_INQUIRY:
5266 : break;
5267 :
5268 43 : case REF_SUBSTRING:
5269 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5270 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5271 43 : break;
5272 : }
5273 12621 : }
5274 :
5275 :
5276 : /* Convert intrinsic function calls into result expressions. */
5277 :
5278 : static bool
5279 2232 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5280 : {
5281 2232 : gfc_symbol *sym;
5282 2232 : gfc_expr *new_expr;
5283 2232 : gfc_expr *arg1;
5284 2232 : gfc_expr *arg2;
5285 2232 : int d, dup;
5286 :
5287 2232 : arg1 = expr->value.function.actual->expr;
5288 2232 : if (expr->value.function.actual->next)
5289 2111 : arg2 = expr->value.function.actual->next->expr;
5290 : else
5291 : arg2 = NULL;
5292 :
5293 2232 : sym = arg1->symtree->n.sym;
5294 :
5295 2232 : if (sym->attr.dummy)
5296 : return false;
5297 :
5298 2208 : new_expr = NULL;
5299 :
5300 2208 : switch (expr->value.function.isym->id)
5301 : {
5302 947 : case GFC_ISYM_LEN:
5303 : /* TODO figure out why this condition is necessary. */
5304 947 : if (sym->attr.function
5305 43 : && (arg1->ts.u.cl->length == NULL
5306 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5307 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5308 : return false;
5309 :
5310 904 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5311 904 : break;
5312 :
5313 228 : case GFC_ISYM_LEN_TRIM:
5314 228 : new_expr = gfc_copy_expr (arg1);
5315 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5316 :
5317 228 : if (!new_expr)
5318 : return false;
5319 :
5320 228 : gfc_replace_expr (arg1, new_expr);
5321 228 : return true;
5322 :
5323 606 : case GFC_ISYM_SIZE:
5324 606 : if (!sym->as || sym->as->rank == 0)
5325 : return false;
5326 :
5327 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5328 : {
5329 360 : dup = mpz_get_si (arg2->value.integer);
5330 360 : d = dup - 1;
5331 : }
5332 : else
5333 : {
5334 530 : dup = sym->as->rank;
5335 530 : d = 0;
5336 : }
5337 :
5338 542 : for (; d < dup; d++)
5339 : {
5340 530 : gfc_expr *tmp;
5341 :
5342 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5343 : {
5344 518 : gfc_free_expr (new_expr);
5345 518 : return false;
5346 : }
5347 :
5348 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5349 : gfc_get_int_expr (gfc_default_integer_kind,
5350 : NULL, 1));
5351 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5352 12 : if (new_expr)
5353 0 : new_expr = gfc_multiply (new_expr, tmp);
5354 : else
5355 : new_expr = tmp;
5356 : }
5357 : break;
5358 :
5359 44 : case GFC_ISYM_LBOUND:
5360 44 : case GFC_ISYM_UBOUND:
5361 : /* TODO These implementations of lbound and ubound do not limit if
5362 : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5363 :
5364 44 : if (!sym->as || sym->as->rank == 0)
5365 : return false;
5366 :
5367 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5368 38 : d = mpz_get_si (arg2->value.integer) - 1;
5369 : else
5370 : return false;
5371 :
5372 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5373 : {
5374 23 : if (sym->as->lower[d])
5375 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5376 : }
5377 : else
5378 : {
5379 15 : if (sym->as->upper[d])
5380 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5381 : }
5382 : break;
5383 :
5384 : default:
5385 : break;
5386 : }
5387 :
5388 1337 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5389 1337 : if (!new_expr)
5390 : return false;
5391 :
5392 113 : gfc_replace_expr (expr, new_expr);
5393 113 : return true;
5394 : }
5395 :
5396 :
5397 : static void
5398 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5399 : gfc_interface_mapping * mapping)
5400 : {
5401 24 : gfc_formal_arglist *f;
5402 24 : gfc_actual_arglist *actual;
5403 :
5404 24 : actual = expr->value.function.actual;
5405 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5406 :
5407 72 : for (; f && actual; f = f->next, actual = actual->next)
5408 : {
5409 24 : if (!actual->expr)
5410 0 : continue;
5411 :
5412 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5413 : }
5414 :
5415 24 : if (map_expr->symtree->n.sym->attr.dimension)
5416 : {
5417 6 : int d;
5418 6 : gfc_array_spec *as;
5419 :
5420 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5421 :
5422 18 : for (d = 0; d < as->rank; d++)
5423 : {
5424 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5425 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5426 : }
5427 :
5428 6 : expr->value.function.esym->as = as;
5429 : }
5430 :
5431 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5432 : {
5433 0 : expr->value.function.esym->ts.u.cl->length
5434 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5435 :
5436 0 : gfc_apply_interface_mapping_to_expr (mapping,
5437 0 : expr->value.function.esym->ts.u.cl->length);
5438 : }
5439 24 : }
5440 :
5441 :
5442 : /* EXPR is a copy of an expression that appeared in the interface
5443 : associated with MAPPING. Walk it recursively looking for references to
5444 : dummy arguments that MAPPING maps to actual arguments. Replace each such
5445 : reference with a reference to the associated actual argument. */
5446 :
5447 : static void
5448 21208 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5449 : gfc_expr * expr)
5450 : {
5451 22773 : gfc_interface_sym_mapping *sym;
5452 22773 : gfc_actual_arglist *actual;
5453 :
5454 22773 : if (!expr)
5455 : return;
5456 :
5457 : /* Copying an expression does not copy its length, so do that here. */
5458 12621 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5459 : {
5460 1802 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5461 1802 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5462 : }
5463 :
5464 : /* Apply the mapping to any references. */
5465 12621 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5466 :
5467 : /* ...and to the expression's symbol, if it has one. */
5468 : /* TODO Find out why the condition on expr->symtree had to be moved into
5469 : the loop rather than being outside it, as originally. */
5470 30014 : for (sym = mapping->syms; sym; sym = sym->next)
5471 17393 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5472 : {
5473 3388 : if (sym->new_sym->n.sym->backend_decl)
5474 3344 : expr->symtree = sym->new_sym;
5475 44 : else if (sym->expr)
5476 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5477 : }
5478 :
5479 : /* ...and to subexpressions in expr->value. */
5480 12621 : switch (expr->expr_type)
5481 : {
5482 : case EXPR_VARIABLE:
5483 : case EXPR_CONSTANT:
5484 : case EXPR_NULL:
5485 : case EXPR_SUBSTRING:
5486 : break;
5487 :
5488 1565 : case EXPR_OP:
5489 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5490 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5491 1565 : break;
5492 :
5493 0 : case EXPR_CONDITIONAL:
5494 0 : gfc_apply_interface_mapping_to_expr (mapping,
5495 0 : expr->value.conditional.true_expr);
5496 0 : gfc_apply_interface_mapping_to_expr (mapping,
5497 0 : expr->value.conditional.false_expr);
5498 0 : break;
5499 :
5500 2975 : case EXPR_FUNCTION:
5501 9556 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5502 6581 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5503 :
5504 2975 : if (expr->value.function.esym == NULL
5505 2662 : && expr->value.function.isym != NULL
5506 2650 : && expr->value.function.actual
5507 2649 : && expr->value.function.actual->expr
5508 2649 : && expr->value.function.actual->expr->symtree
5509 5207 : && gfc_map_intrinsic_function (expr, mapping))
5510 : break;
5511 :
5512 6190 : for (sym = mapping->syms; sym; sym = sym->next)
5513 3556 : if (sym->old == expr->value.function.esym)
5514 : {
5515 24 : expr->value.function.esym = sym->new_sym->n.sym;
5516 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5517 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5518 : }
5519 : break;
5520 :
5521 47 : case EXPR_ARRAY:
5522 47 : case EXPR_STRUCTURE:
5523 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5524 47 : break;
5525 :
5526 0 : case EXPR_COMPCALL:
5527 0 : case EXPR_PPC:
5528 0 : case EXPR_UNKNOWN:
5529 0 : gcc_unreachable ();
5530 : break;
5531 : }
5532 :
5533 : return;
5534 : }
5535 :
5536 :
5537 : /* Evaluate interface expression EXPR using MAPPING. Store the result
5538 : in SE. */
5539 :
5540 : void
5541 4034 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5542 : gfc_se * se, gfc_expr * expr)
5543 : {
5544 4034 : expr = gfc_copy_expr (expr);
5545 4034 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5546 4034 : gfc_conv_expr (se, expr);
5547 4034 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5548 4034 : gfc_free_expr (expr);
5549 4034 : }
5550 :
5551 :
5552 : /* Returns a reference to a temporary array into which a component of
5553 : an actual argument derived type array is copied and then returned
5554 : after the function call. */
5555 : void
5556 2631 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5557 : sym_intent intent, bool formal_ptr,
5558 : const gfc_symbol *fsym, const char *proc_name,
5559 : gfc_symbol *sym, bool check_contiguous)
5560 : {
5561 2631 : gfc_se lse;
5562 2631 : gfc_se rse;
5563 2631 : gfc_ss *lss;
5564 2631 : gfc_ss *rss;
5565 2631 : gfc_loopinfo loop;
5566 2631 : gfc_loopinfo loop2;
5567 2631 : gfc_array_info *info;
5568 2631 : tree offset;
5569 2631 : tree tmp_index;
5570 2631 : tree tmp;
5571 2631 : tree base_type;
5572 2631 : tree size;
5573 2631 : stmtblock_t body;
5574 2631 : int n;
5575 2631 : int dimen;
5576 2631 : gfc_se work_se;
5577 2631 : gfc_se *parmse;
5578 2631 : bool pass_optional;
5579 2631 : bool readonly;
5580 :
5581 2631 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5582 :
5583 2620 : if (pass_optional || check_contiguous)
5584 : {
5585 1348 : gfc_init_se (&work_se, NULL);
5586 1348 : parmse = &work_se;
5587 : }
5588 : else
5589 : parmse = se;
5590 :
5591 2631 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5592 : {
5593 : /* We will create a temporary array, so let us warn. */
5594 868 : char * msg;
5595 :
5596 868 : if (fsym && proc_name)
5597 868 : msg = xasprintf ("An array temporary was created for argument "
5598 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5599 : else
5600 0 : msg = xasprintf ("An array temporary was created");
5601 :
5602 868 : tmp = build_int_cst (logical_type_node, 1);
5603 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5604 : &expr->where, msg);
5605 868 : free (msg);
5606 : }
5607 :
5608 2631 : gfc_init_se (&lse, NULL);
5609 2631 : gfc_init_se (&rse, NULL);
5610 :
5611 : /* Walk the argument expression. */
5612 2631 : rss = gfc_walk_expr (expr);
5613 :
5614 2631 : gcc_assert (rss != gfc_ss_terminator);
5615 :
5616 : /* Initialize the scalarizer. */
5617 2631 : gfc_init_loopinfo (&loop);
5618 2631 : gfc_add_ss_to_loop (&loop, rss);
5619 :
5620 : /* Calculate the bounds of the scalarization. */
5621 2631 : gfc_conv_ss_startstride (&loop);
5622 :
5623 : /* Build an ss for the temporary. */
5624 2631 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5625 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5626 :
5627 2631 : base_type = gfc_typenode_for_spec (&expr->ts);
5628 2631 : if (GFC_ARRAY_TYPE_P (base_type)
5629 2631 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5630 0 : base_type = gfc_get_element_type (base_type);
5631 :
5632 2631 : if (expr->ts.type == BT_CLASS)
5633 121 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5634 :
5635 3795 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5636 1164 : ? expr->ts.u.cl->backend_decl
5637 : : NULL),
5638 : loop.dimen);
5639 :
5640 2631 : parmse->string_length = loop.temp_ss->info->string_length;
5641 :
5642 : /* Associate the SS with the loop. */
5643 2631 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5644 :
5645 : /* Setup the scalarizing loops. */
5646 2631 : gfc_conv_loop_setup (&loop, &expr->where);
5647 :
5648 : /* Pass the temporary descriptor back to the caller. */
5649 2631 : info = &loop.temp_ss->info->data.array;
5650 2631 : parmse->expr = info->descriptor;
5651 :
5652 : /* Setup the gfc_se structures. */
5653 2631 : gfc_copy_loopinfo_to_se (&lse, &loop);
5654 2631 : gfc_copy_loopinfo_to_se (&rse, &loop);
5655 :
5656 2631 : rse.ss = rss;
5657 2631 : lse.ss = loop.temp_ss;
5658 2631 : gfc_mark_ss_chain_used (rss, 1);
5659 2631 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5660 :
5661 : /* Start the scalarized loop body. */
5662 2631 : gfc_start_scalarized_body (&loop, &body);
5663 :
5664 : /* Translate the expression. */
5665 2631 : gfc_conv_expr (&rse, expr);
5666 :
5667 2631 : gfc_conv_tmp_array_ref (&lse);
5668 :
5669 2631 : if (intent != INTENT_OUT)
5670 : {
5671 2593 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5672 2593 : gfc_add_expr_to_block (&body, tmp);
5673 2593 : gcc_assert (rse.ss == gfc_ss_terminator);
5674 2593 : gfc_trans_scalarizing_loops (&loop, &body);
5675 : }
5676 : else
5677 : {
5678 : /* Make sure that the temporary declaration survives by merging
5679 : all the loop declarations into the current context. */
5680 85 : for (n = 0; n < loop.dimen; n++)
5681 : {
5682 47 : gfc_merge_block_scope (&body);
5683 47 : body = loop.code[loop.order[n]];
5684 : }
5685 38 : gfc_merge_block_scope (&body);
5686 : }
5687 :
5688 : /* Add the post block after the second loop, so that any
5689 : freeing of allocated memory is done at the right time. */
5690 2631 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5691 :
5692 : /**********Copy the temporary back again.*********/
5693 :
5694 2631 : gfc_init_se (&lse, NULL);
5695 2631 : gfc_init_se (&rse, NULL);
5696 :
5697 : /* Walk the argument expression. */
5698 2631 : lss = gfc_walk_expr (expr);
5699 2631 : rse.ss = loop.temp_ss;
5700 2631 : lse.ss = lss;
5701 :
5702 : /* Initialize the scalarizer. */
5703 2631 : gfc_init_loopinfo (&loop2);
5704 2631 : gfc_add_ss_to_loop (&loop2, lss);
5705 :
5706 2631 : dimen = rse.ss->dimen;
5707 :
5708 : /* Skip the write-out loop for this case. */
5709 2631 : if (gfc_is_class_array_function (expr))
5710 13 : goto class_array_fcn;
5711 :
5712 : /* Calculate the bounds of the scalarization. */
5713 2618 : gfc_conv_ss_startstride (&loop2);
5714 :
5715 : /* Setup the scalarizing loops. */
5716 2618 : gfc_conv_loop_setup (&loop2, &expr->where);
5717 :
5718 2618 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5719 2618 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5720 :
5721 2618 : gfc_mark_ss_chain_used (lss, 1);
5722 2618 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5723 :
5724 : /* Declare the variable to hold the temporary offset and start the
5725 : scalarized loop body. */
5726 2618 : offset = gfc_create_var (gfc_array_index_type, NULL);
5727 2618 : gfc_start_scalarized_body (&loop2, &body);
5728 :
5729 : /* Build the offsets for the temporary from the loop variables. The
5730 : temporary array has lbounds of zero and strides of one in all
5731 : dimensions, so this is very simple. The offset is only computed
5732 : outside the innermost loop, so the overall transfer could be
5733 : optimized further. */
5734 2618 : info = &rse.ss->info->data.array;
5735 :
5736 2618 : tmp_index = gfc_index_zero_node;
5737 3989 : for (n = dimen - 1; n > 0; n--)
5738 : {
5739 1371 : tree tmp_str;
5740 1371 : tmp = rse.loop->loopvar[n];
5741 1371 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5742 : tmp, rse.loop->from[n]);
5743 1371 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5744 : tmp, tmp_index);
5745 :
5746 2742 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5747 : gfc_array_index_type,
5748 1371 : rse.loop->to[n-1], rse.loop->from[n-1]);
5749 1371 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5750 : gfc_array_index_type,
5751 : tmp_str, gfc_index_one_node);
5752 :
5753 1371 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5754 : gfc_array_index_type, tmp, tmp_str);
5755 : }
5756 :
5757 5236 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5758 : gfc_array_index_type,
5759 2618 : tmp_index, rse.loop->from[0]);
5760 2618 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5761 :
5762 5236 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5763 : gfc_array_index_type,
5764 2618 : rse.loop->loopvar[0], offset);
5765 :
5766 : /* Now use the offset for the reference. */
5767 2618 : tmp = build_fold_indirect_ref_loc (input_location,
5768 : info->data);
5769 2618 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5770 :
5771 2618 : if (expr->ts.type == BT_CHARACTER)
5772 1164 : rse.string_length = expr->ts.u.cl->backend_decl;
5773 :
5774 2618 : gfc_conv_expr (&lse, expr);
5775 :
5776 2618 : gcc_assert (lse.ss == gfc_ss_terminator);
5777 :
5778 : /* Do not do deallocations when we are looking at a g77-style argument. */
5779 :
5780 2618 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, !g77);
5781 2618 : gfc_add_expr_to_block (&body, tmp);
5782 :
5783 : /* Generate the copying loops. */
5784 2618 : gfc_trans_scalarizing_loops (&loop2, &body);
5785 :
5786 : /* Wrap the whole thing up by adding the second loop to the post-block
5787 : and following it by the post-block of the first loop. In this way,
5788 : if the temporary needs freeing, it is done after use!
5789 : If input expr is read-only, e.g. a PARAMETER array, copying back
5790 : modified values is undefined behavior. */
5791 5236 : readonly = (expr->expr_type == EXPR_VARIABLE
5792 2552 : && expr->symtree
5793 5170 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5794 :
5795 2618 : if ((intent != INTENT_IN) && !readonly)
5796 : {
5797 1155 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5798 1155 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5799 : }
5800 :
5801 1463 : class_array_fcn:
5802 :
5803 2631 : gfc_add_block_to_block (&parmse->post, &loop.post);
5804 :
5805 2631 : gfc_cleanup_loop (&loop);
5806 2631 : gfc_cleanup_loop (&loop2);
5807 :
5808 : /* Pass the string length to the argument expression. */
5809 2631 : if (expr->ts.type == BT_CHARACTER)
5810 1164 : parmse->string_length = expr->ts.u.cl->backend_decl;
5811 :
5812 : /* Determine the offset for pointer formal arguments and set the
5813 : lbounds to one. */
5814 2631 : if (formal_ptr)
5815 : {
5816 18 : size = gfc_index_one_node;
5817 18 : offset = gfc_index_zero_node;
5818 36 : for (n = 0; n < dimen; n++)
5819 : {
5820 18 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5821 : gfc_rank_cst[n]);
5822 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5823 : gfc_array_index_type, tmp,
5824 : gfc_index_one_node);
5825 18 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5826 : parmse->expr,
5827 : gfc_rank_cst[n],
5828 : tmp);
5829 18 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5830 : parmse->expr,
5831 : gfc_rank_cst[n],
5832 : gfc_index_one_node);
5833 18 : size = gfc_evaluate_now (size, &parmse->pre);
5834 18 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5835 : gfc_array_index_type,
5836 : offset, size);
5837 18 : offset = gfc_evaluate_now (offset, &parmse->pre);
5838 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5839 : gfc_array_index_type,
5840 18 : rse.loop->to[n], rse.loop->from[n]);
5841 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5842 : gfc_array_index_type,
5843 : tmp, gfc_index_one_node);
5844 18 : size = fold_build2_loc (input_location, MULT_EXPR,
5845 : gfc_array_index_type, size, tmp);
5846 : }
5847 :
5848 18 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5849 : offset);
5850 : }
5851 :
5852 : /* We want either the address for the data or the address of the descriptor,
5853 : depending on the mode of passing array arguments. */
5854 2631 : if (g77)
5855 426 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5856 : else
5857 2205 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5858 :
5859 : /* Basically make this into
5860 :
5861 : if (present)
5862 : {
5863 : if (contiguous)
5864 : {
5865 : pointer = a;
5866 : }
5867 : else
5868 : {
5869 : parmse->pre();
5870 : pointer = parmse->expr;
5871 : }
5872 : }
5873 : else
5874 : pointer = NULL;
5875 :
5876 : foo (pointer);
5877 : if (present && !contiguous)
5878 : se->post();
5879 :
5880 : */
5881 :
5882 2631 : if (pass_optional || check_contiguous)
5883 : {
5884 1348 : tree type;
5885 1348 : stmtblock_t else_block;
5886 1348 : tree pre_stmts, post_stmts;
5887 1348 : tree pointer;
5888 1348 : tree else_stmt;
5889 1348 : tree present_var = NULL_TREE;
5890 1348 : tree cont_var = NULL_TREE;
5891 1348 : tree post_cond;
5892 :
5893 1348 : type = TREE_TYPE (parmse->expr);
5894 1348 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5895 1027 : type = TREE_TYPE (type);
5896 1348 : pointer = gfc_create_var (type, "arg_ptr");
5897 :
5898 1348 : if (check_contiguous)
5899 : {
5900 1348 : gfc_se cont_se, array_se;
5901 1348 : stmtblock_t if_block, else_block;
5902 1348 : tree if_stmt, else_stmt;
5903 1348 : mpz_t size;
5904 1348 : bool size_set;
5905 :
5906 1348 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5907 :
5908 : /* If the size is known to be one at compile-time, set
5909 : cont_var to true unconditionally. This may look
5910 : inelegant, but we're only doing this during
5911 : optimization, so the statements will be optimized away,
5912 : and this saves complexity here. */
5913 :
5914 1348 : size_set = gfc_array_size (expr, &size);
5915 1348 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5916 : {
5917 6 : gfc_add_modify (&se->pre, cont_var,
5918 : build_one_cst (boolean_type_node));
5919 : }
5920 : else
5921 : {
5922 : /* cont_var = is_contiguous (expr); . */
5923 1342 : gfc_init_se (&cont_se, parmse);
5924 1342 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5925 1342 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5926 1342 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5927 1342 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5928 : }
5929 :
5930 1348 : if (size_set)
5931 1149 : mpz_clear (size);
5932 :
5933 : /* arrayse->expr = descriptor of a. */
5934 1348 : gfc_init_se (&array_se, se);
5935 1348 : gfc_conv_expr_descriptor (&array_se, expr);
5936 1348 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5937 1348 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5938 :
5939 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5940 1348 : gfc_init_block (&if_block);
5941 1348 : if (GFC_DESCRIPTOR_TYPE_P (type))
5942 1027 : gfc_add_modify (&if_block, pointer, array_se.expr);
5943 : else
5944 : {
5945 321 : tmp = gfc_conv_array_data (array_se.expr);
5946 321 : tmp = fold_convert (type, tmp);
5947 321 : gfc_add_modify (&if_block, pointer, tmp);
5948 : }
5949 1348 : if_stmt = gfc_finish_block (&if_block);
5950 :
5951 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5952 1348 : gfc_init_block (&else_block);
5953 1348 : gfc_add_block_to_block (&else_block, &parmse->pre);
5954 1669 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5955 1348 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5956 : : parmse->expr);
5957 1348 : gfc_add_modify (&else_block, pointer, tmp);
5958 1348 : else_stmt = gfc_finish_block (&else_block);
5959 :
5960 : /* And put the above into an if statement. */
5961 1348 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5962 : gfc_likely (cont_var,
5963 : PRED_FORTRAN_CONTIGUOUS),
5964 : if_stmt, else_stmt);
5965 : }
5966 : else
5967 : {
5968 : /* pointer = pramse->expr; . */
5969 0 : gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5970 0 : pre_stmts = gfc_finish_block (&parmse->pre);
5971 : }
5972 :
5973 1348 : if (pass_optional)
5974 : {
5975 11 : present_var = gfc_create_var (boolean_type_node, "present");
5976 :
5977 : /* present_var = present(sym); . */
5978 11 : tmp = gfc_conv_expr_present (sym);
5979 11 : tmp = fold_convert (boolean_type_node, tmp);
5980 11 : gfc_add_modify (&se->pre, present_var, tmp);
5981 :
5982 : /* else_stmt = { pointer = NULL; } . */
5983 11 : gfc_init_block (&else_block);
5984 11 : if (GFC_DESCRIPTOR_TYPE_P (type))
5985 0 : gfc_conv_descriptor_data_set (&else_block, pointer,
5986 : null_pointer_node);
5987 : else
5988 11 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5989 11 : else_stmt = gfc_finish_block (&else_block);
5990 :
5991 11 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5992 : gfc_likely (present_var,
5993 : PRED_FORTRAN_ABSENT_DUMMY),
5994 : pre_stmts, else_stmt);
5995 11 : gfc_add_expr_to_block (&se->pre, tmp);
5996 : }
5997 : else
5998 1337 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5999 :
6000 1348 : post_stmts = gfc_finish_block (&parmse->post);
6001 :
6002 : /* Put together the post stuff, plus the optional
6003 : deallocation. */
6004 1348 : if (check_contiguous)
6005 : {
6006 : /* !cont_var. */
6007 1348 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6008 : cont_var,
6009 : build_zero_cst (boolean_type_node));
6010 1348 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
6011 :
6012 1348 : if (pass_optional)
6013 : {
6014 11 : tree present_likely = gfc_likely (present_var,
6015 : PRED_FORTRAN_ABSENT_DUMMY);
6016 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6017 : boolean_type_node, present_likely,
6018 : tmp);
6019 : }
6020 : else
6021 : post_cond = tmp;
6022 : }
6023 : else
6024 : {
6025 0 : gcc_assert (pass_optional);
6026 : post_cond = present_var;
6027 : }
6028 :
6029 1348 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
6030 : post_stmts, build_empty_stmt (input_location));
6031 1348 : gfc_add_expr_to_block (&se->post, tmp);
6032 1348 : if (GFC_DESCRIPTOR_TYPE_P (type))
6033 : {
6034 1027 : type = TREE_TYPE (parmse->expr);
6035 1027 : if (POINTER_TYPE_P (type))
6036 : {
6037 1027 : pointer = gfc_build_addr_expr (type, pointer);
6038 1027 : if (pass_optional)
6039 : {
6040 0 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
6041 0 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
6042 : tmp, pointer,
6043 : fold_convert (type,
6044 : null_pointer_node));
6045 : }
6046 : }
6047 : else
6048 0 : gcc_assert (!pass_optional);
6049 : }
6050 1348 : se->expr = pointer;
6051 : }
6052 :
6053 2631 : return;
6054 : }
6055 :
6056 :
6057 : /* Generate the code for argument list functions. */
6058 :
6059 : static void
6060 5826 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
6061 : {
6062 : /* Pass by value for g77 %VAL(arg), pass the address
6063 : indirectly for %LOC, else by reference. Thus %REF
6064 : is a "do-nothing" and %LOC is the same as an F95
6065 : pointer. */
6066 5826 : if (strcmp (name, "%VAL") == 0)
6067 5814 : gfc_conv_expr (se, expr);
6068 12 : else if (strcmp (name, "%LOC") == 0)
6069 : {
6070 6 : gfc_conv_expr_reference (se, expr);
6071 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
6072 : }
6073 6 : else if (strcmp (name, "%REF") == 0)
6074 6 : gfc_conv_expr_reference (se, expr);
6075 : else
6076 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
6077 5826 : }
6078 :
6079 :
6080 : /* This function tells whether the middle-end representation of the expression
6081 : E given as input may point to data otherwise accessible through a variable
6082 : (sub-)reference.
6083 : It is assumed that the only expressions that may alias are variables,
6084 : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
6085 : may alias.
6086 : This function is used to decide whether freeing an expression's allocatable
6087 : components is safe or should be avoided.
6088 :
6089 : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
6090 : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
6091 : is necessary because for array constructors, aliasing depends on how
6092 : the array is used:
6093 : - If E is an array constructor used as argument to an elemental procedure,
6094 : the array, which is generated through shallow copy by the scalarizer,
6095 : is used directly and can alias the expressions it was copied from.
6096 : - If E is an array constructor used as argument to a non-elemental
6097 : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
6098 : the array as in the previous case, but then that array is used
6099 : to initialize a new descriptor through deep copy. There is no alias
6100 : possible in that case.
6101 : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
6102 : above. */
6103 :
6104 : static bool
6105 7656 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6106 : {
6107 7656 : gfc_constructor *c;
6108 :
6109 7656 : if (e->expr_type == EXPR_VARIABLE)
6110 : return true;
6111 562 : else if (e->expr_type == EXPR_FUNCTION)
6112 : {
6113 161 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
6114 :
6115 161 : if (proc_ifc->result != NULL
6116 161 : && ((proc_ifc->result->ts.type == BT_CLASS
6117 25 : && proc_ifc->result->ts.u.derived->attr.is_class
6118 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
6119 161 : || proc_ifc->result->attr.pointer))
6120 : return true;
6121 : else
6122 : return false;
6123 : }
6124 401 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6125 : return false;
6126 :
6127 79 : for (c = gfc_constructor_first (e->value.constructor);
6128 233 : c; c = gfc_constructor_next (c))
6129 189 : if (c->expr
6130 189 : && expr_may_alias_variables (c->expr, array_may_alias))
6131 : return true;
6132 :
6133 : return false;
6134 : }
6135 :
6136 :
6137 : /* A helper function to set the dtype for unallocated or unassociated
6138 : entities. */
6139 :
6140 : static void
6141 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6142 : {
6143 891 : tree tmp;
6144 891 : tree desc;
6145 891 : tree cond;
6146 891 : tree type;
6147 891 : stmtblock_t block;
6148 :
6149 : /* TODO Figure out how to handle optional dummies. */
6150 891 : if (e && e->expr_type == EXPR_VARIABLE
6151 807 : && e->symtree->n.sym->attr.optional)
6152 108 : return;
6153 :
6154 819 : desc = parmse->expr;
6155 819 : if (desc == NULL_TREE)
6156 : return;
6157 :
6158 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6159 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6160 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6161 192 : desc = gfc_class_data_get (desc);
6162 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6163 : return;
6164 :
6165 783 : gfc_init_block (&block);
6166 783 : tmp = gfc_conv_descriptor_data_get (desc);
6167 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6168 : logical_type_node, tmp,
6169 783 : build_int_cst (TREE_TYPE (tmp), 0));
6170 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6171 783 : gfc_conv_descriptor_dtype_set (&block, desc,
6172 : gfc_get_dtype_rank_type (e->rank, type));
6173 783 : cond = build3_v (COND_EXPR, cond,
6174 : gfc_finish_block (&block),
6175 : build_empty_stmt (input_location));
6176 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6177 : }
6178 :
6179 :
6180 :
6181 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6182 : ISO_Fortran_binding array descriptors. */
6183 :
6184 : static void
6185 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6186 : {
6187 6537 : stmtblock_t block, block2;
6188 6537 : tree cfi, gfc, tmp, tmp2;
6189 6537 : tree present = NULL;
6190 6537 : tree gfc_strlen = NULL;
6191 6537 : tree rank;
6192 6537 : gfc_se se;
6193 :
6194 6537 : if (fsym->attr.optional
6195 1094 : && e->expr_type == EXPR_VARIABLE
6196 1094 : && e->symtree->n.sym->attr.optional)
6197 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6198 :
6199 6537 : gfc_init_block (&block);
6200 :
6201 : /* Convert original argument to a tree. */
6202 6537 : gfc_init_se (&se, NULL);
6203 6537 : if (e->rank == 0)
6204 : {
6205 687 : se.want_pointer = 1;
6206 687 : gfc_conv_expr (&se, e);
6207 687 : gfc = se.expr;
6208 : }
6209 : else
6210 : {
6211 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6212 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6213 : length assumed-length/assumed-size CHARACTER array. This only
6214 : applies if the actual argument is a "variable"; if it's some
6215 : non-lvalue expression, we are going to evaluate it to a
6216 : temporary below anyway. */
6217 5850 : se.force_no_tmp = 1;
6218 5850 : if ((fsym->attr.contiguous
6219 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6220 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6221 937 : || fsym->as->type == AS_EXPLICIT)))
6222 2023 : && !gfc_is_simply_contiguous (e, false, true)
6223 6883 : && gfc_expr_is_variable (e))
6224 : {
6225 1027 : bool optional = fsym->attr.optional;
6226 1027 : fsym->attr.optional = 0;
6227 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6228 1027 : fsym->attr.pointer, fsym,
6229 1027 : fsym->ns->proc_name->name, NULL,
6230 : /* check_contiguous= */ true);
6231 1027 : fsym->attr.optional = optional;
6232 : }
6233 : else
6234 4823 : gfc_conv_expr_descriptor (&se, e);
6235 5850 : gfc = se.expr;
6236 : /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
6237 : elem_len = sizeof(dt) and base_addr = dt(lb) instead.
6238 : gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
6239 : While sm is fine as it uses span*stride and not elem_len. */
6240 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6241 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6242 4823 : else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
6243 12 : gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
6244 : }
6245 6537 : if (e->ts.type == BT_CHARACTER)
6246 : {
6247 3409 : if (se.string_length)
6248 : gfc_strlen = se.string_length;
6249 883 : else if (e->ts.u.cl->backend_decl)
6250 : gfc_strlen = e->ts.u.cl->backend_decl;
6251 : else
6252 0 : gcc_unreachable ();
6253 : }
6254 6537 : gfc_add_block_to_block (&block, &se.pre);
6255 :
6256 : /* Create array descriptor and set version, rank, attribute, type. */
6257 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6258 : ? GFC_MAX_DIMENSIONS : e->rank,
6259 : false), "cfi");
6260 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6261 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6262 : {
6263 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6264 2338 : tmp = build_pointer_type (tmp);
6265 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6266 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6267 : }
6268 : else
6269 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6270 :
6271 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6272 6537 : gfc_add_modify (&block, tmp,
6273 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6274 6537 : if (e->rank < 0)
6275 305 : rank = gfc_conv_descriptor_rank_get (gfc);
6276 : else
6277 6232 : rank = gfc_rank_cst[e->rank];
6278 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6279 6537 : gfc_add_modify (&block, tmp,
6280 6537 : fold_convert (TREE_TYPE (tmp), rank));
6281 6537 : int itype = CFI_type_other;
6282 6537 : if (e->ts.f90_type == BT_VOID)
6283 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6284 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6285 : else
6286 : {
6287 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6288 1 : e->ts = fsym->ts;
6289 6441 : switch (e->ts.type)
6290 : {
6291 2296 : case BT_INTEGER:
6292 2296 : case BT_LOGICAL:
6293 2296 : case BT_REAL:
6294 2296 : case BT_COMPLEX:
6295 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6296 2296 : break;
6297 3410 : case BT_CHARACTER:
6298 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6299 3410 : break;
6300 : case BT_DERIVED:
6301 6537 : itype = CFI_type_struct;
6302 : break;
6303 0 : case BT_VOID:
6304 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6305 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6306 : break;
6307 : case BT_ASSUMED:
6308 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6309 : break;
6310 1 : case BT_CLASS:
6311 1 : if (fsym->ts.type == BT_ASSUMED)
6312 : {
6313 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6314 : // type specifier is assumed-type and is an unlimited polymorphic
6315 : // entity." The actual argument _data component is passed.
6316 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6317 : break;
6318 : }
6319 : else
6320 0 : gcc_unreachable ();
6321 :
6322 0 : case BT_UNSIGNED:
6323 0 : gfc_internal_error ("Unsigned not yet implemented");
6324 :
6325 0 : case BT_PROCEDURE:
6326 0 : case BT_HOLLERITH:
6327 0 : case BT_UNION:
6328 0 : case BT_BOZ:
6329 0 : case BT_UNKNOWN:
6330 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6331 0 : gcc_unreachable ();
6332 : }
6333 : }
6334 :
6335 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6336 6537 : gfc_add_modify (&block, tmp,
6337 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6338 :
6339 6537 : int attr = CFI_attribute_other;
6340 6537 : if (fsym->attr.pointer)
6341 : attr = CFI_attribute_pointer;
6342 5774 : else if (fsym->attr.allocatable)
6343 433 : attr = CFI_attribute_allocatable;
6344 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6345 6537 : gfc_add_modify (&block, tmp,
6346 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6347 :
6348 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6349 : That is very sensible for undefined pointers, but the C code might assume
6350 : that the pointer retains the value, in particular, if it was NULL. */
6351 6537 : if (e->rank == 0)
6352 : {
6353 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6354 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6355 : }
6356 : else
6357 : {
6358 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6359 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6360 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6361 : }
6362 :
6363 : /* Set elem_len if known - must be before the next if block.
6364 : Note that allocatable implies 'len=:'. */
6365 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6366 : {
6367 : /* Length is known at compile time; use 'block' for it. */
6368 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6369 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6370 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6371 : }
6372 :
6373 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6374 91 : goto done;
6375 :
6376 : /* When allocatable + intent out, free the cfi descriptor. */
6377 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6378 : {
6379 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6380 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6381 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6382 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6383 90 : gfc_add_modify (&block, tmp,
6384 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6385 90 : goto done;
6386 : }
6387 :
6388 : /* If not unallocated/unassociated. */
6389 6356 : gfc_init_block (&block2);
6390 :
6391 : /* Set elem_len, which may be only known at run time. */
6392 6356 : if (e->ts.type == BT_CHARACTER
6393 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6394 : {
6395 3408 : gcc_assert (gfc_strlen);
6396 3409 : tmp = gfc_strlen;
6397 3409 : if (e->ts.kind != 1)
6398 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6399 : gfc_charlen_type_node, tmp,
6400 : build_int_cst (gfc_charlen_type_node,
6401 1117 : e->ts.kind));
6402 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6403 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6404 : }
6405 2947 : else if (e->ts.type == BT_ASSUMED)
6406 : {
6407 54 : tmp = gfc_conv_descriptor_elem_len_get (gfc);
6408 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6409 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6410 : }
6411 :
6412 6356 : if (e->ts.type == BT_ASSUMED)
6413 : {
6414 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6415 : an CFI descriptor. Use the type in the descriptor as it provide
6416 : mode information. (Quality of implementation feature.) */
6417 54 : tree cond;
6418 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6419 54 : tree type = fold_convert (TREE_TYPE (ctype),
6420 : gfc_conv_descriptor_type_get (gfc));
6421 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6422 : gfc_conv_descriptor_elem_len_get (gfc));
6423 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6424 54 : kind, build_int_cst (TREE_TYPE (type),
6425 : CFI_type_kind_shift));
6426 :
6427 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6428 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6429 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6430 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6431 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6432 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6433 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6434 : ctype,
6435 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6436 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6437 : tmp, tmp2);
6438 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6439 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6440 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6441 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6442 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6443 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6444 : tmp, tmp2);
6445 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6446 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6447 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6448 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6449 54 : tmp = build_int_cst (TREE_TYPE (type),
6450 : CFI_type_from_type_kind (CFI_type_Character, 1));
6451 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6452 : ctype, tmp);
6453 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6454 : tmp, tmp2);
6455 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6456 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6457 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6458 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6459 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6460 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6461 54 : build_int_cst (TREE_TYPE (type),
6462 : CFI_type_Complex));
6463 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6464 : ctype, tmp);
6465 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6466 : tmp, tmp2);
6467 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6468 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6469 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6470 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6471 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6472 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6473 : cond, tmp);
6474 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6475 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6476 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6477 : cond, tmp);
6478 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6479 : type, kind);
6480 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6481 : ctype, tmp);
6482 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6483 : tmp, tmp2);
6484 54 : gfc_add_expr_to_block (&block2, tmp2);
6485 : }
6486 :
6487 6356 : if (e->rank != 0)
6488 : {
6489 : /* Loop: for (i = 0; i < rank; ++i). */
6490 5735 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6491 : /* Loop body. */
6492 5735 : stmtblock_t loop_body;
6493 5735 : gfc_init_block (&loop_body);
6494 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6495 : ? gfc->dim[i].lbound : 0 */
6496 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6497 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6498 : else
6499 5087 : tmp = gfc_index_zero_node;
6500 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6501 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6502 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6503 : gfc_conv_descriptor_ubound_get (gfc, idx),
6504 : gfc_conv_descriptor_lbound_get (gfc, idx));
6505 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6506 : tmp, gfc_index_one_node);
6507 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6508 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6509 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6510 : gfc_conv_descriptor_stride_get (gfc, idx),
6511 : gfc_conv_descriptor_span_get (gfc));
6512 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6513 :
6514 : /* Generate loop. */
6515 5735 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6516 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6517 :
6518 5735 : if (e->expr_type == EXPR_VARIABLE
6519 5573 : && e->ref
6520 5573 : && e->ref->u.ar.type == AR_FULL
6521 2732 : && e->symtree->n.sym->attr.dummy
6522 988 : && e->symtree->n.sym->as
6523 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6524 : {
6525 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6526 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6527 : }
6528 : }
6529 :
6530 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6531 : {
6532 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6533 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6534 : tmp, null_pointer_node);
6535 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6536 : build_empty_stmt (input_location));
6537 1015 : gfc_add_expr_to_block (&block, tmp);
6538 : }
6539 : else
6540 5341 : gfc_add_block_to_block (&block, &block2);
6541 :
6542 :
6543 6537 : done:
6544 6537 : if (present)
6545 : {
6546 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6547 103 : TREE_TYPE (parmse->expr),
6548 : present, parmse->expr, null_pointer_node);
6549 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6550 : build_empty_stmt (input_location));
6551 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6552 : }
6553 : else
6554 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6555 :
6556 6537 : gfc_init_block (&block);
6557 :
6558 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6559 1196 : || fsym->attr.intent == INTENT_IN)
6560 5550 : goto post_call;
6561 :
6562 987 : gfc_init_block (&block2);
6563 987 : if (e->rank == 0)
6564 : {
6565 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6566 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6567 : }
6568 : else
6569 : {
6570 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6571 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6572 :
6573 559 : if (fsym->attr.allocatable)
6574 : {
6575 : /* gfc->span = cfi->elem_len. */
6576 252 : tmp = fold_convert (gfc_array_index_type,
6577 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6578 : }
6579 : else
6580 : {
6581 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6582 : ? cfi->dim[0].sm : cfi->elem_len). */
6583 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6584 307 : tmp2 = fold_convert (gfc_array_index_type,
6585 : gfc_get_cfi_desc_elem_len (cfi));
6586 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6587 : gfc_array_index_type, tmp, tmp2);
6588 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6589 : tmp, gfc_index_zero_node);
6590 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6591 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6592 : }
6593 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6594 :
6595 : /* Calculate offset + set lbound, ubound and stride. */
6596 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6597 : /* Loop: for (i = 0; i < rank; ++i). */
6598 559 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6599 : /* Loop body. */
6600 559 : stmtblock_t loop_body;
6601 559 : gfc_init_block (&loop_body);
6602 : /* gfc->dim[i].lbound = ... */
6603 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6604 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6605 :
6606 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6607 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6608 : gfc_conv_descriptor_lbound_get (gfc, idx),
6609 : gfc_index_one_node);
6610 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6611 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6612 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6613 :
6614 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6615 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6616 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6617 : gfc_array_index_type, tmp,
6618 : fold_convert (gfc_array_index_type,
6619 : gfc_get_cfi_desc_elem_len (cfi)));
6620 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6621 :
6622 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6623 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6624 : gfc_conv_descriptor_stride_get (gfc, idx),
6625 : gfc_conv_descriptor_lbound_get (gfc, idx));
6626 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6627 : gfc_conv_descriptor_offset_get (gfc), tmp);
6628 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6629 : /* Generate loop. */
6630 559 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6631 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6632 : }
6633 :
6634 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6635 : {
6636 60 : tmp = fold_convert (gfc_charlen_type_node,
6637 : gfc_get_cfi_desc_elem_len (cfi));
6638 60 : if (e->ts.kind != 1)
6639 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6640 : gfc_charlen_type_node, tmp,
6641 : build_int_cst (gfc_charlen_type_node,
6642 24 : e->ts.kind));
6643 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6644 : }
6645 :
6646 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6647 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6648 : tmp, null_pointer_node);
6649 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6650 : build_empty_stmt (input_location));
6651 987 : gfc_add_expr_to_block (&block, tmp);
6652 :
6653 6537 : post_call:
6654 6537 : gfc_add_block_to_block (&block, &se.post);
6655 6537 : if (present && block.head)
6656 : {
6657 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6658 : build_empty_stmt (input_location));
6659 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6660 : }
6661 6531 : else if (block.head)
6662 1564 : gfc_add_block_to_block (&parmse->post, &block);
6663 6537 : }
6664 :
6665 :
6666 : /* Create "conditional temporary" to handle scalar dummy variables with the
6667 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6668 : as fallback. Does not handle CLASS. */
6669 :
6670 : static void
6671 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6672 : {
6673 234 : tree temp;
6674 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6675 234 : gcc_assert (e->rank == 0);
6676 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6677 234 : TREE_STATIC (temp) = 1;
6678 234 : TREE_CONSTANT (temp) = 1;
6679 234 : TREE_READONLY (temp) = 1;
6680 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6681 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6682 234 : TREE_TYPE (parmse->expr),
6683 : cond, parmse->expr, temp);
6684 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6685 234 : }
6686 :
6687 :
6688 : /* Returns true if the type specified in TS is a character type whose length
6689 : is constant. Otherwise returns false. */
6690 :
6691 : static bool
6692 22132 : gfc_const_length_character_type_p (gfc_typespec *ts)
6693 : {
6694 22132 : return (ts->type == BT_CHARACTER
6695 467 : && ts->u.cl
6696 467 : && ts->u.cl->length
6697 467 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6698 22599 : && ts->u.cl->length->ts.type == BT_INTEGER);
6699 : }
6700 :
6701 :
6702 : /* Helper function for the handling of (currently) scalar dummy variables
6703 : with the VALUE attribute. Argument parmse should already be set up. */
6704 : static void
6705 22565 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6706 : vec<tree, va_gc> *& optionalargs)
6707 : {
6708 22565 : tree tmp;
6709 :
6710 22565 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6711 :
6712 22565 : if (IS_PDT (e))
6713 : {
6714 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6715 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6716 6 : gfc_add_expr_to_block (&parmse->pre,
6717 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6718 : parmse->expr, tmp,
6719 : e->rank, 0));
6720 6 : parmse->expr = tmp;
6721 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6722 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6723 6 : return;
6724 : }
6725 :
6726 : /* Absent actual argument for optional scalar dummy. */
6727 22559 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6728 : {
6729 : /* For scalar arguments with VALUE attribute which are passed by
6730 : value, pass "0" and a hidden argument for the optional status. */
6731 427 : if (fsym->ts.type == BT_CHARACTER)
6732 : {
6733 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6734 : zero. */
6735 90 : parmse->expr = null_pointer_node;
6736 90 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6737 : }
6738 337 : else if (gfc_bt_struct (fsym->ts.type)
6739 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6740 : {
6741 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6742 : are pointers and passed as such below. */
6743 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6744 24 : TREE_CONSTANT (temp) = 1;
6745 24 : TREE_READONLY (temp) = 1;
6746 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6747 24 : parmse->expr = temp;
6748 24 : }
6749 : else
6750 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6751 : integer_zero_node);
6752 427 : vec_safe_push (optionalargs, boolean_false_node);
6753 :
6754 427 : return;
6755 : }
6756 :
6757 : /* Truncate a too long constant character actual argument. */
6758 22132 : if (gfc_const_length_character_type_p (&fsym->ts)
6759 467 : && e->expr_type == EXPR_CONSTANT
6760 22215 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6761 : e->value.character.length) < 0)
6762 : {
6763 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6764 :
6765 : /* Truncate actual string argument. */
6766 17 : gfc_conv_expr (parmse, e);
6767 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6768 17 : e->value.character.string);
6769 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6770 :
6771 17 : if (flen == 1)
6772 : {
6773 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6774 14 : gfc_conv_string_parameter (parmse);
6775 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6776 : e->ts.kind);
6777 : }
6778 :
6779 : /* Indicate value,optional scalar dummy argument as present. */
6780 17 : if (fsym->attr.optional)
6781 1 : vec_safe_push (optionalargs, boolean_true_node);
6782 17 : return;
6783 : }
6784 :
6785 : /* gfortran argument passing conventions:
6786 : actual arguments to CHARACTER(len=1),VALUE
6787 : dummy arguments are actually passed by value.
6788 : Strings are truncated to length 1. */
6789 22115 : if (gfc_length_one_character_type_p (&fsym->ts))
6790 : {
6791 378 : if (e->expr_type == EXPR_CONSTANT
6792 54 : && e->value.character.length > 1)
6793 : {
6794 0 : e->value.character.length = 1;
6795 0 : gfc_conv_expr (parmse, e);
6796 : }
6797 :
6798 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6799 378 : gfc_conv_string_parameter (parmse);
6800 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6801 : e->ts.kind);
6802 : /* Truncate resulting string to length 1. */
6803 378 : parmse->string_length = slen1;
6804 : }
6805 :
6806 22115 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6807 : {
6808 : /* F2018:15.5.2.12 Argument presence and
6809 : restrictions on arguments not present. */
6810 823 : if (e->expr_type == EXPR_VARIABLE
6811 650 : && e->rank == 0
6812 1419 : && (gfc_expr_attr (e).allocatable
6813 482 : || gfc_expr_attr (e).pointer))
6814 : {
6815 198 : gfc_se argse;
6816 198 : tree cond;
6817 198 : gfc_init_se (&argse, NULL);
6818 198 : argse.want_pointer = 1;
6819 198 : gfc_conv_expr (&argse, e);
6820 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6821 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6822 : argse.expr, cond);
6823 198 : if (e->symtree->n.sym->attr.dummy)
6824 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6825 : logical_type_node,
6826 : gfc_conv_expr_present (e->symtree->n.sym),
6827 : cond);
6828 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
6829 : /* Create "conditional temporary". */
6830 198 : conv_cond_temp (parmse, e, cond);
6831 : }
6832 625 : else if (e->expr_type != EXPR_VARIABLE
6833 452 : || !e->symtree->n.sym->attr.optional
6834 260 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6835 365 : vec_safe_push (optionalargs, boolean_true_node);
6836 : else
6837 : {
6838 260 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6839 260 : if (gfc_bt_struct (fsym->ts.type)
6840 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6841 36 : conv_cond_temp (parmse, e, tmp);
6842 224 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6843 84 : parmse->expr
6844 168 : = fold_build3_loc (input_location, COND_EXPR,
6845 84 : TREE_TYPE (parmse->expr),
6846 : tmp, parmse->expr,
6847 84 : fold_convert (TREE_TYPE (parmse->expr),
6848 : integer_zero_node));
6849 :
6850 520 : vec_safe_push (optionalargs,
6851 260 : fold_convert (boolean_type_node, tmp));
6852 : }
6853 : }
6854 : }
6855 :
6856 :
6857 : /* Helper function for the handling of NULL() actual arguments associated with
6858 : non-optional dummy variables. Argument parmse should already be set up. */
6859 : static void
6860 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
6861 : {
6862 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
6863 :
6864 : /* Obtain the character length for a NULL() actual with a character
6865 : MOLD argument. Otherwise substitute a suitable dummy length.
6866 : Here we handle only non-optional dummies of non-bind(c) procedures. */
6867 426 : if (fsym->ts.type == BT_CHARACTER)
6868 : {
6869 216 : if (e->ts.type == BT_CHARACTER
6870 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
6871 : {
6872 : /* MOLD is present. Substitute a temporary character NULL pointer.
6873 : For an assumed-rank dummy we need a descriptor that passes the
6874 : correct rank. */
6875 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
6876 : {
6877 54 : tree tmp = parmse->expr;
6878 54 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6879 54 : gfc_conv_descriptor_rank_set (&parmse->pre, tmp, e->rank);
6880 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6881 54 : }
6882 : else
6883 : {
6884 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
6885 108 : gfc_add_modify (&parmse->pre, tmp,
6886 108 : build_zero_cst (TREE_TYPE (tmp)));
6887 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6888 : }
6889 :
6890 : /* Ensure that a usable length is available. */
6891 162 : if (parmse->string_length == NULL_TREE)
6892 : {
6893 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
6894 :
6895 162 : if (ts->u.cl->length != NULL
6896 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6897 108 : gfc_conv_const_charlen (ts->u.cl);
6898 :
6899 162 : if (ts->u.cl->backend_decl)
6900 162 : parmse->string_length = ts->u.cl->backend_decl;
6901 : }
6902 : }
6903 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
6904 : {
6905 : /* MOLD is not present. Pass length of associated dummy character
6906 : argument if constant, or zero. */
6907 54 : if (fsym->ts.u.cl->length != NULL
6908 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6909 : {
6910 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
6911 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
6912 : }
6913 : else
6914 : {
6915 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
6916 : "slen");
6917 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
6918 : build_zero_cst (gfc_charlen_type_node));
6919 : }
6920 : }
6921 : }
6922 210 : else if (fsym->ts.type == BT_DERIVED)
6923 : {
6924 210 : if (e->ts.type != BT_UNKNOWN)
6925 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
6926 : For an assumed-rank dummy we provide a descriptor that passes
6927 : the correct rank. */
6928 : {
6929 138 : tree tmp = parmse->expr;
6930 :
6931 138 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, gfc_expr_attr (e));
6932 138 : gfc_conv_descriptor_rank_set (&parmse->pre, tmp, e->rank);
6933 138 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6934 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6935 : }
6936 : else
6937 : /* MOLD is not present. Use attributes from dummy argument, which is
6938 : not allowed to be assumed-rank. */
6939 : {
6940 72 : int dummy_rank;
6941 72 : tree tmp = parmse->expr;
6942 :
6943 72 : if ((fsym->attr.allocatable || fsym->attr.pointer)
6944 72 : && fsym->attr.intent == INTENT_UNKNOWN)
6945 36 : fsym->attr.intent = INTENT_IN;
6946 72 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6947 72 : dummy_rank = fsym->as ? fsym->as->rank : 0;
6948 24 : if (dummy_rank > 0)
6949 24 : gfc_conv_descriptor_rank_set (&parmse->pre, tmp, dummy_rank);
6950 72 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6951 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6952 : }
6953 : }
6954 426 : }
6955 :
6956 :
6957 : /* Generate code for a procedure call. Note can return se->post != NULL.
6958 : If se->direct_byref is set then se->expr contains the return parameter.
6959 : Return nonzero, if the call has alternate specifiers.
6960 : 'expr' is only needed for procedure pointer components. */
6961 :
6962 : int
6963 137269 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6964 : gfc_actual_arglist * args, gfc_expr * expr,
6965 : vec<tree, va_gc> *append_args)
6966 : {
6967 137269 : gfc_interface_mapping mapping;
6968 137269 : vec<tree, va_gc> *arglist;
6969 137269 : vec<tree, va_gc> *retargs;
6970 137269 : tree tmp;
6971 137269 : tree fntype;
6972 137269 : gfc_se parmse;
6973 137269 : gfc_array_info *info;
6974 137269 : int byref;
6975 137269 : int parm_kind;
6976 137269 : tree type;
6977 137269 : tree var;
6978 137269 : tree len;
6979 137269 : tree base_object;
6980 137269 : vec<tree, va_gc> *stringargs;
6981 137269 : vec<tree, va_gc> *optionalargs;
6982 137269 : tree result = NULL;
6983 137269 : gfc_formal_arglist *formal;
6984 137269 : gfc_actual_arglist *arg;
6985 137269 : int has_alternate_specifier = 0;
6986 137269 : bool need_interface_mapping;
6987 137269 : bool is_builtin;
6988 137269 : bool callee_alloc;
6989 137269 : bool ulim_copy;
6990 137269 : gfc_typespec ts;
6991 137269 : gfc_charlen cl;
6992 137269 : gfc_expr *e;
6993 137269 : gfc_symbol *fsym;
6994 137269 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6995 137269 : gfc_component *comp = NULL;
6996 137269 : int arglen;
6997 137269 : unsigned int argc;
6998 137269 : tree arg1_cntnr = NULL_TREE;
6999 137269 : bool call_needed_for_length = true;
7000 137269 : arglist = NULL;
7001 137269 : retargs = NULL;
7002 137269 : stringargs = NULL;
7003 137269 : optionalargs = NULL;
7004 137269 : var = NULL_TREE;
7005 137269 : len = NULL_TREE;
7006 137269 : gfc_clear_ts (&ts);
7007 137269 : gfc_intrinsic_sym *isym = expr && expr->rank ?
7008 : expr->value.function.isym : NULL;
7009 :
7010 137269 : comp = gfc_get_proc_ptr_comp (expr);
7011 :
7012 274538 : bool elemental_proc = (comp
7013 2043 : && comp->ts.interface
7014 1989 : && comp->ts.interface->attr.elemental)
7015 1844 : || (comp && comp->attr.elemental)
7016 139113 : || sym->attr.elemental;
7017 :
7018 137269 : if (se->ss != NULL)
7019 : {
7020 25053 : if (!elemental_proc)
7021 : {
7022 21494 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
7023 21494 : if (se->ss->info->useflags)
7024 : {
7025 5778 : gcc_assert ((!comp && gfc_return_by_reference (sym)
7026 : && sym->result->attr.dimension)
7027 : || (comp && comp->attr.dimension)
7028 : || gfc_is_class_array_function (expr));
7029 5778 : gcc_assert (se->loop != NULL);
7030 : /* Access the previously obtained result. */
7031 5778 : gfc_conv_tmp_array_ref (se);
7032 5778 : return 0;
7033 : }
7034 : }
7035 19275 : info = &se->ss->info->data.array;
7036 : }
7037 : else
7038 : info = NULL;
7039 :
7040 131491 : stmtblock_t post, clobbers, dealloc_blk;
7041 131491 : gfc_init_block (&post);
7042 131491 : gfc_init_block (&clobbers);
7043 131491 : gfc_init_block (&dealloc_blk);
7044 131491 : gfc_init_interface_mapping (&mapping);
7045 131491 : if (!comp)
7046 : {
7047 129497 : formal = gfc_sym_get_dummy_args (sym);
7048 129497 : need_interface_mapping = sym->attr.dimension ||
7049 114033 : (sym->ts.type == BT_CHARACTER
7050 3198 : && sym->ts.u.cl->length
7051 2452 : && sym->ts.u.cl->length->expr_type
7052 : != EXPR_CONSTANT);
7053 : }
7054 : else
7055 : {
7056 1994 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
7057 1994 : need_interface_mapping = comp->attr.dimension ||
7058 1925 : (comp->ts.type == BT_CHARACTER
7059 229 : && comp->ts.u.cl->length
7060 220 : && comp->ts.u.cl->length->expr_type
7061 : != EXPR_CONSTANT);
7062 : }
7063 :
7064 131491 : base_object = NULL_TREE;
7065 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7066 : is the third and fourth argument to such a function call a value
7067 : denoting the number of elements to copy (i.e., most of the time the
7068 : length of a deferred length string). */
7069 262982 : ulim_copy = (formal == NULL)
7070 32163 : && UNLIMITED_POLY (sym)
7071 131571 : && comp && (strcmp ("_copy", comp->name) == 0);
7072 :
7073 : /* Scan for allocatable actual arguments passed to allocatable dummy
7074 : arguments with INTENT(OUT). As the corresponding actual arguments are
7075 : deallocated before execution of the procedure, we evaluate actual
7076 : argument expressions to avoid problems with possible dependencies. */
7077 131491 : bool force_eval_args = false;
7078 131491 : gfc_formal_arglist *tmp_formal;
7079 403149 : for (arg = args, tmp_formal = formal; arg != NULL;
7080 238320 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7081 : {
7082 272163 : e = arg->expr;
7083 272163 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7084 258735 : if (e && fsym
7085 226824 : && e->expr_type == EXPR_VARIABLE
7086 99687 : && fsym->attr.intent == INTENT_OUT
7087 6342 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7088 6342 : ? CLASS_DATA (fsym)->attr.allocatable
7089 4814 : : fsym->attr.allocatable)
7090 505 : && e->symtree
7091 505 : && e->symtree->n.sym
7092 530898 : && gfc_variable_attr (e, NULL).allocatable)
7093 : {
7094 : force_eval_args = true;
7095 : break;
7096 : }
7097 : }
7098 :
7099 : /* Evaluate the arguments. */
7100 404056 : for (arg = args, argc = 0; arg != NULL;
7101 272565 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7102 : {
7103 272565 : bool finalized = false;
7104 272565 : tree derived_array = NULL_TREE;
7105 272565 : symbol_attribute *attr;
7106 :
7107 272565 : e = arg->expr;
7108 272565 : fsym = formal ? formal->sym : NULL;
7109 511792 : parm_kind = MISSING;
7110 :
7111 239227 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7112 : : fsym->attr)
7113 : : nullptr;
7114 : /* If the procedure requires an explicit interface, the actual
7115 : argument is passed according to the corresponding formal
7116 : argument. If the corresponding formal argument is a POINTER,
7117 : ALLOCATABLE or assumed shape, we do not use g77's calling
7118 : convention, and pass the address of the array descriptor
7119 : instead. Otherwise we use g77's calling convention, in other words
7120 : pass the array data pointer without descriptor. */
7121 239174 : bool nodesc_arg = fsym != NULL
7122 239174 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7123 230072 : && fsym->as
7124 40983 : && fsym->as->type != AS_ASSUMED_SHAPE
7125 24838 : && fsym->as->type != AS_ASSUMED_RANK;
7126 272565 : if (comp)
7127 2749 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7128 : else
7129 269816 : nodesc_arg
7130 : = nodesc_arg
7131 269816 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7132 :
7133 : /* Class array expressions are sometimes coming completely unadorned
7134 : with either arrayspec or _data component. Correct that here.
7135 : OOP-TODO: Move this to the frontend. */
7136 272565 : if (e && e->expr_type == EXPR_VARIABLE
7137 113804 : && !e->ref
7138 51891 : && e->ts.type == BT_CLASS
7139 2609 : && (CLASS_DATA (e)->attr.codimension
7140 2609 : || CLASS_DATA (e)->attr.dimension))
7141 : {
7142 0 : gfc_typespec temp_ts = e->ts;
7143 0 : gfc_add_class_array_ref (e);
7144 0 : e->ts = temp_ts;
7145 : }
7146 :
7147 272565 : if (e == NULL
7148 259131 : || (e->expr_type == EXPR_NULL
7149 745 : && fsym
7150 745 : && fsym->attr.value
7151 72 : && fsym->attr.optional
7152 72 : && !fsym->attr.dimension
7153 72 : && fsym->ts.type != BT_CLASS))
7154 : {
7155 13506 : if (se->ignore_optional)
7156 : {
7157 : /* Some intrinsics have already been resolved to the correct
7158 : parameters. */
7159 632 : continue;
7160 : }
7161 13308 : else if (arg->label)
7162 : {
7163 224 : has_alternate_specifier = 1;
7164 224 : continue;
7165 : }
7166 : else
7167 : {
7168 13084 : gfc_init_se (&parmse, NULL);
7169 :
7170 : /* For scalar arguments with VALUE attribute which are passed by
7171 : value, pass "0" and a hidden argument gives the optional
7172 : status. */
7173 13084 : if (fsym && fsym->attr.optional && fsym->attr.value
7174 427 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7175 : {
7176 427 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7177 : }
7178 : else
7179 : {
7180 : /* Pass a NULL pointer for an absent arg. */
7181 12657 : parmse.expr = null_pointer_node;
7182 :
7183 : /* Is it an absent character dummy? */
7184 12657 : bool absent_char = false;
7185 12657 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7186 :
7187 : /* Fall back to inferred type only if no formal. */
7188 12657 : if (fsym)
7189 11599 : absent_char = (fsym->ts.type == BT_CHARACTER);
7190 1058 : else if (dummy_arg)
7191 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7192 : == BT_CHARACTER);
7193 12657 : if (absent_char)
7194 1115 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7195 : 0);
7196 : }
7197 : }
7198 : }
7199 259059 : else if (e->expr_type == EXPR_NULL
7200 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7201 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7202 293 : && fsym->ts.type == BT_DERIVED)
7203 : {
7204 210 : gfc_init_se (&parmse, NULL);
7205 210 : gfc_conv_expr_reference (&parmse, e);
7206 210 : conv_null_actual (&parmse, e, fsym);
7207 : }
7208 258849 : else if (arg->expr->expr_type == EXPR_NULL
7209 463 : && fsym && !fsym->attr.pointer
7210 163 : && (fsym->ts.type != BT_CLASS
7211 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7212 : {
7213 : /* Pass a NULL pointer to denote an absent arg. */
7214 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7215 : && (fsym->ts.type != BT_CLASS
7216 : || !CLASS_DATA (fsym)->attr.allocatable));
7217 163 : gfc_init_se (&parmse, NULL);
7218 163 : parmse.expr = null_pointer_node;
7219 163 : if (fsym->ts.type == BT_CHARACTER)
7220 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7221 : }
7222 258686 : else if (fsym && fsym->ts.type == BT_CLASS
7223 11273 : && e->ts.type == BT_DERIVED)
7224 : {
7225 : /* The derived type needs to be converted to a temporary
7226 : CLASS object. */
7227 4718 : gfc_init_se (&parmse, se);
7228 4718 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7229 4718 : fsym->attr.optional
7230 1008 : && e->expr_type == EXPR_VARIABLE
7231 5726 : && e->symtree->n.sym->attr.optional,
7232 4718 : CLASS_DATA (fsym)->attr.class_pointer
7233 4718 : || CLASS_DATA (fsym)->attr.allocatable,
7234 : sym->name, &derived_array);
7235 : }
7236 222057 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7237 906 : && e->ts.type != BT_PROCEDURE
7238 882 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7239 12 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7240 : {
7241 : /* The intrinsic type needs to be converted to a temporary
7242 : CLASS object for the unlimited polymorphic formal. */
7243 882 : gfc_find_vtab (&e->ts);
7244 882 : gfc_init_se (&parmse, se);
7245 882 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7246 :
7247 : }
7248 253086 : else if (se->ss && se->ss->info->useflags)
7249 : {
7250 5837 : gfc_ss *ss;
7251 :
7252 5837 : ss = se->ss;
7253 :
7254 : /* An elemental function inside a scalarized loop. */
7255 5837 : gfc_init_se (&parmse, se);
7256 5837 : parm_kind = ELEMENTAL;
7257 :
7258 : /* When no fsym is present, ulim_copy is set and this is a third or
7259 : fourth argument, use call-by-value instead of by reference to
7260 : hand the length properties to the copy routine (i.e., most of the
7261 : time this will be a call to a __copy_character_* routine where the
7262 : third and fourth arguments are the lengths of a deferred length
7263 : char array). */
7264 5837 : if ((fsym && fsym->attr.value)
7265 5603 : || (ulim_copy && (argc == 2 || argc == 3)))
7266 234 : gfc_conv_expr (&parmse, e);
7267 5603 : else if (e->expr_type == EXPR_ARRAY)
7268 : {
7269 306 : gfc_conv_expr (&parmse, e);
7270 306 : if (e->ts.type != BT_CHARACTER)
7271 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7272 : }
7273 : else
7274 5297 : gfc_conv_expr_reference (&parmse, e);
7275 :
7276 5837 : if (e->ts.type == BT_CHARACTER && !e->rank
7277 174 : && e->expr_type == EXPR_FUNCTION)
7278 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7279 : parmse.expr);
7280 :
7281 5787 : if (fsym && fsym->ts.type == BT_DERIVED
7282 7459 : && gfc_is_class_container_ref (e))
7283 : {
7284 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7285 :
7286 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7287 24 : && e->symtree->n.sym->attr.optional)
7288 : {
7289 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7290 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7291 0 : TREE_TYPE (parmse.expr),
7292 : cond, parmse.expr,
7293 0 : fold_convert (TREE_TYPE (parmse.expr),
7294 : null_pointer_node));
7295 : }
7296 : }
7297 :
7298 : /* Scalar dummy arguments of intrinsic type or derived type with
7299 : VALUE attribute. */
7300 5837 : if (fsym
7301 5787 : && fsym->attr.value
7302 234 : && fsym->ts.type != BT_CLASS)
7303 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7304 :
7305 : /* If we are passing an absent array as optional dummy to an
7306 : elemental procedure, make sure that we pass NULL when the data
7307 : pointer is NULL. We need this extra conditional because of
7308 : scalarization which passes arrays elements to the procedure,
7309 : ignoring the fact that the array can be absent/unallocated/... */
7310 5603 : else if (ss->info->can_be_null_ref
7311 415 : && ss->info->type != GFC_SS_REFERENCE)
7312 : {
7313 193 : tree descriptor_data;
7314 :
7315 193 : descriptor_data = ss->info->data.array.data;
7316 193 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7317 : descriptor_data,
7318 193 : fold_convert (TREE_TYPE (descriptor_data),
7319 : null_pointer_node));
7320 193 : parmse.expr
7321 386 : = fold_build3_loc (input_location, COND_EXPR,
7322 193 : TREE_TYPE (parmse.expr),
7323 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7324 193 : fold_convert (TREE_TYPE (parmse.expr),
7325 : null_pointer_node),
7326 : parmse.expr);
7327 : }
7328 :
7329 : /* The scalarizer does not repackage the reference to a class
7330 : array - instead it returns a pointer to the data element. */
7331 5837 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7332 186 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7333 186 : fsym->attr.intent != INTENT_IN
7334 186 : && (CLASS_DATA (fsym)->attr.class_pointer
7335 24 : || CLASS_DATA (fsym)->attr.allocatable),
7336 186 : fsym->attr.optional
7337 0 : && e->expr_type == EXPR_VARIABLE
7338 186 : && e->symtree->n.sym->attr.optional,
7339 186 : CLASS_DATA (fsym)->attr.class_pointer
7340 186 : || CLASS_DATA (fsym)->attr.allocatable);
7341 : }
7342 : else
7343 : {
7344 247249 : bool scalar;
7345 247249 : gfc_ss *argss;
7346 :
7347 247249 : gfc_init_se (&parmse, NULL);
7348 :
7349 : /* Check whether the expression is a scalar or not; we cannot use
7350 : e->rank as it can be nonzero for functions arguments. */
7351 247249 : argss = gfc_walk_expr (e);
7352 247249 : scalar = argss == gfc_ss_terminator;
7353 247249 : if (!scalar)
7354 60785 : gfc_free_ss_chain (argss);
7355 :
7356 : /* Special handling for passing scalar polymorphic coarrays;
7357 : otherwise one passes "class->_data.data" instead of "&class". */
7358 247249 : if (e->rank == 0 && e->ts.type == BT_CLASS
7359 3563 : && fsym && fsym->ts.type == BT_CLASS
7360 3141 : && CLASS_DATA (fsym)->attr.codimension
7361 55 : && !CLASS_DATA (fsym)->attr.dimension)
7362 : {
7363 55 : gfc_add_class_array_ref (e);
7364 55 : parmse.want_coarray = 1;
7365 55 : scalar = false;
7366 : }
7367 :
7368 : /* A scalar or transformational function. */
7369 247249 : if (scalar)
7370 : {
7371 186409 : if (e->expr_type == EXPR_VARIABLE
7372 55283 : && e->symtree->n.sym->attr.cray_pointee
7373 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7374 : {
7375 : /* The Cray pointer needs to be converted to a pointer to
7376 : a type given by the expression. */
7377 6 : gfc_conv_expr (&parmse, e);
7378 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7379 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7380 6 : parmse.expr = convert (type, tmp);
7381 : }
7382 :
7383 186403 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7384 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7385 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7386 :
7387 185716 : else if (fsym && fsym->attr.value)
7388 : {
7389 22076 : if (fsym->ts.type == BT_CHARACTER
7390 543 : && fsym->ts.is_c_interop
7391 181 : && fsym->ns->proc_name != NULL
7392 181 : && fsym->ns->proc_name->attr.is_bind_c)
7393 : {
7394 172 : parmse.expr = NULL;
7395 172 : conv_scalar_char_value (fsym, &parmse, &e);
7396 172 : if (parmse.expr == NULL)
7397 166 : gfc_conv_expr (&parmse, e);
7398 : }
7399 : else
7400 : {
7401 21904 : gfc_conv_expr (&parmse, e);
7402 21904 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7403 : }
7404 : }
7405 :
7406 163640 : else if (arg->name && arg->name[0] == '%')
7407 : /* Argument list functions %VAL, %LOC and %REF are signalled
7408 : through arg->name. */
7409 5826 : conv_arglist_function (&parmse, arg->expr, arg->name);
7410 157814 : else if ((e->expr_type == EXPR_FUNCTION)
7411 8305 : && ((e->value.function.esym
7412 2154 : && e->value.function.esym->result->attr.pointer)
7413 8210 : || (!e->value.function.esym
7414 6151 : && e->symtree->n.sym->attr.pointer))
7415 95 : && fsym && fsym->attr.target)
7416 : /* Make sure the function only gets called once. */
7417 8 : gfc_conv_expr_reference (&parmse, e);
7418 157806 : else if (e->expr_type == EXPR_FUNCTION
7419 8297 : && e->symtree->n.sym->result
7420 7262 : && e->symtree->n.sym->result != e->symtree->n.sym
7421 138 : && e->symtree->n.sym->result->attr.proc_pointer)
7422 : {
7423 : /* Functions returning procedure pointers. */
7424 18 : gfc_conv_expr (&parmse, e);
7425 18 : if (fsym && fsym->attr.proc_pointer)
7426 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7427 : }
7428 :
7429 : else
7430 : {
7431 157788 : bool defer_to_dealloc_blk = false;
7432 157788 : if (e->ts.type == BT_CLASS && fsym
7433 3496 : && fsym->ts.type == BT_CLASS
7434 3074 : && (!CLASS_DATA (fsym)->as
7435 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7436 2718 : && CLASS_DATA (e)->attr.codimension)
7437 : {
7438 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7439 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7440 48 : gfc_add_class_array_ref (e);
7441 48 : parmse.want_coarray = 1;
7442 48 : gfc_conv_expr_reference (&parmse, e);
7443 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7444 48 : fsym->attr.optional
7445 48 : && e->expr_type == EXPR_VARIABLE);
7446 : }
7447 157740 : else if (e->ts.type == BT_CLASS && fsym
7448 3448 : && fsym->ts.type == BT_CLASS
7449 3026 : && !CLASS_DATA (fsym)->as
7450 2670 : && !CLASS_DATA (e)->as
7451 2560 : && strcmp (fsym->ts.u.derived->name,
7452 : e->ts.u.derived->name))
7453 : {
7454 1619 : type = gfc_typenode_for_spec (&fsym->ts);
7455 1619 : var = gfc_create_var (type, fsym->name);
7456 1619 : gfc_conv_expr (&parmse, e);
7457 1619 : if (fsym->attr.optional
7458 153 : && e->expr_type == EXPR_VARIABLE
7459 153 : && e->symtree->n.sym->attr.optional)
7460 : {
7461 66 : stmtblock_t block;
7462 66 : tree cond;
7463 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7464 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7465 : logical_type_node, tmp,
7466 66 : fold_convert (TREE_TYPE (tmp),
7467 : null_pointer_node));
7468 66 : gfc_start_block (&block);
7469 66 : gfc_add_modify (&block, var,
7470 : fold_build1_loc (input_location,
7471 : VIEW_CONVERT_EXPR,
7472 : type, parmse.expr));
7473 66 : gfc_add_expr_to_block (&parmse.pre,
7474 : fold_build3_loc (input_location,
7475 : COND_EXPR, void_type_node,
7476 : cond, gfc_finish_block (&block),
7477 : build_empty_stmt (input_location)));
7478 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7479 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7480 66 : TREE_TYPE (parmse.expr),
7481 : cond, parmse.expr,
7482 66 : fold_convert (TREE_TYPE (parmse.expr),
7483 : null_pointer_node));
7484 66 : }
7485 : else
7486 : {
7487 : /* Since the internal representation of unlimited
7488 : polymorphic expressions includes an extra field
7489 : that other class objects do not, a cast to the
7490 : formal type does not work. */
7491 1553 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7492 : {
7493 91 : tree efield;
7494 :
7495 : /* Evaluate arguments just once, when they have
7496 : side effects. */
7497 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7498 : {
7499 25 : tree cldata, zero;
7500 :
7501 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7502 : &parmse.pre);
7503 :
7504 : /* Prevent memory leak, when old component
7505 : was allocated already. */
7506 25 : cldata = gfc_class_data_get (parmse.expr);
7507 25 : zero = build_int_cst (TREE_TYPE (cldata),
7508 : 0);
7509 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7510 : logical_type_node,
7511 : cldata, zero);
7512 25 : tmp = build3_v (COND_EXPR, tmp,
7513 : gfc_call_free (cldata),
7514 : build_empty_stmt (
7515 : input_location));
7516 25 : gfc_add_expr_to_block (&parmse.finalblock,
7517 : tmp);
7518 25 : gfc_add_modify (&parmse.finalblock,
7519 : cldata, zero);
7520 : }
7521 :
7522 : /* Set the _data field. */
7523 91 : tmp = gfc_class_data_get (var);
7524 91 : efield = fold_convert (TREE_TYPE (tmp),
7525 : gfc_class_data_get (parmse.expr));
7526 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7527 :
7528 : /* Set the _vptr field. */
7529 91 : tmp = gfc_class_vptr_get (var);
7530 91 : efield = fold_convert (TREE_TYPE (tmp),
7531 : gfc_class_vptr_get (parmse.expr));
7532 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7533 :
7534 : /* Set the _len field. */
7535 91 : tmp = gfc_class_len_get (var);
7536 91 : gfc_add_modify (&parmse.pre, tmp,
7537 91 : build_int_cst (TREE_TYPE (tmp), 0));
7538 91 : }
7539 : else
7540 : {
7541 1462 : tmp = fold_build1_loc (input_location,
7542 : VIEW_CONVERT_EXPR,
7543 : type, parmse.expr);
7544 1462 : gfc_add_modify (&parmse.pre, var, tmp);
7545 1553 : ;
7546 : }
7547 1553 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7548 : }
7549 : }
7550 : else
7551 : {
7552 156121 : gfc_conv_expr_reference (&parmse, e);
7553 :
7554 156121 : gfc_symbol *dsym = fsym;
7555 156121 : gfc_dummy_arg *dummy;
7556 :
7557 : /* Use associated dummy as fallback for formal
7558 : argument if there is no explicit interface. */
7559 156121 : if (dsym == NULL
7560 27428 : && (dummy = arg->associated_dummy)
7561 24901 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7562 179615 : && dummy->u.non_intrinsic->sym)
7563 : dsym = dummy->u.non_intrinsic->sym;
7564 :
7565 156121 : if (dsym
7566 152187 : && dsym->attr.intent == INTENT_OUT
7567 3267 : && !dsym->attr.allocatable
7568 3124 : && !dsym->attr.pointer
7569 3106 : && e->expr_type == EXPR_VARIABLE
7570 3105 : && e->ref == NULL
7571 2996 : && e->symtree
7572 2996 : && e->symtree->n.sym
7573 2996 : && !e->symtree->n.sym->attr.dimension
7574 2996 : && e->ts.type != BT_CHARACTER
7575 2894 : && e->ts.type != BT_CLASS
7576 2664 : && (e->ts.type != BT_DERIVED
7577 492 : || (dsym->ts.type == BT_DERIVED
7578 492 : && e->ts.u.derived == dsym->ts.u.derived
7579 : /* Types with allocatable components are
7580 : excluded from clobbering because we need
7581 : the unclobbered pointers to free the
7582 : allocatable components in the callee.
7583 : Same goes for finalizable types or types
7584 : with finalizable components, we need to
7585 : pass the unclobbered values to the
7586 : finalization routines.
7587 : For parameterized types, it's less clear
7588 : but they may not have a constant size
7589 : so better exclude them in any case. */
7590 477 : && !e->ts.u.derived->attr.alloc_comp
7591 351 : && !e->ts.u.derived->attr.pdt_type
7592 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7593 2481 : && e->ts.type != BT_PROCEDURE
7594 158566 : && !sym->attr.elemental)
7595 : {
7596 1112 : tree var;
7597 1112 : var = build_fold_indirect_ref_loc (input_location,
7598 : parmse.expr);
7599 1112 : tree clobber = build_clobber (TREE_TYPE (var));
7600 1112 : gfc_add_modify (&clobbers, var, clobber);
7601 : }
7602 : }
7603 : /* Catch base objects that are not variables. */
7604 157788 : if (e->ts.type == BT_CLASS
7605 3496 : && e->expr_type != EXPR_VARIABLE
7606 306 : && expr && e == expr->base_expr)
7607 80 : base_object = build_fold_indirect_ref_loc (input_location,
7608 : parmse.expr);
7609 :
7610 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7611 : allocated on entry, it must be deallocated. */
7612 130360 : if (fsym && fsym->attr.intent == INTENT_OUT
7613 3196 : && (fsym->attr.allocatable
7614 3053 : || (fsym->ts.type == BT_CLASS
7615 259 : && CLASS_DATA (fsym)->attr.allocatable))
7616 158080 : && !is_CFI_desc (fsym, NULL))
7617 : {
7618 292 : stmtblock_t block;
7619 292 : tree ptr;
7620 :
7621 292 : defer_to_dealloc_blk = true;
7622 :
7623 292 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7624 : &parmse.pre);
7625 :
7626 292 : if (parmse.class_container != NULL_TREE)
7627 156 : parmse.class_container
7628 156 : = gfc_evaluate_data_ref_now (parmse.class_container,
7629 : &parmse.pre);
7630 :
7631 292 : gfc_init_block (&block);
7632 292 : ptr = parmse.expr;
7633 292 : if (e->ts.type == BT_CLASS)
7634 156 : ptr = gfc_class_data_get (ptr);
7635 :
7636 292 : tree cls = parmse.class_container;
7637 292 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7638 : NULL_TREE, true,
7639 : e, e->ts, cls);
7640 292 : gfc_add_expr_to_block (&block, tmp);
7641 292 : gfc_add_modify (&block, ptr,
7642 292 : fold_convert (TREE_TYPE (ptr),
7643 : null_pointer_node));
7644 :
7645 292 : if (fsym->ts.type == BT_CLASS)
7646 149 : gfc_reset_vptr (&block, nullptr,
7647 : build_fold_indirect_ref (parmse.expr),
7648 149 : fsym->ts.u.derived);
7649 :
7650 292 : if (fsym->attr.optional
7651 42 : && e->expr_type == EXPR_VARIABLE
7652 42 : && e->symtree->n.sym->attr.optional)
7653 : {
7654 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7655 : void_type_node,
7656 18 : gfc_conv_expr_present (e->symtree->n.sym),
7657 : gfc_finish_block (&block),
7658 : build_empty_stmt (input_location));
7659 : }
7660 : else
7661 274 : tmp = gfc_finish_block (&block);
7662 :
7663 292 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7664 : }
7665 :
7666 : /* A class array element needs converting back to be a
7667 : class object, if the formal argument is a class object. */
7668 157788 : if (fsym && fsym->ts.type == BT_CLASS
7669 3098 : && e->ts.type == BT_CLASS
7670 3074 : && ((CLASS_DATA (fsym)->as
7671 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7672 2718 : || CLASS_DATA (e)->attr.dimension))
7673 : {
7674 466 : gfc_se class_se = parmse;
7675 466 : gfc_init_block (&class_se.pre);
7676 466 : gfc_init_block (&class_se.post);
7677 :
7678 466 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7679 466 : fsym->attr.intent != INTENT_IN
7680 466 : && (CLASS_DATA (fsym)->attr.class_pointer
7681 267 : || CLASS_DATA (fsym)->attr.allocatable),
7682 466 : fsym->attr.optional
7683 198 : && e->expr_type == EXPR_VARIABLE
7684 664 : && e->symtree->n.sym->attr.optional,
7685 466 : CLASS_DATA (fsym)->attr.class_pointer
7686 466 : || CLASS_DATA (fsym)->attr.allocatable);
7687 :
7688 466 : parmse.expr = class_se.expr;
7689 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7690 466 : ? &dealloc_blk
7691 : : &parmse.pre;
7692 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7693 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7694 : }
7695 :
7696 130360 : if (fsym && (fsym->ts.type == BT_DERIVED
7697 118426 : || fsym->ts.type == BT_ASSUMED)
7698 12801 : && e->ts.type == BT_CLASS
7699 410 : && !CLASS_DATA (e)->attr.dimension
7700 374 : && !CLASS_DATA (e)->attr.codimension)
7701 : {
7702 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7703 : /* The result is a class temporary, whose _data component
7704 : must be freed to avoid a memory leak. */
7705 374 : if (e->expr_type == EXPR_FUNCTION
7706 23 : && CLASS_DATA (e)->attr.allocatable)
7707 : {
7708 19 : tree zero;
7709 :
7710 : /* Finalize the expression. */
7711 19 : gfc_finalize_tree_expr (&parmse, NULL,
7712 19 : gfc_expr_attr (e), e->rank);
7713 19 : gfc_add_block_to_block (&parmse.post,
7714 : &parmse.finalblock);
7715 :
7716 : /* Then free the class _data. */
7717 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7718 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7719 : logical_type_node,
7720 : parmse.expr, zero);
7721 19 : tmp = build3_v (COND_EXPR, tmp,
7722 : gfc_call_free (parmse.expr),
7723 : build_empty_stmt (input_location));
7724 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7725 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7726 : }
7727 : }
7728 :
7729 : /* Wrap scalar variable in a descriptor. We need to convert
7730 : the address of a pointer back to the pointer itself before,
7731 : we can assign it to the data field. */
7732 :
7733 130360 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7734 1338 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7735 : {
7736 1266 : tmp = parmse.expr;
7737 1266 : if (TREE_CODE (tmp) == ADDR_EXPR)
7738 748 : tmp = TREE_OPERAND (tmp, 0);
7739 1266 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7740 : fsym->attr);
7741 1266 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
7742 : parmse.expr);
7743 : }
7744 129094 : else if (fsym && e->expr_type != EXPR_NULL
7745 128796 : && ((fsym->attr.pointer
7746 1740 : && fsym->attr.flavor != FL_PROCEDURE)
7747 127062 : || (fsym->attr.proc_pointer
7748 199 : && !(e->expr_type == EXPR_VARIABLE
7749 199 : && e->symtree->n.sym->attr.dummy))
7750 126875 : || (fsym->attr.proc_pointer
7751 12 : && e->expr_type == EXPR_VARIABLE
7752 12 : && gfc_is_proc_ptr_comp (e))
7753 126869 : || (fsym->attr.allocatable
7754 1041 : && fsym->attr.flavor != FL_PROCEDURE)))
7755 : {
7756 : /* Scalar pointer dummy args require an extra level of
7757 : indirection. The null pointer already contains
7758 : this level of indirection. */
7759 2962 : parm_kind = SCALAR_POINTER;
7760 2962 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7761 : }
7762 : }
7763 : }
7764 60840 : else if (e->ts.type == BT_CLASS
7765 2723 : && fsym && fsym->ts.type == BT_CLASS
7766 2377 : && (CLASS_DATA (fsym)->attr.dimension
7767 55 : || CLASS_DATA (fsym)->attr.codimension))
7768 : {
7769 : /* Pass a class array. */
7770 2377 : gfc_conv_expr_descriptor (&parmse, e);
7771 2377 : bool defer_to_dealloc_blk = false;
7772 :
7773 2377 : if (fsym->attr.optional
7774 798 : && e->expr_type == EXPR_VARIABLE
7775 798 : && e->symtree->n.sym->attr.optional)
7776 : {
7777 438 : stmtblock_t block;
7778 :
7779 438 : gfc_init_block (&block);
7780 438 : gfc_add_block_to_block (&block, &parmse.pre);
7781 :
7782 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
7783 : void_type_node,
7784 438 : gfc_conv_expr_present (e->symtree->n.sym),
7785 : gfc_finish_block (&block),
7786 : build_empty_stmt (input_location));
7787 :
7788 438 : gfc_add_expr_to_block (&parmse.pre, t);
7789 : }
7790 :
7791 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7792 : allocated on entry, it must be deallocated. */
7793 2377 : if (fsym->attr.intent == INTENT_OUT
7794 141 : && CLASS_DATA (fsym)->attr.allocatable)
7795 : {
7796 110 : stmtblock_t block;
7797 110 : tree ptr;
7798 :
7799 : /* In case the data reference to deallocate is dependent on
7800 : its own content, save the resulting pointer to a variable
7801 : and only use that variable from now on, before the
7802 : expression becomes invalid. */
7803 110 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7804 : &parmse.pre);
7805 :
7806 110 : if (parmse.class_container != NULL_TREE)
7807 110 : parmse.class_container
7808 110 : = gfc_evaluate_data_ref_now (parmse.class_container,
7809 : &parmse.pre);
7810 :
7811 110 : gfc_init_block (&block);
7812 110 : ptr = parmse.expr;
7813 110 : ptr = gfc_class_data_get (ptr);
7814 :
7815 110 : tree cls = parmse.class_container;
7816 110 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
7817 : NULL_TREE, NULL_TREE,
7818 : NULL_TREE, true, e,
7819 : GFC_CAF_COARRAY_NOCOARRAY,
7820 : cls);
7821 110 : gfc_add_expr_to_block (&block, tmp);
7822 110 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7823 : void_type_node, ptr,
7824 : null_pointer_node);
7825 110 : gfc_add_expr_to_block (&block, tmp);
7826 110 : gfc_reset_vptr (&block, e, parmse.class_container);
7827 :
7828 110 : if (fsym->attr.optional
7829 30 : && e->expr_type == EXPR_VARIABLE
7830 30 : && (!e->ref
7831 30 : || (e->ref->type == REF_ARRAY
7832 0 : && e->ref->u.ar.type != AR_FULL))
7833 0 : && e->symtree->n.sym->attr.optional)
7834 : {
7835 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7836 : void_type_node,
7837 0 : gfc_conv_expr_present (e->symtree->n.sym),
7838 : gfc_finish_block (&block),
7839 : build_empty_stmt (input_location));
7840 : }
7841 : else
7842 110 : tmp = gfc_finish_block (&block);
7843 :
7844 110 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7845 110 : defer_to_dealloc_blk = true;
7846 : }
7847 :
7848 2377 : gfc_se class_se = parmse;
7849 2377 : gfc_init_block (&class_se.pre);
7850 2377 : gfc_init_block (&class_se.post);
7851 :
7852 2377 : if (e->expr_type != EXPR_VARIABLE)
7853 : {
7854 : int n;
7855 : /* Set the bounds and offset correctly. */
7856 60 : for (n = 0; n < e->rank; n++)
7857 30 : gfc_conv_shift_descriptor_lbound (&class_se.pre,
7858 : class_se.expr,
7859 : n, gfc_index_one_node);
7860 : }
7861 :
7862 : /* The conversion does not repackage the reference to a class
7863 : array - _data descriptor. */
7864 2377 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7865 2377 : fsym->attr.intent != INTENT_IN
7866 2377 : && (CLASS_DATA (fsym)->attr.class_pointer
7867 1229 : || CLASS_DATA (fsym)->attr.allocatable),
7868 2377 : fsym->attr.optional
7869 798 : && e->expr_type == EXPR_VARIABLE
7870 3175 : && e->symtree->n.sym->attr.optional,
7871 2377 : CLASS_DATA (fsym)->attr.class_pointer
7872 2377 : || CLASS_DATA (fsym)->attr.allocatable);
7873 :
7874 2377 : parmse.expr = class_se.expr;
7875 2267 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7876 2377 : ? &dealloc_blk
7877 : : &parmse.pre;
7878 2377 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7879 2377 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7880 :
7881 2377 : if (e->expr_type == EXPR_OP
7882 12 : && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
7883 2389 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
7884 : {
7885 12 : tree cond;
7886 12 : tree dealloc_expr = gfc_finish_block (&parmse.post);
7887 12 : tmp = TREE_OPERAND (parmse.expr, 0);
7888 12 : gfc_init_block (&parmse.post);
7889 12 : cond = gfc_class_data_get (tmp);
7890 12 : tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
7891 : tmp, e->rank, true);
7892 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7893 12 : cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
7894 12 : cond = gfc_conv_descriptor_data_get (cond);
7895 12 : cond = fold_build2_loc (input_location, NE_EXPR,
7896 : logical_type_node, cond,
7897 12 : build_int_cst (TREE_TYPE (cond), 0));
7898 12 : tmp = build3_v (COND_EXPR, cond, dealloc_expr,
7899 : build_empty_stmt (input_location));
7900 :
7901 : /* This specific case should not be processed further and so
7902 : bundle everything up and proceed to the next argument. */
7903 12 : if (fsym && need_interface_mapping && e)
7904 12 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
7905 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7906 12 : gfc_add_block_to_block (&se->pre, &parmse.pre);
7907 12 : gfc_add_block_to_block (&post, &parmse.post);
7908 12 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
7909 12 : vec_safe_push (arglist, parmse.expr);
7910 12 : continue;
7911 12 : }
7912 2365 : }
7913 : else
7914 : {
7915 : /* If the argument is a function call that may not create
7916 : a temporary for the result, we have to check that we
7917 : can do it, i.e. that there is no alias between this
7918 : argument and another one. */
7919 58463 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7920 : {
7921 412 : gfc_expr *iarg;
7922 412 : sym_intent intent;
7923 :
7924 412 : if (fsym != NULL)
7925 403 : intent = fsym->attr.intent;
7926 : else
7927 : intent = INTENT_UNKNOWN;
7928 :
7929 412 : if (gfc_check_fncall_dependency (e, intent, sym, args,
7930 : NOT_ELEMENTAL))
7931 21 : parmse.force_tmp = 1;
7932 :
7933 412 : iarg = e->value.function.actual->expr;
7934 :
7935 : /* Temporary needed if aliasing due to host association. */
7936 412 : if (sym->attr.contained
7937 168 : && !sym->attr.pure
7938 168 : && !sym->attr.implicit_pure
7939 84 : && !sym->attr.use_assoc
7940 84 : && iarg->expr_type == EXPR_VARIABLE
7941 84 : && sym->ns == iarg->symtree->n.sym->ns)
7942 36 : parmse.force_tmp = 1;
7943 :
7944 : /* Ditto within module. */
7945 412 : if (sym->attr.use_assoc
7946 6 : && !sym->attr.pure
7947 6 : && !sym->attr.implicit_pure
7948 0 : && iarg->expr_type == EXPR_VARIABLE
7949 0 : && sym->module == iarg->symtree->n.sym->module)
7950 0 : parmse.force_tmp = 1;
7951 : }
7952 :
7953 : /* Special case for assumed-rank arrays: when passing an
7954 : argument to a nonallocatable/nonpointer dummy, the bounds have
7955 : to be reset as otherwise a last-dim ubound of -1 is
7956 : indistinguishable from an assumed-size array in the callee. */
7957 58463 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
7958 35410 : && fsym->as->type == AS_ASSUMED_RANK
7959 11966 : && e->rank != -1
7960 11652 : && e->expr_type == EXPR_VARIABLE
7961 11187 : && ((fsym->ts.type == BT_CLASS
7962 0 : && !CLASS_DATA (fsym)->attr.class_pointer
7963 0 : && !CLASS_DATA (fsym)->attr.allocatable)
7964 11187 : || (fsym->ts.type != BT_CLASS
7965 11187 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
7966 : {
7967 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7968 10644 : gfc_ref *ref;
7969 10902 : for (ref = e->ref; ref->next; ref = ref->next)
7970 : {
7971 330 : if (ref->next->type == REF_INQUIRY)
7972 : break;
7973 282 : if (ref->type == REF_ARRAY
7974 24 : && ref->u.ar.type != AR_ELEMENT)
7975 : break;
7976 10644 : };
7977 10644 : if (ref->u.ar.type == AR_FULL
7978 9894 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
7979 9774 : ref->u.ar.type = AR_SECTION;
7980 : }
7981 :
7982 58463 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7983 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7984 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7985 :
7986 52613 : else if (e->expr_type == EXPR_VARIABLE
7987 41035 : && is_subref_array (e)
7988 53593 : && !(fsym && fsym->attr.pointer))
7989 : /* The actual argument is a component reference to an
7990 : array of derived types. In this case, the argument
7991 : is converted to a temporary, which is passed and then
7992 : written back after the procedure call. */
7993 727 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7994 685 : fsym ? fsym->attr.intent : INTENT_INOUT,
7995 727 : fsym && fsym->attr.pointer);
7996 :
7997 51886 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
7998 345 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
7999 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
8000 : /* An assumed size class actual argument being passed to
8001 : a 'no descriptor' formal argument just requires the
8002 : data pointer to be passed. For class dummy arguments
8003 : this is stored in the symbol backend decl.. */
8004 6 : parmse.expr = e->symtree->n.sym->backend_decl;
8005 :
8006 51880 : else if (gfc_is_class_array_ref (e, NULL)
8007 51880 : && fsym && fsym->ts.type == BT_DERIVED)
8008 : /* The actual argument is a component reference to an
8009 : array of derived types. In this case, the argument
8010 : is converted to a temporary, which is passed and then
8011 : written back after the procedure call.
8012 : OOP-TODO: Insert code so that if the dynamic type is
8013 : the same as the declared type, copy-in/copy-out does
8014 : not occur. */
8015 108 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8016 108 : fsym->attr.intent,
8017 108 : fsym->attr.pointer);
8018 :
8019 51772 : else if (gfc_is_class_array_function (e)
8020 51772 : && fsym && fsym->ts.type == BT_DERIVED)
8021 : /* See previous comment. For function actual argument,
8022 : the write out is not needed so the intent is set as
8023 : intent in. */
8024 : {
8025 13 : e->must_finalize = 1;
8026 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8027 13 : INTENT_IN, fsym->attr.pointer);
8028 : }
8029 48180 : else if (fsym && fsym->attr.contiguous
8030 90 : && (fsym->attr.target
8031 1762 : ? gfc_is_not_contiguous (e)
8032 1672 : : !gfc_is_simply_contiguous (e, false, true))
8033 357 : && gfc_expr_is_variable (e)
8034 53866 : && e->rank != -1)
8035 : {
8036 333 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8037 333 : fsym->attr.intent,
8038 333 : fsym->attr.pointer);
8039 : }
8040 : else
8041 : /* This is where we introduce a temporary to store the
8042 : result of a non-lvalue array expression. */
8043 51426 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
8044 : sym->name, NULL);
8045 :
8046 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8047 : allocated on entry, it must be deallocated.
8048 : CFI descriptors are handled elsewhere. */
8049 54842 : if (fsym && fsym->attr.allocatable
8050 1787 : && fsym->attr.intent == INTENT_OUT
8051 58212 : && !is_CFI_desc (fsym, NULL))
8052 : {
8053 161 : if (fsym->ts.type == BT_DERIVED
8054 47 : && fsym->ts.u.derived->attr.alloc_comp)
8055 : {
8056 : // deallocate the components first
8057 11 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
8058 : parmse.expr, e->rank);
8059 : /* But check whether dummy argument is optional. */
8060 11 : if (tmp != NULL_TREE
8061 11 : && fsym->attr.optional
8062 6 : && e->expr_type == EXPR_VARIABLE
8063 6 : && e->symtree->n.sym->attr.optional)
8064 : {
8065 6 : tree present;
8066 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
8067 6 : tmp = build3_v (COND_EXPR, present, tmp,
8068 : build_empty_stmt (input_location));
8069 : }
8070 11 : if (tmp != NULL_TREE)
8071 11 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8072 : }
8073 :
8074 161 : tmp = parmse.expr;
8075 : /* With bind(C), the actual argument is replaced by a bind-C
8076 : descriptor; in this case, the data component arrives here,
8077 : which shall not be dereferenced, but still freed and
8078 : nullified. */
8079 161 : if (TREE_TYPE(tmp) != pvoid_type_node)
8080 161 : tmp = build_fold_indirect_ref_loc (input_location,
8081 : parmse.expr);
8082 161 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8083 : NULL_TREE, NULL_TREE, true,
8084 : e,
8085 : GFC_CAF_COARRAY_NOCOARRAY);
8086 161 : if (fsym->attr.optional
8087 48 : && e->expr_type == EXPR_VARIABLE
8088 48 : && e->symtree->n.sym->attr.optional)
8089 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
8090 : void_type_node,
8091 24 : gfc_conv_expr_present (e->symtree->n.sym),
8092 : tmp, build_empty_stmt (input_location));
8093 161 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8094 : }
8095 : }
8096 : }
8097 : /* Special case for an assumed-rank dummy argument. */
8098 272131 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
8099 57144 : && (fsym->ts.type == BT_CLASS
8100 57144 : ? (CLASS_DATA (fsym)->as
8101 4594 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
8102 52550 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8103 : {
8104 12803 : if (fsym->ts.type == BT_CLASS
8105 12803 : ? (CLASS_DATA (fsym)->attr.class_pointer
8106 1067 : || CLASS_DATA (fsym)->attr.allocatable)
8107 11736 : : (fsym->attr.pointer || fsym->attr.allocatable))
8108 : {
8109 : /* Unallocated allocatable arrays and unassociated pointer
8110 : arrays need their dtype setting if they are argument
8111 : associated with assumed rank dummies to set the rank. */
8112 891 : set_dtype_for_unallocated (&parmse, e);
8113 : }
8114 11912 : else if (e->expr_type == EXPR_VARIABLE
8115 11409 : && e->symtree->n.sym->attr.dummy
8116 722 : && (e->ts.type == BT_CLASS
8117 915 : ? (e->ref && e->ref->next
8118 193 : && e->ref->next->type == REF_ARRAY
8119 193 : && e->ref->next->u.ar.type == AR_FULL
8120 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8121 529 : : (e->ref && e->ref->type == REF_ARRAY
8122 529 : && e->ref->u.ar.type == AR_FULL
8123 757 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8124 : {
8125 : /* Assumed-size actual to assumed-rank dummy requires
8126 : dim[rank-1].ubound = -1. */
8127 180 : tree minus_one;
8128 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8129 180 : if (fsym->ts.type == BT_CLASS)
8130 60 : tmp = gfc_class_data_get (tmp);
8131 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8132 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8133 180 : gfc_rank_cst[e->rank - 1],
8134 : minus_one);
8135 : }
8136 : }
8137 :
8138 : /* The case with fsym->attr.optional is that of a user subroutine
8139 : with an interface indicating an optional argument. When we call
8140 : an intrinsic subroutine, however, fsym is NULL, but we might still
8141 : have an optional argument, so we proceed to the substitution
8142 : just in case. Arguments passed to bind(c) procedures via CFI
8143 : descriptors are handled elsewhere. */
8144 259119 : if (e && (fsym == NULL || fsym->attr.optional)
8145 332579 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8146 : {
8147 : /* If an optional argument is itself an optional dummy argument,
8148 : check its presence and substitute a null if absent. This is
8149 : only needed when passing an array to an elemental procedure
8150 : as then array elements are accessed - or no NULL pointer is
8151 : allowed and a "1" or "0" should be passed if not present.
8152 : When passing a non-array-descriptor full array to a
8153 : non-array-descriptor dummy, no check is needed. For
8154 : array-descriptor actual to array-descriptor dummy, see
8155 : PR 41911 for why a check has to be inserted.
8156 : fsym == NULL is checked as intrinsics required the descriptor
8157 : but do not always set fsym.
8158 : Also, it is necessary to pass a NULL pointer to library routines
8159 : which usually ignore optional arguments, so they can handle
8160 : these themselves. */
8161 59354 : if (e->expr_type == EXPR_VARIABLE
8162 26450 : && e->symtree->n.sym->attr.optional
8163 2421 : && (((e->rank != 0 && elemental_proc)
8164 2246 : || e->representation.length || e->ts.type == BT_CHARACTER
8165 2020 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8166 1910 : || (e->rank != 0
8167 1070 : && (fsym == NULL
8168 1034 : || (fsym->as
8169 272 : && (fsym->as->type == AS_ASSUMED_SHAPE
8170 235 : || fsym->as->type == AS_ASSUMED_RANK
8171 117 : || fsym->as->type == AS_DEFERRED)))))
8172 1685 : || se->ignore_optional))
8173 764 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8174 764 : e->representation.length);
8175 : }
8176 :
8177 : /* Make the class container for the first argument available with class
8178 : valued transformational functions. */
8179 272131 : if (argc == 0 && e && e->ts.type == BT_CLASS
8180 4991 : && isym && isym->transformational
8181 84 : && se->ss && se->ss->info)
8182 : {
8183 84 : arg1_cntnr = parmse.expr;
8184 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8185 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8186 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8187 84 : se->ss->info->class_container = arg1_cntnr;
8188 : }
8189 :
8190 : /* Obtain the character length of an assumed character length procedure
8191 : from the typespec of the actual argument. */
8192 272131 : if (e
8193 259119 : && parmse.string_length == NULL_TREE
8194 223503 : && e->ts.type == BT_PROCEDURE
8195 1935 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8196 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8197 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8198 : {
8199 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8200 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8201 : }
8202 :
8203 272131 : if (fsym && e)
8204 : {
8205 : /* Obtain the character length for a NULL() actual with a character
8206 : MOLD argument. Otherwise substitute a suitable dummy length.
8207 : Here we handle non-optional dummies of non-bind(c) procedures. */
8208 227208 : if (e->expr_type == EXPR_NULL
8209 745 : && fsym->ts.type == BT_CHARACTER
8210 296 : && !fsym->attr.optional
8211 227426 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8212 216 : conv_null_actual (&parmse, e, fsym);
8213 : }
8214 :
8215 : /* If any actual argument of the procedure is allocatable and passed
8216 : to an allocatable dummy with INTENT(OUT), we conservatively
8217 : evaluate actual argument expressions before deallocations are
8218 : performed and the procedure is executed. May create temporaries.
8219 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8220 259119 : if (e && fsym && force_eval_args
8221 1108 : && fsym->attr.intent != INTENT_OUT
8222 272540 : && !gfc_is_constant_expr (e))
8223 268 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8224 :
8225 272131 : if (fsym && need_interface_mapping && e)
8226 40528 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8227 :
8228 272131 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8229 272131 : gfc_add_block_to_block (&post, &parmse.post);
8230 272131 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8231 :
8232 : /* Allocated allocatable components of derived types must be
8233 : deallocated for non-variable scalars, array arguments to elemental
8234 : procedures, and array arguments with descriptor to non-elemental
8235 : procedures. As bounds information for descriptorless arrays is no
8236 : longer available here, they are dealt with in trans-array.cc
8237 : (gfc_conv_array_parameter). */
8238 259119 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8239 28481 : && e->ts.u.derived->attr.alloc_comp
8240 7605 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8241 279598 : && !expr_may_alias_variables (e, elemental_proc))
8242 : {
8243 372 : int parm_rank;
8244 : /* It is known the e returns a structure type with at least one
8245 : allocatable component. When e is a function, ensure that the
8246 : function is called once only by using a temporary variable. */
8247 372 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8248 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8249 : parmse.expr, &se->pre);
8250 :
8251 372 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8252 152 : tmp = parmse.expr;
8253 : else
8254 220 : tmp = build_fold_indirect_ref_loc (input_location,
8255 : parmse.expr);
8256 :
8257 372 : parm_rank = e->rank;
8258 372 : switch (parm_kind)
8259 : {
8260 : case (ELEMENTAL):
8261 : case (SCALAR):
8262 372 : parm_rank = 0;
8263 : break;
8264 :
8265 0 : case (SCALAR_POINTER):
8266 0 : tmp = build_fold_indirect_ref_loc (input_location,
8267 : tmp);
8268 0 : break;
8269 : }
8270 :
8271 372 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8272 : {
8273 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8274 : Therefore, class actuals can be handled correctly but derived
8275 : types passed to class formals need the _data component. */
8276 82 : tmp = gfc_class_data_get (tmp);
8277 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8278 : {
8279 56 : if (UNLIMITED_POLY (fsym))
8280 : {
8281 12 : tree type = gfc_typenode_for_spec (&e->ts);
8282 12 : type = build_pointer_type (type);
8283 12 : tmp = fold_convert (type, tmp);
8284 : }
8285 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8286 : }
8287 : }
8288 :
8289 372 : if (e->expr_type == EXPR_OP
8290 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8291 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8292 : {
8293 24 : tree local_tmp;
8294 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8295 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8296 : parm_rank, 0);
8297 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8298 : }
8299 :
8300 : /* Items of array expressions passed to a polymorphic formal arguments
8301 : create their own clean up, so prevent double free. */
8302 372 : if (!finalized && !e->must_finalize
8303 371 : && !(e->expr_type == EXPR_ARRAY && fsym
8304 86 : && fsym->ts.type == BT_CLASS))
8305 : {
8306 351 : bool scalar_res_outside_loop;
8307 1041 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8308 151 : && parm_rank == 0
8309 490 : && parmse.loop;
8310 :
8311 : /* Scalars passed to an assumed rank argument are converted to
8312 : a descriptor. Obtain the data field before deallocating any
8313 : allocatable components. */
8314 298 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8315 612 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8316 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8317 :
8318 351 : if (scalar_res_outside_loop)
8319 : {
8320 : /* Go through the ss chain to find the argument and use
8321 : the stored value. */
8322 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8323 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8324 60 : if (tmp_ss->info
8325 48 : && tmp_ss->info->expr == e
8326 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8327 : {
8328 18 : tmp = tmp_ss->info->data.scalar.value;
8329 18 : break;
8330 : }
8331 : }
8332 :
8333 351 : STRIP_NOPS (tmp);
8334 :
8335 351 : if (derived_array != NULL_TREE)
8336 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8337 : derived_array,
8338 : parm_rank);
8339 351 : else if ((e->ts.type == BT_CLASS
8340 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8341 351 : || e->ts.type == BT_DERIVED)
8342 351 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8343 : parm_rank, 0, true);
8344 0 : else if (e->ts.type == BT_CLASS)
8345 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8346 : tmp, parm_rank);
8347 :
8348 351 : if (scalar_res_outside_loop)
8349 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8350 : else
8351 321 : gfc_prepend_expr_to_block (&post, tmp);
8352 : }
8353 : }
8354 :
8355 : /* Add argument checking of passing an unallocated/NULL actual to
8356 : a nonallocatable/nonpointer dummy. */
8357 :
8358 272131 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8359 : {
8360 6546 : symbol_attribute attr;
8361 6546 : char *msg;
8362 6546 : tree cond;
8363 6546 : tree tmp;
8364 6546 : symbol_attribute fsym_attr;
8365 :
8366 6546 : if (fsym)
8367 : {
8368 6385 : if (fsym->ts.type == BT_CLASS)
8369 : {
8370 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8371 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8372 : }
8373 : else
8374 6064 : fsym_attr = fsym->attr;
8375 : }
8376 :
8377 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8378 4094 : attr = gfc_expr_attr (e);
8379 : else
8380 6081 : goto end_pointer_check;
8381 :
8382 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8383 : allocatable to an optional dummy, cf. 12.5.2.12. */
8384 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8385 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8386 1032 : goto end_pointer_check;
8387 :
8388 3062 : if (attr.optional)
8389 : {
8390 : /* If the actual argument is an optional pointer/allocatable and
8391 : the formal argument takes an nonpointer optional value,
8392 : it is invalid to pass a non-present argument on, even
8393 : though there is no technical reason for this in gfortran.
8394 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8395 60 : tree present, null_ptr, type;
8396 :
8397 60 : if (attr.allocatable
8398 0 : && (fsym == NULL || !fsym_attr.allocatable))
8399 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8400 : "allocated or not present",
8401 0 : e->symtree->n.sym->name);
8402 60 : else if (attr.pointer
8403 12 : && (fsym == NULL || !fsym_attr.pointer))
8404 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8405 : "associated or not present",
8406 12 : e->symtree->n.sym->name);
8407 48 : else if (attr.proc_pointer && !e->value.function.actual
8408 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8409 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8410 : "associated or not present",
8411 0 : e->symtree->n.sym->name);
8412 : else
8413 48 : goto end_pointer_check;
8414 :
8415 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8416 12 : type = TREE_TYPE (present);
8417 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8418 : logical_type_node, present,
8419 : fold_convert (type,
8420 : null_pointer_node));
8421 12 : type = TREE_TYPE (parmse.expr);
8422 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8423 : logical_type_node, parmse.expr,
8424 : fold_convert (type,
8425 : null_pointer_node));
8426 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8427 : logical_type_node, present, null_ptr);
8428 : }
8429 : else
8430 : {
8431 3002 : if (attr.allocatable
8432 256 : && (fsym == NULL || !fsym_attr.allocatable))
8433 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8434 190 : "allocated", e->symtree->n.sym->name);
8435 2812 : else if (attr.pointer
8436 272 : && (fsym == NULL || !fsym_attr.pointer))
8437 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8438 184 : "associated", e->symtree->n.sym->name);
8439 2628 : else if (attr.proc_pointer && !e->value.function.actual
8440 80 : && (fsym == NULL
8441 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8442 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8443 79 : "associated", e->symtree->n.sym->name);
8444 : else
8445 2549 : goto end_pointer_check;
8446 :
8447 453 : tmp = parmse.expr;
8448 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8449 : {
8450 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8451 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8452 76 : tmp = gfc_class_data_get (tmp);
8453 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8454 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8455 : }
8456 :
8457 : /* If the argument is passed by value, we need to strip the
8458 : INDIRECT_REF. */
8459 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8460 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8461 :
8462 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8463 : logical_type_node, tmp,
8464 453 : fold_convert (TREE_TYPE (tmp),
8465 : null_pointer_node));
8466 : }
8467 :
8468 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8469 : msg);
8470 465 : free (msg);
8471 : }
8472 265585 : end_pointer_check:
8473 :
8474 : /* Deferred length dummies pass the character length by reference
8475 : so that the value can be returned. */
8476 272131 : if (parmse.string_length && fsym && fsym->ts.deferred)
8477 : {
8478 795 : if (INDIRECT_REF_P (parmse.string_length))
8479 : {
8480 : /* In chains of functions/procedure calls the string_length already
8481 : is a pointer to the variable holding the length. Therefore
8482 : remove the deref on call. */
8483 90 : tmp = parmse.string_length;
8484 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8485 : }
8486 : else
8487 : {
8488 705 : tmp = parmse.string_length;
8489 705 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8490 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8491 705 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8492 : }
8493 :
8494 795 : if (e && e->expr_type == EXPR_VARIABLE
8495 638 : && fsym->attr.allocatable
8496 368 : && e->ts.u.cl->backend_decl
8497 368 : && VAR_P (e->ts.u.cl->backend_decl))
8498 : {
8499 284 : if (INDIRECT_REF_P (tmp))
8500 0 : tmp = TREE_OPERAND (tmp, 0);
8501 284 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8502 : fold_convert (gfc_charlen_type_node, tmp));
8503 : }
8504 : }
8505 :
8506 : /* Character strings are passed as two parameters, a length and a
8507 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8508 : An unlimited polymorphic formal argument likewise does not
8509 : need the length. */
8510 272131 : if (parmse.string_length != NULL_TREE
8511 37014 : && !sym->attr.is_bind_c
8512 36318 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8513 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8514 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8515 30433 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8516 30324 : && !(fsym && UNLIMITED_POLY (fsym)))
8517 36028 : vec_safe_push (stringargs, parmse.string_length);
8518 :
8519 : /* When calling __copy for character expressions to unlimited
8520 : polymorphic entities, the dst argument needs a string length. */
8521 51936 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8522 5326 : && startswith (sym->name, "__vtab_CHARACTER")
8523 0 : && arg->next && arg->next->expr
8524 0 : && (arg->next->expr->ts.type == BT_DERIVED
8525 0 : || arg->next->expr->ts.type == BT_CLASS)
8526 272131 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8527 0 : vec_safe_push (stringargs, parmse.string_length);
8528 :
8529 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8530 : pass the token and the offset as additional arguments. */
8531 272131 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8532 122 : && attr->codimension && !attr->allocatable)
8533 : {
8534 : /* Token and offset. */
8535 5 : vec_safe_push (stringargs, null_pointer_node);
8536 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8537 5 : gcc_assert (fsym->attr.optional);
8538 : }
8539 239157 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8540 145 : && !attr->allocatable)
8541 : {
8542 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8543 123 : tree offset, tmp2;
8544 :
8545 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8546 123 : caf_type = TREE_TYPE (caf_decl);
8547 123 : if (POINTER_TYPE_P (caf_type)
8548 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8549 3 : caf_desc = TREE_TYPE (caf_type);
8550 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8551 : caf_desc = caf_type;
8552 :
8553 51 : if (caf_desc
8554 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8555 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8556 : {
8557 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8558 54 : ? build_fold_indirect_ref (caf_decl)
8559 : : caf_decl;
8560 51 : tmp = gfc_conv_descriptor_token (tmp);
8561 : }
8562 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8563 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8564 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8565 : else
8566 : {
8567 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8568 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8569 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8570 : }
8571 :
8572 123 : vec_safe_push (stringargs, tmp);
8573 :
8574 123 : if (caf_desc
8575 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8576 51 : offset = build_int_cst (gfc_array_index_type, 0);
8577 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8578 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8579 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8580 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8581 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8582 : else
8583 60 : offset = build_int_cst (gfc_array_index_type, 0);
8584 :
8585 123 : if (caf_desc)
8586 : {
8587 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8588 54 : ? build_fold_indirect_ref (caf_decl)
8589 : : caf_decl;
8590 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8591 : }
8592 : else
8593 : {
8594 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8595 72 : tmp = caf_decl;
8596 : }
8597 :
8598 108 : tmp2 = fsym->ts.type == BT_CLASS
8599 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8600 123 : if ((fsym->ts.type != BT_CLASS
8601 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8602 59 : || fsym->as->type == AS_ASSUMED_RANK))
8603 74 : || (fsym->ts.type == BT_CLASS
8604 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8605 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8606 : {
8607 54 : if (fsym->ts.type == BT_CLASS)
8608 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8609 : else
8610 : {
8611 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8612 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8613 : }
8614 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8615 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8616 : }
8617 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8618 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8619 : else
8620 : {
8621 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8622 : }
8623 :
8624 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8625 : gfc_array_index_type,
8626 : fold_convert (gfc_array_index_type, tmp2),
8627 : fold_convert (gfc_array_index_type, tmp));
8628 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8629 : gfc_array_index_type, offset, tmp);
8630 :
8631 123 : vec_safe_push (stringargs, offset);
8632 : }
8633 :
8634 272131 : vec_safe_push (arglist, parmse.expr);
8635 : }
8636 :
8637 131491 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8638 131491 : gfc_add_block_to_block (&se->pre, &clobbers);
8639 131491 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8640 :
8641 131491 : if (comp)
8642 1994 : ts = comp->ts;
8643 129497 : else if (sym->ts.type == BT_CLASS)
8644 851 : ts = CLASS_DATA (sym)->ts;
8645 : else
8646 128646 : ts = sym->ts;
8647 :
8648 131491 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8649 210 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8650 131281 : else if (ts.type == BT_CHARACTER)
8651 : {
8652 5040 : if (ts.u.cl->length == NULL)
8653 : {
8654 : /* Assumed character length results are not allowed by C418 of the 2003
8655 : standard and are trapped in resolve.cc; except in the case of SPREAD
8656 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8657 : we take the character length of the first argument for the result.
8658 : For dummies, we have to look through the formal argument list for
8659 : this function and use the character length found there.
8660 : Likewise, we handle the case of deferred-length character dummy
8661 : arguments to intrinsics that determine the characteristics of
8662 : the result, which cannot be deferred-length. */
8663 2309 : if (expr->value.function.isym)
8664 1703 : ts.deferred = false;
8665 2309 : if (ts.deferred)
8666 599 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8667 1710 : else if (!sym->attr.dummy)
8668 1703 : cl.backend_decl = (*stringargs)[0];
8669 : else
8670 : {
8671 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8672 26 : for (; formal; formal = formal->next)
8673 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8674 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8675 : }
8676 2309 : len = cl.backend_decl;
8677 : }
8678 : else
8679 : {
8680 2731 : tree tmp;
8681 :
8682 : /* Calculate the length of the returned string. */
8683 2731 : gfc_init_se (&parmse, NULL);
8684 2731 : if (need_interface_mapping)
8685 1885 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8686 : else
8687 846 : gfc_conv_expr (&parmse, ts.u.cl->length);
8688 2731 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8689 2731 : gfc_add_block_to_block (&se->post, &parmse.post);
8690 2731 : tmp = parmse.expr;
8691 : /* TODO: It would be better to have the charlens as
8692 : gfc_charlen_type_node already when the interface is
8693 : created instead of converting it here (see PR 84615). */
8694 2731 : tmp = fold_build2_loc (input_location, MAX_EXPR,
8695 : gfc_charlen_type_node,
8696 : fold_convert (gfc_charlen_type_node, tmp),
8697 : build_zero_cst (gfc_charlen_type_node));
8698 2731 : cl.backend_decl = tmp;
8699 :
8700 : /* The length was fully computed above from the specification
8701 : expression, without needing the callee to actually run. */
8702 2731 : call_needed_for_length = false;
8703 : }
8704 :
8705 : /* Set up a charlen structure for it. */
8706 5040 : cl.next = NULL;
8707 5040 : cl.length = NULL;
8708 5040 : ts.u.cl = &cl;
8709 :
8710 5040 : len = cl.backend_decl;
8711 : }
8712 :
8713 1994 : byref = (comp && (comp->attr.dimension
8714 1925 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
8715 131491 : || (!comp && gfc_return_by_reference (sym));
8716 :
8717 18811 : if (byref)
8718 : {
8719 18811 : if (se->direct_byref)
8720 : {
8721 : /* Sometimes, too much indirection can be applied; e.g. for
8722 : function_result = array_valued_recursive_function. */
8723 6999 : if (TREE_TYPE (TREE_TYPE (se->expr))
8724 6999 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
8725 7017 : && GFC_DESCRIPTOR_TYPE_P
8726 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
8727 18 : se->expr = build_fold_indirect_ref_loc (input_location,
8728 : se->expr);
8729 :
8730 : /* If the lhs of an assignment x = f(..) is allocatable and
8731 : f2003 is allowed, we must do the automatic reallocation.
8732 : TODO - deal with intrinsics, without using a temporary. */
8733 6999 : if (flag_realloc_lhs
8734 6924 : && se->ss && se->ss->loop_chain
8735 203 : && se->ss->loop_chain->is_alloc_lhs
8736 203 : && !expr->value.function.isym
8737 203 : && sym->result->as != NULL)
8738 : {
8739 : /* Evaluate the bounds of the result, if known. */
8740 203 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
8741 : sym->result->as);
8742 :
8743 : /* Perform the automatic reallocation. */
8744 203 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
8745 : expr, NULL);
8746 203 : gfc_add_expr_to_block (&se->pre, tmp);
8747 :
8748 : /* Pass the temporary as the first argument. */
8749 203 : result = info->descriptor;
8750 : }
8751 : else
8752 6796 : result = build_fold_indirect_ref_loc (input_location,
8753 : se->expr);
8754 6999 : vec_safe_push (retargs, se->expr);
8755 : }
8756 11812 : else if (comp && comp->attr.dimension)
8757 : {
8758 66 : gcc_assert (se->loop && info);
8759 :
8760 : /* Set the type of the array. vtable charlens are not always reliable.
8761 : Use the interface, if possible. */
8762 66 : if (comp->ts.type == BT_CHARACTER
8763 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
8764 1 : && comp->ts.interface && comp->ts.interface->result)
8765 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
8766 : else
8767 65 : tmp = gfc_typenode_for_spec (&comp->ts);
8768 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
8769 :
8770 : /* Evaluate the bounds of the result, if known. */
8771 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
8772 :
8773 : /* If the lhs of an assignment x = f(..) is allocatable and
8774 : f2003 is allowed, we must not generate the function call
8775 : here but should just send back the results of the mapping.
8776 : This is signalled by the function ss being flagged. */
8777 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8778 : {
8779 0 : gfc_free_interface_mapping (&mapping);
8780 0 : return has_alternate_specifier;
8781 : }
8782 :
8783 : /* Create a temporary to store the result. In case the function
8784 : returns a pointer, the temporary will be a shallow copy and
8785 : mustn't be deallocated. */
8786 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
8787 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8788 : tmp, NULL_TREE, false,
8789 : !comp->attr.pointer, callee_alloc,
8790 66 : &se->ss->info->expr->where);
8791 :
8792 : /* Pass the temporary as the first argument. */
8793 66 : result = info->descriptor;
8794 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8795 66 : vec_safe_push (retargs, tmp);
8796 : }
8797 11517 : else if (!comp && sym->result->attr.dimension)
8798 : {
8799 8468 : gcc_assert (se->loop && info);
8800 :
8801 : /* Set the type of the array. */
8802 8468 : tmp = gfc_typenode_for_spec (&ts);
8803 8468 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
8804 8468 : gcc_assert (se->ss->dimen == se->loop->dimen);
8805 :
8806 : /* Evaluate the bounds of the result, if known. */
8807 8468 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
8808 :
8809 : /* If the lhs of an assignment x = f(..) is allocatable and
8810 : f2003 is allowed, we must not generate the function call
8811 : here but should just send back the results of the mapping.
8812 : This is signalled by the function ss being flagged. */
8813 8468 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8814 : {
8815 0 : gfc_free_interface_mapping (&mapping);
8816 0 : return has_alternate_specifier;
8817 : }
8818 :
8819 : /* Create a temporary to store the result. In case the function
8820 : returns a pointer, the temporary will be a shallow copy and
8821 : mustn't be deallocated. */
8822 8468 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
8823 8468 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8824 : tmp, NULL_TREE, false,
8825 : !sym->attr.pointer, callee_alloc,
8826 8468 : &se->ss->info->expr->where);
8827 :
8828 : /* Pass the temporary as the first argument. */
8829 8468 : result = info->descriptor;
8830 8468 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8831 8468 : vec_safe_push (retargs, tmp);
8832 : }
8833 3278 : else if (ts.type == BT_CHARACTER)
8834 : {
8835 : /* Pass the string length. */
8836 3217 : type = gfc_get_character_type (ts.kind, ts.u.cl);
8837 3217 : type = build_pointer_type (type);
8838 :
8839 : /* Emit a DECL_EXPR for the VLA type. */
8840 3217 : tmp = TREE_TYPE (type);
8841 3217 : if (TYPE_SIZE (tmp)
8842 3217 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
8843 : {
8844 1929 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
8845 1929 : DECL_ARTIFICIAL (tmp) = 1;
8846 1929 : DECL_IGNORED_P (tmp) = 1;
8847 1929 : tmp = fold_build1_loc (input_location, DECL_EXPR,
8848 1929 : TREE_TYPE (tmp), tmp);
8849 1929 : gfc_add_expr_to_block (&se->pre, tmp);
8850 : }
8851 :
8852 : /* Return an address to a char[0:len-1]* temporary for
8853 : character pointers. */
8854 3217 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8855 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8856 : {
8857 642 : var = gfc_create_var (type, "pstr");
8858 :
8859 642 : if ((!comp && sym->attr.allocatable)
8860 21 : || (comp && comp->attr.allocatable))
8861 : {
8862 355 : gfc_add_modify (&se->pre, var,
8863 355 : fold_convert (TREE_TYPE (var),
8864 : null_pointer_node));
8865 355 : tmp = gfc_call_free (var);
8866 355 : gfc_add_expr_to_block (&se->post, tmp);
8867 : }
8868 :
8869 : /* Provide an address expression for the function arguments. */
8870 642 : var = gfc_build_addr_expr (NULL_TREE, var);
8871 : }
8872 : else
8873 2575 : var = gfc_conv_string_tmp (se, type, len);
8874 :
8875 3217 : vec_safe_push (retargs, var);
8876 : }
8877 : else
8878 : {
8879 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
8880 :
8881 61 : type = gfc_get_complex_type (ts.kind);
8882 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
8883 61 : vec_safe_push (retargs, var);
8884 : }
8885 :
8886 : /* Add the string length to the argument list. */
8887 18811 : if (ts.type == BT_CHARACTER && ts.deferred)
8888 : {
8889 599 : tmp = len;
8890 599 : if (!VAR_P (tmp))
8891 0 : tmp = gfc_evaluate_now (len, &se->pre);
8892 599 : TREE_STATIC (tmp) = 1;
8893 599 : gfc_add_modify (&se->pre, tmp,
8894 599 : build_int_cst (TREE_TYPE (tmp), 0));
8895 599 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8896 599 : vec_safe_push (retargs, tmp);
8897 : }
8898 18212 : else if (ts.type == BT_CHARACTER)
8899 4441 : vec_safe_push (retargs, len);
8900 : }
8901 :
8902 131491 : gfc_free_interface_mapping (&mapping);
8903 :
8904 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
8905 244701 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
8906 156926 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
8907 131491 : vec_safe_reserve (retargs, arglen);
8908 :
8909 : /* Add the return arguments. */
8910 131491 : vec_safe_splice (retargs, arglist);
8911 :
8912 : /* Add the hidden present status for optional+value to the arguments. */
8913 131491 : vec_safe_splice (retargs, optionalargs);
8914 :
8915 : /* Add the hidden string length parameters to the arguments. */
8916 131491 : vec_safe_splice (retargs, stringargs);
8917 :
8918 : /* We may want to append extra arguments here. This is used e.g. for
8919 : calls to libgfortran_matmul_??, which need extra information. */
8920 131491 : vec_safe_splice (retargs, append_args);
8921 :
8922 131491 : arglist = retargs;
8923 :
8924 : /* Generate the actual call. */
8925 131491 : is_builtin = false;
8926 131491 : if (base_object == NULL_TREE)
8927 131411 : conv_function_val (se, &is_builtin, sym, expr, args);
8928 : else
8929 80 : conv_base_obj_fcn_val (se, base_object, expr);
8930 :
8931 : /* If there are alternate return labels, function type should be
8932 : integer. Can't modify the type in place though, since it can be shared
8933 : with other functions. For dummy arguments, the typing is done to
8934 : this result, even if it has to be repeated for each call. */
8935 131491 : if (has_alternate_specifier
8936 131491 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
8937 : {
8938 7 : if (!sym->attr.dummy)
8939 : {
8940 0 : TREE_TYPE (sym->backend_decl)
8941 0 : = build_function_type (integer_type_node,
8942 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
8943 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
8944 : }
8945 : else
8946 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
8947 : }
8948 :
8949 131491 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
8950 131491 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
8951 :
8952 131491 : if (is_builtin)
8953 567 : se->expr = update_builtin_function (se->expr, sym);
8954 :
8955 : /* Allocatable scalar function results must be freed and nullified
8956 : after use. This necessitates the creation of a temporary to
8957 : hold the result to prevent duplicate calls. */
8958 131491 : symbol_attribute attr = comp ? comp->attr : sym->attr;
8959 131491 : bool allocatable = attr.allocatable && !attr.dimension;
8960 134831 : gfc_symbol *der = comp ?
8961 1994 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
8962 : :
8963 129497 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
8964 3340 : bool finalizable = der != NULL && der->ns->proc_name
8965 6677 : && gfc_is_finalizable (der, NULL);
8966 :
8967 131491 : if (!byref && finalizable)
8968 188 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8969 :
8970 131491 : if (!byref && sym->ts.type != BT_CHARACTER
8971 112470 : && allocatable && !finalizable)
8972 : {
8973 236 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
8974 236 : gfc_add_modify (&se->pre, tmp, se->expr);
8975 236 : se->expr = tmp;
8976 236 : tmp = gfc_call_free (tmp);
8977 236 : gfc_add_expr_to_block (&post, tmp);
8978 236 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
8979 : }
8980 :
8981 : /* If we have a pointer function, but we don't want a pointer, e.g.
8982 : something like
8983 : x = f()
8984 : where f is pointer valued, we have to dereference the result. */
8985 131491 : if (!se->want_pointer && !byref
8986 112078 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8987 1652 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
8988 462 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8989 :
8990 : /* f2c calling conventions require a scalar default real function to
8991 : return a double precision result. Convert this back to default
8992 : real. We only care about the cases that can happen in Fortran 77.
8993 : */
8994 131491 : if (flag_f2c && sym->ts.type == BT_REAL
8995 98 : && sym->ts.kind == gfc_default_real_kind
8996 74 : && !sym->attr.pointer
8997 55 : && !sym->attr.allocatable
8998 43 : && !sym->attr.always_explicit)
8999 43 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
9000 :
9001 : /* A pure function may still have side-effects - it may modify its
9002 : parameters. */
9003 131491 : TREE_SIDE_EFFECTS (se->expr) = 1;
9004 : #if 0
9005 : if (!sym->attr.pure)
9006 : TREE_SIDE_EFFECTS (se->expr) = 1;
9007 : #endif
9008 :
9009 131491 : if (byref)
9010 : {
9011 : /* Add the function call to the pre chain. There is no expression. */
9012 18811 : if (!se->no_function_call || call_needed_for_length)
9013 18779 : gfc_add_expr_to_block (&se->pre, se->expr);
9014 :
9015 18811 : se->expr = NULL_TREE;
9016 :
9017 18811 : if (!se->direct_byref)
9018 : {
9019 11812 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
9020 : {
9021 8534 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
9022 : {
9023 : /* Check the data pointer hasn't been modified. This would
9024 : happen in a function returning a pointer. */
9025 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9026 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
9027 : logical_type_node,
9028 : tmp, info->data);
9029 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
9030 : gfc_msg_fault);
9031 : }
9032 8534 : se->expr = info->descriptor;
9033 : /* Bundle in the string length. */
9034 8534 : se->string_length = len;
9035 :
9036 8534 : if (finalizable)
9037 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9038 : }
9039 3278 : else if (ts.type == BT_CHARACTER)
9040 : {
9041 : /* Dereference for character pointer results. */
9042 3217 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9043 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9044 642 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9045 : else
9046 2575 : se->expr = var;
9047 :
9048 3217 : se->string_length = len;
9049 : }
9050 : else
9051 : {
9052 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
9053 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9054 : }
9055 : }
9056 : }
9057 :
9058 : /* Associate the rhs class object's meta-data with the result, when the
9059 : result is a temporary. */
9060 113215 : if (args && args->expr && args->expr->ts.type == BT_CLASS
9061 5003 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
9062 131523 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
9063 : {
9064 32 : gfc_se parmse;
9065 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
9066 :
9067 32 : gfc_init_se (&parmse, NULL);
9068 32 : parmse.data_not_needed = 1;
9069 32 : gfc_conv_expr (&parmse, class_expr);
9070 32 : if (!DECL_LANG_SPECIFIC (result))
9071 32 : gfc_allocate_lang_decl (result);
9072 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
9073 32 : gfc_free_expr (class_expr);
9074 : /* -fcheck= can add diagnostic code, which has to be placed before
9075 : the call. */
9076 32 : if (parmse.pre.head != NULL)
9077 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
9078 32 : gcc_assert (parmse.post.head == NULL_TREE);
9079 : }
9080 :
9081 : /* Follow the function call with the argument post block. */
9082 131491 : if (byref)
9083 : {
9084 : /* Transformational functions of derived types with allocatable
9085 : components must have the result allocatable components copied
9086 : BEFORE the argument post block is appended. Copying the result
9087 : first, then freeing the argument, gives the correct order. */
9088 18811 : arg = expr->value.function.actual;
9089 18811 : if (result && arg && expr->rank
9090 14686 : && isym && isym->transformational
9091 13105 : && isym->id != GFC_ISYM_REDUCE
9092 12979 : && arg->expr
9093 12919 : && arg->expr->ts.type == BT_DERIVED
9094 241 : && arg->expr->ts.u.derived->attr.alloc_comp)
9095 : {
9096 48 : tree tmp2;
9097 : /* Copy the allocatable components. We have to use a
9098 : temporary here to prevent source allocatable components
9099 : from being corrupted. */
9100 48 : tmp2 = gfc_evaluate_now (result, &se->pre);
9101 48 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
9102 : result, tmp2, expr->rank, 0);
9103 48 : gfc_add_expr_to_block (&se->pre, tmp);
9104 48 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
9105 : expr->rank);
9106 48 : gfc_add_expr_to_block (&se->pre, tmp);
9107 :
9108 : /* Finally free the temporary's data field. */
9109 48 : tmp = gfc_conv_descriptor_data_get (tmp2);
9110 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9111 : NULL_TREE, NULL_TREE, true,
9112 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9113 48 : gfc_add_expr_to_block (&se->pre, tmp);
9114 : }
9115 :
9116 18811 : gfc_add_block_to_block (&se->pre, &post);
9117 : }
9118 : else
9119 : {
9120 : /* For a function with a class array result, save the result as
9121 : a temporary, set the info fields needed by the scalarizer and
9122 : call the finalization function of the temporary. Note that the
9123 : nullification of allocatable components needed by the result
9124 : is done in gfc_trans_assignment_1. */
9125 35295 : if (expr && (gfc_is_class_array_function (expr)
9126 34973 : || gfc_is_alloc_class_scalar_function (expr))
9127 841 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9128 113509 : && expr->must_finalize)
9129 : {
9130 : /* TODO Eliminate the doubling of temporaries. This
9131 : one is necessary to ensure no memory leakage. */
9132 321 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9133 :
9134 : /* Finalize the result, if necessary. */
9135 642 : attr = expr->value.function.esym
9136 321 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9137 14 : : CLASS_DATA (expr)->attr;
9138 321 : if (!((gfc_is_class_array_function (expr)
9139 108 : || gfc_is_alloc_class_scalar_function (expr))
9140 321 : && attr.pointer))
9141 276 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9142 : }
9143 112680 : gfc_add_block_to_block (&se->post, &post);
9144 : }
9145 :
9146 : return has_alternate_specifier;
9147 : }
9148 :
9149 :
9150 : /* Fill a character string with spaces. */
9151 :
9152 : static tree
9153 30783 : fill_with_spaces (tree start, tree type, tree size)
9154 : {
9155 30783 : stmtblock_t block, loop;
9156 30783 : tree i, el, exit_label, cond, tmp;
9157 :
9158 : /* For a simple char type, we can call memset(). */
9159 30783 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9160 50978 : return build_call_expr_loc (input_location,
9161 : builtin_decl_explicit (BUILT_IN_MEMSET),
9162 : 3, start,
9163 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9164 25489 : lang_hooks.to_target_charset (' ')),
9165 : fold_convert (size_type_node, size));
9166 :
9167 : /* Otherwise, we use a loop:
9168 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9169 : *el = (type) ' ';
9170 : */
9171 :
9172 : /* Initialize variables. */
9173 5294 : gfc_init_block (&block);
9174 5294 : i = gfc_create_var (sizetype, "i");
9175 5294 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9176 5294 : el = gfc_create_var (build_pointer_type (type), "el");
9177 5294 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9178 5294 : exit_label = gfc_build_label_decl (NULL_TREE);
9179 5294 : TREE_USED (exit_label) = 1;
9180 :
9181 :
9182 : /* Loop body. */
9183 5294 : gfc_init_block (&loop);
9184 :
9185 : /* Exit condition. */
9186 5294 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9187 : build_zero_cst (sizetype));
9188 5294 : tmp = build1_v (GOTO_EXPR, exit_label);
9189 5294 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9190 : build_empty_stmt (input_location));
9191 5294 : gfc_add_expr_to_block (&loop, tmp);
9192 :
9193 : /* Assignment. */
9194 5294 : gfc_add_modify (&loop,
9195 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9196 5294 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9197 :
9198 : /* Increment loop variables. */
9199 5294 : gfc_add_modify (&loop, i,
9200 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9201 5294 : TYPE_SIZE_UNIT (type)));
9202 5294 : gfc_add_modify (&loop, el,
9203 : fold_build_pointer_plus_loc (input_location,
9204 5294 : el, TYPE_SIZE_UNIT (type)));
9205 :
9206 : /* Making the loop... actually loop! */
9207 5294 : tmp = gfc_finish_block (&loop);
9208 5294 : tmp = build1_v (LOOP_EXPR, tmp);
9209 5294 : gfc_add_expr_to_block (&block, tmp);
9210 :
9211 : /* The exit label. */
9212 5294 : tmp = build1_v (LABEL_EXPR, exit_label);
9213 5294 : gfc_add_expr_to_block (&block, tmp);
9214 :
9215 :
9216 5294 : return gfc_finish_block (&block);
9217 : }
9218 :
9219 :
9220 : /* Generate code to copy a string. */
9221 :
9222 : void
9223 35950 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9224 : int dkind, tree slength, tree src, int skind)
9225 : {
9226 35950 : tree tmp, dlen, slen;
9227 35950 : tree dsc;
9228 35950 : tree ssc;
9229 35950 : tree cond;
9230 35950 : tree cond2;
9231 35950 : tree tmp2;
9232 35950 : tree tmp3;
9233 35950 : tree tmp4;
9234 35950 : tree chartype;
9235 35950 : stmtblock_t tempblock;
9236 :
9237 35950 : gcc_assert (dkind == skind);
9238 :
9239 35950 : if (slength != NULL_TREE)
9240 : {
9241 35950 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9242 35950 : ssc = gfc_string_to_single_character (slen, src, skind);
9243 : }
9244 : else
9245 : {
9246 0 : slen = build_one_cst (gfc_charlen_type_node);
9247 0 : ssc = src;
9248 : }
9249 :
9250 35950 : if (dlength != NULL_TREE)
9251 : {
9252 35950 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9253 35950 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9254 : }
9255 : else
9256 : {
9257 0 : dlen = build_one_cst (gfc_charlen_type_node);
9258 0 : dsc = dest;
9259 : }
9260 :
9261 : /* Assign directly if the types are compatible. */
9262 35950 : if (dsc != NULL_TREE && ssc != NULL_TREE
9263 35950 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9264 : {
9265 5167 : gfc_add_modify (block, dsc, ssc);
9266 5167 : return;
9267 : }
9268 :
9269 : /* The string copy algorithm below generates code like
9270 :
9271 : if (destlen > 0)
9272 : {
9273 : if (srclen < destlen)
9274 : {
9275 : memmove (dest, src, srclen);
9276 : // Pad with spaces.
9277 : memset (&dest[srclen], ' ', destlen - srclen);
9278 : }
9279 : else
9280 : {
9281 : // Truncate if too long.
9282 : memmove (dest, src, destlen);
9283 : }
9284 : }
9285 : */
9286 :
9287 : /* Do nothing if the destination length is zero. */
9288 30783 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9289 30783 : build_zero_cst (TREE_TYPE (dlen)));
9290 :
9291 : /* For non-default character kinds, we have to multiply the string
9292 : length by the base type size. */
9293 30783 : chartype = gfc_get_char_type (dkind);
9294 30783 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9295 : slen,
9296 30783 : fold_convert (TREE_TYPE (slen),
9297 : TYPE_SIZE_UNIT (chartype)));
9298 30783 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9299 : dlen,
9300 30783 : fold_convert (TREE_TYPE (dlen),
9301 : TYPE_SIZE_UNIT (chartype)));
9302 :
9303 30783 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9304 30735 : dest = fold_convert (pvoid_type_node, dest);
9305 : else
9306 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9307 :
9308 30783 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9309 30779 : src = fold_convert (pvoid_type_node, src);
9310 : else
9311 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9312 :
9313 : /* Truncate string if source is too long. */
9314 30783 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9315 : dlen);
9316 :
9317 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9318 30783 : if (!CONSTANT_CLASS_P (cond2))
9319 : {
9320 9397 : dest = gfc_evaluate_now (dest, block);
9321 9397 : src = gfc_evaluate_now (src, block);
9322 : }
9323 :
9324 : /* Copy and pad with spaces. */
9325 30783 : tmp3 = build_call_expr_loc (input_location,
9326 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9327 : 3, dest, src,
9328 : fold_convert (size_type_node, slen));
9329 :
9330 : /* Wstringop-overflow appears at -O3 even though this warning is not
9331 : explicitly available in fortran nor can it be switched off. If the
9332 : source length is a constant, its negative appears as a very large
9333 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9334 : the result of the MINUS_EXPR suppresses this spurious warning. */
9335 30783 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9336 30783 : TREE_TYPE(dlen), dlen, slen);
9337 30783 : if (slength && TREE_CONSTANT (slength))
9338 27246 : tmp = gfc_evaluate_now (tmp, block);
9339 :
9340 30783 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9341 30783 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9342 :
9343 30783 : gfc_init_block (&tempblock);
9344 30783 : gfc_add_expr_to_block (&tempblock, tmp3);
9345 30783 : gfc_add_expr_to_block (&tempblock, tmp4);
9346 30783 : tmp3 = gfc_finish_block (&tempblock);
9347 :
9348 : /* The truncated memmove if the slen >= dlen. */
9349 30783 : tmp2 = build_call_expr_loc (input_location,
9350 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9351 : 3, dest, src,
9352 : fold_convert (size_type_node, dlen));
9353 :
9354 : /* The whole copy_string function is there. */
9355 30783 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9356 : tmp3, tmp2);
9357 30783 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9358 : build_empty_stmt (input_location));
9359 30783 : gfc_add_expr_to_block (block, tmp);
9360 : }
9361 :
9362 :
9363 : /* Translate a statement function.
9364 : The value of a statement function reference is obtained by evaluating the
9365 : expression using the values of the actual arguments for the values of the
9366 : corresponding dummy arguments. */
9367 :
9368 : static void
9369 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9370 : {
9371 269 : gfc_symbol *sym;
9372 269 : gfc_symbol *fsym;
9373 269 : gfc_formal_arglist *fargs;
9374 269 : gfc_actual_arglist *args;
9375 269 : gfc_se lse;
9376 269 : gfc_se rse;
9377 269 : gfc_saved_var *saved_vars;
9378 269 : tree *temp_vars;
9379 269 : tree type;
9380 269 : tree tmp;
9381 269 : int n;
9382 :
9383 269 : sym = expr->symtree->n.sym;
9384 269 : args = expr->value.function.actual;
9385 269 : gfc_init_se (&lse, NULL);
9386 269 : gfc_init_se (&rse, NULL);
9387 :
9388 269 : n = 0;
9389 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9390 458 : n++;
9391 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9392 269 : temp_vars = XCNEWVEC (tree, n);
9393 :
9394 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9395 458 : fargs = fargs->next, n++)
9396 : {
9397 : /* Each dummy shall be specified, explicitly or implicitly, to be
9398 : scalar. */
9399 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9400 458 : fsym = fargs->sym;
9401 :
9402 458 : if (fsym->ts.type == BT_CHARACTER)
9403 : {
9404 : /* Copy string arguments. */
9405 48 : tree arglen;
9406 :
9407 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9408 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9409 :
9410 : /* Create a temporary to hold the value. */
9411 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9412 1 : fsym->ts.u.cl->backend_decl
9413 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9414 :
9415 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9416 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9417 :
9418 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9419 :
9420 48 : gfc_conv_expr (&rse, args->expr);
9421 48 : gfc_conv_string_parameter (&rse);
9422 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9423 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9424 :
9425 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9426 : rse.string_length, rse.expr, fsym->ts.kind);
9427 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9428 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9429 : }
9430 : else
9431 : {
9432 : /* For everything else, just evaluate the expression. */
9433 :
9434 : /* Create a temporary to hold the value. */
9435 410 : type = gfc_typenode_for_spec (&fsym->ts);
9436 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9437 :
9438 410 : gfc_conv_expr (&lse, args->expr);
9439 :
9440 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9441 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9442 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9443 : }
9444 :
9445 458 : args = args->next;
9446 : }
9447 :
9448 : /* Use the temporary variables in place of the real ones. */
9449 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9450 458 : fargs = fargs->next, n++)
9451 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9452 :
9453 269 : gfc_conv_expr (se, sym->value);
9454 :
9455 269 : if (sym->ts.type == BT_CHARACTER)
9456 : {
9457 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9458 :
9459 : /* Force the expression to the correct length. */
9460 55 : if (!INTEGER_CST_P (se->string_length)
9461 101 : || tree_int_cst_lt (se->string_length,
9462 46 : sym->ts.u.cl->backend_decl))
9463 : {
9464 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9465 31 : tmp = gfc_create_var (type, sym->name);
9466 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9467 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9468 : sym->ts.kind, se->string_length, se->expr,
9469 : sym->ts.kind);
9470 31 : se->expr = tmp;
9471 : }
9472 55 : se->string_length = sym->ts.u.cl->backend_decl;
9473 : }
9474 :
9475 : /* Restore the original variables. */
9476 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9477 458 : fargs = fargs->next, n++)
9478 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9479 269 : free (temp_vars);
9480 269 : free (saved_vars);
9481 269 : }
9482 :
9483 :
9484 : /* Translate a function expression. */
9485 :
9486 : static void
9487 314333 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9488 : {
9489 314333 : gfc_symbol *sym;
9490 :
9491 314333 : if (expr->value.function.isym)
9492 : {
9493 263232 : gfc_conv_intrinsic_function (se, expr);
9494 263232 : return;
9495 : }
9496 :
9497 : /* expr.value.function.esym is the resolved (specific) function symbol for
9498 : most functions. However this isn't set for dummy procedures. */
9499 51101 : sym = expr->value.function.esym;
9500 51101 : if (!sym)
9501 1630 : sym = expr->symtree->n.sym;
9502 :
9503 : /* The IEEE_ARITHMETIC functions are caught here. */
9504 51101 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9505 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9506 : return;
9507 :
9508 : /* We distinguish statement functions from general functions to improve
9509 : runtime performance. */
9510 38644 : if (sym->attr.proc == PROC_ST_FUNCTION)
9511 : {
9512 269 : gfc_conv_statement_function (se, expr);
9513 269 : return;
9514 : }
9515 :
9516 38375 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9517 : NULL);
9518 : }
9519 :
9520 :
9521 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9522 :
9523 : static bool
9524 39942 : is_zero_initializer_p (gfc_expr * expr)
9525 : {
9526 39942 : if (expr->expr_type != EXPR_CONSTANT)
9527 : return false;
9528 :
9529 : /* We ignore constants with prescribed memory representations for now. */
9530 11429 : if (expr->representation.string)
9531 : return false;
9532 :
9533 11411 : switch (expr->ts.type)
9534 : {
9535 5278 : case BT_INTEGER:
9536 5278 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9537 :
9538 4825 : case BT_REAL:
9539 4825 : return mpfr_zero_p (expr->value.real)
9540 4825 : && MPFR_SIGN (expr->value.real) >= 0;
9541 :
9542 931 : case BT_LOGICAL:
9543 931 : return expr->value.logical == 0;
9544 :
9545 243 : case BT_COMPLEX:
9546 243 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9547 155 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9548 155 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9549 386 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9550 :
9551 : default:
9552 : break;
9553 : }
9554 : return false;
9555 : }
9556 :
9557 :
9558 : static void
9559 35956 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9560 : {
9561 35956 : gfc_ss *ss;
9562 :
9563 35956 : ss = se->ss;
9564 35956 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9565 35956 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9566 :
9567 35956 : gfc_conv_tmp_array_ref (se);
9568 35956 : }
9569 :
9570 :
9571 : /* Build a static initializer. EXPR is the expression for the initial value.
9572 : The other parameters describe the variable of the component being
9573 : initialized. EXPR may be null. */
9574 :
9575 : tree
9576 134830 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9577 : bool array, bool pointer, bool procptr)
9578 : {
9579 134830 : gfc_se se;
9580 :
9581 134830 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9582 41932 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9583 171 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9584 59 : return build_constructor (type, NULL);
9585 :
9586 134771 : if (!(expr || pointer || procptr))
9587 : return NULL_TREE;
9588 :
9589 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9590 : (these are the only two iso_c_binding derived types that can be
9591 : used as initialization expressions). If so, we need to modify
9592 : the 'expr' to be that for a (void *). */
9593 126478 : if (expr != NULL && expr->ts.type == BT_DERIVED
9594 37795 : && expr->ts.is_iso_c && expr->ts.u.derived)
9595 : {
9596 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9597 4 : return build_constructor (type, NULL);
9598 182 : else if (POINTER_TYPE_P (type))
9599 182 : return build_int_cst (type, 0);
9600 : else
9601 0 : gcc_unreachable ();
9602 : }
9603 :
9604 126292 : if (array && !procptr)
9605 : {
9606 8771 : tree ctor;
9607 : /* Arrays need special handling. */
9608 8771 : if (pointer)
9609 779 : ctor = gfc_build_null_descriptor (type);
9610 : /* Special case assigning an array to zero. */
9611 7992 : else if (is_zero_initializer_p (expr))
9612 220 : ctor = build_constructor (type, NULL);
9613 : else
9614 7772 : ctor = gfc_conv_array_initializer (type, expr);
9615 8771 : TREE_STATIC (ctor) = 1;
9616 8771 : return ctor;
9617 : }
9618 117521 : else if (pointer || procptr)
9619 : {
9620 54706 : if (ts->type == BT_CLASS && !procptr)
9621 : {
9622 1762 : gfc_init_se (&se, NULL);
9623 1762 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9624 1762 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9625 1762 : TREE_STATIC (se.expr) = 1;
9626 1762 : return se.expr;
9627 : }
9628 52944 : else if (!expr || expr->expr_type == EXPR_NULL)
9629 28149 : return fold_convert (type, null_pointer_node);
9630 : else
9631 : {
9632 24795 : gfc_init_se (&se, NULL);
9633 24795 : se.want_pointer = 1;
9634 24795 : gfc_conv_expr (&se, expr);
9635 24795 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9636 : return se.expr;
9637 : }
9638 : }
9639 : else
9640 : {
9641 62815 : switch (ts->type)
9642 : {
9643 18180 : case_bt_struct:
9644 18180 : case BT_CLASS:
9645 18180 : gfc_init_se (&se, NULL);
9646 18180 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9647 779 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9648 : else
9649 17401 : gfc_conv_structure (&se, expr, 1);
9650 18180 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9651 18180 : TREE_STATIC (se.expr) = 1;
9652 18180 : return se.expr;
9653 :
9654 2705 : case BT_CHARACTER:
9655 2705 : if (expr->expr_type == EXPR_CONSTANT)
9656 : {
9657 2704 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9658 2704 : TREE_STATIC (ctor) = 1;
9659 2704 : return ctor;
9660 : }
9661 :
9662 : /* Fallthrough. */
9663 41931 : default:
9664 41931 : gfc_init_se (&se, NULL);
9665 41931 : gfc_conv_constant (&se, expr);
9666 41931 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9667 : return se.expr;
9668 : }
9669 : }
9670 : }
9671 :
9672 : static tree
9673 956 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9674 : {
9675 956 : gfc_se rse;
9676 956 : gfc_se lse;
9677 956 : gfc_ss *rss;
9678 956 : gfc_ss *lss;
9679 956 : gfc_array_info *lss_array;
9680 956 : stmtblock_t body;
9681 956 : stmtblock_t block;
9682 956 : gfc_loopinfo loop;
9683 956 : int n;
9684 956 : tree tmp;
9685 :
9686 956 : gfc_start_block (&block);
9687 :
9688 : /* Initialize the scalarizer. */
9689 956 : gfc_init_loopinfo (&loop);
9690 :
9691 956 : gfc_init_se (&lse, NULL);
9692 956 : gfc_init_se (&rse, NULL);
9693 :
9694 : /* Walk the rhs. */
9695 956 : rss = gfc_walk_expr (expr);
9696 956 : if (rss == gfc_ss_terminator)
9697 : /* The rhs is scalar. Add a ss for the expression. */
9698 208 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
9699 :
9700 : /* Create a SS for the destination. */
9701 956 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
9702 : GFC_SS_COMPONENT);
9703 956 : lss_array = &lss->info->data.array;
9704 956 : lss_array->shape = gfc_get_shape (cm->as->rank);
9705 956 : lss_array->descriptor = dest;
9706 956 : lss_array->data = gfc_conv_array_data (dest);
9707 956 : lss_array->offset = gfc_conv_array_offset (dest);
9708 1969 : for (n = 0; n < cm->as->rank; n++)
9709 : {
9710 1013 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
9711 1013 : lss_array->stride[n] = gfc_index_one_node;
9712 :
9713 1013 : mpz_init (lss_array->shape[n]);
9714 1013 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
9715 1013 : cm->as->lower[n]->value.integer);
9716 1013 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
9717 : }
9718 :
9719 : /* Associate the SS with the loop. */
9720 956 : gfc_add_ss_to_loop (&loop, lss);
9721 956 : gfc_add_ss_to_loop (&loop, rss);
9722 :
9723 : /* Calculate the bounds of the scalarization. */
9724 956 : gfc_conv_ss_startstride (&loop);
9725 :
9726 : /* Setup the scalarizing loops. */
9727 956 : gfc_conv_loop_setup (&loop, &expr->where);
9728 :
9729 : /* Setup the gfc_se structures. */
9730 956 : gfc_copy_loopinfo_to_se (&lse, &loop);
9731 956 : gfc_copy_loopinfo_to_se (&rse, &loop);
9732 :
9733 956 : rse.ss = rss;
9734 956 : gfc_mark_ss_chain_used (rss, 1);
9735 956 : lse.ss = lss;
9736 956 : gfc_mark_ss_chain_used (lss, 1);
9737 :
9738 : /* Start the scalarized loop body. */
9739 956 : gfc_start_scalarized_body (&loop, &body);
9740 :
9741 956 : gfc_conv_tmp_array_ref (&lse);
9742 956 : if (cm->ts.type == BT_CHARACTER)
9743 176 : lse.string_length = cm->ts.u.cl->backend_decl;
9744 :
9745 956 : gfc_conv_expr (&rse, expr);
9746 :
9747 956 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
9748 956 : gfc_add_expr_to_block (&body, tmp);
9749 :
9750 956 : gcc_assert (rse.ss == gfc_ss_terminator);
9751 :
9752 : /* Generate the copying loops. */
9753 956 : gfc_trans_scalarizing_loops (&loop, &body);
9754 :
9755 : /* Wrap the whole thing up. */
9756 956 : gfc_add_block_to_block (&block, &loop.pre);
9757 956 : gfc_add_block_to_block (&block, &loop.post);
9758 :
9759 956 : gcc_assert (lss_array->shape != NULL);
9760 956 : gfc_free_shape (&lss_array->shape, cm->as->rank);
9761 956 : gfc_cleanup_loop (&loop);
9762 :
9763 956 : return gfc_finish_block (&block);
9764 : }
9765 :
9766 :
9767 : static stmtblock_t *final_block;
9768 : static tree
9769 1312 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
9770 : gfc_expr * expr)
9771 : {
9772 1312 : gfc_se se;
9773 1312 : stmtblock_t block;
9774 1312 : tree offset;
9775 1312 : int n;
9776 1312 : tree tmp;
9777 1312 : tree tmp2;
9778 1312 : gfc_array_spec *as;
9779 1312 : gfc_expr *arg = NULL;
9780 :
9781 1312 : gfc_start_block (&block);
9782 1312 : gfc_init_se (&se, NULL);
9783 :
9784 : /* Get the descriptor for the expressions. */
9785 1312 : se.want_pointer = 0;
9786 1312 : gfc_conv_expr_descriptor (&se, expr);
9787 1312 : gfc_add_block_to_block (&block, &se.pre);
9788 1312 : gfc_add_modify (&block, dest, se.expr);
9789 1312 : if (cm->ts.type == BT_CHARACTER
9790 1312 : && gfc_deferred_strlen (cm, &tmp))
9791 : {
9792 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
9793 30 : TREE_TYPE (tmp),
9794 30 : TREE_OPERAND (dest, 0),
9795 : tmp, NULL_TREE);
9796 30 : gfc_add_modify (&block, tmp,
9797 30 : fold_convert (TREE_TYPE (tmp),
9798 : se.string_length));
9799 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
9800 : "slen");
9801 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
9802 : }
9803 :
9804 : /* Deal with arrays of derived types with allocatable components. */
9805 1312 : if (gfc_bt_struct (cm->ts.type)
9806 199 : && cm->ts.u.derived->attr.alloc_comp)
9807 : // TODO: Fix caf_mode
9808 113 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
9809 : se.expr, dest,
9810 113 : cm->as->rank, 0);
9811 1199 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
9812 36 : && CLASS_DATA(cm)->attr.allocatable)
9813 : {
9814 36 : if (cm->ts.u.derived->attr.alloc_comp)
9815 : // TODO: Fix caf_mode
9816 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
9817 : se.expr, dest,
9818 : expr->rank, 0);
9819 : else
9820 : {
9821 36 : tmp = TREE_TYPE (dest);
9822 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9823 : tmp, expr->rank, NULL_TREE);
9824 : }
9825 : }
9826 1163 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9827 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9828 : gfc_typenode_for_spec (&cm->ts),
9829 30 : cm->as->rank, NULL_TREE);
9830 : else
9831 1133 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9832 1133 : TREE_TYPE(cm->backend_decl),
9833 1133 : cm->as->rank, NULL_TREE);
9834 :
9835 :
9836 1312 : gfc_add_expr_to_block (&block, tmp);
9837 1312 : gfc_add_block_to_block (&block, &se.post);
9838 :
9839 1312 : if (final_block && !cm->attr.allocatable
9840 96 : && expr->expr_type == EXPR_ARRAY)
9841 : {
9842 96 : tree data_ptr;
9843 96 : data_ptr = gfc_conv_descriptor_data_get (dest);
9844 96 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
9845 96 : }
9846 1216 : else if (final_block && cm->attr.allocatable)
9847 162 : gfc_add_block_to_block (final_block, &se.finalblock);
9848 :
9849 1312 : if (expr->expr_type != EXPR_VARIABLE)
9850 : {
9851 1191 : if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp)
9852 : {
9853 214 : tmp = gfc_deallocate_alloc_comp_no_caf (cm->ts.u.derived,
9854 107 : se.expr, cm->as->rank, true);
9855 107 : gfc_add_expr_to_block (&block, tmp);
9856 : }
9857 1191 : gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
9858 : }
9859 :
9860 : /* We need to know if the argument of a conversion function is a
9861 : variable, so that the correct lower bound can be used. */
9862 1312 : if (expr->expr_type == EXPR_FUNCTION
9863 68 : && expr->value.function.isym
9864 56 : && expr->value.function.isym->conversion
9865 56 : && expr->value.function.actual->expr
9866 56 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
9867 56 : arg = expr->value.function.actual->expr;
9868 :
9869 : /* Obtain the array spec of full array references. */
9870 56 : if (arg)
9871 56 : as = gfc_get_full_arrayspec_from_expr (arg);
9872 : else
9873 1256 : as = gfc_get_full_arrayspec_from_expr (expr);
9874 :
9875 : /* Shift the lbound and ubound of temporaries to being unity,
9876 : rather than zero, based. Always calculate the offset. */
9877 1312 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
9878 1312 : offset = gfc_conv_descriptor_offset_get (dest);
9879 1312 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
9880 :
9881 2680 : for (n = 0; n < expr->rank; n++)
9882 : {
9883 1368 : tree span;
9884 1368 : tree lbound;
9885 :
9886 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
9887 : TODO It looks as if gfc_conv_expr_descriptor should return
9888 : the correct bounds and that the following should not be
9889 : necessary. This would simplify gfc_conv_intrinsic_bound
9890 : as well. */
9891 1368 : if (as && as->lower[n])
9892 : {
9893 92 : gfc_se lbse;
9894 92 : gfc_init_se (&lbse, NULL);
9895 92 : gfc_conv_expr (&lbse, as->lower[n]);
9896 92 : gfc_add_block_to_block (&block, &lbse.pre);
9897 92 : lbound = gfc_evaluate_now (lbse.expr, &block);
9898 92 : }
9899 1276 : else if (as && arg)
9900 : {
9901 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
9902 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
9903 : gfc_rank_cst[n]);
9904 : }
9905 1242 : else if (as)
9906 64 : lbound = gfc_conv_descriptor_lbound_get (dest,
9907 : gfc_rank_cst[n]);
9908 : else
9909 1178 : lbound = gfc_index_one_node;
9910 :
9911 1368 : lbound = fold_convert (gfc_array_index_type, lbound);
9912 :
9913 : /* Shift the bounds and set the offset accordingly. */
9914 1368 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
9915 1368 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9916 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
9917 1368 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9918 : span, lbound);
9919 1368 : gfc_conv_descriptor_ubound_set (&block, dest,
9920 : gfc_rank_cst[n], tmp);
9921 1368 : gfc_conv_descriptor_lbound_set (&block, dest,
9922 : gfc_rank_cst[n], lbound);
9923 :
9924 1368 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9925 : gfc_conv_descriptor_lbound_get (dest,
9926 : gfc_rank_cst[n]),
9927 : gfc_conv_descriptor_stride_get (dest,
9928 : gfc_rank_cst[n]));
9929 1368 : gfc_add_modify (&block, tmp2, tmp);
9930 1368 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9931 : offset, tmp2);
9932 1368 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
9933 : }
9934 :
9935 1312 : if (arg)
9936 : {
9937 : /* If a conversion expression has a null data pointer
9938 : argument, nullify the allocatable component. */
9939 56 : tree non_null_expr;
9940 56 : tree null_expr;
9941 :
9942 56 : if (arg->symtree->n.sym->attr.allocatable
9943 24 : || arg->symtree->n.sym->attr.pointer)
9944 : {
9945 32 : non_null_expr = gfc_finish_block (&block);
9946 32 : gfc_start_block (&block);
9947 32 : gfc_conv_descriptor_data_set (&block, dest,
9948 : null_pointer_node);
9949 32 : null_expr = gfc_finish_block (&block);
9950 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
9951 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
9952 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9953 32 : return build3_v (COND_EXPR, tmp,
9954 : null_expr, non_null_expr);
9955 : }
9956 : }
9957 :
9958 1280 : return gfc_finish_block (&block);
9959 : }
9960 :
9961 :
9962 : /* Allocate or reallocate scalar component, as necessary. */
9963 :
9964 : static void
9965 416 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
9966 : gfc_component *cm, gfc_expr *expr2,
9967 : tree slen)
9968 : {
9969 416 : tree tmp;
9970 416 : tree ptr;
9971 416 : tree size;
9972 416 : tree size_in_bytes;
9973 416 : tree lhs_cl_size = NULL_TREE;
9974 416 : gfc_se se;
9975 :
9976 416 : if (!comp)
9977 0 : return;
9978 :
9979 416 : if (!expr2 || expr2->rank)
9980 : return;
9981 :
9982 416 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9983 :
9984 416 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9985 : {
9986 145 : gcc_assert (expr2->ts.type == BT_CHARACTER);
9987 145 : size = expr2->ts.u.cl->backend_decl;
9988 145 : if (!size || !VAR_P (size))
9989 145 : size = gfc_create_var (TREE_TYPE (slen), "slen");
9990 145 : gfc_add_modify (block, size, slen);
9991 :
9992 145 : gfc_deferred_strlen (cm, &tmp);
9993 145 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
9994 : gfc_charlen_type_node,
9995 145 : TREE_OPERAND (comp, 0),
9996 : tmp, NULL_TREE);
9997 :
9998 145 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
9999 145 : tmp = TYPE_SIZE_UNIT (tmp);
10000 290 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10001 145 : TREE_TYPE (tmp), tmp,
10002 145 : fold_convert (TREE_TYPE (tmp), size));
10003 : }
10004 271 : else if (cm->ts.type == BT_CLASS)
10005 : {
10006 103 : if (expr2->ts.type != BT_CLASS)
10007 : {
10008 103 : if (expr2->ts.type == BT_CHARACTER)
10009 : {
10010 24 : gfc_init_se (&se, NULL);
10011 24 : gfc_conv_expr (&se, expr2);
10012 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
10013 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10014 : gfc_charlen_type_node,
10015 : se.string_length, size);
10016 24 : size = fold_convert (size_type_node, size);
10017 : }
10018 : else
10019 : {
10020 79 : if (expr2->ts.type == BT_DERIVED)
10021 48 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
10022 : else
10023 31 : tmp = gfc_typenode_for_spec (&expr2->ts);
10024 79 : size = TYPE_SIZE_UNIT (tmp);
10025 : }
10026 : }
10027 : else
10028 : {
10029 0 : gfc_expr *e2vtab;
10030 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
10031 0 : gfc_add_vptr_component (e2vtab);
10032 0 : gfc_add_size_component (e2vtab);
10033 0 : gfc_init_se (&se, NULL);
10034 0 : gfc_conv_expr (&se, e2vtab);
10035 0 : gfc_add_block_to_block (block, &se.pre);
10036 0 : size = fold_convert (size_type_node, se.expr);
10037 0 : gfc_free_expr (e2vtab);
10038 : }
10039 : size_in_bytes = size;
10040 : }
10041 : else
10042 : {
10043 : /* Otherwise use the length in bytes of the rhs. */
10044 168 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
10045 168 : size_in_bytes = size;
10046 : }
10047 :
10048 416 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10049 : size_in_bytes, size_one_node);
10050 :
10051 416 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
10052 : {
10053 0 : tmp = build_call_expr_loc (input_location,
10054 : builtin_decl_explicit (BUILT_IN_CALLOC),
10055 : 2, build_one_cst (size_type_node),
10056 : size_in_bytes);
10057 0 : tmp = fold_convert (TREE_TYPE (comp), tmp);
10058 0 : gfc_add_modify (block, comp, tmp);
10059 : }
10060 : else
10061 : {
10062 416 : tmp = build_call_expr_loc (input_location,
10063 : builtin_decl_explicit (BUILT_IN_MALLOC),
10064 : 1, size_in_bytes);
10065 416 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
10066 103 : ptr = gfc_class_data_get (comp);
10067 : else
10068 : ptr = comp;
10069 416 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
10070 416 : gfc_add_modify (block, ptr, tmp);
10071 : }
10072 :
10073 416 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10074 : /* Update the lhs character length. */
10075 145 : gfc_add_modify (block, lhs_cl_size,
10076 145 : fold_convert (TREE_TYPE (lhs_cl_size), size));
10077 : }
10078 :
10079 :
10080 : /* Assign a single component of a derived type constructor. */
10081 :
10082 : static tree
10083 29444 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
10084 : gfc_expr * expr, bool init)
10085 : {
10086 29444 : gfc_se se;
10087 29444 : gfc_se lse;
10088 29444 : stmtblock_t block;
10089 29444 : tree tmp;
10090 29444 : tree vtab;
10091 :
10092 29444 : gfc_start_block (&block);
10093 :
10094 29444 : if (cm->attr.pointer || cm->attr.proc_pointer)
10095 : {
10096 : /* Only care about pointers here, not about allocatables. */
10097 2668 : gfc_init_se (&se, NULL);
10098 : /* Pointer component. */
10099 2668 : if ((cm->attr.dimension || cm->attr.codimension)
10100 682 : && !cm->attr.proc_pointer)
10101 : {
10102 : /* Array pointer. */
10103 666 : if (expr->expr_type == EXPR_NULL)
10104 660 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10105 : else
10106 : {
10107 6 : se.direct_byref = 1;
10108 6 : se.expr = dest;
10109 6 : gfc_conv_expr_descriptor (&se, expr);
10110 6 : gfc_add_block_to_block (&block, &se.pre);
10111 6 : gfc_add_block_to_block (&block, &se.post);
10112 : }
10113 : }
10114 : else
10115 : {
10116 : /* Scalar pointers. */
10117 2002 : se.want_pointer = 1;
10118 2002 : gfc_conv_expr (&se, expr);
10119 2002 : gfc_add_block_to_block (&block, &se.pre);
10120 :
10121 2002 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10122 12 : && expr->symtree->n.sym->attr.dummy)
10123 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10124 :
10125 2002 : gfc_add_modify (&block, dest,
10126 2002 : fold_convert (TREE_TYPE (dest), se.expr));
10127 2002 : gfc_add_block_to_block (&block, &se.post);
10128 : }
10129 : }
10130 26776 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10131 : {
10132 : /* NULL initialization for CLASS components. */
10133 940 : tmp = gfc_trans_structure_assign (dest,
10134 : gfc_class_initializer (&cm->ts, expr),
10135 : false);
10136 940 : gfc_add_expr_to_block (&block, tmp);
10137 : }
10138 25836 : else if ((cm->attr.dimension || cm->attr.codimension)
10139 : && !cm->attr.proc_pointer)
10140 : {
10141 4985 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10142 : {
10143 2753 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10144 2753 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10145 2 : gfc_conv_descriptor_token_set (&block, dest, null_pointer_node);
10146 : }
10147 2232 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10148 : {
10149 1276 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10150 1276 : gfc_add_expr_to_block (&block, tmp);
10151 : }
10152 : else
10153 : {
10154 956 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10155 956 : gfc_add_expr_to_block (&block, tmp);
10156 : }
10157 : }
10158 20851 : else if (cm->ts.type == BT_CLASS
10159 145 : && CLASS_DATA (cm)->attr.dimension
10160 36 : && CLASS_DATA (cm)->attr.allocatable
10161 36 : && expr->ts.type == BT_DERIVED)
10162 : {
10163 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10164 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10165 36 : tmp = gfc_class_vptr_get (dest);
10166 36 : gfc_add_modify (&block, tmp,
10167 36 : fold_convert (TREE_TYPE (tmp), vtab));
10168 36 : tmp = gfc_class_data_get (dest);
10169 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10170 36 : gfc_add_expr_to_block (&block, tmp);
10171 : }
10172 20815 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10173 1772 : && (init
10174 1645 : || (cm->ts.type == BT_CHARACTER
10175 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10176 : {
10177 : /* NULL initialization for allocatable components.
10178 : Deferred-length character is dealt with later. */
10179 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10180 : null_pointer_node));
10181 : }
10182 20664 : else if (init && (cm->attr.allocatable
10183 13485 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10184 109 : && expr->ts.type != BT_CLASS)))
10185 : {
10186 416 : tree size;
10187 :
10188 416 : gfc_init_se (&se, NULL);
10189 416 : gfc_conv_expr (&se, expr);
10190 :
10191 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10192 : if (!cm->attr.dimension) part above. */
10193 416 : gfc_add_block_to_block (&block, &se.pre);
10194 : /* Take care about non-array allocatable components here. The alloc_*
10195 : routine below is motivated by the alloc_scalar_allocatable_for_
10196 : assignment() routine, but with the realloc portions removed and
10197 : different input. */
10198 416 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10199 : se.string_length);
10200 :
10201 416 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10202 0 : && expr->symtree->n.sym->attr.dummy)
10203 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10204 :
10205 416 : if (cm->ts.type == BT_CLASS)
10206 : {
10207 103 : tmp = gfc_class_data_get (dest);
10208 103 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10209 103 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10210 103 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10211 103 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10212 103 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10213 : }
10214 : else
10215 313 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10216 :
10217 : /* For deferred strings insert a memcpy. */
10218 416 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10219 : {
10220 145 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10221 145 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10222 : ? se.string_length
10223 0 : : expr->ts.u.cl->backend_decl);
10224 145 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10225 145 : gfc_add_expr_to_block (&block, tmp);
10226 : }
10227 271 : else if (cm->ts.type == BT_CLASS)
10228 : {
10229 : /* Fix the expression for memcpy. */
10230 103 : if (expr->expr_type != EXPR_VARIABLE)
10231 73 : se.expr = gfc_evaluate_now (se.expr, &block);
10232 :
10233 103 : if (expr->ts.type == BT_CHARACTER)
10234 : {
10235 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10236 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10237 : gfc_charlen_type_node,
10238 : se.string_length, size);
10239 24 : size = fold_convert (size_type_node, size);
10240 : }
10241 : else
10242 79 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10243 :
10244 : /* Now copy the expression to the constructor component _data. */
10245 103 : gfc_add_expr_to_block (&block,
10246 : gfc_build_memcpy_call (tmp, se.expr, size));
10247 :
10248 : /* Fill the unlimited polymorphic _len field. */
10249 103 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10250 : {
10251 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10252 24 : gfc_add_modify (&block, tmp,
10253 24 : fold_convert (TREE_TYPE (tmp),
10254 : se.string_length));
10255 : }
10256 : }
10257 : else
10258 168 : gfc_add_modify (&block, tmp,
10259 168 : fold_convert (TREE_TYPE (tmp), se.expr));
10260 416 : gfc_add_block_to_block (&block, &se.post);
10261 416 : }
10262 20248 : else if (expr->ts.type == BT_UNION)
10263 : {
10264 13 : tree tmp;
10265 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10266 : /* We mark that the entire union should be initialized with a contrived
10267 : EXPR_NULL expression at the beginning. */
10268 13 : if (c != NULL && c->n.component == NULL
10269 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10270 : {
10271 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10272 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10273 6 : gfc_add_expr_to_block (&block, tmp);
10274 6 : c = gfc_constructor_next (c);
10275 : }
10276 : /* The following constructor expression, if any, represents a specific
10277 : map initializer, as given by the user. */
10278 13 : if (c != NULL && c->expr != NULL)
10279 : {
10280 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10281 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10282 6 : gfc_add_expr_to_block (&block, tmp);
10283 : }
10284 : }
10285 20235 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10286 : {
10287 3123 : if (expr->expr_type != EXPR_STRUCTURE)
10288 : {
10289 452 : tree dealloc = NULL_TREE;
10290 452 : gfc_init_se (&se, NULL);
10291 452 : gfc_conv_expr (&se, expr);
10292 452 : gfc_add_block_to_block (&block, &se.pre);
10293 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10294 : expression in a temporary variable and deallocate the allocatable
10295 : components. Then we can the copy the expression to the result. */
10296 452 : if (cm->ts.u.derived->attr.alloc_comp
10297 330 : && expr->expr_type != EXPR_VARIABLE)
10298 : {
10299 300 : se.expr = gfc_evaluate_now (se.expr, &block);
10300 300 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10301 : expr->rank);
10302 : }
10303 452 : gfc_add_modify (&block, dest,
10304 452 : fold_convert (TREE_TYPE (dest), se.expr));
10305 452 : if (cm->ts.u.derived->attr.alloc_comp
10306 330 : && expr->expr_type != EXPR_NULL)
10307 : {
10308 : // TODO: Fix caf_mode
10309 48 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10310 : dest, expr->rank, 0);
10311 48 : gfc_add_expr_to_block (&block, tmp);
10312 48 : if (dealloc != NULL_TREE)
10313 18 : gfc_add_expr_to_block (&block, dealloc);
10314 : }
10315 452 : gfc_add_block_to_block (&block, &se.post);
10316 : }
10317 : else
10318 : {
10319 : /* Nested constructors. */
10320 2671 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10321 2671 : gfc_add_expr_to_block (&block, tmp);
10322 : }
10323 : }
10324 17112 : else if (gfc_deferred_strlen (cm, &tmp))
10325 : {
10326 125 : tree strlen;
10327 125 : strlen = tmp;
10328 125 : gcc_assert (strlen);
10329 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10330 125 : TREE_TYPE (strlen),
10331 125 : TREE_OPERAND (dest, 0),
10332 : strlen, NULL_TREE);
10333 :
10334 125 : if (expr->expr_type == EXPR_NULL)
10335 : {
10336 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10337 107 : gfc_add_modify (&block, dest, tmp);
10338 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10339 107 : gfc_add_modify (&block, strlen, tmp);
10340 : }
10341 : else
10342 : {
10343 18 : tree size;
10344 18 : gfc_init_se (&se, NULL);
10345 18 : gfc_conv_expr (&se, expr);
10346 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10347 18 : size = fold_convert (size_type_node, size);
10348 18 : tmp = build_call_expr_loc (input_location,
10349 : builtin_decl_explicit (BUILT_IN_MALLOC),
10350 : 1, size);
10351 18 : gfc_add_modify (&block, dest,
10352 18 : fold_convert (TREE_TYPE (dest), tmp));
10353 18 : gfc_add_modify (&block, strlen,
10354 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10355 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10356 18 : gfc_add_expr_to_block (&block, tmp);
10357 : }
10358 : }
10359 16987 : else if (!cm->attr.artificial)
10360 : {
10361 : /* Scalar component (excluding deferred parameters). */
10362 16866 : gfc_init_se (&se, NULL);
10363 16866 : gfc_init_se (&lse, NULL);
10364 :
10365 16866 : gfc_conv_expr (&se, expr);
10366 16866 : if (cm->ts.type == BT_CHARACTER)
10367 1057 : lse.string_length = cm->ts.u.cl->backend_decl;
10368 16866 : lse.expr = dest;
10369 16866 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10370 16866 : gfc_add_expr_to_block (&block, tmp);
10371 : }
10372 29444 : return gfc_finish_block (&block);
10373 : }
10374 :
10375 : /* Assign a derived type constructor to a variable. */
10376 :
10377 : tree
10378 20571 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10379 : {
10380 20571 : gfc_constructor *c;
10381 20571 : gfc_component *cm;
10382 20571 : stmtblock_t block;
10383 20571 : tree field;
10384 20571 : tree tmp;
10385 20571 : gfc_se se;
10386 :
10387 20571 : gfc_start_block (&block);
10388 :
10389 20571 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10390 179 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10391 13 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10392 : {
10393 179 : gfc_se lse;
10394 :
10395 179 : gfc_init_se (&se, NULL);
10396 179 : gfc_init_se (&lse, NULL);
10397 179 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10398 179 : lse.expr = dest;
10399 179 : gfc_add_modify (&block, lse.expr,
10400 179 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10401 :
10402 179 : return gfc_finish_block (&block);
10403 : }
10404 :
10405 : /* Make sure that the derived type has been completely built. */
10406 20392 : if (!expr->ts.u.derived->backend_decl
10407 20392 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10408 : {
10409 224 : tmp = gfc_typenode_for_spec (&expr->ts);
10410 224 : gcc_assert (tmp);
10411 : }
10412 :
10413 20392 : cm = expr->ts.u.derived->components;
10414 :
10415 :
10416 20392 : if (coarray)
10417 225 : gfc_init_se (&se, NULL);
10418 :
10419 20392 : for (c = gfc_constructor_first (expr->value.constructor);
10420 52986 : c; c = gfc_constructor_next (c), cm = cm->next)
10421 : {
10422 : /* Skip absent members in default initializers. */
10423 32594 : if (!c->expr && !cm->attr.allocatable)
10424 3150 : continue;
10425 :
10426 : /* Register the component with the caf-lib before it is initialized.
10427 : Register only allocatable components, that are not coarray'ed
10428 : components (%comp[*]). Only register when the constructor is the
10429 : null-expression. */
10430 29444 : if (coarray && !cm->attr.codimension
10431 515 : && (cm->attr.allocatable || cm->attr.pointer)
10432 179 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10433 : {
10434 177 : tree token, desc, size;
10435 354 : bool is_array = cm->ts.type == BT_CLASS
10436 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10437 :
10438 177 : field = cm->backend_decl;
10439 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
10440 177 : TREE_TYPE (field), dest, field, NULL_TREE);
10441 177 : if (cm->ts.type == BT_CLASS)
10442 0 : field = gfc_class_data_get (field);
10443 :
10444 177 : token
10445 : = is_array
10446 177 : ? gfc_conv_descriptor_token (field)
10447 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10448 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10449 52 : gfc_comp_caf_token (cm), NULL_TREE);
10450 :
10451 177 : if (is_array)
10452 : {
10453 : /* The _caf_register routine looks at the rank of the array
10454 : descriptor to decide whether the data registered is an array
10455 : or not. */
10456 125 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10457 125 : : cm->as->rank;
10458 : /* When the rank is not known just set a positive rank, which
10459 : suffices to recognize the data as array. */
10460 125 : if (rank < 0)
10461 0 : rank = 1;
10462 125 : size = build_zero_cst (size_type_node);
10463 125 : desc = field;
10464 125 : gfc_conv_descriptor_rank_set (&block, desc, rank);
10465 : }
10466 : else
10467 : {
10468 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10469 52 : cm->ts.type == BT_CLASS
10470 52 : ? CLASS_DATA (cm)->attr
10471 : : cm->attr);
10472 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10473 : }
10474 177 : gfc_add_block_to_block (&block, &se.pre);
10475 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10476 : 7, size, build_int_cst (
10477 : integer_type_node,
10478 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10479 : gfc_build_addr_expr (pvoid_type_node,
10480 : token),
10481 : gfc_build_addr_expr (NULL_TREE, desc),
10482 : null_pointer_node, null_pointer_node,
10483 : integer_zero_node);
10484 177 : gfc_add_expr_to_block (&block, tmp);
10485 : }
10486 29444 : field = cm->backend_decl;
10487 29444 : gcc_assert(field);
10488 29444 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10489 : dest, field, NULL_TREE);
10490 29444 : if (!c->expr)
10491 : {
10492 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10493 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10494 0 : gfc_free_expr (e);
10495 : }
10496 : else
10497 29444 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10498 29444 : gfc_add_expr_to_block (&block, tmp);
10499 : }
10500 20392 : return gfc_finish_block (&block);
10501 : }
10502 :
10503 : static void
10504 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10505 : gfc_component *un, gfc_expr *init)
10506 : {
10507 21 : gfc_constructor *ctor;
10508 :
10509 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
10510 : return;
10511 :
10512 21 : ctor = gfc_constructor_first (init->value.constructor);
10513 :
10514 21 : if (ctor == NULL || ctor->expr == NULL)
10515 : return;
10516 :
10517 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
10518 :
10519 : /* If we have an 'initialize all' constructor, do it first. */
10520 21 : if (ctor->expr->expr_type == EXPR_NULL)
10521 : {
10522 9 : tree union_type = TREE_TYPE (un->backend_decl);
10523 9 : tree val = build_constructor (union_type, NULL);
10524 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10525 9 : ctor = gfc_constructor_next (ctor);
10526 : }
10527 :
10528 : /* Add the map initializer on top. */
10529 21 : if (ctor != NULL && ctor->expr != NULL)
10530 : {
10531 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
10532 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
10533 12 : TREE_TYPE (un->backend_decl),
10534 12 : un->attr.dimension, un->attr.pointer,
10535 12 : un->attr.proc_pointer);
10536 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10537 : }
10538 : }
10539 :
10540 : /* Build an expression for a constructor. If init is nonzero then
10541 : this is part of a static variable initializer. */
10542 :
10543 : void
10544 38342 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
10545 : {
10546 38342 : gfc_constructor *c;
10547 38342 : gfc_component *cm;
10548 38342 : tree val;
10549 38342 : tree type;
10550 38342 : tree tmp;
10551 38342 : vec<constructor_elt, va_gc> *v = NULL;
10552 :
10553 38342 : gcc_assert (se->ss == NULL);
10554 38342 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10555 38342 : type = gfc_typenode_for_spec (&expr->ts);
10556 :
10557 38342 : if (!init)
10558 : {
10559 16151 : if (IS_PDT (expr) && expr->must_finalize)
10560 276 : final_block = &se->finalblock;
10561 :
10562 : /* Create a temporary variable and fill it in. */
10563 16151 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
10564 : /* The symtree in expr is NULL, if the code to generate is for
10565 : initializing the static members only. */
10566 32302 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
10567 16151 : se->want_coarray);
10568 16151 : gfc_add_expr_to_block (&se->pre, tmp);
10569 16151 : final_block = NULL;
10570 16151 : return;
10571 : }
10572 :
10573 22191 : cm = expr->ts.u.derived->components;
10574 :
10575 22191 : for (c = gfc_constructor_first (expr->value.constructor);
10576 113321 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
10577 : {
10578 : /* Skip absent members in default initializers and allocatable
10579 : components. Although the latter have a default initializer
10580 : of EXPR_NULL,... by default, the static nullify is not needed
10581 : since this is done every time we come into scope. */
10582 99815 : if (!c->expr
10583 88712 : || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)
10584 173665 : || (IS_PDT (cm) && has_parameterized_comps (cm->ts.u.derived)))
10585 8685 : continue;
10586 :
10587 82445 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
10588 47923 : && strcmp (cm->name, "_extends") == 0
10589 1308 : && cm->initializer->symtree)
10590 : {
10591 1308 : tree vtab;
10592 1308 : gfc_symbol *vtabs;
10593 1308 : vtabs = cm->initializer->symtree->n.sym;
10594 1308 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
10595 1308 : vtab = unshare_expr_without_location (vtab);
10596 1308 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
10597 1308 : }
10598 81137 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
10599 : {
10600 8746 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
10601 8746 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10602 : fold_convert (TREE_TYPE (cm->backend_decl),
10603 : val));
10604 8746 : }
10605 72391 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
10606 413 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10607 : fold_convert (TREE_TYPE (cm->backend_decl),
10608 413 : integer_zero_node));
10609 71978 : else if (cm->ts.type == BT_UNION)
10610 21 : gfc_conv_union_initializer (v, cm, c->expr);
10611 : else
10612 : {
10613 71957 : val = gfc_conv_initializer (c->expr, &cm->ts,
10614 71957 : TREE_TYPE (cm->backend_decl),
10615 71957 : cm->attr.dimension, cm->attr.pointer,
10616 71957 : cm->attr.proc_pointer);
10617 71957 : val = unshare_expr_without_location (val);
10618 :
10619 : /* Append it to the constructor list. */
10620 163087 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
10621 : }
10622 : }
10623 :
10624 22191 : se->expr = build_constructor (type, v);
10625 22191 : if (init)
10626 22191 : TREE_CONSTANT (se->expr) = 1;
10627 : }
10628 :
10629 :
10630 : /* Translate a substring expression. */
10631 :
10632 : static void
10633 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
10634 : {
10635 258 : gfc_ref *ref;
10636 :
10637 258 : ref = expr->ref;
10638 :
10639 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
10640 :
10641 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
10642 258 : expr->value.character.length,
10643 258 : expr->value.character.string);
10644 :
10645 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
10646 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
10647 :
10648 258 : if (ref)
10649 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
10650 258 : }
10651 :
10652 :
10653 : /* Entry point for expression translation. Evaluates a scalar quantity.
10654 : EXPR is the expression to be translated, and SE is the state structure if
10655 : called from within the scalarized. */
10656 :
10657 : void
10658 3669812 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
10659 : {
10660 3669812 : gfc_ss *ss;
10661 :
10662 3669812 : ss = se->ss;
10663 3669812 : if (ss && ss->info->expr == expr
10664 239437 : && (ss->info->type == GFC_SS_SCALAR
10665 : || ss->info->type == GFC_SS_REFERENCE))
10666 : {
10667 40690 : gfc_ss_info *ss_info;
10668 :
10669 40690 : ss_info = ss->info;
10670 : /* Substitute a scalar expression evaluated outside the scalarization
10671 : loop. */
10672 40690 : se->expr = ss_info->data.scalar.value;
10673 40690 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
10674 844 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
10675 :
10676 40690 : se->string_length = ss_info->string_length;
10677 40690 : gfc_advance_se_ss_chain (se);
10678 40690 : return;
10679 : }
10680 :
10681 : /* We need to convert the expressions for the iso_c_binding derived types.
10682 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
10683 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
10684 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
10685 : updated to be an integer with a kind equal to the size of a (void *). */
10686 3629122 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
10687 14860 : && expr->ts.u.derived->attr.is_bind_c)
10688 : {
10689 14011 : if (expr->expr_type == EXPR_VARIABLE
10690 9559 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
10691 9559 : || expr->symtree->n.sym->intmod_sym_id
10692 : == ISOCBINDING_NULL_FUNPTR))
10693 : {
10694 : /* Set expr_type to EXPR_NULL, which will result in
10695 : null_pointer_node being used below. */
10696 0 : expr->expr_type = EXPR_NULL;
10697 : }
10698 : else
10699 : {
10700 : /* Update the type/kind of the expression to be what the new
10701 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
10702 14011 : expr->ts.type = BT_INTEGER;
10703 14011 : expr->ts.f90_type = BT_VOID;
10704 14011 : expr->ts.kind = gfc_index_integer_kind;
10705 : }
10706 : }
10707 :
10708 3629122 : gfc_fix_class_refs (expr);
10709 :
10710 3629122 : switch (expr->expr_type)
10711 : {
10712 509175 : case EXPR_OP:
10713 509175 : gfc_conv_expr_op (se, expr);
10714 509175 : break;
10715 :
10716 159 : case EXPR_CONDITIONAL:
10717 159 : gfc_conv_conditional_expr (se, expr);
10718 159 : break;
10719 :
10720 307417 : case EXPR_FUNCTION:
10721 307417 : gfc_conv_function_expr (se, expr);
10722 307417 : break;
10723 :
10724 1144539 : case EXPR_CONSTANT:
10725 1144539 : gfc_conv_constant (se, expr);
10726 1144539 : break;
10727 :
10728 1611256 : case EXPR_VARIABLE:
10729 1611256 : gfc_conv_variable (se, expr);
10730 1611256 : break;
10731 :
10732 4211 : case EXPR_NULL:
10733 4211 : se->expr = null_pointer_node;
10734 4211 : break;
10735 :
10736 258 : case EXPR_SUBSTRING:
10737 258 : gfc_conv_substring_expr (se, expr);
10738 258 : break;
10739 :
10740 16151 : case EXPR_STRUCTURE:
10741 16151 : gfc_conv_structure (se, expr, 0);
10742 : /* F2008 4.5.6.3 para 5: If an executable construct references a
10743 : structure constructor or array constructor, the entity created by
10744 : the constructor is finalized after execution of the innermost
10745 : executable construct containing the reference. This, in fact,
10746 : was later deleted by the Combined Technical Corrigenda 1 TO 4 for
10747 : fortran 2008 (f08/0011). */
10748 16151 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
10749 16151 : && !(gfc_option.allow_std & GFC_STD_GNU)
10750 139 : && expr->must_finalize
10751 16163 : && gfc_may_be_finalized (expr->ts))
10752 : {
10753 12 : locus loc;
10754 12 : gfc_locus_from_location (&loc, input_location);
10755 12 : gfc_warning (0, "The structure constructor at %L has been"
10756 : " finalized. This feature was removed by f08/0011."
10757 : " Use -std=f2018 or -std=gnu to eliminate the"
10758 : " finalization.", &loc);
10759 12 : symbol_attribute attr;
10760 12 : attr.allocatable = attr.pointer = 0;
10761 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
10762 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
10763 : }
10764 : break;
10765 :
10766 35956 : case EXPR_ARRAY:
10767 35956 : gfc_conv_array_constructor_expr (se, expr);
10768 35956 : gfc_add_block_to_block (&se->post, &se->finalblock);
10769 35956 : break;
10770 :
10771 0 : default:
10772 0 : gcc_unreachable ();
10773 3669812 : break;
10774 : }
10775 : }
10776 :
10777 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
10778 : of an assignment. */
10779 : void
10780 374813 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
10781 : {
10782 374813 : gfc_conv_expr (se, expr);
10783 : /* All numeric lvalues should have empty post chains. If not we need to
10784 : figure out a way of rewriting an lvalue so that it has no post chain. */
10785 374813 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
10786 374813 : }
10787 :
10788 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
10789 : numeric expressions. Used for scalar values where inserting cleanup code
10790 : is inconvenient. */
10791 : void
10792 1038988 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
10793 : {
10794 1038988 : tree val;
10795 :
10796 1038988 : gcc_assert (expr->ts.type != BT_CHARACTER);
10797 1038988 : gfc_conv_expr (se, expr);
10798 1038988 : if (se->post.head)
10799 : {
10800 2553 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
10801 2553 : gfc_add_modify (&se->pre, val, se->expr);
10802 2553 : se->expr = val;
10803 2553 : gfc_add_block_to_block (&se->pre, &se->post);
10804 : }
10805 1038988 : }
10806 :
10807 : /* Helper to translate an expression and convert it to a particular type. */
10808 : void
10809 293923 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
10810 : {
10811 293923 : gfc_conv_expr_val (se, expr);
10812 293923 : se->expr = convert (type, se->expr);
10813 293923 : }
10814 :
10815 :
10816 : /* Converts an expression so that it can be passed by reference. Scalar
10817 : values only. */
10818 :
10819 : void
10820 229285 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
10821 : {
10822 229285 : gfc_ss *ss;
10823 229285 : tree var;
10824 :
10825 229285 : ss = se->ss;
10826 229285 : if (ss && ss->info->expr == expr
10827 8023 : && ss->info->type == GFC_SS_REFERENCE)
10828 : {
10829 : /* Returns a reference to the scalar evaluated outside the loop
10830 : for this case. */
10831 907 : gfc_conv_expr (se, expr);
10832 :
10833 907 : if (expr->ts.type == BT_CHARACTER
10834 114 : && expr->expr_type != EXPR_FUNCTION)
10835 102 : gfc_conv_string_parameter (se);
10836 : else
10837 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10838 :
10839 907 : return;
10840 : }
10841 :
10842 228378 : if (expr->ts.type == BT_CHARACTER)
10843 : {
10844 49877 : gfc_conv_expr (se, expr);
10845 49877 : gfc_conv_string_parameter (se);
10846 49877 : return;
10847 : }
10848 :
10849 178501 : if (expr->expr_type == EXPR_VARIABLE)
10850 : {
10851 71209 : se->want_pointer = 1;
10852 71209 : gfc_conv_expr (se, expr);
10853 71209 : if (se->post.head)
10854 : {
10855 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10856 0 : gfc_add_modify (&se->pre, var, se->expr);
10857 0 : gfc_add_block_to_block (&se->pre, &se->post);
10858 0 : se->expr = var;
10859 : }
10860 71209 : return;
10861 : }
10862 :
10863 107292 : if (expr->expr_type == EXPR_CONDITIONAL)
10864 : {
10865 18 : se->want_pointer = 1;
10866 18 : gfc_conv_expr (se, expr);
10867 18 : return;
10868 : }
10869 :
10870 107274 : if (expr->expr_type == EXPR_FUNCTION
10871 13789 : && ((expr->value.function.esym
10872 2107 : && expr->value.function.esym->result
10873 2106 : && expr->value.function.esym->result->attr.pointer
10874 83 : && !expr->value.function.esym->result->attr.dimension)
10875 13712 : || (!expr->value.function.esym && !expr->ref
10876 11576 : && expr->symtree->n.sym->attr.pointer
10877 0 : && !expr->symtree->n.sym->attr.dimension)))
10878 : {
10879 77 : se->want_pointer = 1;
10880 77 : gfc_conv_expr (se, expr);
10881 77 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10882 77 : gfc_add_modify (&se->pre, var, se->expr);
10883 77 : se->expr = var;
10884 77 : return;
10885 : }
10886 :
10887 107197 : gfc_conv_expr (se, expr);
10888 :
10889 : /* Create a temporary var to hold the value. */
10890 107197 : if (TREE_CONSTANT (se->expr))
10891 : {
10892 : tree tmp = se->expr;
10893 84843 : STRIP_TYPE_NOPS (tmp);
10894 84843 : var = build_decl (input_location,
10895 84843 : CONST_DECL, NULL, TREE_TYPE (tmp));
10896 84843 : DECL_INITIAL (var) = tmp;
10897 84843 : TREE_STATIC (var) = 1;
10898 84843 : pushdecl (var);
10899 : }
10900 : else
10901 : {
10902 22354 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10903 22354 : gfc_add_modify (&se->pre, var, se->expr);
10904 : }
10905 :
10906 107197 : if (!expr->must_finalize)
10907 107101 : gfc_add_block_to_block (&se->pre, &se->post);
10908 :
10909 : /* Take the address of that value. */
10910 107197 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
10911 : }
10912 :
10913 :
10914 : /* Get the _len component for an unlimited polymorphic expression. */
10915 :
10916 : static tree
10917 1800 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
10918 : {
10919 1800 : gfc_se se;
10920 1800 : gfc_ref *ref = expr->ref;
10921 :
10922 1800 : gfc_init_se (&se, NULL);
10923 3714 : while (ref && ref->next)
10924 : ref = ref->next;
10925 1800 : gfc_add_len_component (expr);
10926 1800 : gfc_conv_expr (&se, expr);
10927 1800 : gfc_add_block_to_block (block, &se.pre);
10928 1800 : gcc_assert (se.post.head == NULL_TREE);
10929 1800 : if (ref)
10930 : {
10931 262 : gfc_free_ref_list (ref->next);
10932 262 : ref->next = NULL;
10933 : }
10934 : else
10935 : {
10936 1538 : gfc_free_ref_list (expr->ref);
10937 1538 : expr->ref = NULL;
10938 : }
10939 1800 : return se.expr;
10940 : }
10941 :
10942 :
10943 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
10944 : statement-list outside of the scalarizer-loop. When code is generated, that
10945 : depends on the scalarized expression, it is added to RSE.PRE.
10946 : Returns le's _vptr tree and when set the len expressions in to_lenp and
10947 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
10948 : expression. */
10949 :
10950 : static tree
10951 4535 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
10952 : gfc_expr * re, gfc_se *rse,
10953 : tree * to_lenp, tree * from_lenp,
10954 : tree * from_vptrp)
10955 : {
10956 4535 : gfc_se se;
10957 4535 : gfc_expr * vptr_expr;
10958 4535 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
10959 4535 : bool set_vptr = false, temp_rhs = false;
10960 4535 : stmtblock_t *pre = block;
10961 4535 : tree class_expr = NULL_TREE;
10962 4535 : tree from_vptr = NULL_TREE;
10963 :
10964 : /* Create a temporary for complicated expressions. */
10965 4535 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
10966 1263 : && rse->expr != NULL_TREE)
10967 : {
10968 1263 : if (!DECL_P (rse->expr))
10969 : {
10970 392 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10971 37 : class_expr = gfc_get_class_from_expr (rse->expr);
10972 :
10973 392 : if (rse->loop)
10974 159 : pre = &rse->loop->pre;
10975 : else
10976 233 : pre = &rse->pre;
10977 :
10978 392 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
10979 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
10980 : else
10981 355 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
10982 :
10983 392 : rse->expr = tmp;
10984 : }
10985 : else
10986 871 : pre = &rse->pre;
10987 :
10988 : temp_rhs = true;
10989 : }
10990 :
10991 : /* Get the _vptr for the left-hand side expression. */
10992 4535 : gfc_init_se (&se, NULL);
10993 4535 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
10994 4535 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
10995 : {
10996 : /* Care about _len for unlimited polymorphic entities. */
10997 4535 : if (UNLIMITED_POLY (vptr_expr)
10998 3503 : || (vptr_expr->ts.type == BT_DERIVED
10999 2479 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11000 1516 : to_len = trans_get_upoly_len (block, vptr_expr);
11001 4535 : gfc_add_vptr_component (vptr_expr);
11002 4535 : set_vptr = true;
11003 : }
11004 : else
11005 0 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11006 4535 : se.want_pointer = 1;
11007 4535 : gfc_conv_expr (&se, vptr_expr);
11008 4535 : gfc_free_expr (vptr_expr);
11009 4535 : gfc_add_block_to_block (block, &se.pre);
11010 4535 : gcc_assert (se.post.head == NULL_TREE);
11011 4535 : lhs_vptr = se.expr;
11012 4535 : STRIP_NOPS (lhs_vptr);
11013 :
11014 : /* Set the _vptr only when the left-hand side of the assignment is a
11015 : class-object. */
11016 4535 : if (set_vptr)
11017 : {
11018 : /* Get the vptr from the rhs expression only, when it is variable.
11019 : Functions are expected to be assigned to a temporary beforehand. */
11020 3143 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
11021 5316 : ? gfc_find_and_cut_at_last_class_ref (re)
11022 : : NULL;
11023 781 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
11024 : {
11025 781 : if (to_len != NULL_TREE)
11026 : {
11027 : /* Get the _len information from the rhs. */
11028 299 : if (UNLIMITED_POLY (vptr_expr)
11029 : || (vptr_expr->ts.type == BT_DERIVED
11030 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11031 272 : from_len = trans_get_upoly_len (block, vptr_expr);
11032 : }
11033 781 : gfc_add_vptr_component (vptr_expr);
11034 : }
11035 : else
11036 : {
11037 3754 : if (re->expr_type == EXPR_VARIABLE
11038 2362 : && DECL_P (re->symtree->n.sym->backend_decl)
11039 2362 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
11040 834 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
11041 3821 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
11042 : re->symtree->n.sym->backend_decl))))
11043 : {
11044 43 : vptr_expr = NULL;
11045 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
11046 : re->symtree->n.sym->backend_decl));
11047 43 : if (to_len && UNLIMITED_POLY (re))
11048 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
11049 : re->symtree->n.sym->backend_decl));
11050 : }
11051 3711 : else if (temp_rhs && re->ts.type == BT_CLASS)
11052 : {
11053 215 : vptr_expr = NULL;
11054 215 : if (class_expr)
11055 : tmp = class_expr;
11056 178 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11057 0 : tmp = gfc_get_class_from_expr (rse->expr);
11058 : else
11059 : tmp = rse->expr;
11060 :
11061 215 : se.expr = gfc_class_vptr_get (tmp);
11062 215 : from_vptr = se.expr;
11063 215 : if (UNLIMITED_POLY (re))
11064 74 : from_len = gfc_class_len_get (tmp);
11065 :
11066 : }
11067 3496 : else if (re->expr_type != EXPR_NULL)
11068 : /* Only when rhs is non-NULL use its declared type for vptr
11069 : initialisation. */
11070 3367 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
11071 : else
11072 : /* When the rhs is NULL use the vtab of lhs' declared type. */
11073 129 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11074 : }
11075 :
11076 4351 : if (vptr_expr)
11077 : {
11078 4277 : gfc_init_se (&se, NULL);
11079 4277 : se.want_pointer = 1;
11080 4277 : gfc_conv_expr (&se, vptr_expr);
11081 4277 : gfc_free_expr (vptr_expr);
11082 4277 : gfc_add_block_to_block (block, &se.pre);
11083 4277 : gcc_assert (se.post.head == NULL_TREE);
11084 4277 : from_vptr = se.expr;
11085 : }
11086 4535 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
11087 : se.expr));
11088 :
11089 4535 : if (to_len != NULL_TREE)
11090 : {
11091 : /* The _len component needs to be set. Figure how to get the
11092 : value of the right-hand side. */
11093 1516 : if (from_len == NULL_TREE)
11094 : {
11095 1170 : if (rse->string_length != NULL_TREE)
11096 : from_len = rse->string_length;
11097 712 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
11098 : {
11099 0 : gfc_init_se (&se, NULL);
11100 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
11101 0 : gfc_add_block_to_block (block, &se.pre);
11102 0 : gcc_assert (se.post.head == NULL_TREE);
11103 0 : from_len = gfc_evaluate_now (se.expr, block);
11104 : }
11105 : else
11106 712 : from_len = build_zero_cst (gfc_charlen_type_node);
11107 : }
11108 1516 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
11109 : from_len));
11110 : }
11111 : }
11112 :
11113 : /* Return the _len and _vptr trees only, when requested. */
11114 4535 : if (to_lenp)
11115 3319 : *to_lenp = to_len;
11116 4535 : if (from_lenp)
11117 3319 : *from_lenp = from_len;
11118 4535 : if (from_vptrp)
11119 3319 : *from_vptrp = from_vptr;
11120 4535 : return lhs_vptr;
11121 : }
11122 :
11123 :
11124 : /* Assign tokens for pointer components. */
11125 :
11126 : static void
11127 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11128 : gfc_expr *expr2)
11129 : {
11130 12 : symbol_attribute lhs_attr, rhs_attr;
11131 12 : tree tmp, lhs_tok, rhs_tok;
11132 : /* Flag to indicated component refs on the rhs. */
11133 12 : bool rhs_cr;
11134 :
11135 12 : lhs_attr = gfc_caf_attr (expr1);
11136 12 : if (expr2->expr_type != EXPR_NULL)
11137 : {
11138 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11139 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11140 : {
11141 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11142 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11143 :
11144 4 : if (rhs_cr)
11145 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11146 : else
11147 : {
11148 4 : tree caf_decl;
11149 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11150 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11151 : NULL_TREE, NULL);
11152 : }
11153 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11154 : lhs_tok,
11155 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11156 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11157 : }
11158 : }
11159 4 : else if (lhs_attr.codimension)
11160 : {
11161 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11162 4 : if (!lhs_tok)
11163 : {
11164 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11165 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11166 : }
11167 : else
11168 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11169 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11170 : lhs_tok, null_pointer_node);
11171 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11172 : }
11173 12 : }
11174 :
11175 :
11176 : /* Do everything that is needed for a CLASS function expr2. */
11177 :
11178 : static tree
11179 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11180 : gfc_expr *expr1, gfc_expr *expr2)
11181 : {
11182 18 : tree expr1_vptr = NULL_TREE;
11183 18 : tree tmp;
11184 :
11185 18 : gfc_conv_function_expr (rse, expr2);
11186 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11187 :
11188 18 : if (expr1->ts.type != BT_CLASS)
11189 12 : rse->expr = gfc_class_data_get (rse->expr);
11190 : else
11191 : {
11192 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11193 : expr2, rse,
11194 : NULL, NULL, NULL);
11195 6 : gfc_add_block_to_block (block, &rse->pre);
11196 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11197 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11198 :
11199 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11200 6 : fold_convert (TREE_TYPE (expr1_vptr),
11201 : gfc_class_vptr_get (tmp)));
11202 6 : rse->expr = gfc_class_data_get (tmp);
11203 : }
11204 :
11205 18 : return expr1_vptr;
11206 : }
11207 :
11208 :
11209 : tree
11210 10151 : gfc_trans_pointer_assign (gfc_code * code)
11211 : {
11212 10151 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11213 : }
11214 :
11215 :
11216 : /* Generate code for a pointer assignment. */
11217 :
11218 : tree
11219 10206 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11220 : {
11221 10206 : gfc_se lse;
11222 10206 : gfc_se rse;
11223 10206 : stmtblock_t block;
11224 10206 : tree desc;
11225 10206 : tree tmp;
11226 10206 : tree expr1_vptr = NULL_TREE;
11227 10206 : bool scalar, non_proc_ptr_assign;
11228 10206 : gfc_ss *ss;
11229 :
11230 10206 : gfc_start_block (&block);
11231 :
11232 10206 : gfc_init_se (&lse, NULL);
11233 :
11234 : /* Usually testing whether this is not a proc pointer assignment. */
11235 10206 : non_proc_ptr_assign
11236 10206 : = !(gfc_expr_attr (expr1).proc_pointer
11237 1207 : && ((expr2->expr_type == EXPR_VARIABLE
11238 975 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11239 282 : || expr2->expr_type == EXPR_NULL));
11240 :
11241 : /* Check whether the expression is a scalar or not; we cannot use
11242 : expr1->rank as it can be nonzero for proc pointers. */
11243 10206 : ss = gfc_walk_expr (expr1);
11244 10206 : scalar = ss == gfc_ss_terminator;
11245 10206 : if (!scalar)
11246 4384 : gfc_free_ss_chain (ss);
11247 :
11248 10206 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11249 90 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11250 : {
11251 66 : gfc_add_data_component (expr2);
11252 : /* The following is required as gfc_add_data_component doesn't
11253 : update ts.type if there is a trailing REF_ARRAY. */
11254 66 : expr2->ts.type = BT_DERIVED;
11255 : }
11256 :
11257 10206 : if (scalar)
11258 : {
11259 : /* Scalar pointers. */
11260 5822 : lse.want_pointer = 1;
11261 5822 : gfc_conv_expr (&lse, expr1);
11262 5822 : gfc_init_se (&rse, NULL);
11263 5822 : rse.want_pointer = 1;
11264 5822 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11265 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11266 : else
11267 5816 : gfc_conv_expr (&rse, expr2);
11268 :
11269 5822 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11270 : {
11271 769 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11272 : NULL, NULL);
11273 769 : lse.expr = gfc_class_data_get (lse.expr);
11274 : }
11275 :
11276 5822 : if (expr1->symtree->n.sym->attr.proc_pointer
11277 863 : && expr1->symtree->n.sym->attr.dummy)
11278 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11279 : lse.expr);
11280 :
11281 5822 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11282 47 : && expr2->symtree->n.sym->attr.dummy)
11283 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11284 : rse.expr);
11285 :
11286 5822 : gfc_add_block_to_block (&block, &lse.pre);
11287 5822 : gfc_add_block_to_block (&block, &rse.pre);
11288 :
11289 : /* Check character lengths if character expression. The test is only
11290 : really added if -fbounds-check is enabled. Exclude deferred
11291 : character length lefthand sides. */
11292 954 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11293 780 : && !expr1->ts.deferred
11294 365 : && !expr1->symtree->n.sym->attr.proc_pointer
11295 6180 : && !gfc_is_proc_ptr_comp (expr1))
11296 : {
11297 339 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11298 339 : gcc_assert (lse.string_length && rse.string_length);
11299 339 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11300 : lse.string_length, rse.string_length,
11301 : &block);
11302 : }
11303 :
11304 : /* The assignment to an deferred character length sets the string
11305 : length to that of the rhs. */
11306 5822 : if (expr1->ts.deferred)
11307 : {
11308 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11309 413 : gfc_add_modify (&block, lse.string_length,
11310 413 : fold_convert (TREE_TYPE (lse.string_length),
11311 : rse.string_length));
11312 117 : else if (lse.string_length != NULL)
11313 115 : gfc_add_modify (&block, lse.string_length,
11314 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11315 : }
11316 :
11317 5822 : gfc_add_modify (&block, lse.expr,
11318 5822 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11319 :
11320 5822 : if (flag_coarray == GFC_FCOARRAY_LIB)
11321 : {
11322 342 : if (expr1->ref)
11323 : /* Also set the tokens for pointer components in derived typed
11324 : coarrays. */
11325 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11326 330 : else if (gfc_caf_attr (expr1).codimension)
11327 : {
11328 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11329 :
11330 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11331 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11332 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11333 : NULL_TREE, expr1);
11334 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11335 : NULL_TREE, expr2);
11336 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11337 : }
11338 : }
11339 :
11340 5822 : gfc_add_block_to_block (&block, &rse.post);
11341 5822 : gfc_add_block_to_block (&block, &lse.post);
11342 : }
11343 : else
11344 : {
11345 4384 : gfc_ref* remap;
11346 4384 : bool rank_remap;
11347 4384 : tree strlen_lhs;
11348 4384 : tree strlen_rhs = NULL_TREE;
11349 :
11350 : /* Array pointer. Find the last reference on the LHS and if it is an
11351 : array section ref, we're dealing with bounds remapping. In this case,
11352 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11353 : not see it and process the bounds remapping afterwards explicitly. */
11354 14130 : for (remap = expr1->ref; remap; remap = remap->next)
11355 5741 : if (!remap->next && remap->type == REF_ARRAY
11356 4384 : && remap->u.ar.type == AR_SECTION)
11357 : break;
11358 4384 : rank_remap = (remap && remap->u.ar.end[0]);
11359 :
11360 379 : if (remap && expr2->expr_type == EXPR_NULL)
11361 : {
11362 2 : gfc_error ("If bounds remapping is specified at %L, "
11363 : "the pointer target shall not be NULL", &expr1->where);
11364 2 : return NULL_TREE;
11365 : }
11366 :
11367 4382 : gfc_init_se (&lse, NULL);
11368 4382 : if (remap)
11369 377 : lse.descriptor_only = 1;
11370 4382 : gfc_conv_expr_descriptor (&lse, expr1);
11371 4382 : strlen_lhs = lse.string_length;
11372 4382 : desc = lse.expr;
11373 :
11374 4382 : if (expr2->expr_type == EXPR_NULL)
11375 : {
11376 : /* Just set the data pointer to null. */
11377 692 : gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
11378 : }
11379 3690 : else if (rank_remap)
11380 : {
11381 : /* If we are rank-remapping, just get the RHS's descriptor and
11382 : process this later on. */
11383 254 : gfc_init_se (&rse, NULL);
11384 254 : rse.direct_byref = 1;
11385 254 : rse.byref_noassign = 1;
11386 :
11387 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11388 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11389 : expr1, expr2);
11390 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11391 : {
11392 : tree bound[GFC_MAX_DIMENSIONS];
11393 : int i;
11394 :
11395 26 : for (i = 0; i < expr2->rank; i++)
11396 13 : bound[i] = NULL_TREE;
11397 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11398 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11399 : bound, bound, 0,
11400 : GFC_ARRAY_POINTER_CONT, false);
11401 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11402 13 : rse.descriptor_only = 0;
11403 13 : rse.expr = tmp;
11404 13 : rse.direct_byref = 1;
11405 13 : gfc_conv_expr_descriptor (&rse, expr2);
11406 13 : strlen_rhs = rse.string_length;
11407 13 : rse.expr = tmp;
11408 : }
11409 : else
11410 : {
11411 229 : gfc_conv_expr_descriptor (&rse, expr2);
11412 229 : strlen_rhs = rse.string_length;
11413 229 : if (expr1->ts.type == BT_CLASS)
11414 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11415 : expr2, &rse,
11416 : NULL, NULL,
11417 : NULL);
11418 : }
11419 : }
11420 3436 : else if (expr2->expr_type == EXPR_VARIABLE)
11421 : {
11422 : /* Assign directly to the LHS's descriptor. */
11423 3304 : lse.descriptor_only = 0;
11424 3304 : lse.direct_byref = 1;
11425 3304 : gfc_conv_expr_descriptor (&lse, expr2);
11426 3304 : strlen_rhs = lse.string_length;
11427 3304 : gfc_init_se (&rse, NULL);
11428 :
11429 3304 : if (expr1->ts.type == BT_CLASS)
11430 : {
11431 368 : rse.expr = NULL_TREE;
11432 368 : rse.string_length = strlen_rhs;
11433 368 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11434 : NULL, NULL, NULL);
11435 : }
11436 :
11437 3304 : if (remap == NULL)
11438 : {
11439 : /* If the target is not a whole array, use the target array
11440 : reference for remap. */
11441 6781 : for (remap = expr2->ref; remap; remap = remap->next)
11442 3750 : if (remap->type == REF_ARRAY
11443 3241 : && remap->u.ar.type == AR_FULL
11444 2548 : && remap->next)
11445 : break;
11446 : }
11447 : }
11448 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11449 : {
11450 25 : gfc_init_se (&rse, NULL);
11451 25 : rse.want_pointer = 1;
11452 25 : gfc_conv_function_expr (&rse, expr2);
11453 25 : if (expr1->ts.type != BT_CLASS)
11454 : {
11455 12 : rse.expr = gfc_class_data_get (rse.expr);
11456 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11457 : }
11458 : else
11459 : {
11460 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11461 : expr2, &rse, NULL,
11462 : NULL, NULL);
11463 13 : gfc_add_block_to_block (&block, &rse.pre);
11464 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11465 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11466 :
11467 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11468 13 : fold_convert (TREE_TYPE (expr1_vptr),
11469 : gfc_class_vptr_get (tmp)));
11470 13 : rse.expr = gfc_class_data_get (tmp);
11471 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11472 : }
11473 : }
11474 : else
11475 : {
11476 : /* Assign to a temporary descriptor and then copy that
11477 : temporary to the pointer. */
11478 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11479 107 : lse.descriptor_only = 0;
11480 107 : lse.expr = tmp;
11481 107 : lse.direct_byref = 1;
11482 107 : gfc_conv_expr_descriptor (&lse, expr2);
11483 107 : strlen_rhs = lse.string_length;
11484 107 : gfc_add_modify (&lse.pre, desc, tmp);
11485 : }
11486 :
11487 4382 : if (expr1->ts.type == BT_CHARACTER
11488 596 : && expr1->ts.deferred)
11489 : {
11490 338 : gfc_symbol *psym = expr1->symtree->n.sym;
11491 338 : tmp = NULL_TREE;
11492 338 : if (psym->ts.type == BT_CHARACTER
11493 337 : && psym->ts.u.cl->backend_decl)
11494 337 : tmp = psym->ts.u.cl->backend_decl;
11495 1 : else if (expr1->ts.u.cl->backend_decl
11496 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11497 0 : tmp = expr1->ts.u.cl->backend_decl;
11498 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11499 : {
11500 1 : gfc_ref *ref = expr1->ref;
11501 3 : for (;ref; ref = ref->next)
11502 : {
11503 2 : if (ref->type == REF_COMPONENT
11504 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11505 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11506 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11507 1 : TREE_TYPE (tmp),
11508 1 : TREE_OPERAND (lse.expr, 0),
11509 : tmp, NULL_TREE);
11510 : }
11511 : }
11512 :
11513 338 : gcc_assert (tmp);
11514 :
11515 338 : if (expr2->expr_type != EXPR_NULL)
11516 326 : gfc_add_modify (&block, tmp,
11517 326 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
11518 : else
11519 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
11520 : }
11521 :
11522 4382 : gfc_add_block_to_block (&block, &lse.pre);
11523 4382 : if (rank_remap)
11524 254 : gfc_add_block_to_block (&block, &rse.pre);
11525 :
11526 : /* If we do bounds remapping, update LHS descriptor accordingly. */
11527 4382 : if (remap)
11528 : {
11529 527 : int dim;
11530 527 : gcc_assert (remap->u.ar.dimen == expr1->rank);
11531 :
11532 : /* Always set dtype. */
11533 527 : gfc_conv_descriptor_dtype_set (&block, desc,
11534 527 : gfc_get_dtype (TREE_TYPE (desc)));
11535 :
11536 : /* For unlimited polymorphic LHS use elem_len from RHS. */
11537 527 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11538 : {
11539 60 : tree elem_len;
11540 60 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11541 60 : elem_len = fold_convert (gfc_array_index_type, tmp);
11542 60 : elem_len = gfc_evaluate_now (elem_len, &block);
11543 60 : gfc_conv_descriptor_elem_len_set (&block, desc, elem_len);
11544 : }
11545 :
11546 527 : if (rank_remap)
11547 : {
11548 : /* Do rank remapping. We already have the RHS's descriptor
11549 : converted in rse and now have to build the correct LHS
11550 : descriptor for it. */
11551 :
11552 254 : tree data, span;
11553 254 : tree offs, stride;
11554 254 : tree lbound, ubound;
11555 :
11556 : /* Copy data pointer. */
11557 254 : data = gfc_conv_descriptor_data_get (rse.expr);
11558 254 : gfc_conv_descriptor_data_set (&block, desc, data);
11559 :
11560 : /* Copy the span. */
11561 254 : if (VAR_P (rse.expr)
11562 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
11563 12 : span = gfc_conv_descriptor_span_get (rse.expr);
11564 : else
11565 : {
11566 242 : tmp = TREE_TYPE (rse.expr);
11567 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
11568 242 : span = fold_convert (gfc_array_index_type, tmp);
11569 : }
11570 254 : gfc_conv_descriptor_span_set (&block, desc, span);
11571 :
11572 : /* Copy offset but adjust it such that it would correspond
11573 : to a lbound of zero. */
11574 254 : if (expr2->rank == -1)
11575 42 : gfc_conv_descriptor_offset_set (&block, desc,
11576 : gfc_index_zero_node);
11577 : else
11578 : {
11579 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
11580 654 : for (dim = 0; dim < expr2->rank; ++dim)
11581 : {
11582 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11583 : gfc_rank_cst[dim]);
11584 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
11585 : gfc_rank_cst[dim]);
11586 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11587 : gfc_array_index_type, stride,
11588 : lbound);
11589 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
11590 : gfc_array_index_type, offs, tmp);
11591 : }
11592 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11593 : }
11594 : /* Set the bounds as declared for the LHS and calculate strides as
11595 : well as another offset update accordingly. */
11596 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11597 : gfc_rank_cst[0]);
11598 641 : for (dim = 0; dim < expr1->rank; ++dim)
11599 : {
11600 387 : gfc_se lower_se;
11601 387 : gfc_se upper_se;
11602 :
11603 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
11604 :
11605 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
11606 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
11607 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
11608 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
11609 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
11610 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
11611 :
11612 : /* Convert declared bounds. */
11613 387 : gfc_init_se (&lower_se, NULL);
11614 387 : gfc_init_se (&upper_se, NULL);
11615 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
11616 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
11617 :
11618 387 : gfc_add_block_to_block (&block, &lower_se.pre);
11619 387 : gfc_add_block_to_block (&block, &upper_se.pre);
11620 :
11621 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
11622 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
11623 :
11624 387 : lbound = gfc_evaluate_now (lbound, &block);
11625 387 : ubound = gfc_evaluate_now (ubound, &block);
11626 :
11627 387 : gfc_add_block_to_block (&block, &lower_se.post);
11628 387 : gfc_add_block_to_block (&block, &upper_se.post);
11629 :
11630 : /* Set bounds in descriptor. */
11631 387 : gfc_conv_descriptor_lbound_set (&block, desc,
11632 : gfc_rank_cst[dim], lbound);
11633 387 : gfc_conv_descriptor_ubound_set (&block, desc,
11634 : gfc_rank_cst[dim], ubound);
11635 :
11636 : /* Set stride. */
11637 387 : stride = gfc_evaluate_now (stride, &block);
11638 387 : gfc_conv_descriptor_stride_set (&block, desc,
11639 : gfc_rank_cst[dim], stride);
11640 :
11641 : /* Update offset. */
11642 387 : offs = gfc_conv_descriptor_offset_get (desc);
11643 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11644 : gfc_array_index_type, lbound, stride);
11645 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
11646 : gfc_array_index_type, offs, tmp);
11647 387 : offs = gfc_evaluate_now (offs, &block);
11648 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11649 :
11650 : /* Update stride. */
11651 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11652 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
11653 : gfc_array_index_type, stride, tmp);
11654 : }
11655 : }
11656 : else
11657 : {
11658 : /* Bounds remapping. Just shift the lower bounds. */
11659 :
11660 273 : gcc_assert (expr1->rank == expr2->rank);
11661 :
11662 654 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
11663 : {
11664 381 : gfc_se lbound_se;
11665 :
11666 381 : gcc_assert (!remap->u.ar.end[dim]);
11667 381 : gfc_init_se (&lbound_se, NULL);
11668 381 : if (remap->u.ar.start[dim])
11669 : {
11670 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
11671 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
11672 : }
11673 : else
11674 : /* This remap arises from a target that is not a whole
11675 : array. The start expressions will be NULL but we need
11676 : the lbounds to be one. */
11677 156 : lbound_se.expr = gfc_index_one_node;
11678 381 : gfc_conv_shift_descriptor_lbound (&block, desc,
11679 : dim, lbound_se.expr);
11680 381 : gfc_add_block_to_block (&block, &lbound_se.post);
11681 : }
11682 : }
11683 : }
11684 :
11685 : /* If rank remapping was done, check with -fcheck=bounds that
11686 : the target is at least as large as the pointer. */
11687 4382 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
11688 72 : && expr2->rank != -1)
11689 : {
11690 54 : tree lsize, rsize;
11691 54 : tree fault;
11692 54 : const char* msg;
11693 :
11694 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
11695 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
11696 :
11697 54 : lsize = gfc_evaluate_now (lsize, &block);
11698 54 : rsize = gfc_evaluate_now (rsize, &block);
11699 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11700 : rsize, lsize);
11701 :
11702 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
11703 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
11704 : msg, rsize, lsize);
11705 : }
11706 :
11707 : /* Check string lengths if applicable. The check is only really added
11708 : to the output code if -fbounds-check is enabled. */
11709 4382 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
11710 : {
11711 530 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11712 530 : gcc_assert (strlen_lhs && strlen_rhs);
11713 530 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11714 : strlen_lhs, strlen_rhs, &block);
11715 : }
11716 :
11717 4382 : gfc_add_block_to_block (&block, &lse.post);
11718 4382 : if (rank_remap)
11719 254 : gfc_add_block_to_block (&block, &rse.post);
11720 : }
11721 :
11722 10204 : return gfc_finish_block (&block);
11723 : }
11724 :
11725 :
11726 : /* Makes sure se is suitable for passing as a function string parameter. */
11727 : /* TODO: Need to check all callers of this function. It may be abused. */
11728 :
11729 : void
11730 247386 : gfc_conv_string_parameter (gfc_se * se)
11731 : {
11732 247386 : tree type;
11733 :
11734 247386 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
11735 247386 : && integer_onep (se->string_length))
11736 : {
11737 691 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11738 691 : return;
11739 : }
11740 :
11741 246695 : if (TREE_CODE (se->expr) == STRING_CST)
11742 : {
11743 103032 : type = TREE_TYPE (TREE_TYPE (se->expr));
11744 103032 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11745 103032 : return;
11746 : }
11747 :
11748 143663 : if (TREE_CODE (se->expr) == COND_EXPR)
11749 : {
11750 478 : tree cond = TREE_OPERAND (se->expr, 0);
11751 478 : tree lhs = TREE_OPERAND (se->expr, 1);
11752 478 : tree rhs = TREE_OPERAND (se->expr, 2);
11753 :
11754 478 : gfc_se lse, rse;
11755 478 : gfc_init_se (&lse, NULL);
11756 478 : gfc_init_se (&rse, NULL);
11757 :
11758 478 : lse.expr = lhs;
11759 478 : lse.string_length = se->string_length;
11760 478 : gfc_conv_string_parameter (&lse);
11761 :
11762 478 : rse.expr = rhs;
11763 478 : rse.string_length = se->string_length;
11764 478 : gfc_conv_string_parameter (&rse);
11765 :
11766 478 : se->expr
11767 478 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
11768 : cond, lse.expr, rse.expr);
11769 : }
11770 :
11771 143663 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
11772 56033 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
11773 143759 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
11774 : {
11775 87726 : type = TREE_TYPE (se->expr);
11776 87726 : if (TREE_CODE (se->expr) != INDIRECT_REF)
11777 82651 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11778 : else
11779 : {
11780 5075 : if (TREE_CODE (type) == ARRAY_TYPE)
11781 5075 : type = TREE_TYPE (type);
11782 5075 : type = gfc_get_character_type_len_for_eltype (type,
11783 : se->string_length);
11784 5075 : type = build_pointer_type (type);
11785 5075 : se->expr = gfc_build_addr_expr (type, se->expr);
11786 : }
11787 : }
11788 :
11789 143663 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
11790 : }
11791 :
11792 :
11793 : /* Generate code for assignment of scalar variables. Includes character
11794 : strings and derived types with allocatable components.
11795 : If you know that the LHS has no allocations, set dealloc to false.
11796 :
11797 : DEEP_COPY has no effect if the typespec TS is not a derived type with
11798 : allocatable components. Otherwise, if it is set, an explicit copy of each
11799 : allocatable component is made. This is necessary as a simple copy of the
11800 : whole object would copy array descriptors as is, so that the lhs's
11801 : allocatable components would point to the rhs's after the assignment.
11802 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
11803 : necessary if the rhs is a non-pointer function, as the allocatable components
11804 : are not accessible by other means than the function's result after the
11805 : function has returned. It is even more subtle when temporaries are involved,
11806 : as the two following examples show:
11807 : 1. When we evaluate an array constructor, a temporary is created. Thus
11808 : there is theoretically no alias possible. However, no deep copy is
11809 : made for this temporary, so that if the constructor is made of one or
11810 : more variable with allocatable components, those components still point
11811 : to the variable's: DEEP_COPY should be set for the assignment from the
11812 : temporary to the lhs in that case.
11813 : 2. When assigning a scalar to an array, we evaluate the scalar value out
11814 : of the loop, store it into a temporary variable, and assign from that.
11815 : In that case, deep copying when assigning to the temporary would be a
11816 : waste of resources; however deep copies should happen when assigning from
11817 : the temporary to each array element: again DEEP_COPY should be set for
11818 : the assignment from the temporary to the lhs. */
11819 :
11820 : tree
11821 340165 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
11822 : bool deep_copy, bool dealloc, bool in_coarray,
11823 : bool assoc_assign)
11824 : {
11825 340165 : stmtblock_t block;
11826 340165 : tree tmp;
11827 340165 : tree cond;
11828 340165 : int caf_mode;
11829 :
11830 340165 : gfc_init_block (&block);
11831 :
11832 340165 : if (ts.type == BT_CHARACTER)
11833 : {
11834 33530 : tree rlen = NULL;
11835 33530 : tree llen = NULL;
11836 :
11837 33530 : if (lse->string_length != NULL_TREE)
11838 : {
11839 33530 : gfc_conv_string_parameter (lse);
11840 33530 : gfc_add_block_to_block (&block, &lse->pre);
11841 33530 : llen = lse->string_length;
11842 : }
11843 :
11844 33530 : if (rse->string_length != NULL_TREE)
11845 : {
11846 33530 : gfc_conv_string_parameter (rse);
11847 33530 : gfc_add_block_to_block (&block, &rse->pre);
11848 33530 : rlen = rse->string_length;
11849 : }
11850 :
11851 33530 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
11852 : rse->expr, ts.kind);
11853 : }
11854 287307 : else if (gfc_bt_struct (ts.type)
11855 306635 : && (ts.u.derived->attr.alloc_comp
11856 12618 : || (deep_copy && has_parameterized_comps (ts.u.derived))))
11857 : {
11858 6872 : tree tmp_var = NULL_TREE;
11859 6872 : cond = NULL_TREE;
11860 :
11861 : /* Are the rhs and the lhs the same? */
11862 6872 : if (deep_copy)
11863 : {
11864 4128 : if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
11865 2999 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11866 4128 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11867 : gfc_build_addr_expr (NULL_TREE, lse->expr),
11868 : gfc_build_addr_expr (NULL_TREE, rse->expr));
11869 4128 : cond = gfc_evaluate_now (cond, &lse->pre);
11870 : }
11871 :
11872 : /* Deallocate the lhs allocated components as long as it is not
11873 : the same as the rhs. This must be done following the assignment
11874 : to prevent deallocating data that could be used in the rhs
11875 : expression. */
11876 6872 : if (dealloc)
11877 : {
11878 1959 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
11879 1959 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
11880 1959 : 0, gfc_may_be_finalized (ts));
11881 1959 : if (deep_copy)
11882 833 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11883 : tmp);
11884 1959 : gfc_add_expr_to_block (&lse->post, tmp);
11885 : }
11886 :
11887 6872 : gfc_add_block_to_block (&block, &rse->pre);
11888 :
11889 : /* Skip finalization for self-assignment. */
11890 6872 : if (deep_copy && lse->finalblock.head)
11891 : {
11892 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11893 : gfc_finish_block (&lse->finalblock));
11894 24 : gfc_add_expr_to_block (&block, tmp);
11895 : }
11896 : else
11897 6848 : gfc_add_block_to_block (&block, &lse->finalblock);
11898 :
11899 6872 : gfc_add_block_to_block (&block, &lse->pre);
11900 :
11901 6872 : if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
11902 6872 : == TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)))
11903 6566 : gfc_add_modify (&block, lse->expr,
11904 6566 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11905 : else
11906 : {
11907 306 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11908 306 : TREE_TYPE (lse->expr), rse->expr);
11909 306 : gfc_add_modify (&block, lse->expr, tmp);
11910 : }
11911 :
11912 : /* Restore pointer address of coarray components. */
11913 6872 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
11914 : {
11915 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
11916 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11917 : tmp);
11918 5 : gfc_add_expr_to_block (&block, tmp);
11919 : }
11920 :
11921 : /* Do a deep copy if the rhs is a variable, if it is not the
11922 : same as the lhs. */
11923 6872 : if (deep_copy)
11924 : {
11925 4128 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11926 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
11927 4128 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
11928 : caf_mode);
11929 4128 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11930 : tmp);
11931 4128 : gfc_add_expr_to_block (&block, tmp);
11932 : }
11933 : }
11934 299763 : else if (gfc_bt_struct (ts.type))
11935 : {
11936 12456 : gfc_add_block_to_block (&block, &rse->pre);
11937 12456 : gfc_add_block_to_block (&block, &lse->finalblock);
11938 12456 : gfc_add_block_to_block (&block, &lse->pre);
11939 12456 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11940 12456 : TREE_TYPE (lse->expr), rse->expr);
11941 12456 : gfc_add_modify (&block, lse->expr, tmp);
11942 : }
11943 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
11944 287307 : else if (ts.type == BT_CLASS)
11945 : {
11946 788 : gfc_add_block_to_block (&block, &lse->pre);
11947 788 : gfc_add_block_to_block (&block, &rse->pre);
11948 788 : gfc_add_block_to_block (&block, &lse->finalblock);
11949 :
11950 788 : if (!trans_scalar_class_assign (&block, lse, rse))
11951 : {
11952 : /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
11953 : for the lhs which ensures that class data rhs cast as a string
11954 : assigns correctly. */
11955 642 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11956 642 : TREE_TYPE (rse->expr), lse->expr);
11957 642 : gfc_add_modify (&block, tmp, rse->expr);
11958 :
11959 : /* Copy allocatable components but guard against class pointer
11960 : assign, which arrives here. */
11961 : #define DATA_DT ts.u.derived->components->ts.u.derived
11962 642 : if (deep_copy
11963 195 : && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11964 43 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11965 152 : && ts.u.derived->components
11966 794 : && DATA_DT && DATA_DT->attr.alloc_comp)
11967 : {
11968 6 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11969 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
11970 : : 0;
11971 6 : tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
11972 : caf_mode);
11973 6 : gfc_add_expr_to_block (&block, tmp);
11974 : }
11975 : #undef DATA_DT
11976 : }
11977 : }
11978 286519 : else if (ts.type != BT_CLASS)
11979 : {
11980 286519 : gfc_add_block_to_block (&block, &lse->pre);
11981 286519 : gfc_add_block_to_block (&block, &rse->pre);
11982 :
11983 286519 : if (in_coarray)
11984 : {
11985 861 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
11986 : {
11987 0 : tree rtype = TREE_TYPE (TREE_TYPE (rse->expr));
11988 0 : tree rtoken = TYPE_LANG_SPECIFIC (rtype)->caf_token;
11989 0 : gfc_conv_descriptor_token_set (&block, lse->expr, rtoken);
11990 : }
11991 861 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
11992 0 : lse->expr = gfc_conv_array_data (lse->expr);
11993 276 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
11994 861 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
11995 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
11996 : }
11997 286519 : gfc_add_modify (&block, lse->expr,
11998 286519 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11999 : }
12000 :
12001 340165 : gfc_add_block_to_block (&block, &lse->post);
12002 340165 : gfc_add_block_to_block (&block, &rse->post);
12003 :
12004 340165 : return gfc_finish_block (&block);
12005 : }
12006 :
12007 :
12008 : /* There are quite a lot of restrictions on the optimisation in using an
12009 : array function assign without a temporary. */
12010 :
12011 : static bool
12012 14478 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
12013 : {
12014 14478 : gfc_ref * ref;
12015 14478 : bool seen_array_ref;
12016 14478 : bool c = false;
12017 14478 : gfc_symbol *sym = expr1->symtree->n.sym;
12018 :
12019 : /* Play it safe with class functions assigned to a derived type. */
12020 14478 : if (gfc_is_class_array_function (expr2)
12021 14478 : && expr1->ts.type == BT_DERIVED)
12022 : return true;
12023 :
12024 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
12025 14454 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
12026 : return true;
12027 :
12028 : /* Elemental functions are scalarized so that they don't need a
12029 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
12030 : they would need special treatment in gfc_trans_arrayfunc_assign. */
12031 8531 : if (expr2->value.function.esym != NULL
12032 1589 : && expr2->value.function.esym->attr.elemental)
12033 : return true;
12034 :
12035 : /* Need a temporary if rhs is not FULL or a contiguous section. */
12036 8172 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
12037 : return true;
12038 :
12039 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
12040 7922 : if (gfc_ref_needs_temporary_p (expr1->ref))
12041 : return true;
12042 :
12043 : /* Functions returning pointers or allocatables need temporaries. */
12044 7910 : if (gfc_expr_attr (expr2).pointer
12045 7910 : || gfc_expr_attr (expr2).allocatable)
12046 376 : return true;
12047 :
12048 : /* Character array functions need temporaries unless the
12049 : character lengths are the same. */
12050 7534 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
12051 : {
12052 562 : if (UNLIMITED_POLY (expr1))
12053 : return true;
12054 :
12055 556 : if (expr1->ts.u.cl->length == NULL
12056 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12057 : return true;
12058 :
12059 493 : if (expr2->ts.u.cl->length == NULL
12060 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12061 : return true;
12062 :
12063 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
12064 475 : expr2->ts.u.cl->length->value.integer) != 0)
12065 : return true;
12066 : }
12067 :
12068 : /* Check that no LHS component references appear during an array
12069 : reference. This is needed because we do not have the means to
12070 : span any arbitrary stride with an array descriptor. This check
12071 : is not needed for the rhs because the function result has to be
12072 : a complete type. */
12073 7441 : seen_array_ref = false;
12074 14882 : for (ref = expr1->ref; ref; ref = ref->next)
12075 : {
12076 7454 : if (ref->type == REF_ARRAY)
12077 : seen_array_ref= true;
12078 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
12079 : return true;
12080 : }
12081 :
12082 : /* Check for a dependency. */
12083 7428 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
12084 : expr2->value.function.esym,
12085 : expr2->value.function.actual,
12086 : NOT_ELEMENTAL))
12087 : return true;
12088 :
12089 : /* If we have reached here with an intrinsic function, we do not
12090 : need a temporary except in the particular case that reallocation
12091 : on assignment is active and the lhs is allocatable and a target,
12092 : or a pointer which may be a subref pointer. FIXME: The last
12093 : condition can go away when we use span in the intrinsics
12094 : directly.*/
12095 6991 : if (expr2->value.function.isym)
12096 6113 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
12097 12313 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
12098 :
12099 : /* If the LHS is a dummy, we need a temporary if it is not
12100 : INTENT(OUT). */
12101 803 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
12102 : return true;
12103 :
12104 : /* If the lhs has been host_associated, is in common, a pointer or is
12105 : a target and the function is not using a RESULT variable, aliasing
12106 : can occur and a temporary is needed. */
12107 797 : if ((sym->attr.host_assoc
12108 743 : || sym->attr.in_common
12109 737 : || sym->attr.pointer
12110 731 : || sym->attr.cray_pointee
12111 731 : || sym->attr.target)
12112 66 : && expr2->symtree != NULL
12113 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
12114 : return true;
12115 :
12116 : /* A PURE function can unconditionally be called without a temporary. */
12117 755 : if (expr2->value.function.esym != NULL
12118 730 : && expr2->value.function.esym->attr.pure)
12119 : return false;
12120 :
12121 : /* Implicit_pure functions are those which could legally be declared
12122 : to be PURE. */
12123 727 : if (expr2->value.function.esym != NULL
12124 702 : && expr2->value.function.esym->attr.implicit_pure)
12125 : return false;
12126 :
12127 444 : if (!sym->attr.use_assoc
12128 444 : && !sym->attr.in_common
12129 444 : && !sym->attr.pointer
12130 438 : && !sym->attr.target
12131 438 : && !sym->attr.cray_pointee
12132 438 : && expr2->value.function.esym)
12133 : {
12134 : /* A temporary is not needed if the function is not contained and
12135 : the variable is local or host associated and not a pointer or
12136 : a target. */
12137 413 : if (!expr2->value.function.esym->attr.contained)
12138 : return false;
12139 :
12140 : /* A temporary is not needed if the lhs has never been host
12141 : associated and the procedure is contained. */
12142 164 : else if (!sym->attr.host_assoc)
12143 : return false;
12144 :
12145 : /* A temporary is not needed if the variable is local and not
12146 : a pointer, a target or a result. */
12147 6 : if (sym->ns->parent
12148 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12149 : return false;
12150 : }
12151 :
12152 : /* Default to temporary use. */
12153 : return true;
12154 : }
12155 :
12156 :
12157 : /* Provide the loop info so that the lhs descriptor can be built for
12158 : reallocatable assignments from extrinsic function calls. */
12159 :
12160 : static void
12161 203 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12162 : gfc_loopinfo *loop)
12163 : {
12164 : /* Signal that the function call should not be made by
12165 : gfc_conv_loop_setup. */
12166 203 : se->ss->is_alloc_lhs = 1;
12167 203 : gfc_init_loopinfo (loop);
12168 203 : gfc_add_ss_to_loop (loop, *ss);
12169 203 : gfc_add_ss_to_loop (loop, se->ss);
12170 203 : gfc_conv_ss_startstride (loop);
12171 203 : gfc_conv_loop_setup (loop, where);
12172 203 : gfc_copy_loopinfo_to_se (se, loop);
12173 203 : gfc_add_block_to_block (&se->pre, &loop->pre);
12174 203 : gfc_add_block_to_block (&se->pre, &loop->post);
12175 203 : se->ss->is_alloc_lhs = 0;
12176 203 : }
12177 :
12178 :
12179 : /* For assignment to a reallocatable lhs from intrinsic functions,
12180 : replace the se.expr (ie. the result) with a temporary descriptor.
12181 : Null the data field so that the library allocates space for the
12182 : result. Free the data of the original descriptor after the function,
12183 : in case it appears in an argument expression and transfer the
12184 : result to the original descriptor. */
12185 :
12186 : static void
12187 2138 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12188 : {
12189 2138 : tree desc;
12190 2138 : tree res_desc;
12191 2138 : tree tmp;
12192 2138 : tree offset;
12193 2138 : tree zero_cond;
12194 2138 : tree not_same_shape;
12195 2138 : stmtblock_t shape_block;
12196 2138 : int n;
12197 :
12198 : /* Use the allocation done by the library. Substitute the lhs
12199 : descriptor with a copy, whose data field is nulled.*/
12200 2138 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12201 2138 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12202 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12203 :
12204 : /* Unallocated, the descriptor does not have a dtype. */
12205 2138 : if (dtype != NULL_TREE)
12206 13 : gfc_conv_descriptor_dtype_set (&se->pre, desc, dtype);
12207 : else
12208 2125 : gfc_conv_descriptor_dtype_set (&se->pre, desc,
12209 2125 : gfc_get_dtype (TREE_TYPE (desc)));
12210 :
12211 2138 : res_desc = gfc_evaluate_now (desc, &se->pre);
12212 2138 : gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
12213 2138 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12214 :
12215 : /* Free the lhs after the function call and copy the result data to
12216 : the lhs descriptor. */
12217 2138 : tmp = gfc_conv_descriptor_data_get (desc);
12218 2138 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12219 : logical_type_node, tmp,
12220 2138 : build_int_cst (TREE_TYPE (tmp), 0));
12221 2138 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12222 2138 : tmp = gfc_call_free (tmp);
12223 2138 : gfc_add_expr_to_block (&se->post, tmp);
12224 :
12225 2138 : tmp = gfc_conv_descriptor_data_get (res_desc);
12226 2138 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12227 :
12228 : /* Check that the shapes are the same between lhs and expression.
12229 : The evaluation of the shape is done in 'shape_block' to avoid
12230 : uninitialized warnings from the lhs bounds. */
12231 2138 : not_same_shape = boolean_false_node;
12232 2138 : gfc_start_block (&shape_block);
12233 6880 : for (n = 0 ; n < rank; n++)
12234 : {
12235 4742 : tree tmp1;
12236 4742 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12237 4742 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12238 4742 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12239 : gfc_array_index_type, tmp, tmp1);
12240 4742 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12241 4742 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12242 : gfc_array_index_type, tmp, tmp1);
12243 4742 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12244 4742 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12245 : gfc_array_index_type, tmp, tmp1);
12246 4742 : tmp = fold_build2_loc (input_location, NE_EXPR,
12247 : logical_type_node, tmp,
12248 : gfc_index_zero_node);
12249 4742 : tmp = gfc_evaluate_now (tmp, &shape_block);
12250 4742 : if (n == 0)
12251 : not_same_shape = tmp;
12252 : else
12253 2604 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12254 : logical_type_node, tmp,
12255 : not_same_shape);
12256 : }
12257 :
12258 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12259 : shapes being different. */
12260 2138 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12261 : zero_cond, not_same_shape);
12262 2138 : gfc_add_modify (&shape_block, zero_cond, tmp);
12263 2138 : tmp = gfc_finish_block (&shape_block);
12264 2138 : tmp = build3_v (COND_EXPR, zero_cond,
12265 : build_empty_stmt (input_location), tmp);
12266 2138 : gfc_add_expr_to_block (&se->post, tmp);
12267 :
12268 : /* Now reset the bounds returned from the function call to bounds based
12269 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12270 : of 'variable and 'expr' are different. Set the offset accordingly. */
12271 2138 : offset = gfc_index_zero_node;
12272 6880 : for (n = 0 ; n < rank; n++)
12273 : {
12274 4742 : tree lbound;
12275 :
12276 4742 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12277 4742 : lbound = fold_build3_loc (input_location, COND_EXPR,
12278 : gfc_array_index_type, zero_cond,
12279 : gfc_index_one_node, lbound);
12280 4742 : lbound = gfc_evaluate_now (lbound, &se->post);
12281 :
12282 4742 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12283 4742 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12284 : gfc_array_index_type, tmp, lbound);
12285 4742 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12286 : gfc_rank_cst[n], lbound);
12287 4742 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12288 : gfc_rank_cst[n], tmp);
12289 :
12290 : /* Set stride and accumulate the offset. */
12291 4742 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12292 4742 : gfc_conv_descriptor_stride_set (&se->post, desc,
12293 : gfc_rank_cst[n], tmp);
12294 4742 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12295 : gfc_array_index_type, lbound, tmp);
12296 4742 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12297 : gfc_array_index_type, offset, tmp);
12298 4742 : offset = gfc_evaluate_now (offset, &se->post);
12299 : }
12300 :
12301 2138 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12302 2138 : }
12303 :
12304 :
12305 :
12306 : /* Try to translate array(:) = func (...), where func is a transformational
12307 : array function, without using a temporary. Returns NULL if this isn't the
12308 : case. */
12309 :
12310 : static tree
12311 14518 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12312 : {
12313 14518 : gfc_se se;
12314 14518 : gfc_ss *ss = NULL;
12315 14518 : gfc_component *comp = NULL;
12316 14518 : gfc_loopinfo loop;
12317 14518 : tree tmp;
12318 14518 : tree lhs;
12319 14518 : gfc_se final_se;
12320 14518 : gfc_symbol *sym = expr1->symtree->n.sym;
12321 14518 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12322 :
12323 : /* If the symbol is host associated and has not been referenced in its name
12324 : space, it might be lacking a backend_decl and vtable. */
12325 14518 : if (sym->backend_decl == NULL_TREE)
12326 : return NULL_TREE;
12327 :
12328 14478 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12329 : return NULL_TREE;
12330 :
12331 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12332 : functions. */
12333 6873 : comp = gfc_get_proc_ptr_comp (expr2);
12334 :
12335 6873 : if (!(expr2->value.function.isym
12336 718 : || (comp && comp->attr.dimension)
12337 718 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12338 718 : && expr2->value.function.esym->result->attr.dimension)))
12339 0 : return NULL_TREE;
12340 :
12341 6873 : gfc_init_se (&se, NULL);
12342 6873 : gfc_start_block (&se.pre);
12343 6873 : se.want_pointer = 1;
12344 :
12345 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12346 : backend decl, stash the original away for the finalization so that the
12347 : value used is that before the assignment. This is necessary because
12348 : evaluation of the rhs expression using direct by reference can change
12349 : the value. However, the standard mandates that the finalization must occur
12350 : after evaluation of the rhs. */
12351 6873 : gfc_init_se (&final_se, NULL);
12352 :
12353 6873 : if (finalizable)
12354 : {
12355 45 : tmp = sym->backend_decl;
12356 45 : lhs = sym->backend_decl;
12357 45 : if (INDIRECT_REF_P (tmp))
12358 0 : tmp = TREE_OPERAND (tmp, 0);
12359 45 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12360 45 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12361 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12362 : {
12363 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12364 : expr1->rank, 0);
12365 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12366 : }
12367 : }
12368 :
12369 45 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12370 : {
12371 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12372 45 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12373 : }
12374 :
12375 6873 : if (finalizable)
12376 45 : sym->backend_decl = lhs;
12377 :
12378 6873 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12379 :
12380 6873 : if (expr1->ts.type == BT_DERIVED
12381 264 : && expr1->ts.u.derived->attr.alloc_comp)
12382 : {
12383 110 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12384 110 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12385 : expr1->rank);
12386 110 : gfc_add_expr_to_block (&se.pre, tmp);
12387 : }
12388 :
12389 6873 : se.direct_byref = 1;
12390 6873 : se.ss = gfc_walk_expr (expr2);
12391 6873 : gcc_assert (se.ss != gfc_ss_terminator);
12392 :
12393 : /* Since this is a direct by reference call, references to the lhs can be
12394 : used for finalization of the function result just as long as the blocks
12395 : from final_se are added at the right time. */
12396 6873 : gfc_init_se (&final_se, NULL);
12397 6873 : if (finalizable && expr2->value.function.esym)
12398 : {
12399 32 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12400 32 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12401 32 : expr2->value.function.esym->attr,
12402 : expr2->rank);
12403 : }
12404 :
12405 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12406 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12407 : Clearly, this cannot be done for an allocatable function result, since
12408 : the shape of the result is unknown and, in any case, the function must
12409 : correctly take care of the reallocation internally. For intrinsic
12410 : calls, the array data is freed and the library takes care of allocation.
12411 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12412 : to the library. */
12413 6873 : if (flag_realloc_lhs
12414 6798 : && gfc_is_reallocatable_lhs (expr1)
12415 9214 : && !gfc_expr_attr (expr1).codimension
12416 2341 : && !gfc_is_coindexed (expr1)
12417 9214 : && !(expr2->value.function.esym
12418 203 : && expr2->value.function.esym->result->attr.allocatable))
12419 : {
12420 2341 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12421 :
12422 2341 : if (!expr2->value.function.isym)
12423 : {
12424 203 : ss = gfc_walk_expr (expr1);
12425 203 : gcc_assert (ss != gfc_ss_terminator);
12426 :
12427 203 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12428 203 : ss->is_alloc_lhs = 1;
12429 : }
12430 : else
12431 : {
12432 2138 : tree dtype = NULL_TREE;
12433 2138 : tree type = gfc_typenode_for_spec (&expr2->ts);
12434 2138 : if (expr1->ts.type == BT_CLASS)
12435 : {
12436 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12437 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12438 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12439 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12440 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12441 : }
12442 2138 : fcncall_realloc_result (&se, expr1->rank, dtype);
12443 : }
12444 : }
12445 :
12446 6873 : gfc_conv_function_expr (&se, expr2);
12447 :
12448 : /* Fix the result. */
12449 6873 : gfc_add_block_to_block (&se.pre, &se.post);
12450 6873 : if (finalizable)
12451 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12452 :
12453 : /* Do the finalization, including final calls from function arguments. */
12454 45 : if (finalizable)
12455 : {
12456 45 : gfc_add_block_to_block (&se.pre, &final_se.post);
12457 45 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12458 45 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12459 : }
12460 :
12461 6873 : if (ss)
12462 203 : gfc_cleanup_loop (&loop);
12463 : else
12464 6670 : gfc_free_ss_chain (se.ss);
12465 :
12466 6873 : return gfc_finish_block (&se.pre);
12467 : }
12468 :
12469 :
12470 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12471 : can't be done. */
12472 :
12473 : static tree
12474 3964 : gfc_trans_zero_assign (gfc_expr * expr)
12475 : {
12476 3964 : tree dest, len, type;
12477 3964 : tree tmp;
12478 3964 : gfc_symbol *sym;
12479 :
12480 3964 : sym = expr->symtree->n.sym;
12481 3964 : dest = gfc_get_symbol_decl (sym);
12482 :
12483 3964 : type = TREE_TYPE (dest);
12484 3964 : if (POINTER_TYPE_P (type))
12485 249 : type = TREE_TYPE (type);
12486 3964 : if (GFC_ARRAY_TYPE_P (type))
12487 : {
12488 : /* Determine the length of the array. */
12489 2779 : len = GFC_TYPE_ARRAY_SIZE (type);
12490 2779 : if (!len || TREE_CODE (len) != INTEGER_CST)
12491 : return NULL_TREE;
12492 : }
12493 1185 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12494 1185 : && gfc_is_simply_contiguous (expr, false, false))
12495 : {
12496 1085 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12497 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12498 1085 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12499 1085 : dest = gfc_conv_descriptor_data_get (dest);
12500 : }
12501 : else
12502 100 : return NULL_TREE;
12503 :
12504 : /* If we are zeroing a local array avoid taking its address by emitting
12505 : a = {} instead. */
12506 3685 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12507 2557 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12508 2557 : dest, build_constructor (TREE_TYPE (dest),
12509 2557 : NULL));
12510 :
12511 : /* Multiply len by element size. */
12512 1128 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12513 1128 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12514 : len, fold_convert (gfc_array_index_type, tmp));
12515 :
12516 : /* Convert arguments to the correct types. */
12517 1128 : dest = fold_convert (pvoid_type_node, dest);
12518 1128 : len = fold_convert (size_type_node, len);
12519 :
12520 : /* Construct call to __builtin_memset. */
12521 1128 : tmp = build_call_expr_loc (input_location,
12522 : builtin_decl_explicit (BUILT_IN_MEMSET),
12523 : 3, dest, integer_zero_node, len);
12524 1128 : return fold_convert (void_type_node, tmp);
12525 : }
12526 :
12527 :
12528 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
12529 : that constructs the call to __builtin_memcpy. */
12530 :
12531 : tree
12532 8022 : gfc_build_memcpy_call (tree dst, tree src, tree len)
12533 : {
12534 8022 : tree tmp;
12535 :
12536 : /* Convert arguments to the correct types. */
12537 8022 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
12538 7721 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
12539 : else
12540 301 : dst = fold_convert (pvoid_type_node, dst);
12541 :
12542 8022 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
12543 7614 : src = gfc_build_addr_expr (pvoid_type_node, src);
12544 : else
12545 408 : src = fold_convert (pvoid_type_node, src);
12546 :
12547 8022 : len = fold_convert (size_type_node, len);
12548 :
12549 : /* Construct call to __builtin_memcpy. */
12550 8022 : tmp = build_call_expr_loc (input_location,
12551 : builtin_decl_explicit (BUILT_IN_MEMCPY),
12552 : 3, dst, src, len);
12553 8022 : return fold_convert (void_type_node, tmp);
12554 : }
12555 :
12556 :
12557 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
12558 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
12559 : source/rhs, both are gfc_full_array_ref_p which have been checked for
12560 : dependencies. */
12561 :
12562 : static tree
12563 2603 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
12564 : {
12565 2603 : tree dst, dlen, dtype;
12566 2603 : tree src, slen, stype;
12567 2603 : tree tmp;
12568 :
12569 2603 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12570 2603 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
12571 :
12572 2603 : dtype = TREE_TYPE (dst);
12573 2603 : if (POINTER_TYPE_P (dtype))
12574 265 : dtype = TREE_TYPE (dtype);
12575 2603 : stype = TREE_TYPE (src);
12576 2603 : if (POINTER_TYPE_P (stype))
12577 293 : stype = TREE_TYPE (stype);
12578 :
12579 2603 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
12580 : return NULL_TREE;
12581 :
12582 : /* Determine the lengths of the arrays. */
12583 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
12584 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
12585 : return NULL_TREE;
12586 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12587 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12588 : dlen, fold_convert (gfc_array_index_type, tmp));
12589 :
12590 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
12591 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
12592 : return NULL_TREE;
12593 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
12594 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12595 : slen, fold_convert (gfc_array_index_type, tmp));
12596 :
12597 : /* Sanity check that they are the same. This should always be
12598 : the case, as we should already have checked for conformance. */
12599 1486 : if (!tree_int_cst_equal (slen, dlen))
12600 : return NULL_TREE;
12601 :
12602 1486 : return gfc_build_memcpy_call (dst, src, dlen);
12603 : }
12604 :
12605 :
12606 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
12607 : this can't be done. EXPR1 is the destination/lhs for which
12608 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
12609 :
12610 : static tree
12611 8256 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
12612 : {
12613 8256 : unsigned HOST_WIDE_INT nelem;
12614 8256 : tree dst, dtype;
12615 8256 : tree src, stype;
12616 8256 : tree len;
12617 8256 : tree tmp;
12618 :
12619 8256 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
12620 8256 : if (nelem == 0)
12621 : return NULL_TREE;
12622 :
12623 6857 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12624 6857 : dtype = TREE_TYPE (dst);
12625 6857 : if (POINTER_TYPE_P (dtype))
12626 265 : dtype = TREE_TYPE (dtype);
12627 6857 : if (!GFC_ARRAY_TYPE_P (dtype))
12628 : return NULL_TREE;
12629 :
12630 : /* Determine the lengths of the array. */
12631 6009 : len = GFC_TYPE_ARRAY_SIZE (dtype);
12632 6009 : if (!len || TREE_CODE (len) != INTEGER_CST)
12633 : return NULL_TREE;
12634 :
12635 : /* Confirm that the constructor is the same size. */
12636 5905 : if (compare_tree_int (len, nelem) != 0)
12637 : return NULL_TREE;
12638 :
12639 5905 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12640 5905 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
12641 : fold_convert (gfc_array_index_type, tmp));
12642 :
12643 5905 : stype = gfc_typenode_for_spec (&expr2->ts);
12644 5905 : src = gfc_build_constant_array_constructor (expr2, stype);
12645 :
12646 5905 : return gfc_build_memcpy_call (dst, src, len);
12647 : }
12648 :
12649 :
12650 : /* Tells whether the expression is to be treated as a variable reference. */
12651 :
12652 : bool
12653 316505 : gfc_expr_is_variable (gfc_expr *expr)
12654 : {
12655 316783 : gfc_expr *arg;
12656 316783 : gfc_component *comp;
12657 316783 : gfc_symbol *func_ifc;
12658 :
12659 316783 : if (expr->expr_type == EXPR_VARIABLE)
12660 : return true;
12661 :
12662 281283 : arg = gfc_get_noncopying_intrinsic_argument (expr);
12663 281283 : if (arg)
12664 : {
12665 278 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
12666 : return gfc_expr_is_variable (arg);
12667 : }
12668 :
12669 : /* A data-pointer-returning function should be considered as a variable
12670 : too. */
12671 281005 : if (expr->expr_type == EXPR_FUNCTION
12672 37437 : && expr->ref == NULL)
12673 : {
12674 37048 : if (expr->value.function.isym != NULL)
12675 : return false;
12676 :
12677 9671 : if (expr->value.function.esym != NULL)
12678 : {
12679 9662 : func_ifc = expr->value.function.esym;
12680 9662 : goto found_ifc;
12681 : }
12682 9 : gcc_assert (expr->symtree);
12683 9 : func_ifc = expr->symtree->n.sym;
12684 9 : goto found_ifc;
12685 : }
12686 :
12687 243957 : comp = gfc_get_proc_ptr_comp (expr);
12688 243957 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
12689 389 : && comp)
12690 : {
12691 275 : func_ifc = comp->ts.interface;
12692 275 : goto found_ifc;
12693 : }
12694 :
12695 243682 : if (expr->expr_type == EXPR_COMPCALL)
12696 : {
12697 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
12698 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
12699 0 : goto found_ifc;
12700 : }
12701 :
12702 : return false;
12703 :
12704 9946 : found_ifc:
12705 9946 : gcc_assert (func_ifc->attr.function
12706 : && func_ifc->result != NULL);
12707 9946 : return func_ifc->result->attr.pointer;
12708 : }
12709 :
12710 :
12711 : /* Is the lhs OK for automatic reallocation? */
12712 :
12713 : static bool
12714 267748 : is_scalar_reallocatable_lhs (gfc_expr *expr)
12715 : {
12716 267748 : gfc_ref * ref;
12717 :
12718 : /* An allocatable variable with no reference. */
12719 267748 : if (expr->symtree->n.sym->attr.allocatable
12720 6817 : && !expr->ref)
12721 : return true;
12722 :
12723 : /* All that can be left are allocatable components. However, we do
12724 : not check for allocatable components here because the expression
12725 : could be an allocatable component of a pointer component. */
12726 264945 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
12727 242150 : && expr->symtree->n.sym->ts.type != BT_CLASS)
12728 : return false;
12729 :
12730 : /* Find an allocatable component ref last. */
12731 40304 : for (ref = expr->ref; ref; ref = ref->next)
12732 16553 : if (ref->type == REF_COMPONENT
12733 12233 : && !ref->next
12734 9431 : && ref->u.c.component->attr.allocatable)
12735 : return true;
12736 :
12737 : return false;
12738 : }
12739 :
12740 :
12741 : /* Allocate or reallocate scalar lhs, as necessary. */
12742 :
12743 : static void
12744 3655 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
12745 : tree string_length,
12746 : gfc_expr *expr1,
12747 : gfc_expr *expr2)
12748 :
12749 : {
12750 3655 : tree cond;
12751 3655 : tree tmp;
12752 3655 : tree size;
12753 3655 : tree size_in_bytes;
12754 3655 : tree jump_label1;
12755 3655 : tree jump_label2;
12756 3655 : gfc_se lse;
12757 3655 : gfc_ref *ref;
12758 :
12759 3655 : if (!expr1 || expr1->rank)
12760 0 : return;
12761 :
12762 3655 : if (!expr2 || expr2->rank)
12763 : return;
12764 :
12765 5115 : for (ref = expr1->ref; ref; ref = ref->next)
12766 1460 : if (ref->type == REF_SUBSTRING)
12767 : return;
12768 :
12769 3655 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
12770 :
12771 : /* Since this is a scalar lhs, we can afford to do this. That is,
12772 : there is no risk of side effects being repeated. */
12773 3655 : gfc_init_se (&lse, NULL);
12774 3655 : lse.want_pointer = 1;
12775 3655 : gfc_conv_expr (&lse, expr1);
12776 :
12777 3655 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12778 3655 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12779 :
12780 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
12781 3655 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
12782 3655 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
12783 : lse.expr, tmp);
12784 3655 : tmp = build3_v (COND_EXPR, cond,
12785 : build1_v (GOTO_EXPR, jump_label1),
12786 : build_empty_stmt (input_location));
12787 3655 : gfc_add_expr_to_block (block, tmp);
12788 :
12789 3655 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12790 : {
12791 : /* Use the rhs string length and the lhs element size. Note that 'size' is
12792 : used below for the string-length comparison, only. */
12793 1518 : size = string_length;
12794 1518 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12795 3036 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
12796 1518 : TREE_TYPE (tmp), tmp,
12797 1518 : fold_convert (TREE_TYPE (tmp), size));
12798 : }
12799 : else
12800 : {
12801 : /* Otherwise use the length in bytes of the rhs. */
12802 2137 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
12803 2137 : size_in_bytes = size;
12804 : }
12805 :
12806 3655 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12807 : size_in_bytes, size_one_node);
12808 :
12809 3655 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
12810 : {
12811 32 : tree caf_decl, token;
12812 32 : gfc_se caf_se;
12813 32 : symbol_attribute attr;
12814 :
12815 32 : gfc_clear_attr (&attr);
12816 32 : gfc_init_se (&caf_se, NULL);
12817 :
12818 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
12819 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
12820 : NULL);
12821 32 : gfc_add_block_to_block (block, &caf_se.pre);
12822 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
12823 : gfc_build_addr_expr (NULL_TREE, token),
12824 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
12825 : expr1, 1);
12826 : }
12827 3623 : else if (expr1->ts.type == BT_DERIVED
12828 3623 : && (expr1->ts.u.derived->attr.alloc_comp
12829 220 : || has_parameterized_comps (expr1->ts.u.derived)))
12830 : {
12831 116 : tmp = build_call_expr_loc (input_location,
12832 : builtin_decl_explicit (BUILT_IN_CALLOC),
12833 : 2, build_one_cst (size_type_node),
12834 : size_in_bytes);
12835 116 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12836 116 : gfc_add_modify (block, lse.expr, tmp);
12837 : }
12838 : else
12839 : {
12840 3507 : tmp = build_call_expr_loc (input_location,
12841 : builtin_decl_explicit (BUILT_IN_MALLOC),
12842 : 1, size_in_bytes);
12843 3507 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12844 3507 : gfc_add_modify (block, lse.expr, tmp);
12845 : }
12846 :
12847 3655 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12848 : {
12849 : /* Deferred characters need checking for lhs and rhs string
12850 : length. Other deferred parameter variables will have to
12851 : come here too. */
12852 1518 : tmp = build1_v (GOTO_EXPR, jump_label2);
12853 1518 : gfc_add_expr_to_block (block, tmp);
12854 : }
12855 3655 : tmp = build1_v (LABEL_EXPR, jump_label1);
12856 3655 : gfc_add_expr_to_block (block, tmp);
12857 :
12858 : /* For a deferred length character, reallocate if lengths of lhs and
12859 : rhs are different. */
12860 3655 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12861 : {
12862 1518 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12863 : lse.string_length,
12864 1518 : fold_convert (TREE_TYPE (lse.string_length),
12865 : size));
12866 : /* Jump past the realloc if the lengths are the same. */
12867 1518 : tmp = build3_v (COND_EXPR, cond,
12868 : build1_v (GOTO_EXPR, jump_label2),
12869 : build_empty_stmt (input_location));
12870 1518 : gfc_add_expr_to_block (block, tmp);
12871 1518 : tmp = build_call_expr_loc (input_location,
12872 : builtin_decl_explicit (BUILT_IN_REALLOC),
12873 : 2, fold_convert (pvoid_type_node, lse.expr),
12874 : size_in_bytes);
12875 1518 : tree omp_cond = NULL_TREE;
12876 1518 : if (flag_openmp_allocators)
12877 : {
12878 1 : tree omp_tmp;
12879 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
12880 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
12881 :
12882 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12883 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12884 : fold_convert (pvoid_type_node,
12885 : lse.expr), size_in_bytes,
12886 : build_zero_cst (ptr_type_node),
12887 : build_zero_cst (ptr_type_node));
12888 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
12889 : omp_cond, omp_tmp, tmp);
12890 : }
12891 1518 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12892 1518 : gfc_add_modify (block, lse.expr, tmp);
12893 1518 : if (omp_cond)
12894 1 : gfc_add_expr_to_block (block,
12895 : build3_loc (input_location, COND_EXPR,
12896 : void_type_node, omp_cond,
12897 : gfc_omp_call_add_alloc (lse.expr),
12898 : build_empty_stmt (input_location)));
12899 1518 : tmp = build1_v (LABEL_EXPR, jump_label2);
12900 1518 : gfc_add_expr_to_block (block, tmp);
12901 :
12902 : /* Update the lhs character length. */
12903 1518 : size = string_length;
12904 1518 : gfc_add_modify (block, lse.string_length,
12905 1518 : fold_convert (TREE_TYPE (lse.string_length), size));
12906 : }
12907 : }
12908 :
12909 : /* Check for assignments of the type
12910 :
12911 : a = a + 4
12912 :
12913 : to make sure we do not check for reallocation unnecessarily. */
12914 :
12915 :
12916 : /* Strip parentheses from an expression to get the underlying variable.
12917 : This is needed for self-assignment detection since (a) creates a
12918 : parentheses operator node. */
12919 :
12920 : static gfc_expr *
12921 7973 : strip_parentheses (gfc_expr *expr)
12922 : {
12923 0 : while (expr->expr_type == EXPR_OP
12924 318042 : && expr->value.op.op == INTRINSIC_PARENTHESES)
12925 590 : expr = expr->value.op.op1;
12926 316781 : return expr;
12927 : }
12928 :
12929 :
12930 : static bool
12931 7496 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
12932 : {
12933 7973 : gfc_actual_arglist *a;
12934 7973 : gfc_expr *e1, *e2;
12935 :
12936 : /* Strip parentheses to handle cases like a = (a). */
12937 15997 : expr1 = strip_parentheses (expr1);
12938 7973 : expr2 = strip_parentheses (expr2);
12939 :
12940 7973 : switch (expr2->expr_type)
12941 : {
12942 2176 : case EXPR_VARIABLE:
12943 2176 : return gfc_dep_compare_expr (expr1, expr2) == 0;
12944 :
12945 2839 : case EXPR_FUNCTION:
12946 2839 : if (expr2->value.function.esym
12947 305 : && expr2->value.function.esym->attr.elemental)
12948 : {
12949 75 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12950 : {
12951 74 : e1 = a->expr;
12952 74 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12953 : return false;
12954 : }
12955 : return true;
12956 : }
12957 2777 : else if (expr2->value.function.isym
12958 2520 : && expr2->value.function.isym->elemental)
12959 : {
12960 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12961 : {
12962 322 : e1 = a->expr;
12963 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12964 : return false;
12965 : }
12966 : return true;
12967 : }
12968 :
12969 : break;
12970 :
12971 671 : case EXPR_OP:
12972 671 : switch (expr2->value.op.op)
12973 : {
12974 19 : case INTRINSIC_NOT:
12975 19 : case INTRINSIC_UPLUS:
12976 19 : case INTRINSIC_UMINUS:
12977 19 : case INTRINSIC_PARENTHESES:
12978 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
12979 :
12980 627 : case INTRINSIC_PLUS:
12981 627 : case INTRINSIC_MINUS:
12982 627 : case INTRINSIC_TIMES:
12983 627 : case INTRINSIC_DIVIDE:
12984 627 : case INTRINSIC_POWER:
12985 627 : case INTRINSIC_AND:
12986 627 : case INTRINSIC_OR:
12987 627 : case INTRINSIC_EQV:
12988 627 : case INTRINSIC_NEQV:
12989 627 : case INTRINSIC_EQ:
12990 627 : case INTRINSIC_NE:
12991 627 : case INTRINSIC_GT:
12992 627 : case INTRINSIC_GE:
12993 627 : case INTRINSIC_LT:
12994 627 : case INTRINSIC_LE:
12995 627 : case INTRINSIC_EQ_OS:
12996 627 : case INTRINSIC_NE_OS:
12997 627 : case INTRINSIC_GT_OS:
12998 627 : case INTRINSIC_GE_OS:
12999 627 : case INTRINSIC_LT_OS:
13000 627 : case INTRINSIC_LE_OS:
13001 :
13002 627 : e1 = expr2->value.op.op1;
13003 627 : e2 = expr2->value.op.op2;
13004 :
13005 627 : if (e1->rank == 0 && e2->rank > 0)
13006 : return is_runtime_conformable (expr1, e2);
13007 569 : else if (e1->rank > 0 && e2->rank == 0)
13008 : return is_runtime_conformable (expr1, e1);
13009 169 : else if (e1->rank > 0 && e2->rank > 0)
13010 169 : return is_runtime_conformable (expr1, e1)
13011 169 : && is_runtime_conformable (expr1, e2);
13012 : break;
13013 :
13014 : default:
13015 : break;
13016 :
13017 : }
13018 :
13019 : break;
13020 :
13021 : default:
13022 : break;
13023 : }
13024 : return false;
13025 : }
13026 :
13027 :
13028 : static tree
13029 3319 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
13030 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
13031 : bool class_realloc)
13032 : {
13033 3319 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
13034 3319 : vec<tree, va_gc> *args = NULL;
13035 3319 : bool final_expr;
13036 :
13037 3319 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
13038 3319 : if (final_expr)
13039 : {
13040 473 : if (rse->loop)
13041 226 : gfc_prepend_expr_to_block (&rse->loop->pre,
13042 : gfc_finish_block (&lse->finalblock));
13043 : else
13044 247 : gfc_add_block_to_block (block, &lse->finalblock);
13045 : }
13046 :
13047 : /* Store the old vptr so that dynamic types can be compared for
13048 : reallocation to occur or not. */
13049 3319 : if (class_realloc)
13050 : {
13051 283 : tmp = lse->expr;
13052 283 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13053 0 : tmp = gfc_get_class_from_expr (tmp);
13054 : }
13055 :
13056 3319 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
13057 : &from_len, &rhs_vptr);
13058 3319 : if (rhs_vptr == NULL_TREE)
13059 43 : rhs_vptr = vptr;
13060 :
13061 : /* Generate (re)allocation of the lhs. */
13062 3319 : if (class_realloc)
13063 : {
13064 283 : stmtblock_t alloc, re_alloc;
13065 283 : tree class_han, re, size;
13066 :
13067 283 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13068 283 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
13069 : else
13070 0 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
13071 :
13072 283 : size = gfc_vptr_size_get (rhs_vptr);
13073 :
13074 : /* Take into account _len of unlimited polymorphic entities.
13075 : TODO: handle class(*) allocatable function results on rhs. */
13076 283 : if (UNLIMITED_POLY (rhs))
13077 : {
13078 18 : tree len;
13079 18 : if (rhs->expr_type == EXPR_VARIABLE)
13080 12 : len = trans_get_upoly_len (block, rhs);
13081 : else
13082 6 : len = gfc_class_len_get (tmp);
13083 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13084 : fold_convert (size_type_node, len),
13085 : size_one_node);
13086 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
13087 18 : size, fold_convert (TREE_TYPE (size), len));
13088 18 : }
13089 265 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
13090 27 : size = fold_build2_loc (input_location, MULT_EXPR,
13091 : gfc_charlen_type_node, size,
13092 : rse->string_length);
13093 :
13094 :
13095 283 : tmp = lse->expr;
13096 283 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
13097 283 : ? gfc_class_data_get (tmp) : tmp;
13098 :
13099 283 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
13100 0 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
13101 :
13102 : /* Allocate block. */
13103 283 : gfc_init_block (&alloc);
13104 283 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
13105 :
13106 : /* Reallocate if dynamic types are different. */
13107 283 : gfc_init_block (&re_alloc);
13108 283 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
13109 : {
13110 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
13111 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
13112 : }
13113 : else
13114 : {
13115 256 : tmp = fold_convert (pvoid_type_node, class_han);
13116 256 : re = build_call_expr_loc (input_location,
13117 : builtin_decl_explicit (BUILT_IN_REALLOC),
13118 : 2, tmp, size);
13119 256 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
13120 : tmp, re);
13121 256 : tmp = fold_build2_loc (input_location, NE_EXPR,
13122 : logical_type_node, rhs_vptr, old_vptr);
13123 256 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13124 : tmp, re, build_empty_stmt (input_location));
13125 256 : gfc_add_expr_to_block (&re_alloc, re);
13126 : }
13127 283 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
13128 283 : gfc_finish_block (&re_alloc) :
13129 0 : build_empty_stmt (input_location);
13130 :
13131 : /* Allocate if _data is NULL, reallocate otherwise. */
13132 283 : tmp = fold_build2_loc (input_location, EQ_EXPR,
13133 : logical_type_node, class_han,
13134 : build_int_cst (prvoid_type_node, 0));
13135 283 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13136 : gfc_unlikely (tmp,
13137 : PRED_FORTRAN_FAIL_ALLOC),
13138 : gfc_finish_block (&alloc),
13139 : realloc_expr);
13140 283 : gfc_add_expr_to_block (&lse->pre, tmp);
13141 : }
13142 :
13143 3319 : fcn = gfc_vptr_copy_get (vptr);
13144 :
13145 3319 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
13146 3319 : ? gfc_class_data_get (rse->expr) : rse->expr;
13147 3319 : if (use_vptr_copy)
13148 : {
13149 5584 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13150 524 : || INDIRECT_REF_P (tmp)
13151 403 : || (rhs->ts.type == BT_DERIVED
13152 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13153 0 : && !rhs->ts.u.derived->attr.pointer
13154 0 : && !rhs->ts.u.derived->attr.allocatable)
13155 3454 : || (UNLIMITED_POLY (rhs)
13156 134 : && !CLASS_DATA (rhs)->attr.pointer
13157 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13158 2648 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13159 : else
13160 403 : vec_safe_push (args, tmp);
13161 3051 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13162 3051 : ? gfc_class_data_get (lse->expr) : lse->expr;
13163 5322 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13164 780 : || INDIRECT_REF_P (tmp)
13165 283 : || (lhs->ts.type == BT_DERIVED
13166 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13167 0 : && !lhs->ts.u.derived->attr.pointer
13168 0 : && !lhs->ts.u.derived->attr.allocatable)
13169 3334 : || (UNLIMITED_POLY (lhs)
13170 119 : && !CLASS_DATA (lhs)->attr.pointer
13171 119 : && !CLASS_DATA (lhs)->attr.allocatable))
13172 2768 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13173 : else
13174 283 : vec_safe_push (args, tmp);
13175 :
13176 3051 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13177 :
13178 3051 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13179 : {
13180 406 : tree extcopy;
13181 406 : vec_safe_push (args, from_len);
13182 406 : vec_safe_push (args, to_len);
13183 406 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13184 :
13185 406 : tmp = fold_build2_loc (input_location, GT_EXPR,
13186 : logical_type_node, from_len,
13187 406 : build_zero_cst (TREE_TYPE (from_len)));
13188 406 : return fold_build3_loc (input_location, COND_EXPR,
13189 : void_type_node, tmp,
13190 406 : extcopy, stdcopy);
13191 : }
13192 : else
13193 2645 : return stdcopy;
13194 : }
13195 : else
13196 : {
13197 268 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13198 268 : ? gfc_class_data_get (lse->expr) : lse->expr;
13199 268 : stmtblock_t tblock;
13200 268 : gfc_init_block (&tblock);
13201 268 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13202 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13203 268 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13204 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13205 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13206 268 : gfc_add_modify_loc (input_location, &tblock, rhst,
13207 268 : fold_convert (TREE_TYPE (rhst), tmp));
13208 268 : return gfc_finish_block (&tblock);
13209 : }
13210 : }
13211 :
13212 : bool
13213 310740 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13214 : {
13215 310740 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13216 : return false;
13217 :
13218 32001 : return lhs->symtree->n.sym->assoc
13219 32001 : && lhs->symtree->n.sym->assoc->target == rhs;
13220 : }
13221 :
13222 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13223 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13224 : init_flag indicates initialization expressions and dealloc that no
13225 : deallocate prior assignment is needed (if in doubt, set true).
13226 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13227 : routine instead of a pointer assignment. Alias resolution is only done,
13228 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13229 : where it is known, that newly allocated memory on the lhs can never be
13230 : an alias of the rhs. */
13231 :
13232 : static tree
13233 310740 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13234 : bool dealloc, bool use_vptr_copy, bool may_alias)
13235 : {
13236 310740 : gfc_se lse;
13237 310740 : gfc_se rse;
13238 310740 : gfc_ss *lss;
13239 310740 : gfc_ss *lss_section;
13240 310740 : gfc_ss *rss;
13241 310740 : gfc_loopinfo loop;
13242 310740 : tree tmp;
13243 310740 : stmtblock_t block;
13244 310740 : stmtblock_t body;
13245 310740 : bool final_expr;
13246 310740 : bool l_is_temp;
13247 310740 : bool scalar_to_array;
13248 310740 : tree string_length;
13249 310740 : int n;
13250 310740 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13251 310740 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr, rhs_attr;
13252 310740 : bool is_poly_assign;
13253 310740 : bool realloc_flag;
13254 310740 : bool assoc_assign = false;
13255 310740 : bool dummy_class_array_copy;
13256 :
13257 : /* Assignment of the form lhs = rhs. */
13258 310740 : gfc_start_block (&block);
13259 :
13260 310740 : gfc_init_se (&lse, NULL);
13261 310740 : gfc_init_se (&rse, NULL);
13262 :
13263 310740 : gfc_fix_class_refs (expr1);
13264 :
13265 621480 : realloc_flag = flag_realloc_lhs
13266 304628 : && gfc_is_reallocatable_lhs (expr1)
13267 8307 : && expr2->rank
13268 317576 : && !is_runtime_conformable (expr1, expr2);
13269 :
13270 : /* Walk the lhs. */
13271 310740 : lss = gfc_walk_expr (expr1);
13272 310740 : if (realloc_flag)
13273 : {
13274 6453 : lss->no_bounds_check = 1;
13275 6453 : lss->is_alloc_lhs = 1;
13276 : }
13277 : else
13278 304287 : lss->no_bounds_check = expr1->no_bounds_check;
13279 :
13280 310740 : rss = NULL;
13281 :
13282 310740 : if (expr2->expr_type != EXPR_VARIABLE
13283 310740 : && expr2->expr_type != EXPR_CONSTANT
13284 310740 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13285 : {
13286 894 : expr2->must_finalize = 1;
13287 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13288 : function, the result is finalized after execution of the innermost
13289 : executable construct containing the reference. */
13290 894 : if (expr2->expr_type == EXPR_FUNCTION
13291 894 : && (gfc_expr_attr (expr2).pointer
13292 298 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13293 147 : expr2->must_finalize = 0;
13294 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13295 : structure constructor or array constructor, the entity created by
13296 : the constructor is finalized after execution of the innermost
13297 : executable construct containing the reference.
13298 : These finalizations were later deleted by the Combined Technical
13299 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13300 747 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13301 747 : && (expr2->expr_type == EXPR_STRUCTURE
13302 704 : || expr2->expr_type == EXPR_ARRAY))
13303 387 : expr2->must_finalize = 0;
13304 : }
13305 :
13306 :
13307 : /* Checking whether a class assignment is desired is quite complicated and
13308 : needed at two locations, so do it once only before the information is
13309 : needed. */
13310 310740 : lhs_attr = gfc_expr_attr (expr1);
13311 310740 : rhs_attr = gfc_expr_attr (expr2);
13312 310740 : dummy_class_array_copy
13313 621480 : = (expr2->expr_type == EXPR_VARIABLE
13314 32001 : && expr2->rank > 0
13315 8384 : && expr2->symtree != NULL
13316 8384 : && expr2->symtree->n.sym->attr.dummy
13317 1471 : && expr2->ts.type == BT_CLASS
13318 127 : && !rhs_attr.pointer
13319 127 : && !rhs_attr.allocatable
13320 114 : && !CLASS_DATA (expr2)->attr.class_pointer
13321 310854 : && !CLASS_DATA (expr2)->attr.allocatable);
13322 :
13323 : /* What can be sent to trans_class_assignment includes all the obvious
13324 : candidates but scalar assignment of a class expression to a derived type
13325 : must be done using gfc_trans_scalar_assign; partly because it is simpler
13326 : and partly because some cases fail, eg. class assignment to derived_type
13327 : select type temporaries. */
13328 310740 : is_poly_assign
13329 310740 : = (use_vptr_copy
13330 293717 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13331 22958 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13332 20883 : || gfc_is_class_scalar_expr (expr1)
13333 19572 : || gfc_is_class_array_ref (expr2, NULL)
13334 19572 : || (gfc_is_class_scalar_expr (expr2)
13335 30 : && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
13336 314126 : && lhs_attr.flavor != FL_PROCEDURE;
13337 :
13338 310740 : assoc_assign = is_assoc_assign (expr1, expr2);
13339 :
13340 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13341 : mode. Avoid false-positive uninitialized diagnostics with initializing
13342 : the codimension flag unconditionally. */
13343 310740 : lhs_caf_attr.codimension = false;
13344 310740 : rhs_caf_attr.codimension = false;
13345 310740 : if (flag_coarray == GFC_FCOARRAY_LIB)
13346 : {
13347 6789 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13348 6789 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13349 : }
13350 :
13351 310740 : tree reallocation = NULL_TREE;
13352 310740 : if (lss != gfc_ss_terminator)
13353 : {
13354 : /* The assignment needs scalarization. */
13355 : lss_section = lss;
13356 :
13357 : /* Find a non-scalar SS from the lhs. */
13358 : while (lss_section != gfc_ss_terminator
13359 40223 : && lss_section->info->type != GFC_SS_SECTION)
13360 0 : lss_section = lss_section->next;
13361 :
13362 40223 : gcc_assert (lss_section != gfc_ss_terminator);
13363 :
13364 : /* Initialize the scalarizer. */
13365 40223 : gfc_init_loopinfo (&loop);
13366 :
13367 : /* Walk the rhs. */
13368 40223 : rss = gfc_walk_expr (expr2);
13369 40223 : if (rss == gfc_ss_terminator)
13370 : {
13371 : /* The rhs is scalar. Add a ss for the expression. */
13372 15059 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13373 15059 : lss->is_alloc_lhs = 0;
13374 : }
13375 :
13376 : /* When doing a class assign, then the handle to the rhs needs to be a
13377 : pointer to allow for polymorphism. */
13378 40223 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13379 509 : rss->info->type = GFC_SS_REFERENCE;
13380 :
13381 40223 : rss->no_bounds_check = expr2->no_bounds_check;
13382 : /* Associate the SS with the loop. */
13383 40223 : gfc_add_ss_to_loop (&loop, lss);
13384 40223 : gfc_add_ss_to_loop (&loop, rss);
13385 :
13386 : /* Calculate the bounds of the scalarization. */
13387 40223 : gfc_conv_ss_startstride (&loop);
13388 : /* Enable loop reversal. */
13389 683791 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13390 603345 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13391 : /* Resolve any data dependencies in the statement. */
13392 40223 : if (may_alias)
13393 37938 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13394 : /* Setup the scalarizing loops. */
13395 40223 : gfc_conv_loop_setup (&loop, &expr2->where);
13396 :
13397 : /* Setup the gfc_se structures. */
13398 40223 : gfc_copy_loopinfo_to_se (&lse, &loop);
13399 40223 : gfc_copy_loopinfo_to_se (&rse, &loop);
13400 :
13401 40223 : rse.ss = rss;
13402 40223 : gfc_mark_ss_chain_used (rss, 1);
13403 40223 : if (loop.temp_ss == NULL)
13404 : {
13405 39109 : lse.ss = lss;
13406 39109 : gfc_mark_ss_chain_used (lss, 1);
13407 : }
13408 : else
13409 : {
13410 1114 : lse.ss = loop.temp_ss;
13411 1114 : gfc_mark_ss_chain_used (lss, 3);
13412 1114 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13413 : }
13414 :
13415 : /* Allow the scalarizer to workshare array assignments. */
13416 40223 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13417 : == OMPWS_WORKSHARE_FLAG
13418 85 : && loop.temp_ss == NULL)
13419 : {
13420 73 : maybe_workshare = true;
13421 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13422 : }
13423 :
13424 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13425 40223 : if (realloc_flag)
13426 : {
13427 6453 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13428 6453 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13429 6453 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13430 : expr2);
13431 : }
13432 :
13433 : /* Start the scalarized loop body. */
13434 40223 : gfc_start_scalarized_body (&loop, &body);
13435 : }
13436 : else
13437 270517 : gfc_init_block (&body);
13438 :
13439 310740 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13440 :
13441 : /* Translate the expression. */
13442 621480 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13443 310740 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13444 310740 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13445 310740 : gfc_conv_expr (&rse, expr2);
13446 :
13447 : /* Deal with the case of a scalar class function assigned to a derived type.
13448 : */
13449 310740 : if (gfc_is_alloc_class_scalar_function (expr2)
13450 310740 : && expr1->ts.type == BT_DERIVED)
13451 : {
13452 60 : rse.expr = gfc_class_data_get (rse.expr);
13453 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13454 : }
13455 :
13456 : /* Stabilize a string length for temporaries. */
13457 310740 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13458 24760 : && !(VAR_P (rse.string_length)
13459 : || TREE_CODE (rse.string_length) == PARM_DECL
13460 : || INDIRECT_REF_P (rse.string_length)))
13461 23884 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13462 286856 : else if (expr2->ts.type == BT_CHARACTER)
13463 : {
13464 4388 : if (expr1->ts.deferred
13465 6809 : && gfc_expr_attr (expr1).allocatable
13466 6929 : && gfc_check_dependency (expr1, expr2, true))
13467 120 : rse.string_length =
13468 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13469 4388 : string_length = rse.string_length;
13470 : }
13471 : else
13472 : string_length = NULL_TREE;
13473 :
13474 310740 : if (l_is_temp)
13475 : {
13476 1114 : gfc_conv_tmp_array_ref (&lse);
13477 1114 : if (expr2->ts.type == BT_CHARACTER)
13478 123 : lse.string_length = string_length;
13479 : }
13480 : else
13481 : {
13482 309626 : gfc_conv_expr (&lse, expr1);
13483 : /* For some expression (e.g. complex numbers) fold_convert uses a
13484 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13485 : not updated when assigned to. */
13486 309626 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13487 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13488 :
13489 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13490 315779 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13491 : {
13492 36 : tree cond;
13493 36 : const char* msg;
13494 :
13495 36 : tmp = INDIRECT_REF_P (lse.expr)
13496 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13497 36 : STRIP_NOPS (tmp);
13498 :
13499 : /* We should only get array references here. */
13500 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13501 : || TREE_CODE (tmp) == ARRAY_REF);
13502 :
13503 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13504 : or the array itself(ARRAY_REF). */
13505 36 : tmp = TREE_OPERAND (tmp, 0);
13506 :
13507 : /* Provide the address of the array. */
13508 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13509 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13510 :
13511 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13512 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13513 36 : msg = _("Assignment of scalar to unallocated array");
13514 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13515 : &expr1->where, msg);
13516 : }
13517 :
13518 : /* Deallocate the lhs parameterized components if required. */
13519 309626 : if (dealloc
13520 291026 : && !expr1->symtree->n.sym->attr.associate_var
13521 289045 : && expr2->expr_type != EXPR_ARRAY
13522 283006 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
13523 : {
13524 361 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
13525 :
13526 361 : tmp = lse.expr;
13527 361 : if (pdt_dep)
13528 : {
13529 : /* Create a temporary for deallocation after assignment. */
13530 168 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
13531 168 : gfc_add_modify (&lse.pre, tmp, lse.expr);
13532 : }
13533 :
13534 361 : if (expr1->ts.type == BT_DERIVED)
13535 361 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
13536 : expr1->rank);
13537 0 : else if (expr1->ts.type == BT_CLASS)
13538 : {
13539 0 : tmp = gfc_class_data_get (tmp);
13540 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
13541 : tmp, expr1->rank);
13542 : }
13543 :
13544 361 : if (tmp && pdt_dep)
13545 92 : gfc_add_expr_to_block (&rse.post, tmp);
13546 269 : else if (tmp)
13547 67 : gfc_add_expr_to_block (&lse.pre, tmp);
13548 : }
13549 : }
13550 :
13551 : /* Assignments of scalar derived types with allocatable components
13552 : to arrays must be done with a deep copy and the rhs temporary
13553 : must have its components deallocated afterwards. */
13554 621480 : scalar_to_array = (expr2->ts.type == BT_DERIVED
13555 19633 : && expr2->ts.u.derived->attr.alloc_comp
13556 6790 : && !gfc_expr_is_variable (expr2)
13557 314443 : && expr1->rank && !expr2->rank);
13558 621480 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
13559 19916 : && expr1->rank
13560 3840 : && expr1->ts.u.derived->attr.alloc_comp
13561 312169 : && gfc_is_alloc_class_scalar_function (expr2));
13562 310740 : if (scalar_to_array && dealloc)
13563 : {
13564 59 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
13565 59 : gfc_prepend_expr_to_block (&loop.post, tmp);
13566 : }
13567 :
13568 : /* When assigning a character function result to a deferred-length variable,
13569 : the function call must happen before the (re)allocation of the lhs -
13570 : otherwise the character length of the result is not known.
13571 : NOTE 1: This relies on having the exact dependence of the length type
13572 : parameter available to the caller; gfortran saves it in the .mod files.
13573 : NOTE 2: Vector array references generate an index temporary that must
13574 : not go outside the loop. Otherwise, variables should not generate
13575 : a pre block.
13576 : NOTE 3: The concatenation operation generates a temporary pointer,
13577 : whose allocation must go to the innermost loop.
13578 : NOTE 4: Elemental functions may generate a temporary, too. */
13579 310740 : if (flag_realloc_lhs
13580 304628 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
13581 2984 : && !(lss != gfc_ss_terminator
13582 928 : && rss != gfc_ss_terminator
13583 928 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
13584 741 : || (expr2->expr_type == EXPR_FUNCTION
13585 160 : && expr2->value.function.esym != NULL
13586 26 : && expr2->value.function.esym->attr.elemental)
13587 728 : || (expr2->expr_type == EXPR_FUNCTION
13588 147 : && expr2->value.function.isym != NULL
13589 134 : && expr2->value.function.isym->elemental)
13590 672 : || (expr2->expr_type == EXPR_OP
13591 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
13592 2703 : gfc_add_block_to_block (&block, &rse.pre);
13593 :
13594 : /* Nullify the allocatable components corresponding to those of the lhs
13595 : derived type, so that the finalization of the function result does not
13596 : affect the lhs of the assignment. Prepend is used to ensure that the
13597 : nullification occurs before the call to the finalizer. In the case of
13598 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
13599 : as part of the deep copy. */
13600 309912 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
13601 329828 : && (gfc_is_class_array_function (expr2)
13602 19064 : || gfc_is_alloc_class_scalar_function (expr2)))
13603 : {
13604 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
13605 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
13606 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
13607 0 : gfc_add_block_to_block (&loop.post, &rse.post);
13608 : }
13609 :
13610 310740 : tmp = NULL_TREE;
13611 :
13612 310740 : if (is_poly_assign)
13613 : {
13614 3319 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
13615 3319 : use_vptr_copy || (lhs_attr.allocatable
13616 283 : && !lhs_attr.dimension),
13617 3063 : !realloc_flag && flag_realloc_lhs
13618 3870 : && !lhs_attr.pointer);
13619 3319 : if (expr2->expr_type == EXPR_FUNCTION
13620 220 : && expr2->ts.type == BT_DERIVED
13621 18 : && expr2->ts.u.derived->attr.alloc_comp)
13622 : {
13623 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
13624 : rse.expr, expr2->rank);
13625 18 : if (lss == gfc_ss_terminator)
13626 18 : gfc_add_expr_to_block (&rse.post, tmp2);
13627 : else
13628 0 : gfc_add_expr_to_block (&loop.post, tmp2);
13629 : }
13630 :
13631 3319 : expr1->must_finalize = 0;
13632 : }
13633 307421 : else if (!is_poly_assign
13634 307421 : && expr1->ts.type == BT_CLASS
13635 442 : && expr2->ts.type == BT_CLASS
13636 255 : && (expr2->must_finalize || dummy_class_array_copy))
13637 : {
13638 : /* This case comes about when the scalarizer provides array element
13639 : references to class temporaries or nonpointer dummy arrays. Use the
13640 : vptr copy function, since this does a deep copy of allocatable
13641 : components. */
13642 132 : tmp = gfc_get_vptr_from_expr (rse.expr);
13643 132 : if (tmp == NULL_TREE && dummy_class_array_copy)
13644 12 : tmp = gfc_get_vptr_from_expr (gfc_get_class_from_gfc_expr (expr2));
13645 132 : if (tmp != NULL_TREE)
13646 : {
13647 132 : tree fcn = gfc_vptr_copy_get (tmp);
13648 132 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
13649 132 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
13650 132 : tmp = build_call_expr_loc (input_location,
13651 : fcn, 2,
13652 : gfc_build_addr_expr (NULL, rse.expr),
13653 : gfc_build_addr_expr (NULL, lse.expr));
13654 : }
13655 : }
13656 :
13657 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
13658 : after evaluation of the rhs and before reallocation.
13659 : Skip finalization for self-assignment to avoid use-after-free.
13660 : Strip parentheses from both sides to handle cases like a = (a). */
13661 310740 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
13662 310740 : if (final_expr
13663 666 : && gfc_dep_compare_expr (strip_parentheses (expr1),
13664 : strip_parentheses (expr2)) != 0
13665 311382 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
13666 211 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
13667 : {
13668 642 : if (lss == gfc_ss_terminator)
13669 : {
13670 183 : gfc_add_block_to_block (&block, &rse.pre);
13671 183 : gfc_add_block_to_block (&block, &lse.finalblock);
13672 : }
13673 : else
13674 : {
13675 459 : gfc_add_block_to_block (&body, &rse.pre);
13676 459 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
13677 : &lse.finalblock);
13678 : }
13679 : }
13680 : else
13681 310098 : gfc_add_block_to_block (&body, &rse.pre);
13682 :
13683 310740 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
13684 2994 : && assoc_assign)
13685 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
13686 :
13687 : /* If nothing else works, do it the old fashioned way! */
13688 310740 : if (tmp == NULL_TREE)
13689 : {
13690 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
13691 307289 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
13692 307289 : tmp
13693 307289 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13694 307289 : gfc_expr_is_variable (expr2_stripped)
13695 277029 : || scalar_to_array
13696 583580 : || expr2->expr_type == EXPR_ARRAY,
13697 307289 : !(l_is_temp || init_flag) && dealloc,
13698 307289 : expr1->symtree->n.sym->attr.codimension,
13699 : assoc_assign);
13700 : }
13701 :
13702 : /* Add the lse pre block to the body */
13703 310740 : gfc_add_block_to_block (&body, &lse.pre);
13704 310740 : gfc_add_expr_to_block (&body, tmp);
13705 :
13706 : /* Add the post blocks to the body. Scalar finalization must appear before
13707 : the post block in case any dellocations are done. */
13708 310740 : if (rse.finalblock.head
13709 310740 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
13710 14 : && gfc_expr_attr (expr2).elemental)))
13711 : {
13712 142 : gfc_add_block_to_block (&body, &rse.finalblock);
13713 142 : gfc_add_block_to_block (&body, &rse.post);
13714 : }
13715 : else
13716 310598 : gfc_add_block_to_block (&body, &rse.post);
13717 :
13718 310740 : gfc_add_block_to_block (&body, &lse.post);
13719 :
13720 310740 : if (lss == gfc_ss_terminator)
13721 : {
13722 : /* F2003: Add the code for reallocation on assignment. */
13723 267748 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
13724 274172 : && !is_poly_assign)
13725 3655 : alloc_scalar_allocatable_for_assignment (&block, string_length,
13726 : expr1, expr2);
13727 :
13728 : /* Use the scalar assignment as is. */
13729 270517 : gfc_add_block_to_block (&block, &body);
13730 : }
13731 : else
13732 : {
13733 40223 : gcc_assert (lse.ss == gfc_ss_terminator
13734 : && rse.ss == gfc_ss_terminator);
13735 :
13736 40223 : if (l_is_temp)
13737 : {
13738 1114 : gfc_trans_scalarized_loop_boundary (&loop, &body);
13739 :
13740 : /* We need to copy the temporary to the actual lhs. */
13741 1114 : gfc_init_se (&lse, NULL);
13742 1114 : gfc_init_se (&rse, NULL);
13743 1114 : gfc_copy_loopinfo_to_se (&lse, &loop);
13744 1114 : gfc_copy_loopinfo_to_se (&rse, &loop);
13745 :
13746 1114 : rse.ss = loop.temp_ss;
13747 1114 : lse.ss = lss;
13748 :
13749 1114 : gfc_conv_tmp_array_ref (&rse);
13750 1114 : gfc_conv_expr (&lse, expr1);
13751 :
13752 1114 : gcc_assert (lse.ss == gfc_ss_terminator
13753 : && rse.ss == gfc_ss_terminator);
13754 :
13755 1114 : if (expr2->ts.type == BT_CHARACTER)
13756 123 : rse.string_length = string_length;
13757 :
13758 1114 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13759 : false, dealloc);
13760 1114 : gfc_add_expr_to_block (&body, tmp);
13761 : }
13762 :
13763 40223 : if (reallocation != NULL_TREE)
13764 6453 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
13765 :
13766 40223 : if (maybe_workshare)
13767 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
13768 :
13769 : /* Generate the copying loops. */
13770 40223 : gfc_trans_scalarizing_loops (&loop, &body);
13771 :
13772 : /* Wrap the whole thing up. */
13773 40223 : gfc_add_block_to_block (&block, &loop.pre);
13774 40223 : gfc_add_block_to_block (&block, &loop.post);
13775 :
13776 40223 : gfc_cleanup_loop (&loop);
13777 : }
13778 :
13779 : /* Since parameterized components cannot have default initializers,
13780 : the default PDT constructor leaves them unallocated. Do the
13781 : allocation now. */
13782 310740 : if (init_flag && IS_PDT (expr1)
13783 359 : && !expr1->symtree->n.sym->attr.allocatable
13784 359 : && !expr1->symtree->n.sym->attr.dummy)
13785 : {
13786 73 : gfc_symbol *sym = expr1->symtree->n.sym;
13787 73 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
13788 : sym->backend_decl,
13789 73 : sym->as ? sym->as->rank : 0,
13790 73 : sym->param_list);
13791 73 : gfc_add_expr_to_block (&block, tmp);
13792 : }
13793 :
13794 310740 : return gfc_finish_block (&block);
13795 : }
13796 :
13797 :
13798 : /* Check whether EXPR is a copyable array. */
13799 :
13800 : static bool
13801 984857 : copyable_array_p (gfc_expr * expr)
13802 : {
13803 984857 : if (expr->expr_type != EXPR_VARIABLE)
13804 : return false;
13805 :
13806 : /* First check it's an array. */
13807 960947 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
13808 : return false;
13809 :
13810 148408 : if (!gfc_full_array_ref_p (expr->ref, NULL))
13811 : return false;
13812 :
13813 : /* Next check that it's of a simple enough type. */
13814 116810 : switch (expr->ts.type)
13815 : {
13816 : case BT_INTEGER:
13817 : case BT_REAL:
13818 : case BT_COMPLEX:
13819 : case BT_LOGICAL:
13820 : return true;
13821 :
13822 : case BT_CHARACTER:
13823 : return false;
13824 :
13825 6722 : case_bt_struct:
13826 6722 : return (!expr->ts.u.derived->attr.alloc_comp
13827 6722 : && !expr->ts.u.derived->attr.pdt_type);
13828 :
13829 : default:
13830 : break;
13831 : }
13832 :
13833 : return false;
13834 : }
13835 :
13836 : /* Translate an assignment. */
13837 :
13838 : tree
13839 328689 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13840 : bool dealloc, bool use_vptr_copy, bool may_alias)
13841 : {
13842 328689 : tree tmp;
13843 :
13844 : /* Special case a single function returning an array. */
13845 328689 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
13846 : {
13847 14518 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
13848 14518 : if (tmp)
13849 : return tmp;
13850 : }
13851 :
13852 : /* Special case assigning an array to zero. */
13853 321816 : if (copyable_array_p (expr1)
13854 321816 : && is_zero_initializer_p (expr2))
13855 : {
13856 3964 : tmp = gfc_trans_zero_assign (expr1);
13857 3964 : if (tmp)
13858 : return tmp;
13859 : }
13860 :
13861 : /* Special case copying one array to another. */
13862 318131 : if (copyable_array_p (expr1)
13863 28265 : && copyable_array_p (expr2)
13864 2699 : && gfc_compare_types (&expr1->ts, &expr2->ts)
13865 320830 : && !gfc_check_dependency (expr1, expr2, 0))
13866 : {
13867 2603 : tmp = gfc_trans_array_copy (expr1, expr2);
13868 2603 : if (tmp)
13869 : return tmp;
13870 : }
13871 :
13872 : /* Special case initializing an array from a constant array constructor. */
13873 316645 : if (copyable_array_p (expr1)
13874 26779 : && expr2->expr_type == EXPR_ARRAY
13875 324901 : && gfc_compare_types (&expr1->ts, &expr2->ts))
13876 : {
13877 8256 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
13878 8256 : if (tmp)
13879 : return tmp;
13880 : }
13881 :
13882 310740 : if (UNLIMITED_POLY (expr1) && expr1->rank)
13883 310740 : use_vptr_copy = true;
13884 :
13885 : /* Fallback to the scalarizer to generate explicit loops. */
13886 310740 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
13887 310740 : use_vptr_copy, may_alias);
13888 : }
13889 :
13890 : tree
13891 13182 : gfc_trans_init_assign (gfc_code * code)
13892 : {
13893 13182 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
13894 : }
13895 :
13896 : tree
13897 307094 : gfc_trans_assign (gfc_code * code)
13898 : {
13899 307094 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
13900 : }
13901 :
13902 : /* Generate a simple loop for internal use of the form
13903 : for (var = begin; var <cond> end; var += step)
13904 : body; */
13905 : void
13906 12171 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
13907 : enum tree_code cond, tree step, tree body)
13908 : {
13909 12171 : tree tmp;
13910 :
13911 : /* var = begin. */
13912 12171 : gfc_add_modify (block, var, begin);
13913 :
13914 : /* Loop: for (var = begin; var <cond> end; var += step). */
13915 12171 : tree label_loop = gfc_build_label_decl (NULL_TREE);
13916 12171 : tree label_cond = gfc_build_label_decl (NULL_TREE);
13917 12171 : TREE_USED (label_loop) = 1;
13918 12171 : TREE_USED (label_cond) = 1;
13919 :
13920 12171 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
13921 12171 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
13922 :
13923 : /* Loop body. */
13924 12171 : gfc_add_expr_to_block (block, body);
13925 :
13926 : /* End of loop body. */
13927 12171 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
13928 12171 : gfc_add_modify (block, var, tmp);
13929 12171 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
13930 12171 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
13931 12171 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
13932 : build_empty_stmt (input_location));
13933 12171 : gfc_add_expr_to_block (block, tmp);
13934 12171 : }
|
