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 36510 : gfc_get_character_len (tree type)
53 : {
54 36510 : tree len;
55 :
56 36510 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
57 : && TYPE_STRING_FLAG (type));
58 :
59 36510 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
60 36510 : len = (len) ? (len) : (integer_zero_node);
61 36510 : 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 36510 : gfc_get_character_len_in_bytes (tree type)
70 : {
71 36510 : tree tmp, len;
72 :
73 36510 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
74 : && TYPE_STRING_FLAG (type));
75 :
76 36510 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
77 73020 : tmp = (tmp && !integer_zerop (tmp))
78 73020 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
79 36510 : len = gfc_get_character_len (type);
80 36510 : if (tmp && len && !integer_zerop (len))
81 35696 : len = fold_build2_loc (input_location, MULT_EXPR,
82 : gfc_charlen_type_node, len, tmp);
83 36510 : return len;
84 : }
85 :
86 :
87 : tree
88 6441 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
89 : {
90 6441 : tree desc, type;
91 :
92 6441 : type = gfc_get_scalar_to_descriptor_type (TREE_TYPE (scalar), attr);
93 6441 : desc = gfc_create_var (type, "desc");
94 6441 : DECL_ARTIFICIAL (desc) = 1;
95 :
96 6441 : if (CONSTANT_CLASS_P (scalar))
97 : {
98 0 : tree tmp;
99 0 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
100 0 : gfc_add_modify (&se->pre, tmp, scalar);
101 0 : scalar = tmp;
102 : }
103 :
104 6441 : gfc_set_descriptor_from_scalar (&se->pre, desc, scalar);
105 :
106 : /* Copy pointer address back - but only if it could have changed and
107 : if the actual argument is a pointer and not, e.g., NULL(). */
108 6441 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
109 2350 : gfc_add_modify (&se->post, scalar,
110 1175 : fold_convert (TREE_TYPE (scalar),
111 : gfc_conv_descriptor_data_get (desc)));
112 6441 : return desc;
113 : }
114 :
115 :
116 : /* Get the coarray token from the ultimate array or component ref.
117 : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
118 :
119 : tree
120 566 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
121 : {
122 566 : gfc_symbol *sym = expr->symtree->n.sym;
123 1132 : bool is_coarray = sym->ts.type == BT_CLASS
124 566 : ? CLASS_DATA (sym)->attr.codimension
125 517 : : sym->attr.codimension;
126 566 : gfc_expr *caf_expr = gfc_copy_expr (expr);
127 566 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
128 :
129 1748 : while (ref)
130 : {
131 1182 : if (ref->type == REF_COMPONENT
132 435 : && (ref->u.c.component->attr.allocatable
133 104 : || ref->u.c.component->attr.pointer)
134 433 : && (is_coarray || ref->u.c.component->attr.codimension))
135 1182 : last_caf_ref = ref;
136 1182 : ref = ref->next;
137 : }
138 :
139 566 : if (last_caf_ref == NULL)
140 : {
141 216 : gfc_free_expr (caf_expr);
142 216 : return NULL_TREE;
143 : }
144 :
145 143 : tree comp = last_caf_ref->u.c.component->caf_token
146 350 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
147 : : NULL_TREE,
148 : caf;
149 350 : gfc_se se;
150 350 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
151 350 : if (comp == NULL_TREE && comp_ref)
152 : {
153 62 : gfc_free_expr (caf_expr);
154 62 : return NULL_TREE;
155 : }
156 288 : gfc_init_se (&se, outerse);
157 288 : gfc_free_ref_list (last_caf_ref->next);
158 288 : last_caf_ref->next = NULL;
159 288 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
160 576 : caf_expr->corank = last_caf_ref->u.c.component->as
161 288 : ? last_caf_ref->u.c.component->as->corank
162 : : expr->corank;
163 288 : se.want_pointer = comp_ref;
164 288 : gfc_conv_expr (&se, caf_expr);
165 288 : gfc_add_block_to_block (&outerse->pre, &se.pre);
166 :
167 288 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
168 143 : se.expr = TREE_OPERAND (se.expr, 0);
169 288 : gfc_free_expr (caf_expr);
170 :
171 288 : if (comp_ref)
172 143 : caf = fold_build3_loc (input_location, COMPONENT_REF,
173 143 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
174 : else
175 145 : caf = gfc_conv_descriptor_token (se.expr);
176 288 : return gfc_build_addr_expr (NULL_TREE, caf);
177 : }
178 :
179 :
180 : /* This is the seed for an eventual trans-class.c
181 :
182 : The following parameters should not be used directly since they might
183 : in future implementations. Use the corresponding APIs. */
184 : #define CLASS_DATA_FIELD 0
185 : #define CLASS_VPTR_FIELD 1
186 : #define CLASS_LEN_FIELD 2
187 : #define VTABLE_HASH_FIELD 0
188 : #define VTABLE_SIZE_FIELD 1
189 : #define VTABLE_EXTENDS_FIELD 2
190 : #define VTABLE_DEF_INIT_FIELD 3
191 : #define VTABLE_COPY_FIELD 4
192 : #define VTABLE_FINAL_FIELD 5
193 : #define VTABLE_DEALLOCATE_FIELD 6
194 :
195 :
196 : tree
197 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
198 : {
199 40 : tree tmp;
200 40 : tree field;
201 40 : vec<constructor_elt, va_gc> *init = NULL;
202 :
203 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
204 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
205 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
206 :
207 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
208 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
209 :
210 40 : return build_constructor (TREE_TYPE (decl), init);
211 : }
212 :
213 :
214 : tree
215 33838 : gfc_class_data_get (tree decl)
216 : {
217 33838 : tree data;
218 33838 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
219 5603 : decl = build_fold_indirect_ref_loc (input_location, decl);
220 33838 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
221 : CLASS_DATA_FIELD);
222 33838 : return fold_build3_loc (input_location, COMPONENT_REF,
223 33838 : TREE_TYPE (data), decl, data,
224 33838 : NULL_TREE);
225 : }
226 :
227 :
228 : tree
229 47927 : gfc_class_vptr_get (tree decl)
230 : {
231 47927 : tree vptr;
232 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
233 : then available through the saved descriptor. */
234 29335 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
235 49949 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
236 1351 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
237 47927 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
238 2417 : decl = build_fold_indirect_ref_loc (input_location, decl);
239 47927 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
240 : CLASS_VPTR_FIELD);
241 47927 : return fold_build3_loc (input_location, COMPONENT_REF,
242 47927 : TREE_TYPE (vptr), decl, vptr,
243 47927 : NULL_TREE);
244 : }
245 :
246 :
247 : tree
248 7309 : gfc_class_len_get (tree decl)
249 : {
250 7309 : tree len;
251 : /* For class arrays decl may be a temporary descriptor handle, the len is
252 : then available through the saved descriptor. */
253 5183 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
254 7612 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
255 127 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
256 7309 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
257 716 : decl = build_fold_indirect_ref_loc (input_location, decl);
258 7309 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
259 : CLASS_LEN_FIELD);
260 7309 : return fold_build3_loc (input_location, COMPONENT_REF,
261 7309 : TREE_TYPE (len), decl, len,
262 7309 : NULL_TREE);
263 : }
264 :
265 :
266 : /* Try to get the _len component of a class. When the class is not unlimited
267 : poly, i.e. no _len field exists, then return a zero node. */
268 :
269 : static tree
270 8628 : gfc_class_len_or_zero_get (tree decl)
271 : {
272 8628 : tree len;
273 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
274 : then available through the saved descriptor. */
275 4291 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
276 8802 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
277 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
278 8628 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
279 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
280 8628 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
281 : CLASS_LEN_FIELD);
282 11125 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
283 2497 : TREE_TYPE (len), decl, len,
284 : NULL_TREE)
285 6131 : : build_zero_cst (gfc_charlen_type_node);
286 : }
287 :
288 :
289 : tree
290 8446 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
291 : {
292 8446 : tree tmp;
293 8446 : tree tmp2;
294 8446 : tree type;
295 :
296 8446 : tmp = gfc_class_len_or_zero_get (class_expr);
297 :
298 : /* Include the len value in the element size if present. */
299 8446 : if (!integer_zerop (tmp))
300 : {
301 2315 : type = TREE_TYPE (size);
302 2315 : if (block)
303 : {
304 1092 : size = gfc_evaluate_now (size, block);
305 1092 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
306 : }
307 : else
308 1223 : tmp = fold_convert (type , tmp);
309 2315 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
310 : type, size, tmp);
311 2315 : tmp = fold_build2_loc (input_location, GT_EXPR,
312 : logical_type_node, tmp,
313 : build_zero_cst (type));
314 2315 : size = fold_build3_loc (input_location, COND_EXPR,
315 : type, tmp, tmp2, size);
316 : }
317 : else
318 : return size;
319 :
320 2315 : if (block)
321 1092 : size = gfc_evaluate_now (size, block);
322 :
323 : return size;
324 : }
325 :
326 :
327 : /* Get the specified FIELD from the VPTR. */
328 :
329 : static tree
330 22469 : vptr_field_get (tree vptr, int fieldno)
331 : {
332 22469 : tree field;
333 22469 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
334 22469 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
335 : fieldno);
336 22469 : field = fold_build3_loc (input_location, COMPONENT_REF,
337 22469 : TREE_TYPE (field), vptr, field,
338 : NULL_TREE);
339 22469 : gcc_assert (field);
340 22469 : return field;
341 : }
342 :
343 :
344 : /* Get the field from the class' vptr. */
345 :
346 : static tree
347 10416 : class_vtab_field_get (tree decl, int fieldno)
348 : {
349 10416 : tree vptr;
350 10416 : vptr = gfc_class_vptr_get (decl);
351 10416 : return vptr_field_get (vptr, fieldno);
352 : }
353 :
354 :
355 : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
356 : unison. */
357 : #define VTAB_GET_FIELD_GEN(name, field) tree \
358 : gfc_class_vtab_## name ##_get (tree cl) \
359 : { \
360 : return class_vtab_field_get (cl, field); \
361 : } \
362 : \
363 : tree \
364 : gfc_vptr_## name ##_get (tree vptr) \
365 : { \
366 : return vptr_field_get (vptr, field); \
367 : }
368 :
369 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
370 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
371 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
372 4660 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
373 1926 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
374 1089 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
375 : #undef VTAB_GET_FIELD_GEN
376 :
377 : /* The size field is returned as an array index type. Therefore treat
378 : it and only it specially. */
379 :
380 : tree
381 8288 : gfc_class_vtab_size_get (tree cl)
382 : {
383 8288 : tree size;
384 8288 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
385 : /* Always return size as an array index type. */
386 8288 : size = fold_convert (gfc_array_index_type, size);
387 8288 : gcc_assert (size);
388 8288 : return size;
389 : }
390 :
391 : tree
392 6323 : gfc_vptr_size_get (tree vptr)
393 : {
394 6323 : tree size;
395 6323 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
396 : /* Always return size as an array index type. */
397 6323 : size = fold_convert (gfc_array_index_type, size);
398 6323 : gcc_assert (size);
399 6323 : return size;
400 : }
401 :
402 :
403 : #undef CLASS_DATA_FIELD
404 : #undef CLASS_VPTR_FIELD
405 : #undef CLASS_LEN_FIELD
406 : #undef VTABLE_HASH_FIELD
407 : #undef VTABLE_SIZE_FIELD
408 : #undef VTABLE_EXTENDS_FIELD
409 : #undef VTABLE_DEF_INIT_FIELD
410 : #undef VTABLE_COPY_FIELD
411 : #undef VTABLE_FINAL_FIELD
412 :
413 :
414 : /* IF ts is null (default), search for the last _class ref in the chain
415 : of references of the expression and cut the chain there. Although
416 : this routine is similar to class.cc:gfc_add_component_ref (), there
417 : is a significant difference: gfc_add_component_ref () concentrates
418 : on an array ref that is the last ref in the chain and is oblivious
419 : to the kind of refs following.
420 : ELSE IF ts is non-null the cut is at the class entity or component
421 : that is followed by an array reference, which is not an element.
422 : These calls come from trans-array.cc:build_class_array_ref, which
423 : handles scalarized class array references.*/
424 :
425 : gfc_expr *
426 10202 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
427 : gfc_typespec **ts)
428 : {
429 10202 : gfc_expr *base_expr;
430 10202 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
431 :
432 : /* Find the last class reference. */
433 10202 : class_ref = NULL;
434 10202 : array_ref = NULL;
435 :
436 10202 : if (ts)
437 : {
438 483 : if (e->symtree
439 458 : && e->symtree->n.sym->ts.type == BT_CLASS)
440 458 : *ts = &e->symtree->n.sym->ts;
441 : else
442 25 : *ts = NULL;
443 : }
444 :
445 25561 : for (ref = e->ref; ref; ref = ref->next)
446 : {
447 15827 : if (ts)
448 : {
449 1140 : if (ref->type == REF_COMPONENT
450 544 : && ref->u.c.component->ts.type == BT_CLASS
451 0 : && ref->next && ref->next->type == REF_COMPONENT
452 0 : && !strcmp (ref->next->u.c.component->name, "_data")
453 0 : && ref->next->next
454 0 : && ref->next->next->type == REF_ARRAY
455 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
456 : {
457 0 : *ts = &ref->u.c.component->ts;
458 0 : class_ref = ref;
459 0 : break;
460 : }
461 :
462 1140 : if (ref->next == NULL)
463 : break;
464 : }
465 : else
466 : {
467 14687 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
468 14687 : array_ref = ref;
469 :
470 14687 : if (ref->type == REF_COMPONENT
471 8847 : && ref->u.c.component->ts.type == BT_CLASS)
472 : {
473 : /* Component to the right of a part reference with nonzero
474 : rank must not have the ALLOCATABLE attribute. If attempts
475 : are made to reference such a component reference, an error
476 : results followed by an ICE. */
477 1733 : if (array_ref
478 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
479 : return NULL;
480 : class_ref = ref;
481 : }
482 : }
483 : }
484 :
485 10192 : if (ts && *ts == NULL)
486 : return NULL;
487 :
488 : /* Remove and store all subsequent references after the
489 : CLASS reference. */
490 10167 : if (class_ref)
491 : {
492 1531 : tail = class_ref->next;
493 1531 : class_ref->next = NULL;
494 : }
495 8636 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
496 : {
497 8636 : tail = e->ref;
498 8636 : e->ref = NULL;
499 : }
500 :
501 10167 : if (is_mold)
502 61 : base_expr = gfc_expr_to_initialize (e);
503 : else
504 10106 : base_expr = gfc_copy_expr (e);
505 :
506 : /* Restore the original tail expression. */
507 10167 : if (class_ref)
508 : {
509 1531 : gfc_free_ref_list (class_ref->next);
510 1531 : class_ref->next = tail;
511 : }
512 8636 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
513 : {
514 8636 : gfc_free_ref_list (e->ref);
515 8636 : e->ref = tail;
516 : }
517 : return base_expr;
518 : }
519 :
520 : /* Reset the vptr to the declared type, e.g. after deallocation.
521 : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
522 : one with e or class_type. At least one of the two has to be set. The
523 : generated assignment code is added at the end of BLOCK. */
524 :
525 : void
526 11687 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
527 : gfc_symbol *class_type)
528 : {
529 11687 : tree vptr = NULL_TREE;
530 :
531 11687 : if (class_container != NULL_TREE)
532 6932 : vptr = gfc_get_vptr_from_expr (class_container);
533 :
534 6932 : if (vptr == NULL_TREE)
535 : {
536 4762 : gfc_se se;
537 4762 : gcc_assert (e);
538 :
539 : /* Evaluate the expression and obtain the vptr from it. */
540 4762 : gfc_init_se (&se, NULL);
541 4762 : if (e->rank)
542 2354 : gfc_conv_expr_descriptor (&se, e);
543 : else
544 2408 : gfc_conv_expr (&se, e);
545 4762 : gfc_add_block_to_block (block, &se.pre);
546 :
547 4762 : vptr = gfc_get_vptr_from_expr (se.expr);
548 : }
549 :
550 : /* If a vptr is not found, we can do nothing more. */
551 4762 : if (vptr == NULL_TREE)
552 : return;
553 :
554 11677 : if (UNLIMITED_POLY (e)
555 10581 : || UNLIMITED_POLY (class_type)
556 : /* When the class_type's source is not a symbol (e.g. a component's ts),
557 : then look at the _data-components type. */
558 1607 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
559 1607 : && class_type->components && class_type->components->ts.u.derived
560 1601 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
561 1282 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
562 : else
563 : {
564 10395 : gfc_symbol *vtab, *type = nullptr;
565 10395 : tree vtable;
566 :
567 10395 : if (e)
568 8974 : type = e->ts.u.derived;
569 1421 : else if (class_type)
570 : {
571 1421 : if (class_type->ts.type == BT_CLASS)
572 0 : type = CLASS_DATA (class_type)->ts.u.derived;
573 : else
574 : type = class_type;
575 : }
576 8974 : gcc_assert (type);
577 : /* Return the vptr to the address of the declared type. */
578 10395 : vtab = gfc_find_derived_vtab (type);
579 10395 : vtable = vtab->backend_decl;
580 10395 : if (vtable == NULL_TREE)
581 100 : vtable = gfc_get_symbol_decl (vtab);
582 10395 : vtable = gfc_build_addr_expr (NULL, vtable);
583 10395 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
584 10395 : gfc_add_modify (block, vptr, vtable);
585 : }
586 : }
587 :
588 : /* Set the vptr of a class in to from the type given in from. If from is NULL,
589 : then reset the vptr to the default or to. */
590 :
591 : void
592 234 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
593 : {
594 234 : tree tmp, vptr_ref;
595 234 : gfc_symbol *type;
596 :
597 234 : vptr_ref = gfc_get_vptr_from_expr (to);
598 276 : if (POINTER_TYPE_P (TREE_TYPE (from))
599 234 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
600 : {
601 44 : gfc_add_modify (block, vptr_ref,
602 22 : fold_convert (TREE_TYPE (vptr_ref),
603 : gfc_get_vptr_from_expr (from)));
604 256 : return;
605 : }
606 212 : tmp = gfc_get_vptr_from_expr (from);
607 212 : if (tmp)
608 : {
609 170 : gfc_add_modify (block, vptr_ref,
610 170 : fold_convert (TREE_TYPE (vptr_ref), tmp));
611 170 : return;
612 : }
613 42 : if (VAR_P (from)
614 42 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
615 : {
616 42 : gfc_add_modify (block, vptr_ref,
617 42 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
618 42 : return;
619 : }
620 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
621 0 : && GFC_CLASS_TYPE_P (
622 : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
623 : {
624 0 : gfc_add_modify (block, vptr_ref,
625 0 : fold_convert (TREE_TYPE (vptr_ref),
626 : gfc_get_vptr_from_expr (TREE_OPERAND (
627 : TREE_OPERAND (from, 0), 0))));
628 0 : return;
629 : }
630 :
631 : /* If nothing of the above matches, set the vtype according to the type. */
632 0 : tmp = TREE_TYPE (from);
633 0 : if (POINTER_TYPE_P (tmp))
634 0 : tmp = TREE_TYPE (tmp);
635 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
636 : &type);
637 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
638 0 : gcc_assert (tmp);
639 0 : gfc_add_modify (block, vptr_ref,
640 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
641 : }
642 :
643 : /* Reset the len for unlimited polymorphic objects. */
644 :
645 : void
646 663 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
647 : {
648 663 : gfc_expr *e;
649 663 : gfc_se se_len;
650 663 : e = gfc_find_and_cut_at_last_class_ref (expr);
651 663 : if (e == NULL)
652 : return;
653 663 : gfc_add_len_component (e);
654 663 : gfc_init_se (&se_len, NULL);
655 663 : gfc_conv_expr (&se_len, e);
656 663 : gfc_add_modify (block, se_len.expr,
657 663 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
658 663 : gfc_free_expr (e);
659 : }
660 :
661 :
662 : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
663 : reference is found. Note that it is up to the caller to avoid using this
664 : for expressions other than variables. */
665 :
666 : tree
667 1595 : gfc_get_class_from_gfc_expr (gfc_expr *e)
668 : {
669 1595 : gfc_expr *class_expr;
670 1595 : gfc_se cse;
671 1595 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
672 1595 : if (class_expr == NULL)
673 : return NULL_TREE;
674 1595 : gfc_init_se (&cse, NULL);
675 1595 : gfc_conv_expr (&cse, class_expr);
676 1595 : gfc_free_expr (class_expr);
677 1595 : return cse.expr;
678 : }
679 :
680 :
681 : /* Obtain the last class reference in an expression.
682 : Return NULL_TREE if no class reference is found. */
683 :
684 : tree
685 111650 : gfc_get_class_from_expr (tree expr)
686 : {
687 111650 : tree tmp;
688 111650 : tree type;
689 111650 : bool array_descr_found = false;
690 111650 : bool comp_after_descr_found = false;
691 :
692 287410 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
693 : {
694 287410 : if (CONSTANT_CLASS_P (tmp))
695 : return NULL_TREE;
696 :
697 287373 : type = TREE_TYPE (tmp);
698 333089 : while (type)
699 : {
700 325049 : if (GFC_CLASS_TYPE_P (type))
701 : return tmp;
702 304351 : if (GFC_DESCRIPTOR_TYPE_P (type))
703 36307 : array_descr_found = true;
704 304351 : if (type != TYPE_CANONICAL (type))
705 45716 : type = TYPE_CANONICAL (type);
706 : else
707 : type = NULL_TREE;
708 : }
709 266675 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
710 : break;
711 :
712 : /* Avoid walking up the reference chain too far. For class arrays, the
713 : array descriptor is a direct component (through a pointer) of the class
714 : container. So there is exactly one COMPONENT_REF between a class
715 : container and its child array descriptor. After seeing an array
716 : descriptor, we can give up on the second COMPONENT_REF we see, if no
717 : class container was found until that point. */
718 175760 : if (array_descr_found)
719 : {
720 7680 : if (comp_after_descr_found)
721 : {
722 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
723 : return NULL_TREE;
724 : }
725 7668 : else if (TREE_CODE (tmp) == COMPONENT_REF)
726 7680 : comp_after_descr_found = true;
727 : }
728 : }
729 :
730 90915 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
731 61089 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
732 :
733 90915 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
734 20 : return tmp;
735 :
736 : return NULL_TREE;
737 : }
738 :
739 :
740 : /* Obtain the vptr of the last class reference in an expression.
741 : Return NULL_TREE if no class reference is found. */
742 :
743 : tree
744 12354 : gfc_get_vptr_from_expr (tree expr)
745 : {
746 12354 : tree tmp;
747 :
748 12354 : tmp = gfc_get_class_from_expr (expr);
749 :
750 12354 : if (tmp != NULL_TREE)
751 12283 : return gfc_class_vptr_get (tmp);
752 :
753 : return NULL_TREE;
754 : }
755 :
756 : void
757 1977 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
758 : bool lhs_type)
759 : {
760 1977 : tree lhs_dim, rhs_dim, type;
761 :
762 1977 : gfc_conv_descriptor_data_set (block, lhs_desc,
763 : gfc_conv_descriptor_data_get (rhs_desc));
764 1977 : gfc_conv_descriptor_offset_set (block, lhs_desc,
765 : gfc_conv_descriptor_offset_get (rhs_desc));
766 :
767 1977 : gfc_conv_descriptor_dtype_set (block, lhs_desc,
768 : gfc_conv_descriptor_dtype_get (rhs_desc));
769 1977 : gfc_conv_descriptor_span_set (block, lhs_desc,
770 : gfc_conv_descriptor_span_get (rhs_desc));
771 :
772 : /* Assign the dimension as range-ref. */
773 1977 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
774 1977 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
775 :
776 1977 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
777 1977 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
778 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
779 1977 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
780 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
781 1977 : gfc_add_modify (block, lhs_dim, rhs_dim);
782 :
783 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
784 1977 : gfc_copy_coarray_desc_part (block, lhs_desc, rhs_desc);
785 1977 : }
786 :
787 : /* Takes a derived type expression and returns the address of a temporary
788 : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
789 : used for the temporary class object.
790 : optional_alloc_ptr is false when the dummy is neither allocatable
791 : nor a pointer; that's only relevant for the optional handling.
792 : The optional argument 'derived_array' is used to preserve the parmse
793 : expression for deallocation of allocatable components. Assumed rank
794 : formal arguments made this necessary. */
795 : void
796 5331 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
797 : tree opt_vptr_src, bool optional,
798 : bool optional_alloc_ptr, const char *proc_name,
799 : tree *derived_array)
800 : {
801 5331 : tree cond_optional = NULL_TREE;
802 5331 : gfc_ss *ss;
803 5331 : tree ctree;
804 5331 : tree var;
805 5331 : tree tmp;
806 5331 : tree packed = NULL_TREE;
807 :
808 : /* The derived type needs to be converted to a temporary CLASS object. */
809 5331 : tmp = gfc_typenode_for_spec (&fsym->ts);
810 5331 : var = gfc_create_var (tmp, "class");
811 :
812 : /* Set the vptr. */
813 5331 : if (opt_vptr_src)
814 128 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
815 : else
816 5203 : gfc_reset_vptr (&parmse->pre, e, var);
817 :
818 : /* Now set the data field. */
819 5331 : ctree = gfc_class_data_get (var);
820 :
821 5331 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
822 : {
823 4 : tree token;
824 4 : tmp = gfc_get_tree_for_caf_expr (e);
825 4 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
826 2 : tmp = build_fold_indirect_ref (tmp);
827 4 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
828 4 : gfc_conv_descriptor_token_set (&parmse->pre, ctree, token);
829 : }
830 :
831 5331 : if (optional)
832 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
833 :
834 : /* Set the _len as early as possible. */
835 5331 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
836 5331 : && fsym->ts.u.derived->components->ts.u.derived->attr
837 5331 : .unlimited_polymorphic)
838 : {
839 : /* Take care about initializing the _len component correctly. */
840 386 : tree len_tree = gfc_class_len_get (var);
841 386 : if (UNLIMITED_POLY (e))
842 : {
843 12 : gfc_expr *len;
844 12 : gfc_se se;
845 :
846 12 : len = gfc_find_and_cut_at_last_class_ref (e);
847 12 : gfc_add_len_component (len);
848 12 : gfc_init_se (&se, NULL);
849 12 : gfc_conv_expr (&se, len);
850 12 : if (optional)
851 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
852 : cond_optional, se.expr,
853 0 : fold_convert (TREE_TYPE (se.expr),
854 : integer_zero_node));
855 : else
856 12 : tmp = se.expr;
857 12 : gfc_free_expr (len);
858 12 : }
859 : else
860 374 : tmp = integer_zero_node;
861 386 : gfc_add_modify (&parmse->pre, len_tree,
862 386 : fold_convert (TREE_TYPE (len_tree), tmp));
863 : }
864 :
865 5331 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
866 : {
867 : /* If there is a ready made pointer to a derived type, use it
868 : rather than evaluating the expression again. */
869 535 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
870 535 : gfc_add_modify (&parmse->pre, ctree, tmp);
871 : }
872 4796 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
873 : {
874 : /* For an array reference in an elemental procedure call we need
875 : to retain the ss to provide the scalarized array reference. */
876 445 : gfc_conv_expr_reference (parmse, e);
877 445 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
878 445 : if (optional)
879 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
880 : cond_optional, tmp,
881 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
882 445 : gfc_add_modify (&parmse->pre, ctree, tmp);
883 : }
884 : else
885 : {
886 4351 : ss = gfc_walk_expr (e);
887 4351 : if (ss == gfc_ss_terminator)
888 : {
889 3085 : parmse->ss = NULL;
890 3085 : gfc_conv_expr_reference (parmse, e);
891 :
892 : /* Scalar to an assumed-rank array. */
893 3085 : if (fsym->ts.u.derived->components->as)
894 334 : gfc_set_descriptor_from_scalar (&parmse->pre, ctree,
895 : parmse->expr, e, cond_optional);
896 : else
897 : {
898 2751 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
899 2751 : if (optional)
900 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
901 : cond_optional, tmp,
902 132 : fold_convert (TREE_TYPE (tmp),
903 : null_pointer_node));
904 2751 : gfc_add_modify (&parmse->pre, ctree, tmp);
905 : }
906 : }
907 : else
908 : {
909 1266 : stmtblock_t block;
910 1266 : gfc_init_block (&block);
911 1266 : gfc_ref *ref;
912 1266 : int dim;
913 1266 : tree lbshift = NULL_TREE;
914 :
915 : /* Array refs with sections indicate, that a for a formal argument
916 : expecting contiguous repacking needs to be done. */
917 2381 : for (ref = e->ref; ref; ref = ref->next)
918 1265 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
919 : break;
920 1266 : if (IS_CLASS_ARRAY (fsym)
921 1152 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
922 894 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
923 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
924 144 : fsym->attr.contiguous = 1;
925 :
926 : /* Detect any array references with vector subscripts. */
927 2525 : for (ref = e->ref; ref; ref = ref->next)
928 1265 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
929 1223 : && ref->u.ar.type != AR_FULL)
930 : {
931 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
932 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
933 : break;
934 150 : if (dim < ref->u.ar.dimen)
935 : break;
936 : }
937 : /* Array references with vector subscripts and non-variable
938 : expressions need be converted to a one-based descriptor. */
939 1266 : if (ref || e->expr_type != EXPR_VARIABLE)
940 49 : lbshift = gfc_index_one_node;
941 :
942 1266 : parmse->expr = var;
943 1266 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
944 : &lbshift, &packed);
945 :
946 1266 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
947 : {
948 1170 : *derived_array
949 1170 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
950 1170 : if (e->rank == -1)
951 : {
952 : /* Assumed-rank actual: parmse->expr physically holds only
953 : dtype.rank dims; a full struct assign reads past the end.
954 : Copy field-by-field with a runtime-sized dim[] memcpy.
955 : PR fortran/60576. */
956 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
957 :
958 78 : gfc_conv_descriptor_data_set
959 78 : (&block, *derived_array,
960 : gfc_conv_descriptor_data_get (parmse->expr));
961 78 : gfc_conv_descriptor_offset_set
962 78 : (&block, *derived_array,
963 : gfc_conv_descriptor_offset_get (parmse->expr));
964 78 : tree dtype_val = gfc_conv_descriptor_dtype_get (parmse->expr);
965 78 : gfc_conv_descriptor_dtype_set (&block, *derived_array,
966 : dtype_val);
967 78 : rank = gfc_conv_descriptor_rank_get (parmse->expr);
968 78 : rank = fold_convert (size_type_node, rank);
969 78 : dim_field = gfc_get_descriptor_dimension (parmse->expr);
970 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
971 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
972 : size_type_node, rank, dim_size);
973 78 : dst_ptr = gfc_build_addr_expr
974 78 : (pvoid_type_node, gfc_get_descriptor_dimension (*derived_array));
975 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
976 78 : gfc_add_expr_to_block (&block,
977 : build_call_expr_loc (input_location,
978 : builtin_decl_explicit (BUILT_IN_MEMCPY),
979 : 3, dst_ptr, src_ptr, copy_size));
980 : }
981 : else
982 1092 : gfc_add_modify (&block, *derived_array, parmse->expr);
983 : }
984 :
985 1266 : if (optional)
986 : {
987 348 : tmp = gfc_finish_block (&block);
988 :
989 348 : gfc_init_block (&block);
990 348 : gfc_init_absent_descriptor (&block, ctree);
991 348 : if (derived_array && *derived_array != NULL_TREE)
992 348 : gfc_init_absent_descriptor (&block, *derived_array);
993 :
994 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
995 : gfc_finish_block (&block));
996 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
997 : }
998 : else
999 918 : gfc_add_block_to_block (&parmse->pre, &block);
1000 : }
1001 : }
1002 :
1003 : /* Pass the address of the class object. */
1004 5331 : if (packed)
1005 : parmse->expr = packed;
1006 : else
1007 5235 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1008 :
1009 5331 : if (optional && optional_alloc_ptr)
1010 84 : parmse->expr
1011 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1012 : cond_optional, parmse->expr,
1013 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1014 5331 : }
1015 :
1016 : /* Create a new class container, which is required as scalar coarrays
1017 : have an array descriptor while normal scalars haven't. Optionally,
1018 : NULL pointer checks are added if the argument is OPTIONAL. */
1019 :
1020 : static void
1021 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1022 : gfc_typespec class_ts, bool optional)
1023 : {
1024 48 : tree var, ctree, tmp;
1025 48 : stmtblock_t block;
1026 48 : gfc_ref *ref;
1027 48 : gfc_ref *class_ref;
1028 :
1029 48 : gfc_init_block (&block);
1030 :
1031 48 : class_ref = NULL;
1032 144 : for (ref = e->ref; ref; ref = ref->next)
1033 : {
1034 96 : if (ref->type == REF_COMPONENT
1035 48 : && ref->u.c.component->ts.type == BT_CLASS)
1036 96 : class_ref = ref;
1037 : }
1038 :
1039 48 : if (class_ref == NULL
1040 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1041 48 : tmp = e->symtree->n.sym->backend_decl;
1042 : else
1043 : {
1044 : /* Remove everything after the last class reference, convert the
1045 : expression and then recover its tailend once more. */
1046 0 : gfc_se tmpse;
1047 0 : ref = class_ref->next;
1048 0 : class_ref->next = NULL;
1049 0 : gfc_init_se (&tmpse, NULL);
1050 0 : gfc_conv_expr (&tmpse, e);
1051 0 : class_ref->next = ref;
1052 0 : tmp = tmpse.expr;
1053 : }
1054 :
1055 48 : var = gfc_typenode_for_spec (&class_ts);
1056 48 : var = gfc_create_var (var, "class");
1057 :
1058 48 : ctree = gfc_class_vptr_get (var);
1059 96 : gfc_add_modify (&block, ctree,
1060 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1061 :
1062 48 : ctree = gfc_class_data_get (var);
1063 48 : tmp = gfc_conv_descriptor_data_get (
1064 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1065 : ? tmp
1066 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1067 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1068 :
1069 : /* Pass the address of the class object. */
1070 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1071 :
1072 48 : if (optional)
1073 : {
1074 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1075 48 : tree tmp2;
1076 :
1077 48 : tmp = gfc_finish_block (&block);
1078 :
1079 48 : gfc_init_block (&block);
1080 48 : tmp2 = gfc_class_data_get (var);
1081 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1082 : null_pointer_node));
1083 48 : tmp2 = gfc_finish_block (&block);
1084 :
1085 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1086 : cond, tmp, tmp2);
1087 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1088 : }
1089 : else
1090 0 : gfc_add_block_to_block (&parmse->pre, &block);
1091 48 : }
1092 :
1093 :
1094 : /* Takes an intrinsic type expression and returns the address of a temporary
1095 : class object of the 'declared' type. */
1096 : void
1097 930 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1098 : gfc_typespec class_ts)
1099 : {
1100 930 : gfc_symbol *vtab;
1101 930 : gfc_ss *ss;
1102 930 : tree ctree;
1103 930 : tree var;
1104 930 : tree tmp;
1105 930 : int dim;
1106 930 : bool unlimited_poly;
1107 :
1108 1860 : unlimited_poly = class_ts.type == BT_CLASS
1109 930 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1110 930 : && class_ts.u.derived->components->ts.u.derived
1111 930 : ->attr.unlimited_polymorphic;
1112 :
1113 : /* The intrinsic type needs to be converted to a temporary
1114 : CLASS object. */
1115 930 : tmp = gfc_typenode_for_spec (&class_ts);
1116 930 : var = gfc_create_var (tmp, "class");
1117 :
1118 : /* Force a temporary for component or substring references. */
1119 930 : if (unlimited_poly
1120 930 : && class_ts.u.derived->components->attr.dimension
1121 671 : && !class_ts.u.derived->components->attr.allocatable
1122 671 : && !class_ts.u.derived->components->attr.class_pointer
1123 1601 : && is_subref_array (e))
1124 17 : parmse->force_tmp = 1;
1125 :
1126 : /* Set the vptr. */
1127 930 : ctree = gfc_class_vptr_get (var);
1128 :
1129 930 : vtab = gfc_find_vtab (&e->ts);
1130 930 : gcc_assert (vtab);
1131 930 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1132 930 : gfc_add_modify (&parmse->pre, ctree,
1133 930 : fold_convert (TREE_TYPE (ctree), tmp));
1134 :
1135 : /* Now set the data field. */
1136 930 : ctree = gfc_class_data_get (var);
1137 930 : if (parmse->ss && parmse->ss->info->useflags)
1138 : {
1139 : /* For an array reference in an elemental procedure call we need
1140 : to retain the ss to provide the scalarized array reference. */
1141 36 : gfc_conv_expr_reference (parmse, e);
1142 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1143 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1144 : }
1145 : else
1146 : {
1147 894 : ss = gfc_walk_expr (e);
1148 894 : if (ss == gfc_ss_terminator)
1149 : {
1150 247 : parmse->ss = NULL;
1151 247 : gfc_conv_expr_reference (parmse, e);
1152 247 : if (class_ts.u.derived->components->as
1153 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1154 : {
1155 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1156 : gfc_expr_attr (e));
1157 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1158 24 : TREE_TYPE (ctree), tmp);
1159 : }
1160 : else
1161 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1162 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1163 : }
1164 : else
1165 : {
1166 647 : parmse->ss = ss;
1167 647 : gfc_conv_expr_descriptor (parmse, e);
1168 :
1169 : /* Array references with vector subscripts and non-variable expressions
1170 : need be converted to a one-based descriptor. */
1171 647 : if (e->expr_type != EXPR_VARIABLE)
1172 : {
1173 416 : for (dim = 0; dim < e->rank; ++dim)
1174 217 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1175 : dim, gfc_index_one_node);
1176 : }
1177 :
1178 647 : if (class_ts.u.derived->components->as->rank != e->rank)
1179 : {
1180 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1181 49 : TREE_TYPE (ctree), parmse->expr);
1182 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1183 : }
1184 : else
1185 598 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1186 : }
1187 : }
1188 :
1189 930 : gcc_assert (class_ts.type == BT_CLASS);
1190 930 : if (unlimited_poly)
1191 : {
1192 930 : ctree = gfc_class_len_get (var);
1193 : /* When the actual arg is a char array, then set the _len component of the
1194 : unlimited polymorphic entity to the length of the string. */
1195 930 : if (e->ts.type == BT_CHARACTER)
1196 : {
1197 : /* Start with parmse->string_length because this seems to be set to a
1198 : correct value more often. */
1199 175 : if (parmse->string_length)
1200 : tmp = parmse->string_length;
1201 : /* When the string_length is not yet set, then try the backend_decl of
1202 : the cl. */
1203 0 : else if (e->ts.u.cl->backend_decl)
1204 : tmp = e->ts.u.cl->backend_decl;
1205 : /* If both of the above approaches fail, then try to generate an
1206 : expression from the input, which is only feasible currently, when the
1207 : expression can be evaluated to a constant one. */
1208 : else
1209 : {
1210 : /* Try to simplify the expression. */
1211 0 : gfc_simplify_expr (e, 0);
1212 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1213 : {
1214 : /* Amazingly all data is present to compute the length of a
1215 : constant string, but the expression is not yet there. */
1216 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1217 : gfc_charlen_int_kind,
1218 : &e->where);
1219 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1220 0 : e->value.character.length);
1221 0 : gfc_conv_const_charlen (e->ts.u.cl);
1222 0 : e->ts.u.cl->resolved = 1;
1223 0 : tmp = e->ts.u.cl->backend_decl;
1224 : }
1225 : else
1226 : {
1227 0 : gfc_error ("Cannot compute the length of the char array "
1228 : "at %L.", &e->where);
1229 : }
1230 : }
1231 : }
1232 : else
1233 755 : tmp = integer_zero_node;
1234 :
1235 930 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1236 : }
1237 :
1238 : /* Pass the address of the class object. */
1239 930 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1240 930 : }
1241 :
1242 :
1243 : /* Takes a scalarized class array expression and returns the
1244 : address of a temporary scalar class object of the 'declared'
1245 : type.
1246 : OOP-TODO: This could be improved by adding code that branched on
1247 : the dynamic type being the same as the declared type. In this case
1248 : the original class expression can be passed directly.
1249 : optional_alloc_ptr is false when the dummy is neither allocatable
1250 : nor a pointer; that's relevant for the optional handling.
1251 : Set copyback to true if class container's _data and _vtab pointers
1252 : might get modified. */
1253 :
1254 : void
1255 3744 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1256 : bool elemental, bool copyback, bool optional,
1257 : bool optional_alloc_ptr)
1258 : {
1259 3744 : tree ctree;
1260 3744 : tree var;
1261 3744 : tree tmp;
1262 3744 : tree vptr;
1263 3744 : tree cond = NULL_TREE;
1264 3744 : tree slen = NULL_TREE;
1265 3744 : gfc_ref *ref;
1266 3744 : gfc_ref *class_ref;
1267 3744 : stmtblock_t block;
1268 3744 : bool full_array = false;
1269 :
1270 : /* If this is the data field of a class temporary, the class expression
1271 : can be obtained and returned directly. */
1272 3744 : if (e->expr_type != EXPR_VARIABLE
1273 180 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1274 36 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))
1275 3780 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse->expr, 0))))
1276 : {
1277 36 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1278 36 : if (!VAR_P (parmse->expr))
1279 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1280 36 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1281 174 : return;
1282 : }
1283 :
1284 3708 : gfc_init_block (&block);
1285 :
1286 3708 : class_ref = NULL;
1287 7501 : for (ref = e->ref; ref; ref = ref->next)
1288 : {
1289 7125 : if (ref->type == REF_COMPONENT
1290 3826 : && ref->u.c.component->ts.type == BT_CLASS)
1291 7125 : class_ref = ref;
1292 :
1293 7125 : if (ref->next == NULL)
1294 : break;
1295 : }
1296 :
1297 3708 : if ((ref == NULL || class_ref == ref)
1298 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1299 4178 : && (!class_ts.u.derived->components->as
1300 379 : || class_ts.u.derived->components->as->rank != -1))
1301 : return;
1302 :
1303 : /* Test for FULL_ARRAY. */
1304 3570 : if (e->rank == 0
1305 3926 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1306 494 : || (class_ts.u.derived->components->as
1307 366 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1308 411 : full_array = true;
1309 : else
1310 3159 : gfc_is_class_array_ref (e, &full_array);
1311 :
1312 : /* The derived type needs to be converted to a temporary
1313 : CLASS object. */
1314 3570 : tmp = gfc_typenode_for_spec (&class_ts);
1315 3570 : var = gfc_create_var (tmp, "class");
1316 :
1317 : /* Set the data. */
1318 3570 : ctree = gfc_class_data_get (var);
1319 3570 : if (class_ts.u.derived->components->as
1320 3286 : && e->rank != class_ts.u.derived->components->as->rank)
1321 : {
1322 977 : if (e->rank == 0)
1323 356 : gfc_set_descriptor_from_scalar_class (&block, ctree, parmse->expr, e);
1324 : else
1325 621 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1326 : }
1327 : else
1328 : {
1329 2593 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1330 1523 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1331 1523 : TREE_TYPE (ctree), parmse->expr);
1332 2593 : gfc_add_modify (&block, ctree, parmse->expr);
1333 : }
1334 :
1335 : /* Return the data component, except in the case of scalarized array
1336 : references, where nullification of the cannot occur and so there
1337 : is no need. */
1338 3570 : if (!elemental && full_array && copyback)
1339 : {
1340 1194 : if (class_ts.u.derived->components->as
1341 1194 : && e->rank != class_ts.u.derived->components->as->rank)
1342 : {
1343 270 : if (e->rank == 0)
1344 : {
1345 102 : tmp = gfc_class_data_get (parmse->expr);
1346 204 : gfc_add_modify (&parmse->post, tmp,
1347 102 : fold_convert (TREE_TYPE (tmp),
1348 : gfc_conv_descriptor_data_get (ctree)));
1349 : }
1350 : else
1351 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1352 : true);
1353 : }
1354 : else
1355 924 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1356 : }
1357 :
1358 : /* Set the vptr. */
1359 3570 : ctree = gfc_class_vptr_get (var);
1360 :
1361 : /* The vptr is the second field of the actual argument.
1362 : First we have to find the corresponding class reference. */
1363 :
1364 3570 : tmp = NULL_TREE;
1365 3570 : if (gfc_is_class_array_function (e)
1366 3570 : && parmse->class_vptr != NULL_TREE)
1367 : tmp = parmse->class_vptr;
1368 3552 : else if (class_ref == NULL
1369 3041 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1370 : {
1371 3041 : tmp = e->symtree->n.sym->backend_decl;
1372 :
1373 3041 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1374 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1375 :
1376 3041 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1377 397 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1378 :
1379 3041 : slen = build_zero_cst (size_type_node);
1380 : }
1381 511 : else if (parmse->class_container != NULL_TREE)
1382 : /* Don't redundantly evaluate the expression if the required information
1383 : is already available. */
1384 : tmp = parmse->class_container;
1385 : else
1386 : {
1387 : /* Remove everything after the last class reference, convert the
1388 : expression and then recover its tailend once more. */
1389 24 : gfc_se tmpse;
1390 24 : ref = class_ref->next;
1391 24 : class_ref->next = NULL;
1392 24 : gfc_init_se (&tmpse, NULL);
1393 24 : gfc_conv_expr (&tmpse, e);
1394 24 : class_ref->next = ref;
1395 24 : tmp = tmpse.expr;
1396 24 : slen = tmpse.string_length;
1397 : }
1398 :
1399 3570 : gcc_assert (tmp != NULL_TREE);
1400 :
1401 : /* Dereference if needs be. */
1402 3570 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1403 345 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1404 :
1405 3570 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1406 3552 : vptr = gfc_class_vptr_get (tmp);
1407 : else
1408 : vptr = tmp;
1409 :
1410 3570 : gfc_add_modify (&block, ctree,
1411 3570 : fold_convert (TREE_TYPE (ctree), vptr));
1412 :
1413 : /* Return the vptr component, except in the case of scalarized array
1414 : references, where the dynamic type cannot change. */
1415 3570 : if (!elemental && full_array && copyback)
1416 1194 : gfc_add_modify (&parmse->post, vptr,
1417 1194 : fold_convert (TREE_TYPE (vptr), ctree));
1418 :
1419 : /* For unlimited polymorphic objects also set the _len component. */
1420 3570 : if (class_ts.type == BT_CLASS
1421 3570 : && class_ts.u.derived->components
1422 3570 : && class_ts.u.derived->components->ts.u
1423 3570 : .derived->attr.unlimited_polymorphic)
1424 : {
1425 1236 : ctree = gfc_class_len_get (var);
1426 1236 : if (UNLIMITED_POLY (e))
1427 1033 : tmp = gfc_class_len_get (tmp);
1428 203 : else if (e->ts.type == BT_CHARACTER)
1429 : {
1430 0 : gcc_assert (slen != NULL_TREE);
1431 : tmp = slen;
1432 : }
1433 : else
1434 203 : tmp = build_zero_cst (size_type_node);
1435 1236 : gfc_add_modify (&parmse->pre, ctree,
1436 1236 : fold_convert (TREE_TYPE (ctree), tmp));
1437 :
1438 : /* Return the len component, except in the case of scalarized array
1439 : references, where the dynamic type cannot change. */
1440 1236 : if (!elemental && full_array && copyback
1441 477 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1442 464 : gfc_add_modify (&parmse->post, tmp,
1443 464 : fold_convert (TREE_TYPE (tmp), ctree));
1444 : }
1445 :
1446 3570 : if (optional)
1447 : {
1448 510 : tree tmp2;
1449 :
1450 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1451 : /* parmse->pre may contain some preparatory instructions for the
1452 : temporary array descriptor. Those may only be executed when the
1453 : optional argument is set, therefore add parmse->pre's instructions
1454 : to block, which is later guarded by an if (optional_arg_given). */
1455 510 : gfc_add_block_to_block (&parmse->pre, &block);
1456 510 : block.head = parmse->pre.head;
1457 510 : parmse->pre.head = NULL_TREE;
1458 510 : tmp = gfc_finish_block (&block);
1459 :
1460 510 : if (optional_alloc_ptr)
1461 102 : tmp2 = build_empty_stmt (input_location);
1462 : else
1463 : {
1464 408 : gfc_init_block (&block);
1465 408 : gfc_conv_descriptor_data_set (&block, gfc_class_data_get (var),
1466 : null_pointer_node);
1467 408 : tmp2 = gfc_finish_block (&block);
1468 : }
1469 :
1470 510 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1471 : cond, tmp, tmp2);
1472 510 : gfc_add_expr_to_block (&parmse->pre, tmp);
1473 :
1474 510 : if (!elemental && full_array && copyback)
1475 : {
1476 30 : tmp2 = build_empty_stmt (input_location);
1477 30 : tmp = gfc_finish_block (&parmse->post);
1478 30 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1479 : cond, tmp, tmp2);
1480 30 : gfc_add_expr_to_block (&parmse->post, tmp);
1481 : }
1482 : }
1483 : else
1484 3060 : gfc_add_block_to_block (&parmse->pre, &block);
1485 :
1486 : /* Pass the address of the class object. */
1487 3570 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1488 :
1489 3570 : if (optional && optional_alloc_ptr)
1490 204 : parmse->expr = build3_loc (input_location, COND_EXPR,
1491 102 : TREE_TYPE (parmse->expr),
1492 : cond, parmse->expr,
1493 102 : fold_convert (TREE_TYPE (parmse->expr),
1494 : null_pointer_node));
1495 : }
1496 :
1497 :
1498 : /* Given a class array declaration and an index, returns the address
1499 : of the referenced element. */
1500 :
1501 : static tree
1502 768 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1503 : bool unlimited)
1504 : {
1505 768 : tree data, size, tmp, ctmp, offset, ptr;
1506 :
1507 768 : data = data_comp != NULL_TREE ? data_comp :
1508 0 : gfc_class_data_get (class_decl);
1509 768 : size = gfc_class_vtab_size_get (class_decl);
1510 :
1511 768 : if (unlimited)
1512 : {
1513 244 : tmp = fold_convert (gfc_array_index_type,
1514 : gfc_class_len_get (class_decl));
1515 244 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1516 : gfc_array_index_type, size, tmp);
1517 244 : tmp = fold_build2_loc (input_location, GT_EXPR,
1518 : logical_type_node, tmp,
1519 244 : build_zero_cst (TREE_TYPE (tmp)));
1520 244 : size = fold_build3_loc (input_location, COND_EXPR,
1521 : gfc_array_index_type, tmp, ctmp, size);
1522 : }
1523 :
1524 768 : offset = fold_build2_loc (input_location, MULT_EXPR,
1525 : gfc_array_index_type,
1526 : index, size);
1527 :
1528 768 : data = gfc_conv_descriptor_data_get (data);
1529 768 : ptr = fold_convert (pvoid_type_node, data);
1530 768 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1531 768 : return fold_convert (TREE_TYPE (data), ptr);
1532 : }
1533 :
1534 :
1535 : /* Copies one class expression to another, assuming that if either
1536 : 'to' or 'from' are arrays they are packed. Should 'from' be
1537 : NULL_TREE, the initialization expression for 'to' is used, assuming
1538 : that the _vptr is set. */
1539 :
1540 : tree
1541 816 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1542 : {
1543 816 : tree fcn;
1544 816 : tree fcn_type;
1545 816 : tree from_data;
1546 816 : tree from_len;
1547 816 : tree to_data;
1548 816 : tree to_len;
1549 816 : tree to_ref;
1550 816 : tree from_ref;
1551 816 : vec<tree, va_gc> *args;
1552 816 : tree tmp;
1553 816 : tree stdcopy;
1554 816 : tree extcopy;
1555 816 : tree index;
1556 816 : bool is_from_desc = false, is_to_class = false;
1557 :
1558 816 : args = NULL;
1559 : /* To prevent warnings on uninitialized variables. */
1560 816 : from_len = to_len = NULL_TREE;
1561 :
1562 816 : if (from != NULL_TREE)
1563 816 : fcn = gfc_class_vtab_copy_get (from);
1564 : else
1565 0 : fcn = gfc_class_vtab_copy_get (to);
1566 :
1567 816 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1568 :
1569 816 : if (from != NULL_TREE)
1570 : {
1571 816 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1572 816 : if (is_from_desc)
1573 : {
1574 0 : from_data = from;
1575 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1576 : }
1577 : else
1578 : {
1579 : /* Check that from is a class. When the class is part of a coarray,
1580 : then from is a common pointer and is to be used as is. */
1581 1632 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1582 816 : ? build_fold_indirect_ref (from) : from;
1583 1632 : from_data =
1584 816 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1585 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1586 816 : ? gfc_class_data_get (from) : from;
1587 816 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1588 : }
1589 : }
1590 : else
1591 0 : from_data = gfc_class_vtab_def_init_get (to);
1592 :
1593 816 : if (unlimited)
1594 : {
1595 182 : if (from != NULL_TREE && unlimited)
1596 182 : from_len = gfc_class_len_or_zero_get (from);
1597 : else
1598 0 : from_len = build_zero_cst (size_type_node);
1599 : }
1600 :
1601 816 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1602 : {
1603 816 : is_to_class = true;
1604 816 : to_data = gfc_class_data_get (to);
1605 816 : if (unlimited)
1606 182 : to_len = gfc_class_len_get (to);
1607 : }
1608 : else
1609 : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1610 0 : to_data = to;
1611 :
1612 816 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1613 : {
1614 384 : stmtblock_t loopbody;
1615 384 : stmtblock_t body;
1616 384 : stmtblock_t ifbody;
1617 384 : gfc_loopinfo loop;
1618 :
1619 384 : gfc_init_block (&body);
1620 384 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1621 : gfc_array_index_type, nelems,
1622 : gfc_index_one_node);
1623 384 : nelems = gfc_evaluate_now (tmp, &body);
1624 384 : index = gfc_create_var (gfc_array_index_type, "S");
1625 :
1626 384 : if (is_from_desc)
1627 : {
1628 384 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1629 : unlimited);
1630 384 : vec_safe_push (args, from_ref);
1631 : }
1632 : else
1633 0 : vec_safe_push (args, from_data);
1634 :
1635 384 : if (is_to_class)
1636 384 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1637 : else
1638 : {
1639 0 : tmp = gfc_conv_array_data (to);
1640 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1641 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1642 : gfc_build_array_ref (tmp, index, to));
1643 : }
1644 384 : vec_safe_push (args, to_ref);
1645 :
1646 : /* Add bounds check. */
1647 384 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1648 : {
1649 25 : const char *name = "<<unknown>>";
1650 25 : int dim, rank;
1651 :
1652 25 : if (DECL_P (to))
1653 0 : name = IDENTIFIER_POINTER (DECL_NAME (to));
1654 :
1655 25 : rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
1656 55 : for (dim = 1; dim <= rank; dim++)
1657 : {
1658 30 : tree from_len, to_len, cond;
1659 30 : char *msg;
1660 :
1661 30 : from_len = gfc_conv_descriptor_size (from_data, dim);
1662 30 : from_len = fold_convert (long_integer_type_node, from_len);
1663 30 : to_len = gfc_conv_descriptor_size (to_data, dim);
1664 30 : to_len = fold_convert (long_integer_type_node, to_len);
1665 30 : msg = xasprintf ("Array bound mismatch for dimension %d "
1666 : "of array '%s' (%%ld/%%ld)",
1667 : dim, name);
1668 30 : cond = fold_build2_loc (input_location, NE_EXPR,
1669 : logical_type_node, from_len, to_len);
1670 30 : gfc_trans_runtime_check (true, false, cond, &body,
1671 : NULL, msg, to_len, from_len);
1672 30 : free (msg);
1673 : }
1674 : }
1675 :
1676 384 : tmp = build_call_vec (fcn_type, fcn, args);
1677 :
1678 : /* Build the body of the loop. */
1679 384 : gfc_init_block (&loopbody);
1680 384 : gfc_add_expr_to_block (&loopbody, tmp);
1681 :
1682 : /* Build the loop and return. */
1683 384 : gfc_init_loopinfo (&loop);
1684 384 : loop.dimen = 1;
1685 384 : loop.from[0] = gfc_index_zero_node;
1686 384 : loop.loopvar[0] = index;
1687 384 : loop.to[0] = nelems;
1688 384 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1689 384 : gfc_init_block (&ifbody);
1690 384 : gfc_add_block_to_block (&ifbody, &loop.pre);
1691 384 : stdcopy = gfc_finish_block (&ifbody);
1692 : /* In initialization mode from_len is a constant zero. */
1693 384 : if (unlimited && !integer_zerop (from_len))
1694 : {
1695 122 : vec_safe_push (args, from_len);
1696 122 : vec_safe_push (args, to_len);
1697 122 : tmp = build_call_vec (fcn_type, fcn, args);
1698 : /* Build the body of the loop. */
1699 122 : gfc_init_block (&loopbody);
1700 122 : gfc_add_expr_to_block (&loopbody, tmp);
1701 :
1702 : /* Build the loop and return. */
1703 122 : gfc_init_loopinfo (&loop);
1704 122 : loop.dimen = 1;
1705 122 : loop.from[0] = gfc_index_zero_node;
1706 122 : loop.loopvar[0] = index;
1707 122 : loop.to[0] = nelems;
1708 122 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1709 122 : gfc_init_block (&ifbody);
1710 122 : gfc_add_block_to_block (&ifbody, &loop.pre);
1711 122 : extcopy = gfc_finish_block (&ifbody);
1712 :
1713 122 : tmp = fold_build2_loc (input_location, GT_EXPR,
1714 : logical_type_node, from_len,
1715 122 : build_zero_cst (TREE_TYPE (from_len)));
1716 122 : tmp = fold_build3_loc (input_location, COND_EXPR,
1717 : void_type_node, tmp, extcopy, stdcopy);
1718 122 : gfc_add_expr_to_block (&body, tmp);
1719 122 : tmp = gfc_finish_block (&body);
1720 : }
1721 : else
1722 : {
1723 262 : gfc_add_expr_to_block (&body, stdcopy);
1724 262 : tmp = gfc_finish_block (&body);
1725 : }
1726 384 : gfc_cleanup_loop (&loop);
1727 : }
1728 : else
1729 : {
1730 432 : gcc_assert (!is_from_desc);
1731 432 : vec_safe_push (args, from_data);
1732 432 : vec_safe_push (args, to_data);
1733 432 : stdcopy = build_call_vec (fcn_type, fcn, args);
1734 :
1735 : /* In initialization mode from_len is a constant zero. */
1736 432 : if (unlimited && !integer_zerop (from_len))
1737 : {
1738 60 : vec_safe_push (args, from_len);
1739 60 : vec_safe_push (args, to_len);
1740 60 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1741 60 : tmp = fold_build2_loc (input_location, GT_EXPR,
1742 : logical_type_node, from_len,
1743 60 : build_zero_cst (TREE_TYPE (from_len)));
1744 60 : tmp = fold_build3_loc (input_location, COND_EXPR,
1745 : void_type_node, tmp, extcopy, stdcopy);
1746 : }
1747 : else
1748 : tmp = stdcopy;
1749 : }
1750 :
1751 : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1752 816 : if (from == NULL_TREE)
1753 : {
1754 0 : tree cond;
1755 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1756 : logical_type_node,
1757 : from_data, null_pointer_node);
1758 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1759 : void_type_node, cond,
1760 : tmp, build_empty_stmt (input_location));
1761 : }
1762 :
1763 816 : return tmp;
1764 : }
1765 :
1766 :
1767 : static tree
1768 106 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1769 : {
1770 106 : gfc_actual_arglist *actual;
1771 106 : gfc_expr *ppc;
1772 106 : gfc_code *ppc_code;
1773 106 : tree res;
1774 :
1775 106 : actual = gfc_get_actual_arglist ();
1776 106 : actual->expr = gfc_copy_expr (rhs);
1777 106 : actual->next = gfc_get_actual_arglist ();
1778 106 : actual->next->expr = gfc_copy_expr (lhs);
1779 106 : ppc = gfc_copy_expr (obj);
1780 106 : gfc_add_vptr_component (ppc);
1781 106 : gfc_add_component_ref (ppc, "_copy");
1782 106 : ppc_code = gfc_get_code (EXEC_CALL);
1783 106 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1784 : /* Although '_copy' is set to be elemental in class.cc, it is
1785 : not staying that way. Find out why, sometime.... */
1786 106 : ppc_code->resolved_sym->attr.elemental = 1;
1787 106 : ppc_code->ext.actual = actual;
1788 106 : ppc_code->expr1 = ppc;
1789 : /* Since '_copy' is elemental, the scalarizer will take care
1790 : of arrays in gfc_trans_call. */
1791 106 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1792 106 : gfc_free_statements (ppc_code);
1793 :
1794 106 : if (UNLIMITED_POLY(obj))
1795 : {
1796 : /* Check if rhs is non-NULL. */
1797 24 : gfc_se src;
1798 24 : gfc_init_se (&src, NULL);
1799 24 : gfc_conv_expr (&src, rhs);
1800 24 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1801 24 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1802 24 : src.expr, fold_convert (TREE_TYPE (src.expr),
1803 : null_pointer_node));
1804 24 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1805 : build_empty_stmt (input_location));
1806 : }
1807 :
1808 106 : return res;
1809 : }
1810 :
1811 : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1812 : A MEMCPY is needed to copy the full data from the default initializer
1813 : of the dynamic type. */
1814 :
1815 : tree
1816 491 : gfc_trans_class_init_assign (gfc_code *code)
1817 : {
1818 491 : stmtblock_t block;
1819 491 : tree tmp;
1820 491 : bool cmp_flag = true;
1821 491 : gfc_se dst,src,memsz;
1822 491 : gfc_expr *lhs, *rhs, *sz;
1823 491 : gfc_component *cmp;
1824 491 : gfc_symbol *sym;
1825 491 : gfc_ref *ref;
1826 :
1827 491 : gfc_start_block (&block);
1828 :
1829 491 : lhs = gfc_copy_expr (code->expr1);
1830 :
1831 491 : rhs = gfc_copy_expr (code->expr1);
1832 491 : gfc_add_vptr_component (rhs);
1833 :
1834 : /* Make sure that the component backend_decls have been built, which
1835 : will not have happened if the derived types concerned have not
1836 : been referenced. */
1837 491 : gfc_get_derived_type (rhs->ts.u.derived);
1838 491 : gfc_add_def_init_component (rhs);
1839 : /* The _def_init is always scalar. */
1840 491 : rhs->rank = 0;
1841 :
1842 : /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
1843 : default initializer components NULL, use the passed value even though
1844 : F2018(8.5.10) asserts that it should considered to be undefined. This is
1845 : needed for consistency with other brands. */
1846 491 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1847 : : NULL;
1848 491 : if (code->op != EXEC_ALLOCATE
1849 430 : && sym && sym->attr.dummy
1850 430 : && sym->attr.intent == INTENT_OUT)
1851 : {
1852 430 : ref = rhs->ref;
1853 860 : while (ref && ref->next)
1854 : ref = ref->next;
1855 430 : cmp = ref->u.c.component->ts.u.derived->components;
1856 665 : for (; cmp; cmp = cmp->next)
1857 : {
1858 458 : if (cmp->initializer)
1859 : break;
1860 235 : else if (!cmp->next)
1861 170 : cmp_flag = false;
1862 : }
1863 : }
1864 :
1865 491 : if (code->expr1->ts.type == BT_CLASS
1866 468 : && CLASS_DATA (code->expr1)->attr.dimension)
1867 : {
1868 106 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1869 106 : *tmparr = *CLASS_DATA (code->expr1)->as;
1870 : /* Adding the array ref to the class expression results in correct
1871 : indexing to the dynamic type. */
1872 106 : gfc_add_full_array_ref (lhs, tmparr);
1873 106 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1874 106 : }
1875 385 : else if (cmp_flag)
1876 : {
1877 : /* Scalar initialization needs the _data component. */
1878 228 : gfc_add_data_component (lhs);
1879 228 : sz = gfc_copy_expr (code->expr1);
1880 228 : gfc_add_vptr_component (sz);
1881 228 : gfc_add_size_component (sz);
1882 :
1883 228 : gfc_init_se (&dst, NULL);
1884 228 : gfc_init_se (&src, NULL);
1885 228 : gfc_init_se (&memsz, NULL);
1886 228 : gfc_conv_expr (&dst, lhs);
1887 228 : gfc_conv_expr (&src, rhs);
1888 228 : gfc_conv_expr (&memsz, sz);
1889 228 : gfc_add_block_to_block (&block, &src.pre);
1890 228 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1891 :
1892 228 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1893 :
1894 228 : if (UNLIMITED_POLY(code->expr1))
1895 : {
1896 : /* Check if _def_init is non-NULL. */
1897 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1898 : logical_type_node, src.expr,
1899 7 : fold_convert (TREE_TYPE (src.expr),
1900 : null_pointer_node));
1901 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1902 : tmp, build_empty_stmt (input_location));
1903 : }
1904 : }
1905 : else
1906 157 : tmp = build_empty_stmt (input_location);
1907 :
1908 491 : if (code->expr1->symtree->n.sym->attr.dummy
1909 440 : && (code->expr1->symtree->n.sym->attr.optional
1910 434 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1911 : {
1912 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1913 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1914 : present, tmp,
1915 : build_empty_stmt (input_location));
1916 : }
1917 :
1918 491 : gfc_add_expr_to_block (&block, tmp);
1919 491 : gfc_free_expr (lhs);
1920 491 : gfc_free_expr (rhs);
1921 :
1922 491 : return gfc_finish_block (&block);
1923 : }
1924 :
1925 :
1926 : /* Class valued elemental function calls or class array elements arriving
1927 : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1928 : is used to ensure that the rhs dynamic type is assigned to the lhs. */
1929 :
1930 : static bool
1931 745 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1932 : {
1933 745 : tree fcn;
1934 745 : tree rse_expr;
1935 745 : tree class_data;
1936 745 : tree tmp;
1937 745 : tree zero;
1938 745 : tree cond;
1939 745 : tree final_cond;
1940 745 : stmtblock_t inner_block;
1941 745 : bool is_descriptor;
1942 745 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
1943 745 : bool not_lhs_array_type;
1944 :
1945 : /* Temporaries arising from dependencies in assignment get cast as a
1946 : character type of the dynamic size of the rhs. Use the vptr copy
1947 : for this case. */
1948 745 : tmp = TREE_TYPE (lse->expr);
1949 745 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
1950 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
1951 :
1952 : /* Use ordinary assignment if the rhs is not a call expression or
1953 : the lhs is not a class entity or an array(ie. character) type. */
1954 709 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
1955 1024 : && not_lhs_array_type)
1956 : return false;
1957 :
1958 : /* Ordinary assignment can be used if both sides are class expressions
1959 : since the dynamic type is preserved by copying the vptr. This
1960 : should only occur, where temporaries are involved. */
1961 466 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
1962 466 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
1963 : return false;
1964 :
1965 : /* Fix the class expression and the class data of the rhs. */
1966 466 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
1967 466 : || not_call_expr)
1968 : {
1969 466 : tmp = gfc_get_class_from_expr (rse->expr);
1970 466 : if (tmp == NULL_TREE)
1971 : return false;
1972 146 : rse_expr = gfc_evaluate_now (tmp, block);
1973 : }
1974 : else
1975 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
1976 :
1977 146 : class_data = gfc_class_data_get (rse_expr);
1978 :
1979 : /* Check that the rhs data is not null. */
1980 146 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
1981 146 : if (is_descriptor)
1982 146 : class_data = gfc_conv_descriptor_data_get (class_data);
1983 146 : class_data = gfc_evaluate_now (class_data, block);
1984 :
1985 146 : zero = build_int_cst (TREE_TYPE (class_data), 0);
1986 146 : cond = fold_build2_loc (input_location, NE_EXPR,
1987 : logical_type_node,
1988 : class_data, zero);
1989 :
1990 : /* Copy the rhs to the lhs. */
1991 146 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
1992 146 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
1993 146 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
1994 146 : tmp = is_descriptor ? tmp : class_data;
1995 146 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
1996 : gfc_build_addr_expr (NULL, lse->expr));
1997 146 : gfc_add_expr_to_block (block, tmp);
1998 :
1999 : /* Only elemental function results need to be finalised and freed. */
2000 146 : if (not_call_expr)
2001 : return true;
2002 :
2003 : /* Finalize the class data if needed. */
2004 0 : gfc_init_block (&inner_block);
2005 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
2006 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
2007 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
2008 : logical_type_node, fcn, zero);
2009 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2010 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
2011 0 : tmp = build3_v (COND_EXPR, final_cond,
2012 : tmp, build_empty_stmt (input_location));
2013 0 : gfc_add_expr_to_block (&inner_block, tmp);
2014 :
2015 : /* Free the class data. */
2016 0 : tmp = gfc_call_free (class_data);
2017 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2018 : build_empty_stmt (input_location));
2019 0 : gfc_add_expr_to_block (&inner_block, tmp);
2020 :
2021 : /* Finish the inner block and subject it to the condition on the
2022 : class data being non-zero. */
2023 0 : tmp = gfc_finish_block (&inner_block);
2024 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2025 : build_empty_stmt (input_location));
2026 0 : gfc_add_expr_to_block (block, tmp);
2027 :
2028 0 : return true;
2029 : }
2030 :
2031 : /* End of prototype trans-class.c */
2032 :
2033 :
2034 : static void
2035 13122 : realloc_lhs_warning (bt type, bool array, locus *where)
2036 : {
2037 13122 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
2038 25 : gfc_warning (OPT_Wrealloc_lhs,
2039 : "Code for reallocating the allocatable array at %L will "
2040 : "be added", where);
2041 13097 : else if (warn_realloc_lhs_all)
2042 4 : gfc_warning (OPT_Wrealloc_lhs_all,
2043 : "Code for reallocating the allocatable variable at %L "
2044 : "will be added", where);
2045 13122 : }
2046 :
2047 :
2048 : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
2049 : gfc_expr *);
2050 :
2051 : /* Copy the scalarization loop variables. */
2052 :
2053 : static void
2054 1302858 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2055 : {
2056 1302858 : dest->ss = src->ss;
2057 1302858 : dest->loop = src->loop;
2058 0 : }
2059 :
2060 :
2061 : /* Initialize a simple expression holder.
2062 :
2063 : Care must be taken when multiple se are created with the same parent.
2064 : The child se must be kept in sync. The easiest way is to delay creation
2065 : of a child se until after the previous se has been translated. */
2066 :
2067 : void
2068 4742332 : gfc_init_se (gfc_se * se, gfc_se * parent)
2069 : {
2070 4742332 : memset (se, 0, sizeof (gfc_se));
2071 4742332 : gfc_init_block (&se->pre);
2072 4742332 : gfc_init_block (&se->finalblock);
2073 4742332 : gfc_init_block (&se->post);
2074 :
2075 4742332 : se->parent = parent;
2076 :
2077 4742332 : if (parent)
2078 1302858 : gfc_copy_se_loopvars (se, parent);
2079 4742332 : }
2080 :
2081 :
2082 : /* Advances to the next SS in the chain. Use this rather than setting
2083 : se->ss = se->ss->next because all the parents needs to be kept in sync.
2084 : See gfc_init_se. */
2085 :
2086 : void
2087 248562 : gfc_advance_se_ss_chain (gfc_se * se)
2088 : {
2089 248562 : gfc_se *p;
2090 :
2091 248562 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2092 :
2093 : p = se;
2094 : /* Walk down the parent chain. */
2095 651662 : while (p != NULL)
2096 : {
2097 : /* Simple consistency check. */
2098 403100 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2099 : || p->parent->ss->nested_ss == p->ss);
2100 :
2101 403100 : p->ss = p->ss->next;
2102 :
2103 403100 : p = p->parent;
2104 : }
2105 248562 : }
2106 :
2107 :
2108 : /* Ensures the result of the expression as either a temporary variable
2109 : or a constant so that it can be used repeatedly. */
2110 :
2111 : void
2112 8392 : gfc_make_safe_expr (gfc_se * se)
2113 : {
2114 8392 : tree var;
2115 :
2116 8392 : if (CONSTANT_CLASS_P (se->expr))
2117 : return;
2118 :
2119 : /* We need a temporary for this result. */
2120 274 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2121 274 : gfc_add_modify (&se->pre, var, se->expr);
2122 274 : se->expr = var;
2123 : }
2124 :
2125 :
2126 : /* Return an expression which determines if a dummy parameter is present.
2127 : Also used for arguments to procedures with multiple entry points. */
2128 :
2129 : tree
2130 11940 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2131 : {
2132 11940 : tree decl, orig_decl, cond;
2133 :
2134 11940 : gcc_assert (sym->attr.dummy);
2135 11940 : orig_decl = decl = gfc_get_symbol_decl (sym);
2136 :
2137 : /* Intrinsic scalars and derived types with VALUE attribute which are passed
2138 : by value use a hidden argument to denote the presence status. */
2139 11940 : if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
2140 : {
2141 1082 : char name[GFC_MAX_SYMBOL_LEN + 2];
2142 1082 : tree tree_name;
2143 :
2144 1082 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2145 1082 : name[0] = '.';
2146 1082 : strcpy (&name[1], sym->name);
2147 1082 : tree_name = get_identifier (name);
2148 :
2149 : /* Walk function argument list to find hidden arg. */
2150 1082 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2151 5428 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2152 5428 : if (DECL_NAME (cond) == tree_name
2153 5428 : && DECL_ARTIFICIAL (cond))
2154 : break;
2155 :
2156 1082 : gcc_assert (cond);
2157 1082 : return cond;
2158 : }
2159 :
2160 : /* Assumed-shape arrays use a local variable for the array data;
2161 : the actual PARAM_DECL is in a saved decl. As the local variable
2162 : is NULL, it can be checked instead, unless use_saved_desc is
2163 : requested. */
2164 :
2165 10858 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2166 : {
2167 888 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2168 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2169 888 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2170 : }
2171 :
2172 10858 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2173 10858 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2174 :
2175 : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2176 : as actual argument to denote absent dummies. For array descriptors,
2177 : we thus also need to check the array descriptor. For BT_CLASS, it
2178 : can also occur for scalars and F2003 due to type->class wrapping and
2179 : class->class wrapping. Note further that BT_CLASS always uses an
2180 : array descriptor for arrays, also for explicit-shape/assumed-size.
2181 : For assumed-rank arrays, no local variable is generated, hence,
2182 : the following also applies with !use_saved_desc. */
2183 :
2184 10858 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2185 7703 : && !sym->attr.allocatable
2186 6485 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2187 2302 : || (sym->ts.type == BT_CLASS
2188 1047 : && !CLASS_DATA (sym)->attr.allocatable
2189 573 : && !CLASS_DATA (sym)->attr.class_pointer))
2190 4396 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2191 6 : || sym->ts.type == BT_CLASS))
2192 : {
2193 4390 : tree tmp;
2194 :
2195 4390 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2196 1525 : || sym->as->type == AS_ASSUMED_RANK
2197 1437 : || sym->attr.codimension))
2198 3462 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2199 : {
2200 1105 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2201 1105 : if (sym->ts.type == BT_CLASS)
2202 177 : tmp = gfc_class_data_get (tmp);
2203 1105 : tmp = gfc_conv_array_data (tmp);
2204 : }
2205 3285 : else if (sym->ts.type == BT_CLASS)
2206 36 : tmp = gfc_class_data_get (decl);
2207 : else
2208 : tmp = NULL_TREE;
2209 :
2210 1141 : if (tmp != NULL_TREE)
2211 : {
2212 1141 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2213 1141 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2214 1141 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2215 : logical_type_node, cond, tmp);
2216 : }
2217 : }
2218 :
2219 : return cond;
2220 : }
2221 :
2222 :
2223 : /* Converts a missing, dummy argument into a null or zero. */
2224 :
2225 : void
2226 886 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2227 : {
2228 886 : tree present;
2229 886 : tree tmp;
2230 :
2231 886 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2232 :
2233 886 : if (kind > 0)
2234 : {
2235 : /* Create a temporary and convert it to the correct type. */
2236 54 : tmp = gfc_get_int_type (kind);
2237 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2238 : se->expr));
2239 :
2240 : /* Test for a NULL value. */
2241 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2242 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2243 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2244 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2245 : }
2246 : else
2247 : {
2248 832 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2249 : present, se->expr,
2250 832 : build_zero_cst (TREE_TYPE (se->expr)));
2251 832 : tmp = gfc_evaluate_now (tmp, &se->pre);
2252 832 : se->expr = tmp;
2253 : }
2254 :
2255 886 : if (ts.type == BT_CHARACTER)
2256 : {
2257 : /* Handle deferred-length dummies that pass the character length by
2258 : reference so that the value can be returned. */
2259 262 : if (ts.deferred && INDIRECT_REF_P (se->string_length))
2260 : {
2261 18 : tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
2262 18 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2263 : present, tmp, null_pointer_node);
2264 18 : tmp = gfc_evaluate_now (tmp, &se->pre);
2265 18 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2266 : }
2267 : else
2268 : {
2269 244 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2270 244 : tmp = fold_build3_loc (input_location, COND_EXPR,
2271 : gfc_charlen_type_node,
2272 : present, se->string_length, tmp);
2273 244 : tmp = gfc_evaluate_now (tmp, &se->pre);
2274 : }
2275 262 : se->string_length = tmp;
2276 : }
2277 886 : return;
2278 : }
2279 :
2280 :
2281 : /* Get the character length of an expression, looking through gfc_refs
2282 : if necessary. */
2283 :
2284 : tree
2285 20320 : gfc_get_expr_charlen (gfc_expr *e)
2286 : {
2287 20320 : gfc_ref *r;
2288 20320 : tree length;
2289 20320 : tree previous = NULL_TREE;
2290 20320 : gfc_se se;
2291 :
2292 20320 : gcc_assert (e->expr_type == EXPR_VARIABLE
2293 : && e->ts.type == BT_CHARACTER);
2294 :
2295 20320 : length = NULL; /* To silence compiler warning. */
2296 :
2297 20320 : if (is_subref_array (e) && e->ts.u.cl->length)
2298 : {
2299 827 : gfc_se tmpse;
2300 827 : gfc_init_se (&tmpse, NULL);
2301 827 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2302 827 : e->ts.u.cl->backend_decl = tmpse.expr;
2303 827 : return tmpse.expr;
2304 : }
2305 :
2306 : /* First candidate: if the variable is of type CHARACTER, the
2307 : expression's length could be the length of the character
2308 : variable. */
2309 19493 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2310 19181 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2311 :
2312 : /* Look through the reference chain for component references. */
2313 39141 : for (r = e->ref; r; r = r->next)
2314 : {
2315 19648 : previous = length;
2316 19648 : switch (r->type)
2317 : {
2318 312 : case REF_COMPONENT:
2319 312 : if (r->u.c.component->ts.type == BT_CHARACTER)
2320 312 : length = r->u.c.component->ts.u.cl->backend_decl;
2321 : break;
2322 :
2323 : case REF_ARRAY:
2324 : /* Do nothing. */
2325 : break;
2326 :
2327 20 : case REF_SUBSTRING:
2328 20 : gfc_init_se (&se, NULL);
2329 20 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2330 20 : length = se.expr;
2331 20 : if (r->u.ss.end)
2332 0 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2333 : else
2334 20 : se.expr = previous;
2335 20 : length = fold_build2_loc (input_location, MINUS_EXPR,
2336 : gfc_charlen_type_node,
2337 : se.expr, length);
2338 20 : length = fold_build2_loc (input_location, PLUS_EXPR,
2339 : gfc_charlen_type_node, length,
2340 : gfc_index_one_node);
2341 20 : break;
2342 :
2343 0 : default:
2344 0 : gcc_unreachable ();
2345 19648 : break;
2346 : }
2347 : }
2348 :
2349 19493 : gcc_assert (length != NULL);
2350 : return length;
2351 : }
2352 :
2353 :
2354 : /* Return for an expression the backend decl of the coarray. */
2355 :
2356 : tree
2357 2164 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2358 : {
2359 2164 : tree caf_decl;
2360 2164 : bool found = false;
2361 2164 : gfc_ref *ref;
2362 :
2363 2164 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2364 :
2365 : /* Not-implemented diagnostic. */
2366 2164 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2367 39 : && UNLIMITED_POLY (expr->symtree->n.sym)
2368 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2369 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2370 : "%L is not supported", &expr->where);
2371 :
2372 4589 : for (ref = expr->ref; ref; ref = ref->next)
2373 2425 : if (ref->type == REF_COMPONENT)
2374 : {
2375 225 : if (ref->u.c.component->ts.type == BT_CLASS
2376 0 : && UNLIMITED_POLY (ref->u.c.component)
2377 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2378 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2379 : "component at %L is not supported", &expr->where);
2380 : }
2381 :
2382 : /* Make sure the backend_decl is present before accessing it. */
2383 2164 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2384 2164 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2385 : : expr->symtree->n.sym->backend_decl;
2386 :
2387 2164 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2388 : {
2389 39 : if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2390 45 : && GFC_DECL_SAVED_DESCRIPTOR (caf_decl))
2391 6 : caf_decl = GFC_DECL_SAVED_DESCRIPTOR (caf_decl);
2392 :
2393 39 : if (expr->ref && expr->ref->type == REF_ARRAY)
2394 : {
2395 28 : caf_decl = gfc_class_data_get (caf_decl);
2396 28 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2397 : return caf_decl;
2398 : }
2399 11 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2400 2 : && GFC_DECL_TOKEN (caf_decl)
2401 13 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2402 : return caf_decl;
2403 :
2404 23 : for (ref = expr->ref; ref; ref = ref->next)
2405 : {
2406 18 : if (ref->type == REF_COMPONENT
2407 9 : && strcmp (ref->u.c.component->name, "_data") != 0)
2408 : {
2409 0 : caf_decl = gfc_class_data_get (caf_decl);
2410 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2411 : return caf_decl;
2412 : break;
2413 : }
2414 18 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2415 : break;
2416 : }
2417 : }
2418 2134 : if (expr->symtree->n.sym->attr.codimension)
2419 : return caf_decl;
2420 :
2421 : /* The following code assumes that the coarray is a component reachable via
2422 : only scalar components/variables; the Fortran standard guarantees this. */
2423 :
2424 76 : for (ref = expr->ref; ref; ref = ref->next)
2425 76 : if (ref->type == REF_COMPONENT)
2426 : {
2427 76 : gfc_component *comp = ref->u.c.component;
2428 :
2429 76 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2430 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2431 76 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2432 76 : TREE_TYPE (comp->backend_decl), caf_decl,
2433 : comp->backend_decl, NULL_TREE);
2434 76 : if (comp->ts.type == BT_CLASS)
2435 : {
2436 0 : caf_decl = gfc_class_data_get (caf_decl);
2437 0 : if (CLASS_DATA (comp)->attr.codimension)
2438 : {
2439 : found = true;
2440 : break;
2441 : }
2442 : }
2443 76 : if (comp->attr.codimension)
2444 : {
2445 : found = true;
2446 : break;
2447 : }
2448 : }
2449 76 : gcc_assert (found && caf_decl);
2450 : return caf_decl;
2451 : }
2452 :
2453 :
2454 : /* Obtain the Coarray token - and optionally also the offset. */
2455 :
2456 : void
2457 2035 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2458 : tree se_expr, gfc_expr *expr)
2459 : {
2460 2035 : tree tmp;
2461 :
2462 2035 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2463 :
2464 : /* Coarray token. */
2465 2035 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2466 646 : *token = gfc_conv_descriptor_token (caf_decl);
2467 1387 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2468 1588 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2469 6 : *token = GFC_DECL_TOKEN (caf_decl);
2470 : else
2471 : {
2472 1383 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2473 : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2474 1383 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2475 : }
2476 :
2477 2035 : if (offset == NULL)
2478 : return;
2479 :
2480 : /* Offset between the coarray base address and the address wanted. */
2481 187 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2482 187 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2483 0 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2484 0 : *offset = build_int_cst (gfc_array_index_type, 0);
2485 187 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2486 187 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2487 0 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2488 187 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2489 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2490 : else
2491 187 : *offset = build_int_cst (gfc_array_index_type, 0);
2492 :
2493 187 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2494 187 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2495 : {
2496 0 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2497 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2498 : }
2499 187 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2500 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2501 : else
2502 : {
2503 187 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2504 : tmp = se_expr;
2505 : }
2506 :
2507 187 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2508 : *offset, fold_convert (gfc_array_index_type, tmp));
2509 :
2510 187 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2511 0 : && expr->symtree->n.sym->attr.codimension
2512 0 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2513 : {
2514 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2515 0 : gfc_ref *ref = base_expr->ref;
2516 0 : gfc_se base_se;
2517 :
2518 : // Iterate through the refs until the last one.
2519 0 : while (ref->next)
2520 : ref = ref->next;
2521 :
2522 0 : if (ref->type == REF_ARRAY
2523 0 : && ref->u.ar.type != AR_FULL)
2524 : {
2525 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2526 0 : int i;
2527 0 : for (i = 0; i < ranksum; ++i)
2528 : {
2529 0 : ref->u.ar.start[i] = NULL;
2530 0 : ref->u.ar.end[i] = NULL;
2531 : }
2532 0 : ref->u.ar.type = AR_FULL;
2533 : }
2534 0 : gfc_init_se (&base_se, NULL);
2535 0 : if (gfc_caf_attr (base_expr).dimension)
2536 : {
2537 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2538 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2539 : }
2540 : else
2541 : {
2542 0 : gfc_conv_expr (&base_se, base_expr);
2543 0 : tmp = base_se.expr;
2544 : }
2545 :
2546 0 : gfc_free_expr (base_expr);
2547 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2548 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2549 0 : }
2550 187 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2551 0 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2552 187 : else if (INDIRECT_REF_P (caf_decl))
2553 0 : tmp = TREE_OPERAND (caf_decl, 0);
2554 : else
2555 : {
2556 187 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2557 : tmp = caf_decl;
2558 : }
2559 :
2560 187 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2561 : fold_convert (gfc_array_index_type, *offset),
2562 : fold_convert (gfc_array_index_type, tmp));
2563 : }
2564 :
2565 :
2566 : /* Convert the coindex of a coarray into an image index; the result is
2567 : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2568 : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2569 :
2570 : tree
2571 1742 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2572 : {
2573 1742 : gfc_ref *ref;
2574 1742 : tree lbound, ubound, extent, tmp, img_idx;
2575 1742 : gfc_se se;
2576 1742 : int i;
2577 :
2578 1803 : for (ref = e->ref; ref; ref = ref->next)
2579 1803 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2580 : break;
2581 1742 : gcc_assert (ref != NULL);
2582 :
2583 1742 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2584 191 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2585 191 : null_pointer_node);
2586 :
2587 1551 : img_idx = build_zero_cst (gfc_array_index_type);
2588 1551 : extent = build_one_cst (gfc_array_index_type);
2589 1551 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2590 634 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2591 : {
2592 323 : gfc_init_se (&se, NULL);
2593 323 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2594 323 : gfc_add_block_to_block (block, &se.pre);
2595 323 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2596 323 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2597 323 : TREE_TYPE (lbound), se.expr, lbound);
2598 323 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2599 : extent, tmp);
2600 323 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2601 323 : TREE_TYPE (tmp), img_idx, tmp);
2602 323 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2603 : {
2604 12 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2605 12 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2606 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
2607 12 : TREE_TYPE (tmp), extent, tmp);
2608 : }
2609 : }
2610 : else
2611 2496 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2612 : {
2613 1256 : gfc_init_se (&se, NULL);
2614 1256 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2615 1256 : gfc_add_block_to_block (block, &se.pre);
2616 1256 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2617 1256 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2618 1256 : TREE_TYPE (lbound), se.expr, lbound);
2619 1256 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2620 : extent, tmp);
2621 1256 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2622 : img_idx, tmp);
2623 1256 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2624 : {
2625 16 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2626 16 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2627 16 : TREE_TYPE (ubound), ubound, lbound);
2628 16 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2629 16 : tmp, build_one_cst (TREE_TYPE (tmp)));
2630 16 : extent = fold_build2_loc (input_location, MULT_EXPR,
2631 16 : TREE_TYPE (tmp), extent, tmp);
2632 : }
2633 : }
2634 1551 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2635 1551 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2636 1551 : return fold_convert (integer_type_node, img_idx);
2637 : }
2638 :
2639 :
2640 : /* For each character array constructor subexpression without a ts.u.cl->length,
2641 : replace it by its first element (if there aren't any elements, the length
2642 : should already be set to zero). */
2643 :
2644 : static void
2645 110 : flatten_array_ctors_without_strlen (gfc_expr* e)
2646 : {
2647 110 : gfc_actual_arglist* arg;
2648 110 : gfc_constructor* c;
2649 :
2650 110 : if (!e)
2651 : return;
2652 :
2653 110 : switch (e->expr_type)
2654 : {
2655 :
2656 0 : case EXPR_OP:
2657 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2658 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2659 0 : break;
2660 :
2661 0 : case EXPR_COMPCALL:
2662 : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2663 0 : gcc_unreachable ();
2664 :
2665 13 : case EXPR_FUNCTION:
2666 40 : for (arg = e->value.function.actual; arg; arg = arg->next)
2667 27 : flatten_array_ctors_without_strlen (arg->expr);
2668 : break;
2669 :
2670 0 : case EXPR_ARRAY:
2671 :
2672 : /* We've found what we're looking for. */
2673 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2674 : {
2675 0 : gfc_constructor *c;
2676 0 : gfc_expr* new_expr;
2677 :
2678 0 : gcc_assert (e->value.constructor);
2679 :
2680 0 : c = gfc_constructor_first (e->value.constructor);
2681 0 : new_expr = c->expr;
2682 0 : c->expr = NULL;
2683 :
2684 0 : flatten_array_ctors_without_strlen (new_expr);
2685 0 : gfc_replace_expr (e, new_expr);
2686 0 : break;
2687 : }
2688 :
2689 : /* Otherwise, fall through to handle constructor elements. */
2690 0 : gcc_fallthrough ();
2691 0 : case EXPR_STRUCTURE:
2692 0 : for (c = gfc_constructor_first (e->value.constructor);
2693 0 : c; c = gfc_constructor_next (c))
2694 0 : flatten_array_ctors_without_strlen (c->expr);
2695 : break;
2696 :
2697 : default:
2698 : break;
2699 :
2700 : }
2701 : }
2702 :
2703 :
2704 : /* Generate code to initialize a string length variable. Returns the
2705 : value. For array constructors, cl->length might be NULL and in this case,
2706 : the first element of the constructor is needed. expr is the original
2707 : expression so we can access it but can be NULL if this is not needed. */
2708 :
2709 : void
2710 3933 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2711 : {
2712 3933 : gfc_se se;
2713 :
2714 3933 : gfc_init_se (&se, NULL);
2715 :
2716 3933 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2717 1379 : return;
2718 :
2719 : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2720 : "flatten" array constructors by taking their first element; all elements
2721 : should be the same length or a cl->length should be present. */
2722 2647 : if (!cl->length)
2723 : {
2724 176 : gfc_expr* expr_flat;
2725 176 : if (!expr)
2726 : return;
2727 83 : expr_flat = gfc_copy_expr (expr);
2728 83 : flatten_array_ctors_without_strlen (expr_flat);
2729 83 : gfc_resolve_expr (expr_flat);
2730 83 : if (expr_flat->rank)
2731 13 : gfc_conv_expr_descriptor (&se, expr_flat);
2732 : else
2733 70 : gfc_conv_expr (&se, expr_flat);
2734 83 : if (expr_flat->expr_type != EXPR_VARIABLE)
2735 77 : gfc_add_block_to_block (pblock, &se.pre);
2736 83 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2737 83 : gfc_add_block_to_block (pblock, &se.post);
2738 83 : gfc_free_expr (expr_flat);
2739 : }
2740 : else
2741 : {
2742 : /* Convert cl->length. */
2743 2471 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2744 2471 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2745 : gfc_charlen_type_node, se.expr,
2746 2471 : build_zero_cst (TREE_TYPE (se.expr)));
2747 2471 : gfc_add_block_to_block (pblock, &se.pre);
2748 : }
2749 :
2750 2554 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2751 1630 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2752 : else
2753 924 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2754 : }
2755 :
2756 :
2757 : static void
2758 7232 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2759 : const char *name, locus *where)
2760 : {
2761 7232 : tree tmp;
2762 7232 : tree type;
2763 7232 : tree fault;
2764 7232 : gfc_se start;
2765 7232 : gfc_se end;
2766 7232 : char *msg;
2767 7232 : mpz_t length;
2768 :
2769 7232 : type = gfc_get_character_type (kind, ref->u.ss.length);
2770 7232 : type = build_pointer_type (type);
2771 :
2772 7232 : gfc_init_se (&start, se);
2773 7232 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2774 7232 : gfc_add_block_to_block (&se->pre, &start.pre);
2775 :
2776 7232 : if (integer_onep (start.expr))
2777 2776 : gfc_conv_string_parameter (se);
2778 : else
2779 : {
2780 4456 : tmp = start.expr;
2781 4456 : STRIP_NOPS (tmp);
2782 : /* Avoid multiple evaluation of substring start. */
2783 4456 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2784 1585 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2785 :
2786 : /* Change the start of the string. */
2787 4456 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2788 1112 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2789 3464 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2790 5448 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2791 992 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2792 : tmp = se->expr;
2793 : else
2794 984 : tmp = build_fold_indirect_ref_loc (input_location,
2795 : se->expr);
2796 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2797 4456 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2798 : {
2799 4328 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2800 4328 : se->expr = gfc_build_addr_expr (type, tmp);
2801 : }
2802 128 : else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2803 : {
2804 8 : tree diff;
2805 8 : diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr,
2806 : build_one_cst (gfc_charlen_type_node));
2807 8 : diff = fold_convert (size_type_node, diff);
2808 8 : se->expr
2809 8 : = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff);
2810 : }
2811 : }
2812 :
2813 : /* Length = end + 1 - start. */
2814 7232 : gfc_init_se (&end, se);
2815 7232 : if (ref->u.ss.end == NULL)
2816 202 : end.expr = se->string_length;
2817 : else
2818 : {
2819 7030 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2820 7030 : gfc_add_block_to_block (&se->pre, &end.pre);
2821 : }
2822 7232 : tmp = end.expr;
2823 7232 : STRIP_NOPS (tmp);
2824 7232 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2825 2179 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2826 :
2827 7232 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2828 445 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2829 7677 : && !gfc_contains_implied_index_p (ref->u.ss.end))
2830 : {
2831 445 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2832 : logical_type_node, start.expr,
2833 : end.expr);
2834 :
2835 : /* Check lower bound. */
2836 445 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2837 : start.expr,
2838 445 : build_one_cst (TREE_TYPE (start.expr)));
2839 445 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2840 : logical_type_node, nonempty, fault);
2841 445 : if (name)
2842 444 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2843 : "is less than one", name);
2844 : else
2845 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2846 : "is less than one");
2847 445 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2848 : fold_convert (long_integer_type_node,
2849 : start.expr));
2850 445 : free (msg);
2851 :
2852 : /* Check upper bound. */
2853 445 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2854 : end.expr, se->string_length);
2855 445 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2856 : logical_type_node, nonempty, fault);
2857 445 : if (name)
2858 444 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2859 : "exceeds string length (%%ld)", name);
2860 : else
2861 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2862 : "exceeds string length (%%ld)");
2863 445 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2864 : fold_convert (long_integer_type_node, end.expr),
2865 : fold_convert (long_integer_type_node,
2866 : se->string_length));
2867 445 : free (msg);
2868 : }
2869 :
2870 : /* Try to calculate the length from the start and end expressions. */
2871 7232 : if (ref->u.ss.end
2872 7232 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2873 : {
2874 6014 : HOST_WIDE_INT i_len;
2875 :
2876 6014 : i_len = gfc_mpz_get_hwi (length) + 1;
2877 6014 : if (i_len < 0)
2878 : i_len = 0;
2879 :
2880 6014 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2881 6014 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2882 : }
2883 : else
2884 : {
2885 1218 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2886 : fold_convert (gfc_charlen_type_node, end.expr),
2887 : fold_convert (gfc_charlen_type_node, start.expr));
2888 1218 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2889 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2890 1218 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2891 : tmp, build_int_cst (gfc_charlen_type_node, 0));
2892 : }
2893 :
2894 7232 : se->string_length = tmp;
2895 7232 : }
2896 :
2897 :
2898 : /* Convert a derived type component reference. */
2899 :
2900 : void
2901 185366 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2902 : {
2903 185366 : gfc_component *c;
2904 185366 : tree tmp;
2905 185366 : tree decl;
2906 185366 : tree field;
2907 185366 : tree context;
2908 :
2909 185366 : c = ref->u.c.component;
2910 :
2911 185366 : if (c->backend_decl == NULL_TREE
2912 6 : && ref->u.c.sym != NULL)
2913 6 : gfc_get_derived_type (ref->u.c.sym);
2914 :
2915 185366 : field = c->backend_decl;
2916 185366 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2917 185366 : decl = se->expr;
2918 185366 : context = DECL_FIELD_CONTEXT (field);
2919 :
2920 : /* Components can correspond to fields of different containing
2921 : types, as components are created without context, whereas
2922 : a concrete use of a component has the type of decl as context.
2923 : So, if the type doesn't match, we search the corresponding
2924 : FIELD_DECL in the parent type. To not waste too much time
2925 : we cache this result in norestrict_decl.
2926 : On the other hand, if the context is a UNION or a MAP (a
2927 : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2928 :
2929 185366 : if (context != TREE_TYPE (decl)
2930 185366 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2931 13811 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2932 : {
2933 13811 : tree f2 = c->norestrict_decl;
2934 23242 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2935 8773 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2936 8773 : if (TREE_CODE (f2) == FIELD_DECL
2937 8773 : && DECL_NAME (f2) == DECL_NAME (field))
2938 : break;
2939 13811 : gcc_assert (f2);
2940 13811 : c->norestrict_decl = f2;
2941 13811 : field = f2;
2942 : }
2943 :
2944 185366 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2945 0 : && strcmp ("_data", c->name) == 0)
2946 : {
2947 : /* Found a ref to the _data component. Store the associated ref to
2948 : the vptr in se->class_vptr. */
2949 0 : se->class_vptr = gfc_class_vptr_get (decl);
2950 : }
2951 : else
2952 185366 : se->class_vptr = NULL_TREE;
2953 :
2954 185366 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2955 : decl, field, NULL_TREE);
2956 :
2957 185366 : se->expr = tmp;
2958 :
2959 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2960 : strlen () conditional below. */
2961 185366 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2962 9222 : && !c->ts.deferred
2963 5944 : && !c->attr.pdt_string)
2964 : {
2965 5608 : tmp = c->ts.u.cl->backend_decl;
2966 : /* Components must always be constant length. */
2967 5608 : gcc_assert (tmp && INTEGER_CST_P (tmp));
2968 5608 : se->string_length = tmp;
2969 : }
2970 :
2971 185366 : if (gfc_deferred_strlen (c, &field))
2972 : {
2973 3614 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2974 3614 : TREE_TYPE (field),
2975 : decl, field, NULL_TREE);
2976 3614 : se->string_length = tmp;
2977 : }
2978 :
2979 185366 : if (((c->attr.pointer || c->attr.allocatable)
2980 108309 : && (!c->attr.dimension && !c->attr.codimension)
2981 58446 : && c->ts.type != BT_CHARACTER)
2982 129227 : || c->attr.proc_pointer)
2983 62776 : se->expr = build_fold_indirect_ref_loc (input_location,
2984 : se->expr);
2985 185366 : }
2986 :
2987 :
2988 : /* This function deals with component references to components of the
2989 : parent type for derived type extensions. */
2990 : void
2991 67884 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2992 : {
2993 67884 : gfc_component *c;
2994 67884 : gfc_component *cmp;
2995 67884 : gfc_symbol *dt;
2996 67884 : gfc_ref parent;
2997 :
2998 67884 : dt = ref->u.c.sym;
2999 67884 : c = ref->u.c.component;
3000 :
3001 : /* Return if the component is in this type, i.e. not in the parent type. */
3002 119195 : for (cmp = dt->components; cmp; cmp = cmp->next)
3003 107986 : if (c == cmp)
3004 56675 : return;
3005 :
3006 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3007 11209 : parent.type = REF_COMPONENT;
3008 11209 : parent.next = NULL;
3009 11209 : parent.u.c.sym = dt;
3010 11209 : parent.u.c.component = dt->components;
3011 :
3012 11209 : if (dt->backend_decl == NULL)
3013 0 : gfc_get_derived_type (dt);
3014 :
3015 : /* Build the reference and call self. */
3016 11209 : gfc_conv_component_ref (se, &parent);
3017 11209 : parent.u.c.sym = dt->components->ts.u.derived;
3018 11209 : parent.u.c.component = c;
3019 11209 : conv_parent_component_references (se, &parent);
3020 : }
3021 :
3022 :
3023 : static void
3024 621 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
3025 : {
3026 621 : tree res = se->expr;
3027 :
3028 621 : switch (ref->u.i)
3029 : {
3030 265 : case INQUIRY_RE:
3031 530 : res = fold_build1_loc (input_location, REALPART_EXPR,
3032 265 : TREE_TYPE (TREE_TYPE (res)), res);
3033 265 : break;
3034 :
3035 239 : case INQUIRY_IM:
3036 478 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
3037 239 : TREE_TYPE (TREE_TYPE (res)), res);
3038 239 : break;
3039 :
3040 7 : case INQUIRY_KIND:
3041 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
3042 7 : ts->kind);
3043 7 : se->string_length = NULL_TREE;
3044 7 : break;
3045 :
3046 110 : case INQUIRY_LEN:
3047 110 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
3048 : se->string_length);
3049 110 : se->string_length = NULL_TREE;
3050 110 : break;
3051 :
3052 0 : default:
3053 0 : gcc_unreachable ();
3054 : }
3055 621 : se->expr = res;
3056 621 : }
3057 :
3058 : /* Dereference VAR where needed if it is a pointer, reference, etc.
3059 : according to Fortran semantics. */
3060 :
3061 : tree
3062 1482152 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3063 : bool is_classarray)
3064 : {
3065 1482152 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3066 : return var;
3067 302815 : if (is_CFI_desc (sym, NULL))
3068 11892 : return build_fold_indirect_ref_loc (input_location, var);
3069 :
3070 : /* Characters are entirely different from other types, they are treated
3071 : separately. */
3072 290923 : if (sym->ts.type == BT_CHARACTER)
3073 : {
3074 : /* Dereference character pointer dummy arguments
3075 : or results. */
3076 33561 : if ((sym->attr.pointer || sym->attr.allocatable
3077 19351 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3078 14546 : && (sym->attr.dummy
3079 11230 : || sym->attr.function
3080 10832 : || sym->attr.result))
3081 4423 : var = build_fold_indirect_ref_loc (input_location, var);
3082 : }
3083 257362 : else if (!sym->attr.value)
3084 : {
3085 : /* Dereference temporaries for class array dummy arguments. */
3086 177303 : if (sym->attr.dummy && is_classarray
3087 264365 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3088 : {
3089 5661 : if (!descriptor_only_p)
3090 2932 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3091 :
3092 5661 : var = build_fold_indirect_ref_loc (input_location, var);
3093 : }
3094 :
3095 : /* Dereference non-character scalar dummy arguments. */
3096 256264 : if (sym->attr.dummy && !sym->attr.dimension
3097 107365 : && !(sym->attr.codimension && sym->attr.allocatable)
3098 107299 : && (sym->ts.type != BT_CLASS
3099 20537 : || (!CLASS_DATA (sym)->attr.dimension
3100 11936 : && !(CLASS_DATA (sym)->attr.codimension
3101 283 : && CLASS_DATA (sym)->attr.allocatable))))
3102 98557 : var = build_fold_indirect_ref_loc (input_location, var);
3103 :
3104 : /* Dereference scalar hidden result. */
3105 256264 : if (flag_f2c && sym->ts.type == BT_COMPLEX
3106 286 : && (sym->attr.function || sym->attr.result)
3107 108 : && !sym->attr.dimension && !sym->attr.pointer
3108 60 : && !sym->attr.always_explicit)
3109 36 : var = build_fold_indirect_ref_loc (input_location, var);
3110 :
3111 : /* Dereference non-character, non-class pointer variables.
3112 : These must be dummies, results, or scalars. */
3113 256264 : if (!is_classarray
3114 247717 : && (sym->attr.pointer || sym->attr.allocatable
3115 197322 : || gfc_is_associate_pointer (sym)
3116 192256 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3117 335715 : && (sym->attr.dummy
3118 37429 : || sym->attr.function
3119 36499 : || sym->attr.result
3120 35345 : || (!sym->attr.dimension
3121 35340 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3122 79446 : var = build_fold_indirect_ref_loc (input_location, var);
3123 : /* Now treat the class array pointer variables accordingly. */
3124 176818 : else if (sym->ts.type == BT_CLASS
3125 20983 : && sym->attr.dummy
3126 20537 : && (CLASS_DATA (sym)->attr.dimension
3127 11936 : || CLASS_DATA (sym)->attr.codimension)
3128 8884 : && ((CLASS_DATA (sym)->as
3129 8884 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3130 7821 : || CLASS_DATA (sym)->attr.allocatable
3131 6412 : || CLASS_DATA (sym)->attr.class_pointer))
3132 3081 : var = build_fold_indirect_ref_loc (input_location, var);
3133 : /* And the case where a non-dummy, non-result, non-function,
3134 : non-allocable and non-pointer classarray is present. This case was
3135 : previously covered by the first if, but with introducing the
3136 : condition !is_classarray there, that case has to be covered
3137 : explicitly. */
3138 173737 : else if (sym->ts.type == BT_CLASS
3139 17902 : && !sym->attr.dummy
3140 446 : && !sym->attr.function
3141 446 : && !sym->attr.result
3142 446 : && (CLASS_DATA (sym)->attr.dimension
3143 4 : || CLASS_DATA (sym)->attr.codimension)
3144 446 : && (sym->assoc
3145 0 : || !CLASS_DATA (sym)->attr.allocatable)
3146 446 : && !CLASS_DATA (sym)->attr.class_pointer)
3147 446 : var = build_fold_indirect_ref_loc (input_location, var);
3148 : }
3149 :
3150 : return var;
3151 : }
3152 :
3153 : /* Return the contents of a variable. Also handles reference/pointer
3154 : variables (all Fortran pointer references are implicit). */
3155 :
3156 : static void
3157 1638676 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3158 : {
3159 1638676 : gfc_ss *ss;
3160 1638676 : gfc_ref *ref;
3161 1638676 : gfc_symbol *sym;
3162 1638676 : tree parent_decl = NULL_TREE;
3163 1638676 : int parent_flag;
3164 1638676 : bool return_value;
3165 1638676 : bool alternate_entry;
3166 1638676 : bool entry_master;
3167 1638676 : bool is_classarray;
3168 1638676 : bool first_time = true;
3169 :
3170 1638676 : sym = expr->symtree->n.sym;
3171 1638676 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3172 1638676 : ss = se->ss;
3173 1638676 : if (ss != NULL)
3174 : {
3175 136116 : gfc_ss_info *ss_info = ss->info;
3176 :
3177 : /* Check that something hasn't gone horribly wrong. */
3178 136116 : gcc_assert (ss != gfc_ss_terminator);
3179 136116 : gcc_assert (ss_info->expr == expr);
3180 :
3181 : /* A scalarized term. We already know the descriptor. */
3182 136116 : se->expr = ss_info->data.array.descriptor;
3183 136116 : se->string_length = ss_info->string_length;
3184 136116 : ref = ss_info->data.array.ref;
3185 136116 : if (ref)
3186 135762 : gcc_assert (ref->type == REF_ARRAY
3187 : && ref->u.ar.type != AR_ELEMENT);
3188 : else
3189 354 : gfc_conv_tmp_array_ref (se);
3190 : }
3191 : else
3192 : {
3193 1502560 : tree se_expr = NULL_TREE;
3194 :
3195 1502560 : se->expr = gfc_get_symbol_decl (sym);
3196 :
3197 : /* Deal with references to a parent results or entries by storing
3198 : the current_function_decl and moving to the parent_decl. */
3199 1502560 : return_value = sym->attr.function && sym->result == sym;
3200 19683 : alternate_entry = sym->attr.function && sym->attr.entry
3201 1503699 : && sym->result == sym;
3202 3005120 : entry_master = sym->attr.result
3203 15130 : && sym->ns->proc_name->attr.entry_master
3204 1502941 : && !gfc_return_by_reference (sym->ns->proc_name);
3205 1502560 : if (current_function_decl)
3206 1483663 : parent_decl = DECL_CONTEXT (current_function_decl);
3207 :
3208 1502560 : if ((se->expr == parent_decl && return_value)
3209 1502443 : || (sym->ns && sym->ns->proc_name
3210 1496845 : && parent_decl
3211 1477948 : && sym->ns->proc_name->backend_decl == parent_decl
3212 39379 : && (alternate_entry || entry_master)))
3213 : parent_flag = 1;
3214 : else
3215 1502410 : parent_flag = 0;
3216 :
3217 : /* Special case for assigning the return value of a function.
3218 : Self recursive functions must have an explicit return value. */
3219 1502560 : if (return_value && (se->expr == current_function_decl || parent_flag))
3220 10618 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3221 :
3222 : /* Similarly for alternate entry points. */
3223 1491942 : else if (alternate_entry
3224 1106 : && (sym->ns->proc_name->backend_decl == current_function_decl
3225 0 : || parent_flag))
3226 : {
3227 1106 : gfc_entry_list *el = NULL;
3228 :
3229 1705 : for (el = sym->ns->entries; el; el = el->next)
3230 1705 : if (sym == el->sym)
3231 : {
3232 1106 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3233 1106 : break;
3234 : }
3235 : }
3236 :
3237 1490836 : else if (entry_master
3238 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3239 0 : || parent_flag))
3240 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3241 :
3242 12019 : if (se_expr)
3243 12019 : se->expr = se_expr;
3244 :
3245 : /* Procedure actual arguments. Look out for temporary variables
3246 : with the same attributes as function values. */
3247 1490541 : else if (!sym->attr.temporary
3248 1490473 : && sym->attr.flavor == FL_PROCEDURE
3249 22559 : && se->expr != current_function_decl)
3250 : {
3251 22486 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3252 : {
3253 20774 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3254 20774 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3255 : }
3256 : return;
3257 : }
3258 :
3259 1480074 : if (sym->ts.type == BT_CLASS
3260 76247 : && sym->attr.class_ok
3261 76005 : && sym->ts.u.derived->attr.is_class)
3262 : {
3263 29202 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3264 84121 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3265 5803 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3266 : else
3267 70202 : se->class_container = se->expr;
3268 : }
3269 :
3270 : /* Dereference the expression, where needed. */
3271 1480074 : if (se->class_container && CLASS_DATA (sym)->attr.codimension
3272 2113 : && !CLASS_DATA (sym)->attr.dimension)
3273 910 : se->expr
3274 910 : = gfc_maybe_dereference_var (sym, se->class_container,
3275 910 : se->descriptor_only, is_classarray);
3276 : else
3277 1479164 : se->expr
3278 1479164 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3279 : is_classarray);
3280 :
3281 1480074 : ref = expr->ref;
3282 : }
3283 :
3284 : /* For character variables, also get the length. */
3285 1616190 : if (sym->ts.type == BT_CHARACTER)
3286 : {
3287 : /* If the character length of an entry isn't set, get the length from
3288 : the master function instead. */
3289 168125 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3290 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3291 : else
3292 168125 : se->string_length = sym->ts.u.cl->backend_decl;
3293 168125 : gcc_assert (se->string_length);
3294 :
3295 : /* For coarray strings return the pointer to the data and not the
3296 : descriptor. */
3297 5143 : if (sym->attr.codimension && sym->attr.associate_var
3298 6 : && !se->descriptor_only
3299 168131 : && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
3300 6 : se->expr = gfc_conv_descriptor_data_get (se->expr);
3301 : }
3302 :
3303 : /* F202Y: Runtime warning that an assumed rank object is associated
3304 : with an assumed size object. */
3305 1616190 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3306 90661 : && (gfc_option.allow_std & GFC_STD_F202Y)
3307 1616424 : && expr->rank == -1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3308 : {
3309 60 : tree dim, lower, upper, cond;
3310 60 : char *msg;
3311 :
3312 60 : dim = fold_convert (gfc_array_dim_rank_type,
3313 : gfc_conv_descriptor_rank_get (se->expr));
3314 60 : dim = fold_build2_loc (input_location, MINUS_EXPR,
3315 : gfc_array_dim_rank_type, dim, gfc_rank_cst[1]);
3316 60 : lower = gfc_conv_descriptor_lbound_get (se->expr, dim);
3317 60 : upper = gfc_conv_descriptor_ubound_get (se->expr, dim);
3318 :
3319 60 : msg = xasprintf ("Assumed rank object %s is associated with an "
3320 : "assumed size object", sym->name);
3321 60 : cond = fold_build2_loc (input_location, LT_EXPR,
3322 : logical_type_node, upper, lower);
3323 60 : gfc_trans_runtime_check (false, true, cond, &se->pre,
3324 : &gfc_current_locus, msg);
3325 60 : free (msg);
3326 : }
3327 :
3328 : /* Some expressions leak through that haven't been fixed up. */
3329 1616190 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3330 418 : gfc_fixup_inferred_type_refs (expr);
3331 :
3332 1616190 : gfc_typespec *ts = &sym->ts;
3333 2065600 : while (ref)
3334 : {
3335 807636 : switch (ref->type)
3336 : {
3337 625974 : case REF_ARRAY:
3338 : /* Return the descriptor if that's what we want and this is an array
3339 : section reference. */
3340 625974 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3341 : return;
3342 : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3343 : /* Return the descriptor for array pointers and allocations. */
3344 277444 : if (se->want_pointer
3345 24722 : && ref->next == NULL && (se->descriptor_only))
3346 : return;
3347 :
3348 267748 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3349 : /* Return a pointer to an element. */
3350 267748 : break;
3351 :
3352 174067 : case REF_COMPONENT:
3353 174067 : ts = &ref->u.c.component->ts;
3354 174067 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3355 6135 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3356 3250 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3357 3250 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3358 2729 : && strcmp ("_data", ref->u.c.component->name) == 0)
3359 : /* Skip the first ref of a _data component, because for class
3360 : arrays that one is already done by introducing a temporary
3361 : array descriptor. */
3362 : break;
3363 :
3364 171338 : if (ref->u.c.sym->attr.extension)
3365 56584 : conv_parent_component_references (se, ref);
3366 :
3367 171338 : gfc_conv_component_ref (se, ref);
3368 :
3369 171338 : if (ref->u.c.component->ts.type == BT_CLASS
3370 12684 : && ref->u.c.component->attr.class_ok
3371 12684 : && ref->u.c.component->ts.u.derived->attr.is_class)
3372 12684 : se->class_container = se->expr;
3373 158654 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3374 156160 : && ref->u.c.sym->attr.is_class))
3375 87095 : se->class_container = NULL_TREE;
3376 :
3377 171338 : if (!ref->next && ref->u.c.sym->attr.codimension
3378 0 : && se->want_pointer && se->descriptor_only)
3379 : return;
3380 :
3381 : break;
3382 :
3383 6974 : case REF_SUBSTRING:
3384 6974 : gfc_conv_substring (se, ref, expr->ts.kind,
3385 6974 : expr->symtree->name, &expr->where);
3386 6974 : break;
3387 :
3388 621 : case REF_INQUIRY:
3389 621 : conv_inquiry (se, ref, expr, ts);
3390 621 : break;
3391 :
3392 0 : default:
3393 0 : gcc_unreachable ();
3394 449410 : break;
3395 : }
3396 449410 : first_time = false;
3397 449410 : ref = ref->next;
3398 : }
3399 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3400 : separately. */
3401 1257964 : if (se->want_pointer)
3402 : {
3403 137279 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3404 8216 : gfc_conv_string_parameter (se);
3405 : else
3406 129063 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3407 : }
3408 : }
3409 :
3410 :
3411 : /* Unary ops are easy... Or they would be if ! was a valid op. */
3412 :
3413 : static void
3414 29025 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3415 : {
3416 29025 : gfc_se operand;
3417 29025 : tree type;
3418 :
3419 29025 : gcc_assert (expr->ts.type != BT_CHARACTER);
3420 : /* Initialize the operand. */
3421 29025 : gfc_init_se (&operand, se);
3422 29025 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3423 29025 : gfc_add_block_to_block (&se->pre, &operand.pre);
3424 :
3425 29025 : type = gfc_typenode_for_spec (&expr->ts);
3426 :
3427 : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3428 : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3429 : All other unary operators have an equivalent GIMPLE unary operator. */
3430 29025 : if (code == TRUTH_NOT_EXPR)
3431 20388 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3432 : build_int_cst (type, 0));
3433 : else
3434 8637 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3435 :
3436 29025 : }
3437 :
3438 : /* Expand power operator to optimal multiplications when a value is raised
3439 : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3440 : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3441 : Programming", 3rd Edition, 1998. */
3442 :
3443 : /* This code is mostly duplicated from expand_powi in the backend.
3444 : We establish the "optimal power tree" lookup table with the defined size.
3445 : The items in the table are the exponents used to calculate the index
3446 : exponents. Any integer n less than the value can get an "addition chain",
3447 : with the first node being one. */
3448 : #define POWI_TABLE_SIZE 256
3449 :
3450 : /* The table is from builtins.cc. */
3451 : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3452 : {
3453 : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3454 : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3455 : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3456 : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3457 : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3458 : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3459 : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3460 : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3461 : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3462 : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3463 : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3464 : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3465 : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3466 : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3467 : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3468 : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3469 : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3470 : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3471 : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3472 : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3473 : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3474 : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3475 : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3476 : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3477 : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3478 : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3479 : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3480 : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3481 : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3482 : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3483 : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3484 : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3485 : };
3486 :
3487 : /* If n is larger than lookup table's max index, we use the "window
3488 : method". */
3489 : #define POWI_WINDOW_SIZE 3
3490 :
3491 : /* Recursive function to expand the power operator. The temporary
3492 : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3493 : static tree
3494 178323 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3495 : {
3496 178323 : tree op0;
3497 178323 : tree op1;
3498 178323 : tree tmp;
3499 178323 : int digit;
3500 :
3501 178323 : if (n < POWI_TABLE_SIZE)
3502 : {
3503 137336 : if (tmpvar[n])
3504 : return tmpvar[n];
3505 :
3506 56612 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3507 56612 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3508 : }
3509 40987 : else if (n & 1)
3510 : {
3511 10015 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3512 10015 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3513 10015 : op1 = gfc_conv_powi (se, digit, tmpvar);
3514 : }
3515 : else
3516 : {
3517 30972 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3518 30972 : op1 = op0;
3519 : }
3520 :
3521 97599 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3522 97599 : tmp = gfc_evaluate_now (tmp, &se->pre);
3523 :
3524 97599 : if (n < POWI_TABLE_SIZE)
3525 56612 : tmpvar[n] = tmp;
3526 :
3527 : return tmp;
3528 : }
3529 :
3530 :
3531 : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3532 : return 1. Else return 0 and a call to runtime library functions
3533 : will have to be built. */
3534 : static int
3535 3305 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3536 : {
3537 3305 : tree cond;
3538 3305 : tree tmp;
3539 3305 : tree type;
3540 3305 : tree vartmp[POWI_TABLE_SIZE];
3541 3305 : HOST_WIDE_INT m;
3542 3305 : unsigned HOST_WIDE_INT n;
3543 3305 : int sgn;
3544 3305 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3545 :
3546 : /* If exponent is too large, we won't expand it anyway, so don't bother
3547 : with large integer values. */
3548 3305 : if (!wi::fits_shwi_p (wrhs))
3549 : return 0;
3550 :
3551 2945 : m = wrhs.to_shwi ();
3552 : /* Use the wide_int's routine to reliably get the absolute value on all
3553 : platforms. Then convert it to a HOST_WIDE_INT like above. */
3554 2945 : n = wi::abs (wrhs).to_shwi ();
3555 :
3556 2945 : type = TREE_TYPE (lhs);
3557 2945 : sgn = tree_int_cst_sgn (rhs);
3558 :
3559 2945 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3560 5890 : || optimize_size) && (m > 2 || m < -1))
3561 : return 0;
3562 :
3563 : /* rhs == 0 */
3564 1639 : if (sgn == 0)
3565 : {
3566 282 : se->expr = gfc_build_const (type, integer_one_node);
3567 282 : return 1;
3568 : }
3569 :
3570 : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3571 1357 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3572 : {
3573 220 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3574 220 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3575 220 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3576 220 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3577 :
3578 : /* If rhs is even,
3579 : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3580 220 : if ((n & 1) == 0)
3581 : {
3582 104 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3583 : logical_type_node, tmp, cond);
3584 104 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3585 : tmp, build_int_cst (type, 1),
3586 : build_int_cst (type, 0));
3587 104 : return 1;
3588 : }
3589 : /* If rhs is odd,
3590 : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3591 116 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3592 : build_int_cst (type, -1),
3593 : build_int_cst (type, 0));
3594 116 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3595 : cond, build_int_cst (type, 1), tmp);
3596 116 : return 1;
3597 : }
3598 :
3599 1137 : memset (vartmp, 0, sizeof (vartmp));
3600 1137 : vartmp[1] = lhs;
3601 1137 : if (sgn == -1)
3602 : {
3603 141 : tmp = gfc_build_const (type, integer_one_node);
3604 141 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3605 : vartmp[1]);
3606 : }
3607 :
3608 1137 : se->expr = gfc_conv_powi (se, n, vartmp);
3609 :
3610 1137 : return 1;
3611 : }
3612 :
3613 : /* Convert lhs**rhs, for constant rhs, when both are unsigned.
3614 : Method:
3615 : if (rhs == 0) ! Checked here.
3616 : return 1;
3617 : if (lhs & 1 == 1) ! odd_cnd
3618 : {
3619 : if (bit_size(rhs) < bit_size(lhs)) ! Checked here.
3620 : return lhs ** rhs;
3621 :
3622 : mask = 1 << (bit_size(a) - 1) / 2;
3623 : return lhs ** (n & rhs);
3624 : }
3625 : if (rhs > bit_size(lhs)) ! Checked here.
3626 : return 0;
3627 :
3628 : return lhs ** rhs;
3629 : */
3630 :
3631 : static int
3632 15120 : gfc_conv_cst_uint_power (gfc_se * se, tree lhs, tree rhs)
3633 : {
3634 15120 : tree type = TREE_TYPE (lhs);
3635 15120 : tree tmp, is_odd, odd_branch, even_branch;
3636 15120 : unsigned HOST_WIDE_INT lhs_prec, rhs_prec;
3637 15120 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3638 15120 : unsigned HOST_WIDE_INT n, n_odd;
3639 15120 : tree vartmp_odd[POWI_TABLE_SIZE], vartmp_even[POWI_TABLE_SIZE];
3640 :
3641 : /* Anything ** 0 is one. */
3642 15120 : if (integer_zerop (rhs))
3643 : {
3644 1800 : se->expr = build_int_cst (type, 1);
3645 1800 : return 1;
3646 : }
3647 :
3648 13320 : if (!wi::fits_uhwi_p (wrhs))
3649 : return 0;
3650 :
3651 12960 : n = wrhs.to_uhwi ();
3652 :
3653 : /* tmp = a & 1; . */
3654 12960 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3655 : lhs, build_int_cst (type, 1));
3656 12960 : is_odd = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3657 : tmp, build_int_cst (type, 1));
3658 :
3659 12960 : lhs_prec = TYPE_PRECISION (type);
3660 12960 : rhs_prec = TYPE_PRECISION (TREE_TYPE (rhs));
3661 :
3662 12960 : if (rhs_prec >= lhs_prec && lhs_prec <= HOST_BITS_PER_WIDE_INT)
3663 : {
3664 7044 : unsigned HOST_WIDE_INT mask = (HOST_WIDE_INT_1U << (lhs_prec - 1)) - 1;
3665 7044 : n_odd = n & mask;
3666 : }
3667 : else
3668 : n_odd = n;
3669 :
3670 12960 : memset (vartmp_odd, 0, sizeof (vartmp_odd));
3671 12960 : vartmp_odd[0] = build_int_cst (type, 1);
3672 12960 : vartmp_odd[1] = lhs;
3673 12960 : odd_branch = gfc_conv_powi (se, n_odd, vartmp_odd);
3674 12960 : even_branch = NULL_TREE;
3675 :
3676 12960 : if (n > lhs_prec)
3677 4260 : even_branch = build_int_cst (type, 0);
3678 : else
3679 : {
3680 8700 : if (n_odd != n)
3681 : {
3682 0 : memset (vartmp_even, 0, sizeof (vartmp_even));
3683 0 : vartmp_even[0] = build_int_cst (type, 1);
3684 0 : vartmp_even[1] = lhs;
3685 0 : even_branch = gfc_conv_powi (se, n, vartmp_even);
3686 : }
3687 : }
3688 4260 : if (even_branch != NULL_TREE)
3689 4260 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, is_odd,
3690 : odd_branch, even_branch);
3691 : else
3692 8700 : se->expr = odd_branch;
3693 :
3694 : return 1;
3695 : }
3696 :
3697 : /* Power op (**). Constant integer exponent and powers of 2 have special
3698 : handling. */
3699 :
3700 : static void
3701 49183 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3702 : {
3703 49183 : tree gfc_int4_type_node;
3704 49183 : int kind;
3705 49183 : int ikind;
3706 49183 : int res_ikind_1, res_ikind_2;
3707 49183 : gfc_se lse;
3708 49183 : gfc_se rse;
3709 49183 : tree fndecl = NULL;
3710 :
3711 49183 : gfc_init_se (&lse, se);
3712 49183 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3713 49183 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3714 49183 : gfc_add_block_to_block (&se->pre, &lse.pre);
3715 :
3716 49183 : gfc_init_se (&rse, se);
3717 49183 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3718 49183 : gfc_add_block_to_block (&se->pre, &rse.pre);
3719 :
3720 49183 : if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
3721 : {
3722 17563 : if (expr->value.op.op2->ts.type == BT_INTEGER)
3723 : {
3724 2292 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3725 20483 : return;
3726 : }
3727 15271 : else if (expr->value.op.op2->ts.type == BT_UNSIGNED)
3728 : {
3729 15120 : if (gfc_conv_cst_uint_power (se, lse.expr, rse.expr))
3730 : return;
3731 : }
3732 : }
3733 :
3734 32784 : if ((expr->value.op.op2->ts.type == BT_INTEGER
3735 31468 : || expr->value.op.op2->ts.type == BT_UNSIGNED)
3736 31916 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3737 1013 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3738 : return;
3739 :
3740 32784 : if (INTEGER_CST_P (lse.expr)
3741 15377 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE
3742 48161 : && expr->value.op.op2->ts.type == BT_INTEGER)
3743 : {
3744 257 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3745 257 : HOST_WIDE_INT v;
3746 257 : unsigned HOST_WIDE_INT w;
3747 257 : int kind, ikind, bit_size;
3748 :
3749 257 : v = wlhs.to_shwi ();
3750 257 : w = absu_hwi (v);
3751 :
3752 257 : kind = expr->value.op.op1->ts.kind;
3753 257 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3754 257 : bit_size = gfc_integer_kinds[ikind].bit_size;
3755 :
3756 257 : if (v == 1)
3757 : {
3758 : /* 1**something is always 1. */
3759 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3760 245 : return;
3761 : }
3762 222 : else if (v == -1)
3763 : {
3764 : /* (-1)**n is 1 - ((n & 1) << 1) */
3765 34 : tree type;
3766 34 : tree tmp;
3767 :
3768 34 : type = TREE_TYPE (lse.expr);
3769 34 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3770 : rse.expr, build_int_cst (type, 1));
3771 34 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3772 : tmp, build_int_cst (type, 1));
3773 34 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3774 : build_int_cst (type, 1), tmp);
3775 34 : se->expr = tmp;
3776 34 : return;
3777 : }
3778 188 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3779 : {
3780 : /* Here v is +/- 2**e. The further simplification uses
3781 : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3782 : 1<<(4*n), etc., but we have to make sure to return zero
3783 : if the number of bits is too large. */
3784 176 : tree lshift;
3785 176 : tree type;
3786 176 : tree shift;
3787 176 : tree ge;
3788 176 : tree cond;
3789 176 : tree num_bits;
3790 176 : tree cond2;
3791 176 : tree tmp1;
3792 :
3793 176 : type = TREE_TYPE (lse.expr);
3794 :
3795 176 : if (w == 2)
3796 116 : shift = rse.expr;
3797 60 : else if (w == 4)
3798 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3799 12 : TREE_TYPE (rse.expr),
3800 : rse.expr, rse.expr);
3801 : else
3802 : {
3803 : /* use popcount for fast log2(w) */
3804 48 : int e = wi::popcount (w-1);
3805 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3806 48 : TREE_TYPE (rse.expr),
3807 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3808 : rse.expr);
3809 : }
3810 :
3811 176 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3812 : build_int_cst (type, 1), shift);
3813 176 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3814 : rse.expr, build_int_cst (type, 0));
3815 176 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3816 : build_int_cst (type, 0));
3817 176 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3818 176 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3819 : rse.expr, num_bits);
3820 176 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3821 : build_int_cst (type, 0), cond);
3822 176 : if (v > 0)
3823 : {
3824 : se->expr = tmp1;
3825 : }
3826 : else
3827 : {
3828 : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3829 42 : tree tmp2;
3830 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3831 : rse.expr, build_int_cst (type, 1));
3832 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3833 : tmp2, build_int_cst (type, 1));
3834 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3835 : build_int_cst (type, 1), tmp2);
3836 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3837 : tmp1, tmp2);
3838 : }
3839 176 : return;
3840 : }
3841 : }
3842 : /* Handle unsigned separate from signed above, things would be too
3843 : complicated otherwise. */
3844 :
3845 32539 : if (INTEGER_CST_P (lse.expr) && expr->value.op.op1->ts.type == BT_UNSIGNED)
3846 : {
3847 15120 : gfc_expr * op1 = expr->value.op.op1;
3848 15120 : tree type;
3849 :
3850 15120 : type = TREE_TYPE (lse.expr);
3851 :
3852 15120 : if (mpz_cmp_ui (op1->value.integer, 1) == 0)
3853 : {
3854 : /* 1**something is always 1. */
3855 1260 : se->expr = build_int_cst (type, 1);
3856 1260 : return;
3857 : }
3858 :
3859 : /* Simplify 2u**x to a shift, with the value set to zero if it falls
3860 : outside the range. */
3861 26460 : if (mpz_popcount (op1->value.integer) == 1)
3862 : {
3863 2520 : tree prec_m1, lim, shift, lshift, cond, tmp;
3864 2520 : tree rtype = TREE_TYPE (rse.expr);
3865 2520 : int e = mpz_scan1 (op1->value.integer, 0);
3866 :
3867 2520 : shift = fold_build2_loc (input_location, MULT_EXPR,
3868 2520 : rtype, build_int_cst (rtype, e),
3869 : rse.expr);
3870 2520 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3871 : build_int_cst (type, 1), shift);
3872 5040 : prec_m1 = fold_build2_loc (input_location, MINUS_EXPR, rtype,
3873 2520 : build_int_cst (rtype, TYPE_PRECISION (type)),
3874 : build_int_cst (rtype, 1));
3875 2520 : lim = fold_build2_loc (input_location, TRUNC_DIV_EXPR, rtype,
3876 2520 : prec_m1, build_int_cst (rtype, e));
3877 2520 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3878 : rse.expr, lim);
3879 2520 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond,
3880 : build_int_cst (type, 0), lshift);
3881 2520 : se->expr = tmp;
3882 2520 : return;
3883 : }
3884 : }
3885 :
3886 28759 : gfc_int4_type_node = gfc_get_int_type (4);
3887 :
3888 : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3889 : library routine. But in the end, we have to convert the result back
3890 : if this case applies -- with res_ikind_K, we keep track whether operand K
3891 : falls into this case. */
3892 28759 : res_ikind_1 = -1;
3893 28759 : res_ikind_2 = -1;
3894 :
3895 28759 : kind = expr->value.op.op1->ts.kind;
3896 28759 : switch (expr->value.op.op2->ts.type)
3897 : {
3898 1071 : case BT_INTEGER:
3899 1071 : ikind = expr->value.op.op2->ts.kind;
3900 1071 : switch (ikind)
3901 : {
3902 168 : case 1:
3903 168 : case 2:
3904 168 : rse.expr = convert (gfc_int4_type_node, rse.expr);
3905 168 : res_ikind_2 = ikind;
3906 : /* Fall through. */
3907 :
3908 : case 4:
3909 : ikind = 0;
3910 : break;
3911 :
3912 182 : case 8:
3913 182 : ikind = 1;
3914 182 : break;
3915 :
3916 6 : case 16:
3917 6 : ikind = 2;
3918 6 : break;
3919 :
3920 0 : default:
3921 0 : gcc_unreachable ();
3922 : }
3923 1071 : switch (kind)
3924 : {
3925 0 : case 1:
3926 0 : case 2:
3927 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
3928 : {
3929 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
3930 0 : res_ikind_1 = kind;
3931 : }
3932 : else
3933 0 : gcc_unreachable ();
3934 : /* Fall through. */
3935 :
3936 : case 4:
3937 : kind = 0;
3938 : break;
3939 :
3940 212 : case 8:
3941 212 : kind = 1;
3942 212 : break;
3943 :
3944 6 : case 10:
3945 6 : kind = 2;
3946 6 : break;
3947 :
3948 18 : case 16:
3949 18 : kind = 3;
3950 18 : break;
3951 :
3952 0 : default:
3953 0 : gcc_unreachable ();
3954 : }
3955 :
3956 1071 : switch (expr->value.op.op1->ts.type)
3957 : {
3958 129 : case BT_INTEGER:
3959 129 : if (kind == 3) /* Case 16 was not handled properly above. */
3960 : kind = 2;
3961 129 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3962 129 : break;
3963 :
3964 710 : case BT_REAL:
3965 : /* Use builtins for real ** int4. */
3966 :
3967 710 : if (real_minus_onep (lse.expr))
3968 : {
3969 : /* (-1.0)**n is (real) (1 - ((n & 1) << 1)), see the integer case
3970 : above. */
3971 :
3972 59 : tree lhs_type, rhs_type;
3973 59 : tree tmp;
3974 59 : lhs_type = TREE_TYPE (lse.expr);
3975 59 : rhs_type = TREE_TYPE (rse.expr);
3976 59 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, rhs_type,
3977 : rse.expr, build_int_cst (rhs_type, 1));
3978 59 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, rhs_type,
3979 : tmp, build_int_cst (rhs_type, 1));
3980 59 : tmp = fold_build2_loc (input_location, MINUS_EXPR, rhs_type,
3981 : build_int_cst (rhs_type, 1), tmp);
3982 59 : se->expr = fold_convert (lhs_type, tmp);
3983 59 : return;
3984 : }
3985 :
3986 651 : if (ikind == 0)
3987 : {
3988 555 : switch (kind)
3989 : {
3990 391 : case 0:
3991 391 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3992 391 : break;
3993 :
3994 146 : case 1:
3995 146 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3996 146 : break;
3997 :
3998 6 : case 2:
3999 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4000 6 : break;
4001 :
4002 12 : case 3:
4003 : /* Use the __builtin_powil() only if real(kind=16) is
4004 : actually the C long double type. */
4005 12 : if (!gfc_real16_is_float128)
4006 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4007 : break;
4008 :
4009 : default:
4010 : gcc_unreachable ();
4011 : }
4012 : }
4013 :
4014 : /* If we don't have a good builtin for this, go for the
4015 : library function. */
4016 543 : if (!fndecl)
4017 108 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
4018 : break;
4019 :
4020 232 : case BT_COMPLEX:
4021 232 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
4022 232 : break;
4023 :
4024 0 : default:
4025 0 : gcc_unreachable ();
4026 : }
4027 : break;
4028 :
4029 139 : case BT_REAL:
4030 139 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
4031 139 : break;
4032 :
4033 729 : case BT_COMPLEX:
4034 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
4035 729 : break;
4036 :
4037 26820 : case BT_UNSIGNED:
4038 26820 : {
4039 : /* Valid kinds for unsigned are 1, 2, 4, 8, 16. Instead of using a
4040 : large switch statement, let's just use __builtin_ctz. */
4041 26820 : int base = __builtin_ctz (expr->value.op.op1->ts.kind);
4042 26820 : int expon = __builtin_ctz (expr->value.op.op2->ts.kind);
4043 26820 : fndecl = gfor_fndecl_unsigned_pow_list[base][expon];
4044 : }
4045 26820 : break;
4046 :
4047 0 : default:
4048 0 : gcc_unreachable ();
4049 28700 : break;
4050 : }
4051 :
4052 28700 : se->expr = build_call_expr_loc (input_location,
4053 : fndecl, 2, lse.expr, rse.expr);
4054 :
4055 : /* Convert the result back if it is of wrong integer kind. */
4056 28700 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
4057 : {
4058 : /* We want the maximum of both operand kinds as result. */
4059 0 : if (res_ikind_1 < res_ikind_2)
4060 0 : res_ikind_1 = res_ikind_2;
4061 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
4062 : }
4063 : }
4064 :
4065 :
4066 : /* Generate code to allocate a string temporary. */
4067 :
4068 : tree
4069 5000 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4070 : {
4071 5000 : tree var;
4072 5000 : tree tmp;
4073 :
4074 5000 : if (gfc_can_put_var_on_stack (len))
4075 : {
4076 : /* Create a temporary variable to hold the result. */
4077 4754 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4078 2377 : TREE_TYPE (len), len,
4079 2377 : build_int_cst (TREE_TYPE (len), 1));
4080 2377 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4081 :
4082 2377 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4083 2377 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4084 : else
4085 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
4086 :
4087 2377 : var = gfc_create_var (tmp, "str");
4088 2377 : var = gfc_build_addr_expr (type, var);
4089 : }
4090 : else
4091 : {
4092 : /* Allocate a temporary to hold the result. */
4093 2623 : var = gfc_create_var (type, "pstr");
4094 2623 : gcc_assert (POINTER_TYPE_P (type));
4095 2623 : tmp = TREE_TYPE (type);
4096 2623 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4097 2623 : tmp = TREE_TYPE (tmp);
4098 2623 : tmp = TYPE_SIZE_UNIT (tmp);
4099 2623 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4100 : fold_convert (size_type_node, len),
4101 : fold_convert (size_type_node, tmp));
4102 2623 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4103 2623 : gfc_add_modify (&se->pre, var, tmp);
4104 :
4105 : /* Free the temporary afterwards. */
4106 2623 : tmp = gfc_call_free (var);
4107 2623 : gfc_add_expr_to_block (&se->post, tmp);
4108 : }
4109 :
4110 5000 : return var;
4111 : }
4112 :
4113 :
4114 : /* Handle a string concatenation operation. A temporary will be allocated to
4115 : hold the result. */
4116 :
4117 : static void
4118 1348 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4119 : {
4120 1348 : gfc_se lse, rse;
4121 1348 : tree len, type, var, tmp, fndecl;
4122 :
4123 1348 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4124 : && expr->value.op.op2->ts.type == BT_CHARACTER);
4125 1348 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4126 :
4127 1348 : gfc_init_se (&lse, se);
4128 1348 : gfc_conv_expr (&lse, expr->value.op.op1);
4129 1348 : gfc_conv_string_parameter (&lse);
4130 1348 : gfc_init_se (&rse, se);
4131 1348 : gfc_conv_expr (&rse, expr->value.op.op2);
4132 1348 : gfc_conv_string_parameter (&rse);
4133 :
4134 1348 : gfc_add_block_to_block (&se->pre, &lse.pre);
4135 1348 : gfc_add_block_to_block (&se->pre, &rse.pre);
4136 :
4137 1348 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4138 1348 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4139 1348 : if (len == NULL_TREE)
4140 : {
4141 1129 : len = fold_build2_loc (input_location, PLUS_EXPR,
4142 : gfc_charlen_type_node,
4143 : fold_convert (gfc_charlen_type_node,
4144 : lse.string_length),
4145 : fold_convert (gfc_charlen_type_node,
4146 : rse.string_length));
4147 : }
4148 :
4149 1348 : type = build_pointer_type (type);
4150 :
4151 1348 : var = gfc_conv_string_tmp (se, type, len);
4152 :
4153 : /* Do the actual concatenation. */
4154 1348 : if (expr->ts.kind == 1)
4155 1257 : fndecl = gfor_fndecl_concat_string;
4156 91 : else if (expr->ts.kind == 4)
4157 91 : fndecl = gfor_fndecl_concat_string_char4;
4158 : else
4159 0 : gcc_unreachable ();
4160 :
4161 1348 : tmp = build_call_expr_loc (input_location,
4162 : fndecl, 6, len, var, lse.string_length, lse.expr,
4163 : rse.string_length, rse.expr);
4164 1348 : gfc_add_expr_to_block (&se->pre, tmp);
4165 :
4166 : /* Add the cleanup for the operands. */
4167 1348 : gfc_add_block_to_block (&se->pre, &rse.post);
4168 1348 : gfc_add_block_to_block (&se->pre, &lse.post);
4169 :
4170 1348 : se->expr = var;
4171 1348 : se->string_length = len;
4172 1348 : }
4173 :
4174 : /* Translates an op expression. Common (binary) cases are handled by this
4175 : function, others are passed on. Recursion is used in either case.
4176 : We use the fact that (op1.ts == op2.ts) (except for the power
4177 : operator **).
4178 : Operators need no special handling for scalarized expressions as long as
4179 : they call gfc_conv_simple_val to get their operands.
4180 : Character strings get special handling. */
4181 :
4182 : static void
4183 514194 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4184 : {
4185 514194 : enum tree_code code;
4186 514194 : gfc_se lse;
4187 514194 : gfc_se rse;
4188 514194 : tree tmp, type;
4189 514194 : int lop;
4190 514194 : int checkstring;
4191 :
4192 514194 : checkstring = 0;
4193 514194 : lop = 0;
4194 514194 : switch (expr->value.op.op)
4195 : {
4196 15465 : case INTRINSIC_PARENTHESES:
4197 15465 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4198 3802 : && flag_protect_parens)
4199 : {
4200 3668 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
4201 3668 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
4202 91359 : return;
4203 : }
4204 :
4205 : /* Fallthrough. */
4206 11803 : case INTRINSIC_UPLUS:
4207 11803 : gfc_conv_expr (se, expr->value.op.op1);
4208 11803 : return;
4209 :
4210 4969 : case INTRINSIC_UMINUS:
4211 4969 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4212 4969 : return;
4213 :
4214 20388 : case INTRINSIC_NOT:
4215 20388 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4216 20388 : return;
4217 :
4218 : case INTRINSIC_PLUS:
4219 : code = PLUS_EXPR;
4220 : break;
4221 :
4222 29855 : case INTRINSIC_MINUS:
4223 29855 : code = MINUS_EXPR;
4224 29855 : break;
4225 :
4226 33505 : case INTRINSIC_TIMES:
4227 33505 : code = MULT_EXPR;
4228 33505 : break;
4229 :
4230 7169 : case INTRINSIC_DIVIDE:
4231 : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
4232 : an integer or unsigned, we must round towards zero, so we use a
4233 : TRUNC_DIV_EXPR. */
4234 7169 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4235 : code = TRUNC_DIV_EXPR;
4236 : else
4237 422835 : code = RDIV_EXPR;
4238 : break;
4239 :
4240 49183 : case INTRINSIC_POWER:
4241 49183 : gfc_conv_power_op (se, expr);
4242 49183 : return;
4243 :
4244 1348 : case INTRINSIC_CONCAT:
4245 1348 : gfc_conv_concat_op (se, expr);
4246 1348 : return;
4247 :
4248 4884 : case INTRINSIC_AND:
4249 4884 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4250 : lop = 1;
4251 : break;
4252 :
4253 56234 : case INTRINSIC_OR:
4254 56234 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
4255 : lop = 1;
4256 : break;
4257 :
4258 : /* EQV and NEQV only work on logicals, but since we represent them
4259 : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4260 12815 : case INTRINSIC_EQ:
4261 12815 : case INTRINSIC_EQ_OS:
4262 12815 : case INTRINSIC_EQV:
4263 12815 : code = EQ_EXPR;
4264 12815 : checkstring = 1;
4265 12815 : lop = 1;
4266 12815 : break;
4267 :
4268 210519 : case INTRINSIC_NE:
4269 210519 : case INTRINSIC_NE_OS:
4270 210519 : case INTRINSIC_NEQV:
4271 210519 : code = NE_EXPR;
4272 210519 : checkstring = 1;
4273 210519 : lop = 1;
4274 210519 : break;
4275 :
4276 12185 : case INTRINSIC_GT:
4277 12185 : case INTRINSIC_GT_OS:
4278 12185 : code = GT_EXPR;
4279 12185 : checkstring = 1;
4280 12185 : lop = 1;
4281 12185 : break;
4282 :
4283 1677 : case INTRINSIC_GE:
4284 1677 : case INTRINSIC_GE_OS:
4285 1677 : code = GE_EXPR;
4286 1677 : checkstring = 1;
4287 1677 : lop = 1;
4288 1677 : break;
4289 :
4290 4400 : case INTRINSIC_LT:
4291 4400 : case INTRINSIC_LT_OS:
4292 4400 : code = LT_EXPR;
4293 4400 : checkstring = 1;
4294 4400 : lop = 1;
4295 4400 : break;
4296 :
4297 2612 : case INTRINSIC_LE:
4298 2612 : case INTRINSIC_LE_OS:
4299 2612 : code = LE_EXPR;
4300 2612 : checkstring = 1;
4301 2612 : lop = 1;
4302 2612 : break;
4303 :
4304 0 : case INTRINSIC_USER:
4305 0 : case INTRINSIC_ASSIGN:
4306 : /* These should be converted into function calls by the frontend. */
4307 0 : gcc_unreachable ();
4308 :
4309 0 : default:
4310 0 : fatal_error (input_location, "Unknown intrinsic op");
4311 422835 : return;
4312 : }
4313 :
4314 : /* The only exception to this is **, which is handled separately anyway. */
4315 422835 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4316 :
4317 422835 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4318 388299 : checkstring = 0;
4319 :
4320 : /* lhs */
4321 422835 : gfc_init_se (&lse, se);
4322 422835 : gfc_conv_expr (&lse, expr->value.op.op1);
4323 422835 : gfc_add_block_to_block (&se->pre, &lse.pre);
4324 :
4325 : /* rhs */
4326 422835 : gfc_init_se (&rse, se);
4327 422835 : gfc_conv_expr (&rse, expr->value.op.op2);
4328 422835 : gfc_add_block_to_block (&se->pre, &rse.pre);
4329 :
4330 422835 : if (checkstring)
4331 : {
4332 34536 : gfc_conv_string_parameter (&lse);
4333 34536 : gfc_conv_string_parameter (&rse);
4334 :
4335 69072 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4336 : rse.string_length, rse.expr,
4337 34536 : expr->value.op.op1->ts.kind,
4338 : code);
4339 34536 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4340 34536 : gfc_add_block_to_block (&lse.post, &rse.post);
4341 : }
4342 :
4343 422835 : type = gfc_typenode_for_spec (&expr->ts);
4344 :
4345 422835 : if (lop)
4346 : {
4347 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4348 305326 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4349 172571 : && expr->value.op.op1->ts.type == BT_INTEGER
4350 75056 : && expr->value.op.op1->symtree
4351 75056 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4352 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4353 :
4354 305326 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4355 72851 : && expr->value.op.op2->ts.type == BT_INTEGER
4356 13370 : && expr->value.op.op2->symtree
4357 13370 : && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
4358 12 : TREE_THIS_VOLATILE (rse.expr) = 1;
4359 :
4360 : /* The result of logical ops is always logical_type_node. */
4361 305326 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4362 : lse.expr, rse.expr);
4363 305326 : se->expr = convert (type, tmp);
4364 : }
4365 : else
4366 117509 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4367 :
4368 : /* Add the post blocks. */
4369 422835 : gfc_add_block_to_block (&se->post, &rse.post);
4370 422835 : gfc_add_block_to_block (&se->post, &lse.post);
4371 : }
4372 :
4373 : static void
4374 159 : gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
4375 : {
4376 159 : gfc_se cond_se, true_se, false_se;
4377 159 : tree condition, true_val, false_val;
4378 159 : tree type;
4379 :
4380 159 : gfc_init_se (&cond_se, se);
4381 159 : gfc_init_se (&true_se, se);
4382 159 : gfc_init_se (&false_se, se);
4383 :
4384 159 : gfc_conv_expr (&cond_se, expr->value.conditional.condition);
4385 159 : gfc_add_block_to_block (&se->pre, &cond_se.pre);
4386 159 : condition = gfc_evaluate_now (cond_se.expr, &se->pre);
4387 :
4388 159 : true_se.want_pointer = se->want_pointer;
4389 159 : gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
4390 159 : true_val = true_se.expr;
4391 159 : false_se.want_pointer = se->want_pointer;
4392 159 : gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
4393 159 : false_val = false_se.expr;
4394 :
4395 159 : if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
4396 24 : gfc_add_expr_to_block (
4397 : &se->pre,
4398 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4399 24 : true_se.pre.head != NULL_TREE
4400 6 : ? gfc_finish_block (&true_se.pre)
4401 18 : : build_empty_stmt (input_location),
4402 24 : false_se.pre.head != NULL_TREE
4403 24 : ? gfc_finish_block (&false_se.pre)
4404 0 : : build_empty_stmt (input_location)));
4405 :
4406 159 : if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
4407 6 : gfc_add_expr_to_block (
4408 : &se->post,
4409 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4410 6 : true_se.post.head != NULL_TREE
4411 0 : ? gfc_finish_block (&true_se.post)
4412 6 : : build_empty_stmt (input_location),
4413 6 : false_se.post.head != NULL_TREE
4414 6 : ? gfc_finish_block (&false_se.post)
4415 0 : : build_empty_stmt (input_location)));
4416 :
4417 159 : type = gfc_typenode_for_spec (&expr->ts);
4418 159 : if (se->want_pointer)
4419 18 : type = build_pointer_type (type);
4420 :
4421 159 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
4422 : true_val, false_val);
4423 159 : if (expr->ts.type == BT_CHARACTER)
4424 66 : se->string_length
4425 66 : = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
4426 : condition, true_se.string_length,
4427 : false_se.string_length);
4428 159 : }
4429 :
4430 : /* If a string's length is one, we convert it to a single character. */
4431 :
4432 : tree
4433 142922 : gfc_string_to_single_character (tree len, tree str, int kind)
4434 : {
4435 :
4436 142922 : if (len == NULL
4437 142922 : || !tree_fits_uhwi_p (len)
4438 262423 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4439 : return NULL_TREE;
4440 :
4441 119449 : if (TREE_INT_CST_LOW (len) == 1)
4442 : {
4443 22815 : str = fold_convert (gfc_get_pchar_type (kind), str);
4444 22815 : return build_fold_indirect_ref_loc (input_location, str);
4445 : }
4446 :
4447 96634 : if (kind == 1
4448 79144 : && TREE_CODE (str) == ADDR_EXPR
4449 68095 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4450 48729 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4451 30155 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4452 30155 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4453 30155 : && TREE_INT_CST_LOW (len) > 1
4454 124943 : && TREE_INT_CST_LOW (len)
4455 : == (unsigned HOST_WIDE_INT)
4456 28309 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4457 : {
4458 28309 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4459 28309 : ret = build_fold_indirect_ref_loc (input_location, ret);
4460 28309 : if (TREE_CODE (ret) == INTEGER_CST)
4461 : {
4462 28309 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4463 28309 : int i, length = TREE_STRING_LENGTH (string_cst);
4464 28309 : const char *ptr = TREE_STRING_POINTER (string_cst);
4465 :
4466 42443 : for (i = 1; i < length; i++)
4467 41745 : if (ptr[i] != ' ')
4468 : return NULL_TREE;
4469 :
4470 : return ret;
4471 : }
4472 : }
4473 :
4474 : return NULL_TREE;
4475 : }
4476 :
4477 :
4478 : static void
4479 220 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4480 : {
4481 220 : gcc_assert (expr);
4482 :
4483 : /* We used to modify the tree here. Now it is done earlier in
4484 : the front-end, so we only check it here to avoid regressions. */
4485 220 : if (sym->backend_decl)
4486 : {
4487 67 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4488 67 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4489 67 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4490 67 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4491 : }
4492 :
4493 : /* If we have a constant character expression, make it into an
4494 : integer of type C char. */
4495 220 : if ((*expr)->expr_type == EXPR_CONSTANT)
4496 : {
4497 166 : gfc_typespec ts;
4498 166 : gfc_clear_ts (&ts);
4499 :
4500 332 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4501 166 : (*expr)->value.character.string[0]);
4502 166 : gfc_replace_expr (*expr, tmp);
4503 : }
4504 54 : else if (se != NULL)
4505 : {
4506 54 : gfc_conv_expr (se, *expr);
4507 54 : gfc_conv_string_parameter (se);
4508 108 : se->expr = gfc_string_to_single_character (integer_one_node,
4509 54 : se->expr, (*expr)->ts.kind);
4510 54 : se->string_length = integer_one_node;
4511 : }
4512 220 : }
4513 :
4514 : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4515 : if STR is a string literal, otherwise return -1. */
4516 :
4517 : static int
4518 32772 : gfc_optimize_len_trim (tree len, tree str, int kind)
4519 : {
4520 32772 : if (kind == 1
4521 27680 : && TREE_CODE (str) == ADDR_EXPR
4522 24257 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4523 15503 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4524 10017 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4525 10017 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4526 10017 : && tree_fits_uhwi_p (len)
4527 10017 : && tree_to_uhwi (len) >= 1
4528 32772 : && tree_to_uhwi (len)
4529 9973 : == (unsigned HOST_WIDE_INT)
4530 9973 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4531 : {
4532 9973 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4533 9973 : folded = build_fold_indirect_ref_loc (input_location, folded);
4534 9973 : if (TREE_CODE (folded) == INTEGER_CST)
4535 : {
4536 9973 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4537 9973 : int length = TREE_STRING_LENGTH (string_cst);
4538 9973 : const char *ptr = TREE_STRING_POINTER (string_cst);
4539 :
4540 14897 : for (; length > 0; length--)
4541 14897 : if (ptr[length - 1] != ' ')
4542 : break;
4543 :
4544 : return length;
4545 : }
4546 : }
4547 : return -1;
4548 : }
4549 :
4550 : /* Helper to build a call to memcmp. */
4551 :
4552 : static tree
4553 13351 : build_memcmp_call (tree s1, tree s2, tree n)
4554 : {
4555 13351 : tree tmp;
4556 :
4557 13351 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4558 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4559 : else
4560 13351 : s1 = fold_convert (pvoid_type_node, s1);
4561 :
4562 13351 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4563 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4564 : else
4565 13351 : s2 = fold_convert (pvoid_type_node, s2);
4566 :
4567 13351 : n = fold_convert (size_type_node, n);
4568 :
4569 13351 : tmp = build_call_expr_loc (input_location,
4570 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4571 : 3, s1, s2, n);
4572 :
4573 13351 : return fold_convert (integer_type_node, tmp);
4574 : }
4575 :
4576 : /* Compare two strings. If they are all single characters, the result is the
4577 : subtraction of them. Otherwise, we build a library call. */
4578 :
4579 : tree
4580 34635 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4581 : enum tree_code code)
4582 : {
4583 34635 : tree sc1;
4584 34635 : tree sc2;
4585 34635 : tree fndecl;
4586 :
4587 34635 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4588 34635 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4589 :
4590 34635 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4591 34635 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4592 :
4593 34635 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4594 : {
4595 : /* Deal with single character specially. */
4596 4851 : sc1 = fold_convert (integer_type_node, sc1);
4597 4851 : sc2 = fold_convert (integer_type_node, sc2);
4598 4851 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4599 4851 : sc1, sc2);
4600 : }
4601 :
4602 29784 : if ((code == EQ_EXPR || code == NE_EXPR)
4603 29222 : && optimize
4604 24477 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4605 : {
4606 : /* If one string is a string literal with LEN_TRIM longer
4607 : than the length of the second string, the strings
4608 : compare unequal. */
4609 16386 : int len = gfc_optimize_len_trim (len1, str1, kind);
4610 16386 : if (len > 0 && compare_tree_int (len2, len) < 0)
4611 0 : return integer_one_node;
4612 16386 : len = gfc_optimize_len_trim (len2, str2, kind);
4613 16386 : if (len > 0 && compare_tree_int (len1, len) < 0)
4614 0 : return integer_one_node;
4615 : }
4616 :
4617 : /* We can compare via memcpy if the strings are known to be equal
4618 : in length and they are
4619 : - kind=1
4620 : - kind=4 and the comparison is for (in)equality. */
4621 :
4622 19966 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4623 19628 : && tree_int_cst_equal (len1, len2)
4624 43195 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4625 : {
4626 13351 : tree tmp;
4627 13351 : tree chartype;
4628 :
4629 13351 : chartype = gfc_get_char_type (kind);
4630 13351 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4631 13351 : fold_convert (TREE_TYPE(len1),
4632 : TYPE_SIZE_UNIT(chartype)),
4633 : len1);
4634 13351 : return build_memcmp_call (str1, str2, tmp);
4635 : }
4636 :
4637 : /* Build a call for the comparison. */
4638 16433 : if (kind == 1)
4639 13578 : fndecl = gfor_fndecl_compare_string;
4640 2855 : else if (kind == 4)
4641 2855 : fndecl = gfor_fndecl_compare_string_char4;
4642 : else
4643 0 : gcc_unreachable ();
4644 :
4645 16433 : return build_call_expr_loc (input_location, fndecl, 4,
4646 16433 : len1, str1, len2, str2);
4647 : }
4648 :
4649 :
4650 : /* Return the backend_decl for a procedure pointer component. */
4651 :
4652 : static tree
4653 1926 : get_proc_ptr_comp (gfc_expr *e)
4654 : {
4655 1926 : gfc_se comp_se;
4656 1926 : gfc_expr *e2;
4657 1926 : expr_t old_type;
4658 :
4659 1926 : gfc_init_se (&comp_se, NULL);
4660 1926 : e2 = gfc_copy_expr (e);
4661 : /* We have to restore the expr type later so that gfc_free_expr frees
4662 : the exact same thing that was allocated.
4663 : TODO: This is ugly. */
4664 1926 : old_type = e2->expr_type;
4665 1926 : e2->expr_type = EXPR_VARIABLE;
4666 1926 : gfc_conv_expr (&comp_se, e2);
4667 1926 : e2->expr_type = old_type;
4668 1926 : gfc_free_expr (e2);
4669 1926 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4670 : }
4671 :
4672 :
4673 : /* Convert a typebound function reference from a class object. */
4674 : static void
4675 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4676 : {
4677 80 : gfc_ref *ref;
4678 80 : tree var;
4679 :
4680 80 : if (!VAR_P (base_object))
4681 : {
4682 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4683 0 : gfc_add_modify (&se->pre, var, base_object);
4684 : }
4685 80 : se->expr = gfc_class_vptr_get (base_object);
4686 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4687 80 : ref = expr->ref;
4688 308 : while (ref && ref->next)
4689 : ref = ref->next;
4690 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4691 80 : if (ref->u.c.sym->attr.extension)
4692 0 : conv_parent_component_references (se, ref);
4693 80 : gfc_conv_component_ref (se, ref);
4694 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4695 80 : }
4696 :
4697 : static tree
4698 130413 : get_builtin_fn (gfc_symbol * sym)
4699 : {
4700 130413 : if (!gfc_option.disable_omp_is_initial_device
4701 130409 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4702 631 : && !strcmp (sym->name, "omp_is_initial_device"))
4703 41 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4704 :
4705 130372 : if (!gfc_option.disable_omp_get_initial_device
4706 130365 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4707 4288 : && !strcmp (sym->name, "omp_get_initial_device"))
4708 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4709 :
4710 130343 : if (!gfc_option.disable_omp_get_num_devices
4711 130336 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4712 4259 : && !strcmp (sym->name, "omp_get_num_devices"))
4713 107 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4714 :
4715 130236 : if (!gfc_option.disable_acc_on_device
4716 130056 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4717 1169 : && !strcmp (sym->name, "acc_on_device_h"))
4718 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4719 :
4720 : return NULL_TREE;
4721 : }
4722 :
4723 : static tree
4724 567 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4725 : {
4726 567 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4727 :
4728 567 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4729 : /* In Fortran omp_is_initial_device returns logical(4)
4730 : but the builtin uses 'int'. */
4731 41 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4732 :
4733 526 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4734 : {
4735 : /* Likewise for the return type; additionally, the argument it a
4736 : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4737 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4738 390 : CALL_EXPR_ARG (fn_call, 0));
4739 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4740 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4741 : }
4742 : return fn_call;
4743 : }
4744 :
4745 : static void
4746 133165 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4747 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4748 : {
4749 133165 : tree tmp;
4750 :
4751 133165 : if (gfc_is_proc_ptr_comp (expr))
4752 1926 : tmp = get_proc_ptr_comp (expr);
4753 131239 : else if (sym->attr.dummy)
4754 : {
4755 826 : tmp = gfc_get_symbol_decl (sym);
4756 826 : if (sym->attr.proc_pointer)
4757 89 : tmp = build_fold_indirect_ref_loc (input_location,
4758 : tmp);
4759 826 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4760 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4761 : }
4762 : else
4763 : {
4764 130413 : if (!sym->backend_decl)
4765 32912 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4766 :
4767 130413 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4768 567 : *is_builtin = true;
4769 : else
4770 : {
4771 129846 : TREE_USED (sym->backend_decl) = 1;
4772 129846 : tmp = sym->backend_decl;
4773 : }
4774 :
4775 130413 : if (sym->attr.cray_pointee)
4776 : {
4777 : /* TODO - make the cray pointee a pointer to a procedure,
4778 : assign the pointer to it and use it for the call. This
4779 : will do for now! */
4780 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4781 19 : gfc_get_symbol_decl (sym->cp_pointer));
4782 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4783 : }
4784 :
4785 130413 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4786 : {
4787 129785 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4788 129785 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4789 : }
4790 : }
4791 133165 : se->expr = tmp;
4792 133165 : }
4793 :
4794 :
4795 : /* Initialize MAPPING. */
4796 :
4797 : void
4798 133282 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4799 : {
4800 133282 : mapping->syms = NULL;
4801 133282 : mapping->charlens = NULL;
4802 133282 : }
4803 :
4804 :
4805 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4806 :
4807 : void
4808 133282 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4809 : {
4810 133282 : gfc_interface_sym_mapping *sym;
4811 133282 : gfc_interface_sym_mapping *nextsym;
4812 133282 : gfc_charlen *cl;
4813 133282 : gfc_charlen *nextcl;
4814 :
4815 174100 : for (sym = mapping->syms; sym; sym = nextsym)
4816 : {
4817 40818 : nextsym = sym->next;
4818 40818 : sym->new_sym->n.sym->formal = NULL;
4819 40818 : gfc_free_symbol (sym->new_sym->n.sym);
4820 40818 : gfc_free_expr (sym->expr);
4821 40818 : free (sym->new_sym);
4822 40818 : free (sym);
4823 : }
4824 137970 : for (cl = mapping->charlens; cl; cl = nextcl)
4825 : {
4826 4688 : nextcl = cl->next;
4827 4688 : gfc_free_expr (cl->length);
4828 4688 : free (cl);
4829 : }
4830 133282 : }
4831 :
4832 :
4833 : /* Return a copy of gfc_charlen CL. Add the returned structure to
4834 : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4835 :
4836 : static gfc_charlen *
4837 4688 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4838 : gfc_charlen * cl)
4839 : {
4840 4688 : gfc_charlen *new_charlen;
4841 :
4842 4688 : new_charlen = gfc_get_charlen ();
4843 4688 : new_charlen->next = mapping->charlens;
4844 4688 : new_charlen->length = gfc_copy_expr (cl->length);
4845 :
4846 4688 : mapping->charlens = new_charlen;
4847 4688 : return new_charlen;
4848 : }
4849 :
4850 :
4851 : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4852 : array variable that can be used as the actual argument for dummy
4853 : argument SYM, except in the case of assumed rank dummies of
4854 : non-intrinsic functions where the descriptor must be passed. Add any
4855 : initialization code to BLOCK. PACKED is as for gfc_get_nodesc_array_type
4856 : and DATA points to the first element in the passed array. */
4857 :
4858 : static tree
4859 8482 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4860 : gfc_packed packed, tree data, tree len,
4861 : bool assumed_rank_formal)
4862 : {
4863 8482 : tree type;
4864 8482 : tree var;
4865 :
4866 8482 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4867 70 : type = gfc_get_character_type_len (sym->ts.kind, len);
4868 : else
4869 8412 : type = gfc_typenode_for_spec (&sym->ts);
4870 :
4871 8482 : if (assumed_rank_formal)
4872 13 : type = TREE_TYPE (data);
4873 : else
4874 8469 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4875 8469 : !sym->attr.target && !sym->attr.pointer
4876 8445 : && !sym->attr.proc_pointer);
4877 :
4878 8482 : var = gfc_create_var (type, "ifm");
4879 8482 : gfc_add_modify (block, var, fold_convert (type, data));
4880 :
4881 8482 : return var;
4882 : }
4883 :
4884 :
4885 : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4886 : and offset of descriptorless array type TYPE given that it has the same
4887 : size as DESC. Add any set-up code to BLOCK. */
4888 :
4889 : static void
4890 8152 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4891 : {
4892 8152 : int n;
4893 8152 : tree dim;
4894 8152 : tree offset;
4895 8152 : tree tmp;
4896 :
4897 8152 : offset = gfc_index_zero_node;
4898 9266 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4899 : {
4900 1114 : dim = gfc_rank_cst[n];
4901 1114 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4902 1114 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4903 : {
4904 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
4905 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
4906 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
4907 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
4908 : }
4909 1113 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4910 : {
4911 1087 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4912 : gfc_array_index_type,
4913 : gfc_conv_descriptor_ubound_get (desc, dim),
4914 : gfc_conv_descriptor_lbound_get (desc, dim));
4915 3261 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4916 : gfc_array_index_type,
4917 1087 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4918 1087 : tmp = gfc_evaluate_now (tmp, block);
4919 1087 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4920 : }
4921 4456 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4922 1114 : GFC_TYPE_ARRAY_LBOUND (type, n),
4923 1114 : GFC_TYPE_ARRAY_STRIDE (type, n));
4924 1114 : offset = fold_build2_loc (input_location, MINUS_EXPR,
4925 : gfc_array_index_type, offset, tmp);
4926 : }
4927 8152 : offset = gfc_evaluate_now (offset, block);
4928 8152 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
4929 8152 : }
4930 :
4931 :
4932 : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4933 : in SE. The caller may still use se->expr and se->string_length after
4934 : calling this function. */
4935 :
4936 : void
4937 40818 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4938 : gfc_symbol * sym, gfc_se * se,
4939 : gfc_expr *expr)
4940 : {
4941 40818 : gfc_interface_sym_mapping *sm;
4942 40818 : tree desc;
4943 40818 : tree tmp;
4944 40818 : tree value;
4945 40818 : gfc_symbol *new_sym;
4946 40818 : gfc_symtree *root;
4947 40818 : gfc_symtree *new_symtree;
4948 :
4949 : /* Create a new symbol to represent the actual argument. */
4950 40818 : new_sym = gfc_new_symbol (sym->name, NULL);
4951 40818 : new_sym->ts = sym->ts;
4952 40818 : new_sym->as = gfc_copy_array_spec (sym->as);
4953 40818 : new_sym->attr.referenced = 1;
4954 40818 : new_sym->attr.dimension = sym->attr.dimension;
4955 40818 : new_sym->attr.contiguous = sym->attr.contiguous;
4956 40818 : new_sym->attr.codimension = sym->attr.codimension;
4957 40818 : new_sym->attr.pointer = sym->attr.pointer;
4958 40818 : new_sym->attr.allocatable = sym->attr.allocatable;
4959 40818 : new_sym->attr.flavor = sym->attr.flavor;
4960 40818 : new_sym->attr.function = sym->attr.function;
4961 40818 : new_sym->attr.dummy = 0;
4962 :
4963 : /* Ensure that the interface is available and that
4964 : descriptors are passed for array actual arguments. */
4965 40818 : if (sym->attr.flavor == FL_PROCEDURE)
4966 : {
4967 36 : new_sym->formal = expr->symtree->n.sym->formal;
4968 36 : new_sym->attr.always_explicit
4969 36 : = expr->symtree->n.sym->attr.always_explicit;
4970 : }
4971 :
4972 : /* Create a fake symtree for it. */
4973 40818 : root = NULL;
4974 40818 : new_symtree = gfc_new_symtree (&root, sym->name);
4975 40818 : new_symtree->n.sym = new_sym;
4976 40818 : gcc_assert (new_symtree == root);
4977 :
4978 : /* Create a dummy->actual mapping. */
4979 40818 : sm = XCNEW (gfc_interface_sym_mapping);
4980 40818 : sm->next = mapping->syms;
4981 40818 : sm->old = sym;
4982 40818 : sm->new_sym = new_symtree;
4983 40818 : sm->expr = gfc_copy_expr (expr);
4984 40818 : mapping->syms = sm;
4985 :
4986 : /* Stabilize the argument's value. */
4987 40818 : if (!sym->attr.function && se)
4988 40720 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
4989 :
4990 40818 : if (sym->ts.type == BT_CHARACTER)
4991 : {
4992 : /* Create a copy of the dummy argument's length. */
4993 2886 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4994 2886 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
4995 :
4996 : /* If the length is specified as "*", record the length that
4997 : the caller is passing. We should use the callee's length
4998 : in all other cases. */
4999 2886 : if (!new_sym->ts.u.cl->length && se)
5000 : {
5001 2646 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5002 2646 : new_sym->ts.u.cl->backend_decl = se->string_length;
5003 : }
5004 : }
5005 :
5006 40804 : if (!se)
5007 62 : return;
5008 :
5009 : /* Use the passed value as-is if the argument is a function. */
5010 40756 : if (sym->attr.flavor == FL_PROCEDURE)
5011 36 : value = se->expr;
5012 :
5013 : /* If the argument is a pass-by-value scalar, use the value as is. */
5014 40720 : else if (!sym->attr.dimension && sym->attr.value)
5015 78 : value = se->expr;
5016 :
5017 : /* If the argument is either a string or a pointer to a string,
5018 : convert it to a boundless character type. */
5019 40642 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5020 : {
5021 1305 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5022 1305 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5023 1305 : tmp = build_pointer_type (tmp);
5024 1305 : if (sym->attr.pointer)
5025 126 : value = build_fold_indirect_ref_loc (input_location,
5026 : se->expr);
5027 : else
5028 1179 : value = se->expr;
5029 1305 : value = fold_convert (tmp, value);
5030 : }
5031 :
5032 : /* If the argument is a scalar, a pointer to an array or an allocatable,
5033 : dereference it. */
5034 39337 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5035 29358 : value = build_fold_indirect_ref_loc (input_location,
5036 : se->expr);
5037 :
5038 : /* For character(*), use the actual argument's descriptor. */
5039 9979 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5040 1497 : value = build_fold_indirect_ref_loc (input_location,
5041 : se->expr);
5042 :
5043 : /* If the argument is an array descriptor, use it to determine
5044 : information about the actual argument's shape. */
5045 8482 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5046 8482 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5047 : {
5048 8152 : bool assumed_rank_formal = false;
5049 :
5050 : /* Get the actual argument's descriptor. */
5051 8152 : desc = build_fold_indirect_ref_loc (input_location,
5052 : se->expr);
5053 :
5054 : /* Create the replacement variable. */
5055 8152 : if (sym->as && sym->as->type == AS_ASSUMED_RANK
5056 7362 : && !(sym->ns && sym->ns->proc_name
5057 7362 : && sym->ns->proc_name->attr.proc == PROC_INTRINSIC))
5058 : {
5059 : assumed_rank_formal = true;
5060 : tmp = desc;
5061 : }
5062 : else
5063 8139 : tmp = gfc_conv_descriptor_data_get (desc);
5064 :
5065 8152 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5066 : PACKED_NO, tmp,
5067 : se->string_length,
5068 : assumed_rank_formal);
5069 :
5070 : /* Use DESC to work out the upper bounds, strides and offset. */
5071 8152 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5072 : }
5073 : else
5074 : /* Otherwise we have a packed array. */
5075 330 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5076 : PACKED_FULL, se->expr,
5077 : se->string_length,
5078 : false);
5079 :
5080 40756 : new_sym->backend_decl = value;
5081 : }
5082 :
5083 :
5084 : /* Called once all dummy argument mappings have been added to MAPPING,
5085 : but before the mapping is used to evaluate expressions. Pre-evaluate
5086 : the length of each argument, adding any initialization code to PRE and
5087 : any finalization code to POST. */
5088 :
5089 : static void
5090 133245 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5091 : stmtblock_t * pre, stmtblock_t * post)
5092 : {
5093 133245 : gfc_interface_sym_mapping *sym;
5094 133245 : gfc_expr *expr;
5095 133245 : gfc_se se;
5096 :
5097 174001 : for (sym = mapping->syms; sym; sym = sym->next)
5098 40756 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5099 2872 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5100 : {
5101 226 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5102 226 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5103 226 : gfc_init_se (&se, NULL);
5104 226 : gfc_conv_expr (&se, expr);
5105 226 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5106 226 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5107 226 : gfc_add_block_to_block (pre, &se.pre);
5108 226 : gfc_add_block_to_block (post, &se.post);
5109 :
5110 226 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5111 : }
5112 133245 : }
5113 :
5114 :
5115 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5116 : constructor C. */
5117 :
5118 : static void
5119 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5120 : gfc_constructor_base base)
5121 : {
5122 47 : gfc_constructor *c;
5123 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5124 : {
5125 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5126 381 : if (c->iterator)
5127 : {
5128 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5129 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5130 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5131 : }
5132 : }
5133 47 : }
5134 :
5135 :
5136 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5137 : reference REF. */
5138 :
5139 : static void
5140 12759 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5141 : gfc_ref * ref)
5142 : {
5143 12759 : int n;
5144 :
5145 14244 : for (; ref; ref = ref->next)
5146 1485 : switch (ref->type)
5147 : {
5148 : case REF_ARRAY:
5149 2915 : for (n = 0; n < ref->u.ar.dimen; n++)
5150 : {
5151 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5152 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5153 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5154 : }
5155 : break;
5156 :
5157 : case REF_COMPONENT:
5158 : case REF_INQUIRY:
5159 : break;
5160 :
5161 43 : case REF_SUBSTRING:
5162 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5163 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5164 43 : break;
5165 : }
5166 12759 : }
5167 :
5168 :
5169 : /* Convert intrinsic function calls into result expressions. */
5170 :
5171 : static bool
5172 2232 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5173 : {
5174 2232 : gfc_symbol *sym;
5175 2232 : gfc_expr *new_expr;
5176 2232 : gfc_expr *arg1;
5177 2232 : gfc_expr *arg2;
5178 2232 : int d, dup;
5179 :
5180 2232 : arg1 = expr->value.function.actual->expr;
5181 2232 : if (expr->value.function.actual->next)
5182 2111 : arg2 = expr->value.function.actual->next->expr;
5183 : else
5184 : arg2 = NULL;
5185 :
5186 2232 : sym = arg1->symtree->n.sym;
5187 :
5188 2232 : if (sym->attr.dummy)
5189 : return false;
5190 :
5191 2208 : new_expr = NULL;
5192 :
5193 2208 : switch (expr->value.function.isym->id)
5194 : {
5195 947 : case GFC_ISYM_LEN:
5196 : /* TODO figure out why this condition is necessary. */
5197 947 : if (sym->attr.function
5198 43 : && (arg1->ts.u.cl->length == NULL
5199 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5200 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5201 : return false;
5202 :
5203 904 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5204 904 : break;
5205 :
5206 228 : case GFC_ISYM_LEN_TRIM:
5207 228 : new_expr = gfc_copy_expr (arg1);
5208 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5209 :
5210 228 : if (!new_expr)
5211 : return false;
5212 :
5213 228 : gfc_replace_expr (arg1, new_expr);
5214 228 : return true;
5215 :
5216 606 : case GFC_ISYM_SIZE:
5217 606 : if (!sym->as || sym->as->rank == 0)
5218 : return false;
5219 :
5220 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5221 : {
5222 360 : dup = mpz_get_si (arg2->value.integer);
5223 360 : d = dup - 1;
5224 : }
5225 : else
5226 : {
5227 530 : dup = sym->as->rank;
5228 530 : d = 0;
5229 : }
5230 :
5231 542 : for (; d < dup; d++)
5232 : {
5233 530 : gfc_expr *tmp;
5234 :
5235 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5236 : {
5237 518 : gfc_free_expr (new_expr);
5238 518 : return false;
5239 : }
5240 :
5241 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5242 : gfc_get_int_expr (gfc_default_integer_kind,
5243 : NULL, 1));
5244 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5245 12 : if (new_expr)
5246 0 : new_expr = gfc_multiply (new_expr, tmp);
5247 : else
5248 : new_expr = tmp;
5249 : }
5250 : break;
5251 :
5252 44 : case GFC_ISYM_LBOUND:
5253 44 : case GFC_ISYM_UBOUND:
5254 : /* TODO These implementations of lbound and ubound do not limit if
5255 : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5256 :
5257 44 : if (!sym->as || sym->as->rank == 0)
5258 : return false;
5259 :
5260 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5261 38 : d = mpz_get_si (arg2->value.integer) - 1;
5262 : else
5263 : return false;
5264 :
5265 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5266 : {
5267 23 : if (sym->as->lower[d])
5268 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5269 : }
5270 : else
5271 : {
5272 15 : if (sym->as->upper[d])
5273 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5274 : }
5275 : break;
5276 :
5277 : default:
5278 : break;
5279 : }
5280 :
5281 1337 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5282 1337 : if (!new_expr)
5283 : return false;
5284 :
5285 113 : gfc_replace_expr (expr, new_expr);
5286 113 : return true;
5287 : }
5288 :
5289 :
5290 : static void
5291 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5292 : gfc_interface_mapping * mapping)
5293 : {
5294 24 : gfc_formal_arglist *f;
5295 24 : gfc_actual_arglist *actual;
5296 :
5297 24 : actual = expr->value.function.actual;
5298 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5299 :
5300 72 : for (; f && actual; f = f->next, actual = actual->next)
5301 : {
5302 24 : if (!actual->expr)
5303 0 : continue;
5304 :
5305 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5306 : }
5307 :
5308 24 : if (map_expr->symtree->n.sym->attr.dimension)
5309 : {
5310 6 : int d;
5311 6 : gfc_array_spec *as;
5312 :
5313 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5314 :
5315 18 : for (d = 0; d < as->rank; d++)
5316 : {
5317 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5318 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5319 : }
5320 :
5321 6 : expr->value.function.esym->as = as;
5322 : }
5323 :
5324 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5325 : {
5326 0 : expr->value.function.esym->ts.u.cl->length
5327 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5328 :
5329 0 : gfc_apply_interface_mapping_to_expr (mapping,
5330 0 : expr->value.function.esym->ts.u.cl->length);
5331 : }
5332 24 : }
5333 :
5334 :
5335 : /* EXPR is a copy of an expression that appeared in the interface
5336 : associated with MAPPING. Walk it recursively looking for references to
5337 : dummy arguments that MAPPING maps to actual arguments. Replace each such
5338 : reference with a reference to the associated actual argument. */
5339 :
5340 : static void
5341 21343 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5342 : gfc_expr * expr)
5343 : {
5344 22910 : gfc_interface_sym_mapping *sym;
5345 22910 : gfc_actual_arglist *actual;
5346 :
5347 22910 : if (!expr)
5348 : return;
5349 :
5350 : /* Copying an expression does not copy its length, so do that here. */
5351 12759 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5352 : {
5353 1802 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5354 1802 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5355 : }
5356 :
5357 : /* Apply the mapping to any references. */
5358 12759 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5359 :
5360 : /* ...and to the expression's symbol, if it has one. */
5361 : /* TODO Find out why the condition on expr->symtree had to be moved into
5362 : the loop rather than being outside it, as originally. */
5363 30212 : for (sym = mapping->syms; sym; sym = sym->next)
5364 17453 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5365 : {
5366 3412 : if (sym->new_sym->n.sym->backend_decl)
5367 3368 : expr->symtree = sym->new_sym;
5368 44 : else if (sym->expr)
5369 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5370 : }
5371 :
5372 : /* ...and to subexpressions in expr->value. */
5373 12759 : switch (expr->expr_type)
5374 : {
5375 : case EXPR_VARIABLE:
5376 : case EXPR_CONSTANT:
5377 : case EXPR_NULL:
5378 : case EXPR_SUBSTRING:
5379 : break;
5380 :
5381 1567 : case EXPR_OP:
5382 1567 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5383 1567 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5384 1567 : break;
5385 :
5386 0 : case EXPR_CONDITIONAL:
5387 0 : gfc_apply_interface_mapping_to_expr (mapping,
5388 0 : expr->value.conditional.true_expr);
5389 0 : gfc_apply_interface_mapping_to_expr (mapping,
5390 0 : expr->value.conditional.false_expr);
5391 0 : break;
5392 :
5393 2976 : case EXPR_FUNCTION:
5394 9558 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5395 6582 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5396 :
5397 2976 : if (expr->value.function.esym == NULL
5398 2663 : && expr->value.function.isym != NULL
5399 2651 : && expr->value.function.actual
5400 2650 : && expr->value.function.actual->expr
5401 2650 : && expr->value.function.actual->expr->symtree
5402 5208 : && gfc_map_intrinsic_function (expr, mapping))
5403 : break;
5404 :
5405 6192 : for (sym = mapping->syms; sym; sym = sym->next)
5406 3557 : if (sym->old == expr->value.function.esym)
5407 : {
5408 24 : expr->value.function.esym = sym->new_sym->n.sym;
5409 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5410 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5411 : }
5412 : break;
5413 :
5414 47 : case EXPR_ARRAY:
5415 47 : case EXPR_STRUCTURE:
5416 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5417 47 : break;
5418 :
5419 0 : case EXPR_COMPCALL:
5420 0 : case EXPR_PPC:
5421 0 : case EXPR_UNKNOWN:
5422 0 : gcc_unreachable ();
5423 : break;
5424 : }
5425 :
5426 : return;
5427 : }
5428 :
5429 :
5430 : /* Evaluate interface expression EXPR using MAPPING. Store the result
5431 : in SE. */
5432 :
5433 : void
5434 4154 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5435 : gfc_se * se, gfc_expr * expr)
5436 : {
5437 4154 : expr = gfc_copy_expr (expr);
5438 4154 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5439 4154 : gfc_conv_expr (se, expr);
5440 4154 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5441 4154 : gfc_free_expr (expr);
5442 4154 : }
5443 :
5444 :
5445 : /* Returns a reference to a temporary array into which a component of
5446 : an actual argument derived type array is copied and then returned
5447 : after the function call. */
5448 : void
5449 2958 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5450 : sym_intent intent, bool formal_ptr,
5451 : const gfc_symbol *fsym, const char *proc_name,
5452 : gfc_symbol *sym, bool check_contiguous,
5453 : bool deep_copy, bool span_only)
5454 : {
5455 2958 : gfc_se lse;
5456 2958 : gfc_se rse;
5457 2958 : gfc_ss *lss;
5458 2958 : gfc_ss *rss;
5459 2958 : gfc_loopinfo loop;
5460 2958 : gfc_loopinfo loop2;
5461 2958 : gfc_array_info *info;
5462 2958 : tree offset;
5463 2958 : tree tmp_index;
5464 2958 : tree tmp;
5465 2958 : tree base_type;
5466 2958 : tree size;
5467 2958 : stmtblock_t body;
5468 2958 : int n;
5469 2958 : int dimen;
5470 2958 : gfc_se work_se;
5471 2958 : gfc_se *parmse;
5472 2958 : bool pass_optional;
5473 2958 : bool readonly;
5474 :
5475 2958 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5476 :
5477 2917 : if (pass_optional || check_contiguous)
5478 : {
5479 1543 : gfc_init_se (&work_se, NULL);
5480 1543 : parmse = &work_se;
5481 : }
5482 : else
5483 : parmse = se;
5484 :
5485 2958 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5486 : {
5487 : /* We will create a temporary array, so let us warn. */
5488 868 : char * msg;
5489 :
5490 868 : if (fsym && proc_name)
5491 868 : msg = xasprintf ("An array temporary was created for argument "
5492 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5493 : else
5494 0 : msg = xasprintf ("An array temporary was created");
5495 :
5496 868 : tmp = build_int_cst (logical_type_node, 1);
5497 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5498 : &expr->where, msg);
5499 868 : free (msg);
5500 : }
5501 :
5502 2958 : gfc_init_se (&lse, NULL);
5503 2958 : gfc_init_se (&rse, NULL);
5504 :
5505 : /* Walk the argument expression. */
5506 2958 : rss = gfc_walk_expr (expr);
5507 :
5508 2958 : gcc_assert (rss != gfc_ss_terminator);
5509 :
5510 : /* Initialize the scalarizer. */
5511 2958 : gfc_init_loopinfo (&loop);
5512 2958 : gfc_add_ss_to_loop (&loop, rss);
5513 :
5514 : /* Calculate the bounds of the scalarization. */
5515 2958 : gfc_conv_ss_startstride (&loop);
5516 :
5517 : /* Build an ss for the temporary. */
5518 2958 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5519 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5520 :
5521 2958 : base_type = gfc_typenode_for_spec (&expr->ts);
5522 2958 : if (GFC_ARRAY_TYPE_P (base_type)
5523 2958 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5524 0 : base_type = gfc_get_element_type (base_type);
5525 :
5526 2958 : if (expr->ts.type == BT_CLASS)
5527 127 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5528 :
5529 4182 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5530 1224 : ? expr->ts.u.cl->backend_decl
5531 : : NULL),
5532 : loop.dimen);
5533 :
5534 2958 : parmse->string_length = loop.temp_ss->info->string_length;
5535 :
5536 : /* Associate the SS with the loop. */
5537 2958 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5538 :
5539 : /* Setup the scalarizing loops. */
5540 2958 : gfc_conv_loop_setup (&loop, &expr->where);
5541 :
5542 : /* Pass the temporary descriptor back to the caller. */
5543 2958 : info = &loop.temp_ss->info->data.array;
5544 2958 : parmse->expr = info->descriptor;
5545 :
5546 : /* Setup the gfc_se structures. */
5547 2958 : gfc_copy_loopinfo_to_se (&lse, &loop);
5548 2958 : gfc_copy_loopinfo_to_se (&rse, &loop);
5549 :
5550 2958 : rse.ss = rss;
5551 2958 : lse.ss = loop.temp_ss;
5552 2958 : gfc_mark_ss_chain_used (rss, 1);
5553 2958 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5554 :
5555 : /* Start the scalarized loop body. */
5556 2958 : gfc_start_scalarized_body (&loop, &body);
5557 :
5558 : /* Translate the expression. */
5559 2958 : gfc_conv_expr (&rse, expr);
5560 :
5561 2958 : gfc_conv_tmp_array_ref (&lse);
5562 :
5563 2958 : if (intent != INTENT_OUT)
5564 : {
5565 2914 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, deep_copy, false);
5566 2914 : gfc_add_expr_to_block (&body, tmp);
5567 2914 : gcc_assert (rse.ss == gfc_ss_terminator);
5568 2914 : gfc_trans_scalarizing_loops (&loop, &body);
5569 : }
5570 : else
5571 : {
5572 : /* Make sure that the temporary declaration survives by merging
5573 : all the loop declarations into the current context. */
5574 97 : for (n = 0; n < loop.dimen; n++)
5575 : {
5576 53 : gfc_merge_block_scope (&body);
5577 53 : body = loop.code[loop.order[n]];
5578 : }
5579 44 : gfc_merge_block_scope (&body);
5580 : }
5581 :
5582 : /* Add the post block after the second loop, so that any
5583 : freeing of allocated memory is done at the right time. */
5584 2958 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5585 :
5586 : /**********Copy the temporary back again.*********/
5587 :
5588 2958 : gfc_init_se (&lse, NULL);
5589 2958 : gfc_init_se (&rse, NULL);
5590 :
5591 : /* Walk the argument expression. */
5592 2958 : lss = gfc_walk_expr (expr);
5593 2958 : rse.ss = loop.temp_ss;
5594 2958 : lse.ss = lss;
5595 :
5596 : /* Initialize the scalarizer. */
5597 2958 : gfc_init_loopinfo (&loop2);
5598 2958 : gfc_add_ss_to_loop (&loop2, lss);
5599 :
5600 2958 : dimen = rse.ss->dimen;
5601 :
5602 : /* Skip the write-out loop for this case. */
5603 2958 : if (gfc_is_class_array_function (expr))
5604 13 : goto class_array_fcn;
5605 :
5606 : /* Calculate the bounds of the scalarization. */
5607 2945 : gfc_conv_ss_startstride (&loop2);
5608 :
5609 : /* Setup the scalarizing loops. */
5610 2945 : gfc_conv_loop_setup (&loop2, &expr->where);
5611 :
5612 2945 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5613 2945 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5614 :
5615 2945 : gfc_mark_ss_chain_used (lss, 1);
5616 2945 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5617 :
5618 : /* Declare the variable to hold the temporary offset and start the
5619 : scalarized loop body. */
5620 2945 : offset = gfc_create_var (gfc_array_index_type, NULL);
5621 2945 : gfc_start_scalarized_body (&loop2, &body);
5622 :
5623 : /* Build the offsets for the temporary from the loop variables. The
5624 : temporary array has lbounds of zero and strides of one in all
5625 : dimensions, so this is very simple. The offset is only computed
5626 : outside the innermost loop, so the overall transfer could be
5627 : optimized further. */
5628 2945 : info = &rse.ss->info->data.array;
5629 :
5630 2945 : tmp_index = gfc_index_zero_node;
5631 4346 : for (n = dimen - 1; n > 0; n--)
5632 : {
5633 1401 : tree tmp_str;
5634 1401 : tmp = rse.loop->loopvar[n];
5635 1401 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5636 : tmp, rse.loop->from[n]);
5637 1401 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5638 : tmp, tmp_index);
5639 :
5640 2802 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5641 : gfc_array_index_type,
5642 1401 : rse.loop->to[n-1], rse.loop->from[n-1]);
5643 1401 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5644 : gfc_array_index_type,
5645 : tmp_str, gfc_index_one_node);
5646 :
5647 1401 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5648 : gfc_array_index_type, tmp, tmp_str);
5649 : }
5650 :
5651 5890 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5652 : gfc_array_index_type,
5653 2945 : tmp_index, rse.loop->from[0]);
5654 2945 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5655 :
5656 5890 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5657 : gfc_array_index_type,
5658 2945 : rse.loop->loopvar[0], offset);
5659 :
5660 : /* Now use the offset for the reference. */
5661 2945 : tmp = build_fold_indirect_ref_loc (input_location,
5662 : info->data);
5663 2945 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5664 :
5665 2945 : if (expr->ts.type == BT_CHARACTER)
5666 1224 : rse.string_length = expr->ts.u.cl->backend_decl;
5667 :
5668 2945 : gfc_conv_expr (&lse, expr);
5669 :
5670 2945 : gcc_assert (lse.ss == gfc_ss_terminator);
5671 :
5672 : /* Do not do deallocations when we are looking at a g77-style argument. */
5673 :
5674 2945 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, !g77);
5675 2945 : gfc_add_expr_to_block (&body, tmp);
5676 :
5677 : /* Generate the copying loops. */
5678 2945 : gfc_trans_scalarizing_loops (&loop2, &body);
5679 :
5680 : /* Wrap the whole thing up by adding the second loop to the post-block
5681 : and following it by the post-block of the first loop. In this way,
5682 : if the temporary needs freeing, it is done after use!
5683 : If input expr is read-only, e.g. a PARAMETER array, copying back
5684 : modified values is undefined behavior. */
5685 5890 : readonly = (expr->expr_type == EXPR_VARIABLE
5686 2891 : && expr->symtree
5687 5836 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5688 :
5689 2945 : if ((intent != INTENT_IN) && !readonly)
5690 : {
5691 1230 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5692 1230 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5693 : }
5694 :
5695 1715 : class_array_fcn:
5696 :
5697 : /* A deep copy allocated fresh components for the temporary; free them
5698 : again once the call has returned, before the temporary itself goes.
5699 : Only INTENT_IN is supported, as writing the temporary back would leave
5700 : the actual argument holding the freed component pointers. */
5701 2958 : gcc_assert (!deep_copy || intent == INTENT_IN);
5702 2958 : if (deep_copy && expr->ts.type == BT_DERIVED
5703 24 : && expr->ts.u.derived->attr.alloc_comp)
5704 : {
5705 24 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, parmse->expr,
5706 : dimen);
5707 24 : gfc_add_expr_to_block (&parmse->post, tmp);
5708 : }
5709 :
5710 2958 : gfc_add_block_to_block (&parmse->post, &loop.post);
5711 :
5712 2958 : gfc_cleanup_loop (&loop);
5713 2958 : gfc_cleanup_loop (&loop2);
5714 :
5715 : /* Pass the string length to the argument expression. */
5716 2958 : if (expr->ts.type == BT_CHARACTER)
5717 1224 : parmse->string_length = expr->ts.u.cl->backend_decl;
5718 :
5719 : /* Determine the offset for pointer formal arguments and set the
5720 : lbounds to one. */
5721 2958 : if (formal_ptr)
5722 : {
5723 18 : size = gfc_index_one_node;
5724 18 : offset = gfc_index_zero_node;
5725 36 : for (n = 0; n < dimen; n++)
5726 : {
5727 18 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5728 : gfc_rank_cst[n]);
5729 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5730 : gfc_array_index_type, tmp,
5731 : gfc_index_one_node);
5732 18 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5733 : parmse->expr,
5734 : gfc_rank_cst[n],
5735 : tmp);
5736 18 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5737 : parmse->expr,
5738 : gfc_rank_cst[n],
5739 : gfc_index_one_node);
5740 18 : size = gfc_evaluate_now (size, &parmse->pre);
5741 18 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5742 : gfc_array_index_type,
5743 : offset, size);
5744 18 : offset = gfc_evaluate_now (offset, &parmse->pre);
5745 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5746 : gfc_array_index_type,
5747 18 : rse.loop->to[n], rse.loop->from[n]);
5748 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5749 : gfc_array_index_type,
5750 : tmp, gfc_index_one_node);
5751 18 : size = fold_build2_loc (input_location, MULT_EXPR,
5752 : gfc_array_index_type, size, tmp);
5753 : }
5754 :
5755 18 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5756 : offset);
5757 : }
5758 :
5759 : /* We want either the address for the data or the address of the descriptor,
5760 : depending on the mode of passing array arguments. */
5761 2958 : if (g77)
5762 489 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5763 : else
5764 2469 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5765 :
5766 : /* Basically make this into
5767 :
5768 : if (present)
5769 : {
5770 : if (contiguous)
5771 : {
5772 : pointer = a;
5773 : }
5774 : else
5775 : {
5776 : parmse->pre();
5777 : pointer = parmse->expr;
5778 : }
5779 : }
5780 : else
5781 : pointer = NULL;
5782 :
5783 : foo (pointer);
5784 : if (present && !contiguous)
5785 : se->post();
5786 :
5787 : */
5788 :
5789 2958 : if (pass_optional || check_contiguous)
5790 : {
5791 1543 : tree type;
5792 1543 : stmtblock_t else_block;
5793 1543 : tree pre_stmts, post_stmts;
5794 1543 : tree pointer;
5795 1543 : tree else_stmt;
5796 1543 : tree present_var = NULL_TREE;
5797 1543 : tree cont_var = NULL_TREE;
5798 1543 : tree post_cond;
5799 :
5800 1543 : type = TREE_TYPE (parmse->expr);
5801 1543 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5802 1177 : type = TREE_TYPE (type);
5803 1543 : pointer = gfc_create_var (type, "arg_ptr");
5804 :
5805 1543 : if (check_contiguous)
5806 : {
5807 1513 : gfc_se cont_se, array_se;
5808 1513 : stmtblock_t if_block, else_block;
5809 1513 : tree if_stmt, else_stmt;
5810 1513 : mpz_t size;
5811 1513 : bool size_set;
5812 :
5813 1513 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5814 :
5815 : /* If the size is known to be one at compile-time, set
5816 : cont_var to true unconditionally. This may look
5817 : inelegant, but we're only doing this during
5818 : optimization, so the statements will be optimized away,
5819 : and this saves complexity here. */
5820 :
5821 1513 : size_set = gfc_array_size (expr, &size);
5822 1513 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5823 : {
5824 6 : gfc_add_modify (&se->pre, cont_var,
5825 : build_one_cst (boolean_type_node));
5826 : }
5827 : else
5828 : {
5829 : /* cont_var = is_contiguous (expr), or just that the span is the
5830 : element length for a dummy that takes any stride. */
5831 1507 : gfc_init_se (&cont_se, parmse);
5832 1507 : if (span_only)
5833 90 : gfc_conv_span_is_elem_len (&cont_se, expr);
5834 : else
5835 1417 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5836 1507 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5837 1507 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5838 1507 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5839 : }
5840 :
5841 1513 : if (size_set)
5842 1155 : mpz_clear (size);
5843 :
5844 : /* arrayse->expr = descriptor of a. */
5845 1513 : gfc_init_se (&array_se, se);
5846 1513 : gfc_conv_expr_descriptor (&array_se, expr);
5847 1513 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5848 1513 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5849 :
5850 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5851 1513 : gfc_init_block (&if_block);
5852 1513 : if (GFC_DESCRIPTOR_TYPE_P (type))
5853 1153 : gfc_add_modify (&if_block, pointer, array_se.expr);
5854 : else
5855 : {
5856 360 : tmp = gfc_conv_array_data (array_se.expr);
5857 360 : tmp = fold_convert (type, tmp);
5858 360 : gfc_add_modify (&if_block, pointer, tmp);
5859 : }
5860 1513 : if_stmt = gfc_finish_block (&if_block);
5861 :
5862 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5863 1513 : gfc_init_block (&else_block);
5864 1513 : gfc_add_block_to_block (&else_block, &parmse->pre);
5865 1873 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5866 1513 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5867 : : parmse->expr);
5868 1513 : gfc_add_modify (&else_block, pointer, tmp);
5869 1513 : else_stmt = gfc_finish_block (&else_block);
5870 :
5871 : /* And put the above into an if statement. */
5872 1513 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5873 : gfc_likely (cont_var,
5874 : PRED_FORTRAN_CONTIGUOUS),
5875 : if_stmt, else_stmt);
5876 : }
5877 : else
5878 : {
5879 : /* pointer = parmse->expr; . */
5880 36 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5881 30 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5882 : : parmse->expr);
5883 30 : gfc_add_modify (&parmse->pre, pointer, tmp);
5884 30 : pre_stmts = gfc_finish_block (&parmse->pre);
5885 : }
5886 :
5887 1543 : if (pass_optional)
5888 : {
5889 41 : present_var = gfc_create_var (boolean_type_node, "present");
5890 :
5891 : /* present_var = present(sym); . */
5892 41 : tmp = gfc_conv_expr_present (sym);
5893 41 : tmp = fold_convert (boolean_type_node, tmp);
5894 41 : gfc_add_modify (&se->pre, present_var, tmp);
5895 :
5896 : /* else_stmt = { pointer = NULL; } . */
5897 41 : gfc_init_block (&else_block);
5898 41 : if (GFC_DESCRIPTOR_TYPE_P (type))
5899 24 : gfc_conv_descriptor_data_set (&else_block, pointer,
5900 : null_pointer_node);
5901 : else
5902 17 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5903 41 : else_stmt = gfc_finish_block (&else_block);
5904 :
5905 41 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5906 : gfc_likely (present_var,
5907 : PRED_FORTRAN_ABSENT_DUMMY),
5908 : pre_stmts, else_stmt);
5909 41 : gfc_add_expr_to_block (&se->pre, tmp);
5910 : }
5911 : else
5912 1502 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5913 :
5914 1543 : post_stmts = gfc_finish_block (&parmse->post);
5915 :
5916 : /* Put together the post stuff, plus the optional
5917 : deallocation. */
5918 1543 : if (check_contiguous)
5919 : {
5920 : /* !cont_var. */
5921 1513 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5922 : cont_var,
5923 : build_zero_cst (boolean_type_node));
5924 1513 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5925 :
5926 1513 : if (pass_optional)
5927 : {
5928 11 : tree present_likely = gfc_likely (present_var,
5929 : PRED_FORTRAN_ABSENT_DUMMY);
5930 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5931 : boolean_type_node, present_likely,
5932 : tmp);
5933 : }
5934 : else
5935 : post_cond = tmp;
5936 : }
5937 : else
5938 : {
5939 30 : gcc_assert (pass_optional);
5940 : post_cond = present_var;
5941 : }
5942 :
5943 1543 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5944 : post_stmts, build_empty_stmt (input_location));
5945 1543 : gfc_add_expr_to_block (&se->post, tmp);
5946 1543 : if (GFC_DESCRIPTOR_TYPE_P (type))
5947 : {
5948 1177 : type = TREE_TYPE (parmse->expr);
5949 1177 : if (POINTER_TYPE_P (type))
5950 : {
5951 1177 : pointer = gfc_build_addr_expr (type, pointer);
5952 1177 : if (pass_optional)
5953 : {
5954 24 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5955 24 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
5956 : tmp, pointer,
5957 : fold_convert (type,
5958 : null_pointer_node));
5959 : }
5960 : }
5961 : else
5962 0 : gcc_assert (!pass_optional);
5963 : }
5964 1543 : se->expr = pointer;
5965 1543 : se->string_length = parmse->string_length;
5966 : }
5967 :
5968 2958 : return;
5969 : }
5970 :
5971 :
5972 : /* Generate the code for argument list functions. */
5973 :
5974 : static void
5975 5846 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5976 : {
5977 : /* Pass by value for g77 %VAL(arg), pass the address
5978 : indirectly for %LOC, else by reference. Thus %REF
5979 : is a "do-nothing" and %LOC is the same as an F95
5980 : pointer. */
5981 5846 : if (strcmp (name, "%VAL") == 0)
5982 5834 : gfc_conv_expr (se, expr);
5983 12 : else if (strcmp (name, "%LOC") == 0)
5984 : {
5985 6 : gfc_conv_expr_reference (se, expr);
5986 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
5987 : }
5988 6 : else if (strcmp (name, "%REF") == 0)
5989 6 : gfc_conv_expr_reference (se, expr);
5990 : else
5991 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
5992 5846 : }
5993 :
5994 :
5995 : /* This function tells whether the middle-end representation of the expression
5996 : E given as input may point to data otherwise accessible through a variable
5997 : (sub-)reference.
5998 : It is assumed that the only expressions that may alias are variables,
5999 : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
6000 : may alias.
6001 : This function is used to decide whether freeing an expression's allocatable
6002 : components is safe or should be avoided.
6003 :
6004 : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
6005 : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
6006 : is necessary because for array constructors, aliasing depends on how
6007 : the array is used:
6008 : - If E is an array constructor used as argument to an elemental procedure,
6009 : the array, which is generated through shallow copy by the scalarizer,
6010 : is used directly and can alias the expressions it was copied from.
6011 : - If E is an array constructor used as argument to a non-elemental
6012 : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
6013 : the array as in the previous case, but then that array is used
6014 : to initialize a new descriptor through deep copy. There is no alias
6015 : possible in that case.
6016 : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
6017 : above. */
6018 :
6019 : static bool
6020 7753 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6021 : {
6022 7753 : gfc_constructor *c;
6023 :
6024 7753 : if (e->expr_type == EXPR_VARIABLE)
6025 : return true;
6026 562 : else if (e->expr_type == EXPR_FUNCTION)
6027 : {
6028 161 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
6029 :
6030 161 : if (proc_ifc->result != NULL
6031 161 : && ((proc_ifc->result->ts.type == BT_CLASS
6032 25 : && proc_ifc->result->ts.u.derived->attr.is_class
6033 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
6034 161 : || proc_ifc->result->attr.pointer))
6035 : return true;
6036 : else
6037 160 : return false;
6038 : }
6039 401 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6040 : return false;
6041 :
6042 79 : for (c = gfc_constructor_first (e->value.constructor);
6043 233 : c; c = gfc_constructor_next (c))
6044 189 : if (c->expr
6045 189 : && expr_may_alias_variables (c->expr, array_may_alias))
6046 : return true;
6047 :
6048 : return false;
6049 : }
6050 :
6051 :
6052 : /* A helper function to set the dtype for unallocated or unassociated
6053 : entities. */
6054 :
6055 : static void
6056 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6057 : {
6058 891 : tree tmp;
6059 891 : tree desc;
6060 891 : tree cond;
6061 891 : tree type;
6062 891 : stmtblock_t block;
6063 :
6064 : /* TODO Figure out how to handle optional dummies. */
6065 891 : if (e && e->expr_type == EXPR_VARIABLE
6066 807 : && e->symtree->n.sym->attr.optional)
6067 108 : return;
6068 :
6069 819 : desc = parmse->expr;
6070 819 : if (desc == NULL_TREE)
6071 : return;
6072 :
6073 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6074 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6075 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6076 192 : desc = gfc_class_data_get (desc);
6077 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6078 : return;
6079 :
6080 783 : gfc_init_block (&block);
6081 783 : tmp = gfc_conv_descriptor_data_get (desc);
6082 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6083 : logical_type_node, tmp,
6084 783 : build_int_cst (TREE_TYPE (tmp), 0));
6085 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6086 783 : gfc_conv_descriptor_dtype_set (&block, desc,
6087 : gfc_get_dtype_rank_type (e->rank, type));
6088 783 : cond = build3_v (COND_EXPR, cond,
6089 : gfc_finish_block (&block),
6090 : build_empty_stmt (input_location));
6091 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6092 : }
6093 :
6094 :
6095 :
6096 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6097 : ISO_Fortran_binding array descriptors. */
6098 :
6099 : static void
6100 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6101 : {
6102 6537 : stmtblock_t block, block2;
6103 6537 : tree cfi, gfc, tmp, tmp2;
6104 6537 : tree present = NULL;
6105 6537 : tree gfc_strlen = NULL;
6106 6537 : tree rank;
6107 6537 : gfc_se se;
6108 :
6109 6537 : if (fsym->attr.optional
6110 1094 : && e->expr_type == EXPR_VARIABLE
6111 1094 : && e->symtree->n.sym->attr.optional)
6112 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6113 :
6114 6537 : gfc_init_block (&block);
6115 :
6116 : /* Convert original argument to a tree. */
6117 6537 : gfc_init_se (&se, NULL);
6118 6537 : if (e->rank == 0)
6119 : {
6120 687 : se.want_pointer = 1;
6121 687 : gfc_conv_expr (&se, e);
6122 687 : gfc = se.expr;
6123 : }
6124 : else
6125 : {
6126 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6127 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6128 : length assumed-length/assumed-size CHARACTER array. This only
6129 : applies if the actual argument is a "variable"; if it's some
6130 : non-lvalue expression, we are going to evaluate it to a
6131 : temporary below anyway. */
6132 5850 : se.force_no_tmp = 1;
6133 5850 : if ((fsym->attr.contiguous
6134 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6135 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6136 937 : || fsym->as->type == AS_EXPLICIT)))
6137 2023 : && !gfc_is_simply_contiguous (e, false, true)
6138 6883 : && gfc_expr_is_variable (e))
6139 : {
6140 1027 : bool optional = fsym->attr.optional;
6141 1027 : fsym->attr.optional = 0;
6142 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6143 1027 : fsym->attr.pointer, fsym,
6144 1027 : fsym->ns->proc_name->name, NULL,
6145 : /* check_contiguous= */ true);
6146 1027 : fsym->attr.optional = optional;
6147 : }
6148 : else
6149 4823 : gfc_conv_expr_descriptor (&se, e);
6150 5850 : gfc = se.expr;
6151 : /* For dt(:)%var, the base_addr is that of the subobject and elem_len is
6152 : its size, see below. The descriptor built for a subreference of the
6153 : array provides both. While sm is fine as it uses span*stride and not
6154 : elem_len. */
6155 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6156 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6157 : }
6158 6537 : if (e->ts.type == BT_CHARACTER)
6159 : {
6160 3409 : if (se.string_length)
6161 : gfc_strlen = se.string_length;
6162 1 : else if (e->ts.u.cl->backend_decl)
6163 : gfc_strlen = e->ts.u.cl->backend_decl;
6164 : else
6165 0 : gcc_unreachable ();
6166 : }
6167 6537 : gfc_add_block_to_block (&block, &se.pre);
6168 :
6169 : /* Create array descriptor and set version, rank, attribute, type. */
6170 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6171 : ? GFC_MAX_DIMENSIONS : e->rank,
6172 : false), "cfi");
6173 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6174 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6175 : {
6176 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6177 2338 : tmp = build_pointer_type (tmp);
6178 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6179 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6180 : }
6181 : else
6182 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6183 :
6184 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6185 6537 : gfc_add_modify (&block, tmp,
6186 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6187 6537 : if (e->rank < 0)
6188 305 : rank = gfc_conv_descriptor_rank_get (gfc);
6189 : else
6190 6232 : rank = gfc_rank_cst[e->rank];
6191 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6192 6537 : gfc_add_modify (&block, tmp,
6193 6537 : fold_convert (TREE_TYPE (tmp), rank));
6194 6537 : int itype = CFI_type_other;
6195 6537 : if (e->ts.f90_type == BT_VOID)
6196 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6197 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6198 : else
6199 : {
6200 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6201 1 : e->ts = fsym->ts;
6202 6441 : switch (e->ts.type)
6203 : {
6204 2296 : case BT_INTEGER:
6205 2296 : case BT_LOGICAL:
6206 2296 : case BT_REAL:
6207 2296 : case BT_COMPLEX:
6208 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6209 2296 : break;
6210 3410 : case BT_CHARACTER:
6211 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6212 3410 : break;
6213 : case BT_DERIVED:
6214 6537 : itype = CFI_type_struct;
6215 : break;
6216 0 : case BT_VOID:
6217 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6218 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6219 : break;
6220 : case BT_ASSUMED:
6221 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6222 : break;
6223 1 : case BT_CLASS:
6224 1 : if (fsym->ts.type == BT_ASSUMED)
6225 : {
6226 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6227 : // type specifier is assumed-type and is an unlimited polymorphic
6228 : // entity." The actual argument _data component is passed.
6229 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6230 : break;
6231 : }
6232 : else
6233 0 : gcc_unreachable ();
6234 :
6235 0 : case BT_UNSIGNED:
6236 0 : gfc_internal_error ("Unsigned not yet implemented");
6237 :
6238 0 : case BT_PROCEDURE:
6239 0 : case BT_HOLLERITH:
6240 0 : case BT_UNION:
6241 0 : case BT_BOZ:
6242 0 : case BT_UNKNOWN:
6243 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6244 0 : gcc_unreachable ();
6245 : }
6246 : }
6247 :
6248 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6249 6537 : gfc_add_modify (&block, tmp,
6250 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6251 :
6252 6537 : int attr = CFI_attribute_other;
6253 6537 : if (fsym->attr.pointer)
6254 : attr = CFI_attribute_pointer;
6255 5774 : else if (fsym->attr.allocatable)
6256 433 : attr = CFI_attribute_allocatable;
6257 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6258 6537 : gfc_add_modify (&block, tmp,
6259 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6260 :
6261 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6262 : That is very sensible for undefined pointers, but the C code might assume
6263 : that the pointer retains the value, in particular, if it was NULL. */
6264 6537 : if (e->rank == 0)
6265 : {
6266 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6267 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6268 : }
6269 : else
6270 : {
6271 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6272 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6273 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6274 : }
6275 :
6276 : /* Set elem_len if known - must be before the next if block.
6277 : Note that allocatable implies 'len=:'. */
6278 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6279 : {
6280 : /* Length is known at compile time; use 'block' for it. */
6281 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6282 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6283 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6284 : }
6285 :
6286 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6287 91 : goto done;
6288 :
6289 : /* When allocatable + intent out, free the cfi descriptor. */
6290 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6291 : {
6292 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6293 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6294 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6295 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6296 90 : gfc_add_modify (&block, tmp,
6297 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6298 90 : goto done;
6299 : }
6300 :
6301 : /* If not unallocated/unassociated. */
6302 6356 : gfc_init_block (&block2);
6303 :
6304 : /* Set elem_len, which may be only known at run time. */
6305 6356 : if (e->ts.type == BT_CHARACTER
6306 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6307 : {
6308 3408 : gcc_assert (gfc_strlen);
6309 3409 : tmp = gfc_strlen;
6310 3409 : if (e->ts.kind != 1)
6311 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6312 : gfc_charlen_type_node, tmp,
6313 : build_int_cst (gfc_charlen_type_node,
6314 1117 : e->ts.kind));
6315 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6316 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6317 : }
6318 2947 : else if (e->ts.type == BT_ASSUMED)
6319 : {
6320 54 : tmp = gfc_conv_descriptor_elem_len_get (gfc);
6321 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6322 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6323 : }
6324 :
6325 6356 : if (e->ts.type == BT_ASSUMED)
6326 : {
6327 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6328 : an CFI descriptor. Use the type in the descriptor as it provide
6329 : mode information. (Quality of implementation feature.) */
6330 54 : tree cond;
6331 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6332 54 : tree type = fold_convert (TREE_TYPE (ctype),
6333 : gfc_conv_descriptor_type_get (gfc));
6334 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6335 : gfc_conv_descriptor_elem_len_get (gfc));
6336 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6337 54 : kind, build_int_cst (TREE_TYPE (type),
6338 : CFI_type_kind_shift));
6339 :
6340 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6341 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6342 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6343 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6344 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6345 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6346 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6347 : ctype,
6348 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6349 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6350 : tmp, tmp2);
6351 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6352 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6353 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6354 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6355 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6356 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6357 : tmp, tmp2);
6358 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6359 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6360 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6361 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6362 54 : tmp = build_int_cst (TREE_TYPE (type),
6363 : CFI_type_from_type_kind (CFI_type_Character, 1));
6364 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6365 : ctype, tmp);
6366 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6367 : tmp, tmp2);
6368 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6369 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6370 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6371 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6372 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6373 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6374 54 : build_int_cst (TREE_TYPE (type),
6375 : CFI_type_Complex));
6376 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6377 : ctype, tmp);
6378 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6379 : tmp, tmp2);
6380 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6381 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6382 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6383 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6384 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6385 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6386 : cond, tmp);
6387 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6388 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6389 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6390 : cond, tmp);
6391 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6392 : type, kind);
6393 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6394 : ctype, tmp);
6395 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6396 : tmp, tmp2);
6397 54 : gfc_add_expr_to_block (&block2, tmp2);
6398 : }
6399 :
6400 6356 : if (e->rank != 0)
6401 : {
6402 : /* Loop: for (i = 0; i < rank; ++i). */
6403 5735 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6404 : /* Loop body. */
6405 5735 : stmtblock_t loop_body;
6406 5735 : gfc_init_block (&loop_body);
6407 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6408 : ? gfc->dim[i].lbound : 0 */
6409 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6410 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6411 : else
6412 5087 : tmp = gfc_index_zero_node;
6413 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6414 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6415 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6416 : gfc_conv_descriptor_ubound_get (gfc, idx),
6417 : gfc_conv_descriptor_lbound_get (gfc, idx));
6418 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6419 : tmp, gfc_index_one_node);
6420 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6421 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6422 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6423 : gfc_conv_descriptor_stride_get (gfc, idx),
6424 : gfc_conv_descriptor_span_get (gfc));
6425 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6426 :
6427 : /* Generate loop. */
6428 5735 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6429 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6430 :
6431 5735 : if (e->expr_type == EXPR_VARIABLE
6432 5573 : && e->ref
6433 5573 : && e->ref->u.ar.type == AR_FULL
6434 2732 : && e->symtree->n.sym->attr.dummy
6435 988 : && e->symtree->n.sym->as
6436 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6437 : {
6438 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6439 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6440 : }
6441 : }
6442 :
6443 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6444 : {
6445 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6446 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6447 : tmp, null_pointer_node);
6448 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6449 : build_empty_stmt (input_location));
6450 1015 : gfc_add_expr_to_block (&block, tmp);
6451 : }
6452 : else
6453 5341 : gfc_add_block_to_block (&block, &block2);
6454 :
6455 :
6456 6537 : done:
6457 6537 : if (present)
6458 : {
6459 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6460 103 : TREE_TYPE (parmse->expr),
6461 : present, parmse->expr, null_pointer_node);
6462 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6463 : build_empty_stmt (input_location));
6464 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6465 : }
6466 : else
6467 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6468 :
6469 6537 : gfc_init_block (&block);
6470 :
6471 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6472 1196 : || fsym->attr.intent == INTENT_IN)
6473 5550 : goto post_call;
6474 :
6475 987 : gfc_init_block (&block2);
6476 987 : if (e->rank == 0)
6477 : {
6478 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6479 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6480 : }
6481 : else
6482 : {
6483 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6484 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6485 :
6486 559 : if (fsym->attr.allocatable)
6487 : {
6488 : /* gfc->span = cfi->elem_len. */
6489 252 : tmp = fold_convert (gfc_array_index_type,
6490 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6491 : }
6492 : else
6493 : {
6494 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6495 : ? cfi->dim[0].sm : cfi->elem_len). */
6496 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6497 307 : tmp2 = fold_convert (gfc_array_index_type,
6498 : gfc_get_cfi_desc_elem_len (cfi));
6499 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6500 : gfc_array_index_type, tmp, tmp2);
6501 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6502 : tmp, gfc_index_zero_node);
6503 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6504 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6505 : }
6506 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6507 :
6508 : /* Calculate offset + set lbound, ubound and stride. */
6509 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6510 : /* Loop: for (i = 0; i < rank; ++i). */
6511 559 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6512 : /* Loop body. */
6513 559 : stmtblock_t loop_body;
6514 559 : gfc_init_block (&loop_body);
6515 : /* gfc->dim[i].lbound = ... */
6516 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6517 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6518 :
6519 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6520 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6521 : gfc_conv_descriptor_lbound_get (gfc, idx),
6522 : gfc_index_one_node);
6523 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6524 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6525 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6526 :
6527 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6528 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6529 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6530 : gfc_array_index_type, tmp,
6531 : fold_convert (gfc_array_index_type,
6532 : gfc_get_cfi_desc_elem_len (cfi)));
6533 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6534 :
6535 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6536 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6537 : gfc_conv_descriptor_stride_get (gfc, idx),
6538 : gfc_conv_descriptor_lbound_get (gfc, idx));
6539 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6540 : gfc_conv_descriptor_offset_get (gfc), tmp);
6541 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6542 : /* Generate loop. */
6543 559 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6544 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6545 : }
6546 :
6547 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6548 : {
6549 60 : tmp = fold_convert (gfc_charlen_type_node,
6550 : gfc_get_cfi_desc_elem_len (cfi));
6551 60 : if (e->ts.kind != 1)
6552 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6553 : gfc_charlen_type_node, tmp,
6554 : build_int_cst (gfc_charlen_type_node,
6555 24 : e->ts.kind));
6556 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6557 : }
6558 :
6559 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6560 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6561 : tmp, null_pointer_node);
6562 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6563 : build_empty_stmt (input_location));
6564 987 : gfc_add_expr_to_block (&block, tmp);
6565 :
6566 6537 : post_call:
6567 6537 : gfc_add_block_to_block (&block, &se.post);
6568 6537 : if (present && block.head)
6569 : {
6570 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6571 : build_empty_stmt (input_location));
6572 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6573 : }
6574 6531 : else if (block.head)
6575 1564 : gfc_add_block_to_block (&parmse->post, &block);
6576 6537 : }
6577 :
6578 :
6579 : /* Create "conditional temporary" to handle scalar dummy variables with the
6580 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6581 : as fallback. Does not handle CLASS. */
6582 :
6583 : static void
6584 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6585 : {
6586 234 : tree temp;
6587 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6588 234 : gcc_assert (e->rank == 0);
6589 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6590 234 : TREE_STATIC (temp) = 1;
6591 234 : TREE_CONSTANT (temp) = 1;
6592 234 : TREE_READONLY (temp) = 1;
6593 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6594 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6595 234 : TREE_TYPE (parmse->expr),
6596 : cond, parmse->expr, temp);
6597 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6598 234 : }
6599 :
6600 :
6601 : /* Returns true if the type specified in TS is a character type whose length
6602 : is constant. Otherwise returns false. */
6603 :
6604 : static bool
6605 22228 : gfc_const_length_character_type_p (gfc_typespec *ts)
6606 : {
6607 22228 : return (ts->type == BT_CHARACTER
6608 515 : && ts->u.cl
6609 515 : && ts->u.cl->length
6610 479 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6611 22695 : && ts->u.cl->length->ts.type == BT_INTEGER);
6612 : }
6613 :
6614 :
6615 : /* Returns true if FORMAL contains an explicit-shape array dummy with the
6616 : VALUE attribute. The bounds of such a dummy may have to be evaluated
6617 : on the caller side, which needs an interface mapping. */
6618 :
6619 : static bool
6620 115860 : has_value_array_dummy (gfc_formal_arglist *formal)
6621 : {
6622 310078 : for (; formal; formal = formal->next)
6623 194284 : if (formal->sym && formal->sym->attr.value && formal->sym->attr.dimension
6624 174 : && formal->sym->as && formal->sym->as->type == AS_EXPLICIT)
6625 : return true;
6626 :
6627 : return false;
6628 : }
6629 :
6630 :
6631 : /* Sequence association (F2023, 15.5.2.12) of a scalar actual argument E with
6632 : an explicit-shape array dummy FSYM that has the VALUE attribute. Copy as
6633 : many elements as the dummy declares into a temporary and pass that.
6634 : MAPPING supplies the caller-side values of any dummy arguments appearing
6635 : in the bounds or the character length of FSYM. */
6636 :
6637 : static void
6638 36 : conv_seq_assoc_value_arg (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
6639 : gfc_interface_mapping *mapping)
6640 : {
6641 36 : tree nelems, elem_type, elem_size, tmpvar, src, tmp;
6642 36 : gfc_se se;
6643 36 : int n;
6644 :
6645 36 : gcc_assert (fsym->as && fsym->as->type == AS_EXPLICIT);
6646 :
6647 : /* Address of the first element of the actual argument's sequence. */
6648 36 : gfc_init_se (&se, NULL);
6649 36 : if (e->ts.type == BT_CHARACTER)
6650 : {
6651 12 : gfc_conv_expr (&se, e);
6652 12 : gfc_conv_string_parameter (&se);
6653 : /* The hidden length argument is that of the actual argument, as it
6654 : is for a dummy that does not have the VALUE attribute. */
6655 12 : parmse->string_length = se.string_length;
6656 : }
6657 : else
6658 24 : gfc_conv_expr_reference (&se, e);
6659 36 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6660 36 : gfc_add_block_to_block (&parmse->post, &se.post);
6661 36 : src = se.expr;
6662 :
6663 : /* Number of elements of the dummy. */
6664 36 : nelems = gfc_index_one_node;
6665 78 : for (n = 0; n < fsym->as->rank; n++)
6666 : {
6667 42 : tree lbound, ubound, extent;
6668 :
6669 42 : gfc_init_se (&se, NULL);
6670 42 : gfc_apply_interface_mapping (mapping, &se, fsym->as->upper[n]);
6671 42 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6672 42 : gfc_add_block_to_block (&parmse->post, &se.post);
6673 42 : ubound = fold_convert (gfc_array_index_type, se.expr);
6674 :
6675 42 : if (fsym->as->lower[n])
6676 : {
6677 42 : gfc_init_se (&se, NULL);
6678 42 : gfc_apply_interface_mapping (mapping, &se, fsym->as->lower[n]);
6679 42 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6680 42 : gfc_add_block_to_block (&parmse->post, &se.post);
6681 42 : lbound = fold_convert (gfc_array_index_type, se.expr);
6682 : }
6683 : else
6684 0 : lbound = gfc_index_one_node;
6685 :
6686 42 : extent = fold_build2_loc (input_location, MINUS_EXPR,
6687 : gfc_array_index_type, ubound, lbound);
6688 42 : extent = fold_build2_loc (input_location, PLUS_EXPR,
6689 : gfc_array_index_type, extent,
6690 : gfc_index_one_node);
6691 42 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6692 : extent, gfc_index_zero_node);
6693 42 : nelems = fold_build2_loc (input_location, MULT_EXPR,
6694 : gfc_array_index_type, nelems, extent);
6695 : }
6696 36 : nelems = gfc_evaluate_now (nelems, &parmse->pre);
6697 :
6698 : /* Element type and size of the dummy. For characters the element
6699 : sequence is grouped by the character length of the dummy. */
6700 36 : if (fsym->ts.type == BT_CHARACTER)
6701 : {
6702 12 : tree len;
6703 :
6704 12 : if (fsym->ts.u.cl->length)
6705 : {
6706 12 : gfc_init_se (&se, NULL);
6707 12 : gfc_apply_interface_mapping (mapping, &se, fsym->ts.u.cl->length);
6708 12 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6709 12 : gfc_add_block_to_block (&parmse->post, &se.post);
6710 12 : len = fold_convert (gfc_charlen_type_node, se.expr);
6711 : }
6712 : else
6713 0 : len = fold_convert (gfc_charlen_type_node, parmse->string_length);
6714 :
6715 12 : tree char_size = TYPE_SIZE_UNIT (gfc_get_char_type (fsym->ts.kind));
6716 :
6717 12 : elem_type = gfc_get_character_type_len (fsym->ts.kind, len);
6718 12 : elem_size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6719 : fold_convert (size_type_node, len),
6720 : fold_convert (size_type_node, char_size));
6721 : }
6722 : else
6723 : {
6724 24 : elem_type = gfc_typenode_for_spec (&fsym->ts);
6725 24 : elem_size = fold_convert (size_type_node, TYPE_SIZE_UNIT (elem_type));
6726 : }
6727 :
6728 : /* The temporary holding the copy. Allocate at least one element so that
6729 : a zero-sized dummy does not produce a degenerate array type. */
6730 36 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6731 : nelems, gfc_index_one_node);
6732 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6733 : tmp, gfc_index_one_node);
6734 36 : tmp = build_array_type (elem_type,
6735 : build_range_type (gfc_array_index_type,
6736 : gfc_index_zero_node, tmp));
6737 36 : tmpvar = gfc_create_var (tmp, "seq_copy");
6738 36 : gfc_add_expr_to_block (&parmse->pre,
6739 : fold_build1_loc (input_location, DECL_EXPR, tmp,
6740 : tmpvar));
6741 :
6742 36 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6743 : fold_convert (size_type_node, nelems), elem_size);
6744 36 : tmp = gfc_build_memcpy_call (fold_convert (pvoid_type_node,
6745 : gfc_build_addr_expr (NULL_TREE,
6746 : tmpvar)),
6747 : fold_convert (pvoid_type_node, src), tmp);
6748 36 : gfc_add_expr_to_block (&parmse->pre, tmp);
6749 :
6750 : /* The memcpy also copied the component pointers of a derived type, which
6751 : would leave the temporary sharing the actual argument's allocatable
6752 : components. Give the copy components of its own and free them again
6753 : once the call has returned. */
6754 36 : if (fsym->ts.type == BT_DERIVED && fsym->ts.u.derived->attr.alloc_comp)
6755 : {
6756 6 : tree src_ptr = fold_convert (build_pointer_type (elem_type), src);
6757 6 : tree elem_idx = gfc_create_var (gfc_array_index_type, "elem");
6758 6 : tree dest_elem = gfc_build_array_ref (tmpvar, elem_idx, NULL_TREE);
6759 6 : tree src_offset = fold_build2_loc (input_location, MULT_EXPR, sizetype,
6760 : fold_convert (sizetype, elem_idx),
6761 : elem_size);
6762 6 : tree src_elem
6763 6 : = build_fold_indirect_ref_loc (input_location,
6764 : fold_build_pointer_plus_loc
6765 : (input_location, src_ptr, src_offset));
6766 :
6767 6 : tmp = gfc_copy_alloc_comp (fsym->ts.u.derived, src_elem, dest_elem, 0, 0);
6768 6 : gfc_simple_for_loop (&parmse->pre, elem_idx, gfc_index_zero_node, nelems,
6769 : LT_EXPR, gfc_index_one_node, tmp);
6770 :
6771 6 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived, dest_elem, 0);
6772 6 : gfc_simple_for_loop (&parmse->post, elem_idx, gfc_index_zero_node, nelems,
6773 : LT_EXPR, gfc_index_one_node, tmp);
6774 : }
6775 :
6776 36 : if (fsym->ts.type == BT_CHARACTER)
6777 12 : parmse->expr
6778 12 : = gfc_build_addr_expr (build_pointer_type (gfc_get_char_type
6779 : (fsym->ts.kind)), tmpvar);
6780 : else
6781 24 : parmse->expr = gfc_build_addr_expr (build_pointer_type (elem_type), tmpvar);
6782 36 : }
6783 :
6784 :
6785 : /* Helper function for the handling of (currently) scalar dummy variables
6786 : with the VALUE attribute. Argument parmse should already be set up. */
6787 : static void
6788 22673 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6789 : vec<tree, va_gc> *& optionalargs)
6790 : {
6791 22673 : tree tmp;
6792 :
6793 22673 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6794 :
6795 22673 : if (IS_PDT (e))
6796 : {
6797 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6798 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6799 6 : gfc_add_expr_to_block (&parmse->pre,
6800 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6801 : parmse->expr, tmp,
6802 : e->rank, 0));
6803 6 : parmse->expr = tmp;
6804 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6805 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6806 6 : return;
6807 : }
6808 :
6809 : /* Absent actual argument for optional scalar dummy. */
6810 22667 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6811 : {
6812 : /* For scalar arguments with VALUE attribute which are passed by
6813 : value, pass "0" and a hidden argument for the optional status. */
6814 439 : if (fsym->ts.type == BT_CHARACTER)
6815 : {
6816 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6817 : zero. */
6818 102 : parmse->expr = null_pointer_node;
6819 102 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6820 : }
6821 337 : else if (gfc_bt_struct (fsym->ts.type)
6822 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6823 : {
6824 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6825 : are pointers and passed as such below. */
6826 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6827 24 : TREE_CONSTANT (temp) = 1;
6828 24 : TREE_READONLY (temp) = 1;
6829 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6830 24 : parmse->expr = temp;
6831 24 : }
6832 : else
6833 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6834 : integer_zero_node);
6835 439 : vec_safe_push (optionalargs, boolean_false_node);
6836 :
6837 439 : return;
6838 : }
6839 :
6840 : /* Assumed-length or non-constant-length CHARACTER VALUE dummy: copy
6841 : the actual argument and pass the copy. */
6842 22228 : if (fsym->ts.type == BT_CHARACTER
6843 515 : && (!fsym->ts.u.cl || !fsym->ts.u.cl->length
6844 479 : || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT))
6845 : {
6846 : /* An optional actual argument that is absent has nothing to copy
6847 : from; pass a null pointer and a length of zero instead. */
6848 48 : tree present = NULL_TREE;
6849 48 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
6850 24 : && e->symtree->n.sym->attr.optional)
6851 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
6852 :
6853 48 : gfc_conv_string_parameter (parmse);
6854 48 : tree len = fold_convert (gfc_charlen_type_node, parmse->string_length);
6855 48 : if (present)
6856 : {
6857 12 : len = fold_build3_loc (input_location, COND_EXPR,
6858 : gfc_charlen_type_node, present, len,
6859 : build_zero_cst (gfc_charlen_type_node));
6860 12 : len = gfc_evaluate_now (len, &parmse->pre);
6861 12 : parmse->string_length = len;
6862 : }
6863 48 : tree chartype = gfc_get_character_type_len (fsym->ts.kind, len);
6864 48 : tree val_copy = gfc_create_var (chartype, "val_copy");
6865 48 : tmp = fold_build1_loc (input_location, DECL_EXPR, chartype, val_copy);
6866 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
6867 : /* The copy size is in bytes, not in characters. */
6868 48 : tree bytes
6869 48 : = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6870 : fold_convert (size_type_node, len),
6871 48 : fold_convert (size_type_node,
6872 : TYPE_SIZE_UNIT (gfc_get_char_type
6873 : (fsym->ts.kind))));
6874 48 : tmp = gfc_build_memcpy_call (
6875 : fold_convert (pvoid_type_node,
6876 : gfc_build_addr_expr (NULL_TREE, val_copy)),
6877 : fold_convert (pvoid_type_node, parmse->expr), bytes);
6878 48 : if (present)
6879 12 : tmp = build3_v (COND_EXPR, present, tmp,
6880 : build_empty_stmt (input_location));
6881 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
6882 48 : parmse->expr = fold_convert (
6883 : build_pointer_type (gfc_get_char_type (fsym->ts.kind)),
6884 : gfc_build_addr_expr (NULL_TREE, val_copy));
6885 48 : if (present)
6886 24 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6887 12 : TREE_TYPE (parmse->expr), present,
6888 : parmse->expr,
6889 12 : fold_convert (TREE_TYPE (parmse->expr),
6890 : null_pointer_node));
6891 : }
6892 :
6893 : /* Truncate a too long constant character actual argument. */
6894 22228 : if (gfc_const_length_character_type_p (&fsym->ts)
6895 467 : && e->expr_type == EXPR_CONSTANT
6896 22311 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6897 : e->value.character.length) < 0)
6898 : {
6899 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6900 :
6901 : /* Truncate actual string argument. */
6902 17 : gfc_conv_expr (parmse, e);
6903 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6904 17 : e->value.character.string);
6905 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6906 :
6907 17 : if (flen == 1)
6908 : {
6909 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6910 14 : gfc_conv_string_parameter (parmse);
6911 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6912 : e->ts.kind);
6913 : }
6914 :
6915 : /* Indicate value,optional scalar dummy argument as present. */
6916 17 : if (fsym->attr.optional)
6917 1 : vec_safe_push (optionalargs, boolean_true_node);
6918 : return;
6919 : }
6920 :
6921 : /* gfortran argument passing conventions:
6922 : actual arguments to CHARACTER(len=1),VALUE
6923 : dummy arguments are actually passed by value.
6924 : Strings are truncated to length 1. */
6925 22211 : if (gfc_length_one_character_type_p (&fsym->ts))
6926 : {
6927 378 : if (e->expr_type == EXPR_CONSTANT
6928 54 : && e->value.character.length > 1)
6929 : {
6930 0 : e->value.character.length = 1;
6931 0 : gfc_conv_expr (parmse, e);
6932 : }
6933 :
6934 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6935 378 : gfc_conv_string_parameter (parmse);
6936 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6937 : e->ts.kind);
6938 : /* Truncate resulting string to length 1. */
6939 378 : parmse->string_length = slen1;
6940 : }
6941 :
6942 22211 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6943 : {
6944 : /* F2018:15.5.2.12 Argument presence and
6945 : restrictions on arguments not present. */
6946 847 : if (e->expr_type == EXPR_VARIABLE
6947 674 : && e->rank == 0
6948 1467 : && (gfc_expr_attr (e).allocatable
6949 620 : || gfc_expr_attr (e).pointer))
6950 : {
6951 198 : gfc_se argse;
6952 198 : tree cond;
6953 198 : gfc_init_se (&argse, NULL);
6954 198 : argse.want_pointer = 1;
6955 198 : gfc_conv_expr (&argse, e);
6956 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6957 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6958 : argse.expr, cond);
6959 198 : if (e->symtree->n.sym->attr.dummy)
6960 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6961 : logical_type_node,
6962 : gfc_conv_expr_present (e->symtree->n.sym),
6963 : cond);
6964 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
6965 : /* Create "conditional temporary". */
6966 198 : conv_cond_temp (parmse, e, cond);
6967 : }
6968 649 : else if (e->expr_type != EXPR_VARIABLE
6969 476 : || !e->symtree->n.sym->attr.optional
6970 272 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6971 377 : vec_safe_push (optionalargs, boolean_true_node);
6972 : else
6973 : {
6974 272 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6975 272 : if (gfc_bt_struct (fsym->ts.type)
6976 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6977 36 : conv_cond_temp (parmse, e, tmp);
6978 236 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6979 84 : parmse->expr
6980 168 : = fold_build3_loc (input_location, COND_EXPR,
6981 84 : TREE_TYPE (parmse->expr),
6982 : tmp, parmse->expr,
6983 84 : fold_convert (TREE_TYPE (parmse->expr),
6984 : integer_zero_node));
6985 :
6986 544 : vec_safe_push (optionalargs,
6987 272 : fold_convert (boolean_type_node, tmp));
6988 : }
6989 : }
6990 : }
6991 :
6992 :
6993 : /* Helper function for the handling of NULL() actual arguments associated with
6994 : non-optional dummy variables. Argument parmse should already be set up. */
6995 : static void
6996 444 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
6997 : {
6998 444 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
6999 :
7000 : /* Obtain the character length for a NULL() actual with a character
7001 : MOLD argument. Otherwise substitute a suitable dummy length.
7002 : Here we handle only non-optional dummies of non-bind(c) procedures. */
7003 444 : if (fsym->ts.type == BT_CHARACTER)
7004 : {
7005 216 : if (e->ts.type == BT_CHARACTER
7006 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
7007 : {
7008 : /* MOLD is present. Substitute a temporary character NULL pointer.
7009 : For an assumed-rank dummy we need a descriptor that passes the
7010 : correct rank. */
7011 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
7012 : {
7013 54 : tree tmp;
7014 54 : tmp = gfc_create_null_actual_descriptor (&parmse->pre, &e->ts,
7015 : fsym->attr, e->rank);
7016 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7017 54 : }
7018 : else
7019 : {
7020 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
7021 108 : gfc_add_modify (&parmse->pre, tmp,
7022 108 : build_zero_cst (TREE_TYPE (tmp)));
7023 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7024 : }
7025 :
7026 : /* Ensure that a usable length is available. */
7027 162 : if (parmse->string_length == NULL_TREE)
7028 : {
7029 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
7030 :
7031 162 : if (ts->u.cl->length != NULL
7032 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
7033 108 : gfc_conv_const_charlen (ts->u.cl);
7034 :
7035 162 : if (ts->u.cl->backend_decl)
7036 162 : parmse->string_length = ts->u.cl->backend_decl;
7037 : }
7038 : }
7039 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
7040 : {
7041 : /* MOLD is not present. Pass length of associated dummy character
7042 : argument if constant, or zero. */
7043 54 : if (fsym->ts.u.cl->length != NULL
7044 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7045 : {
7046 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
7047 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
7048 : }
7049 : else
7050 : {
7051 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
7052 : "slen");
7053 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
7054 : build_zero_cst (gfc_charlen_type_node));
7055 : }
7056 : }
7057 : }
7058 228 : else if (fsym->ts.type == BT_DERIVED
7059 18 : || ((fsym->attr.allocatable || fsym->attr.pointer)
7060 18 : && fsym->ts.type != BT_CLASS))
7061 : {
7062 228 : if (e->ts.type != BT_UNKNOWN)
7063 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
7064 : For an assumed-rank dummy we provide a descriptor that passes
7065 : the correct rank. */
7066 : {
7067 138 : tree tmp = gfc_create_null_actual_descriptor (&parmse->pre, &e->ts,
7068 : fsym->attr, e->rank);
7069 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7070 : }
7071 : else
7072 : /* MOLD is not present. Use attributes from dummy argument, which is
7073 : not allowed to be assumed-rank. */
7074 : {
7075 90 : int dummy_rank = fsym->as ? fsym->as->rank : 0;
7076 90 : tree tmp = gfc_create_null_actual_descriptor (&parmse->pre, &fsym->ts,
7077 : fsym->attr, dummy_rank);
7078 90 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7079 : }
7080 : }
7081 444 : }
7082 :
7083 :
7084 : /* Return true if a subobject of the elements of an array is referenced. */
7085 :
7086 : static bool
7087 30 : is_subobject_ref (gfc_expr *e)
7088 : {
7089 30 : bool seen_array = false;
7090 :
7091 72 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
7092 : {
7093 60 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7094 : seen_array = true;
7095 30 : else if (seen_array)
7096 : return true;
7097 : }
7098 :
7099 : return false;
7100 : }
7101 :
7102 :
7103 : /* Return true if expr is a span addressed dummy that is passed on as a whole,
7104 : rather than a reference to a subobject of the elements of an array. */
7105 :
7106 : static bool
7107 799 : is_whole_span_addressed_dummy (gfc_expr *e)
7108 : {
7109 799 : return e->expr_type == EXPR_VARIABLE
7110 799 : && e->symtree && e->symtree->n.sym
7111 799 : && gfc_is_span_addressed_dummy (e->symtree->n.sym)
7112 829 : && !is_subobject_ref (e);
7113 : }
7114 :
7115 :
7116 : /* Return true if the dummy fsym has an array descriptor and so addresses its
7117 : elements by the strides held in it. Such a dummy accepts an actual
7118 : argument of any stride; only a dummy without a descriptor, or one declared
7119 : CONTIGUOUS, needs it packed into contiguous storage. */
7120 :
7121 : static bool
7122 157 : dummy_accepts_strided_arg (gfc_symbol *fsym, bool nodesc_arg)
7123 : {
7124 126 : return fsym && !nodesc_arg && !fsym->attr.contiguous && fsym->as
7125 247 : && (fsym->as->type == AS_ASSUMED_SHAPE
7126 0 : || fsym->as->type == AS_ASSUMED_RANK
7127 0 : || fsym->as->type == AS_DEFERRED);
7128 : }
7129 :
7130 :
7131 : /* Return true if the actual argument expr for the dummy fsym may be passed as
7132 : a copy-in/copy-out temporary. A pointer associated with a TARGET or POINTER
7133 : dummy must remain valid after the call, so the actual argument is passed
7134 : directly, with a descriptor whose span provides the element spacing. An
7135 : actual argument with a vector subscript is not definable and its pointer
7136 : association is undefined on return, so it is still copied. */
7137 :
7138 : static bool
7139 1317 : copy_in_out_allowed (gfc_symbol *fsym, gfc_expr *e, bool nodesc_arg)
7140 : {
7141 1317 : if (fsym == NULL || nodesc_arg || gfc_has_vector_subscript (e))
7142 : return true;
7143 :
7144 1181 : if (gfc_dummy_requires_direct_arg (fsym))
7145 : return false;
7146 :
7147 941 : return !(fsym->attr.pointer && !fsym->attr.contiguous && fsym->as
7148 6 : && (fsym->as->type == AS_ASSUMED_SHAPE
7149 : || fsym->as->type == AS_ASSUMED_RANK
7150 : || fsym->as->type == AS_DEFERRED));
7151 : }
7152 :
7153 :
7154 : /* Return true if E is a reference to a function returning a pointer array,
7155 : whose elements may be spaced by more than the element size. */
7156 :
7157 : static bool
7158 53280 : pointer_array_result_p (gfc_expr *e)
7159 : {
7160 53280 : return e->expr_type == EXPR_FUNCTION
7161 4052 : && e->rank > 0
7162 4052 : && e->ts.type != BT_CLASS
7163 57319 : && gfc_expr_attr (e).pointer;
7164 : }
7165 :
7166 :
7167 : /* Evaluate the pointer array function reference E into a temporary pointer
7168 : in BLOCK and return a variable expression for that pointer. */
7169 :
7170 : static gfc_expr *
7171 145 : pointer_result_var (stmtblock_t *block, gfc_expr *e)
7172 : {
7173 145 : gfc_symtree *st = gfc_get_unique_symtree (NULL);
7174 145 : gfc_symbol *sym = gfc_new_symbol (st->name, NULL);
7175 145 : st->n.sym = sym;
7176 145 : sym->ts = e->ts;
7177 145 : sym->attr.flavor = FL_VARIABLE;
7178 145 : sym->attr.referenced = 1;
7179 145 : sym->attr.dimension = 1;
7180 145 : sym->attr.pointer = 1;
7181 145 : sym->as = gfc_get_array_spec ();
7182 145 : sym->as->rank = e->rank;
7183 145 : sym->as->type = AS_DEFERRED;
7184 :
7185 145 : gfc_se se;
7186 145 : gfc_init_se (&se, NULL);
7187 145 : gfc_conv_expr_descriptor (&se, e);
7188 145 : gfc_add_block_to_block (block, &se.pre);
7189 145 : gfc_add_block_to_block (block, &se.post);
7190 :
7191 145 : gcc_assert (VAR_P (se.expr) && GFC_DECL_PTR_ARRAY_P (se.expr));
7192 145 : sym->backend_decl = se.expr;
7193 :
7194 145 : if (sym->ts.type == BT_CHARACTER)
7195 : {
7196 36 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
7197 36 : sym->ts.u.cl->backend_decl = gfc_evaluate_now (se.string_length, block);
7198 : }
7199 :
7200 145 : gfc_expr *var = gfc_get_variable_expr (st);
7201 145 : var->where = e->where;
7202 145 : return var;
7203 : }
7204 :
7205 :
7206 : /* Generate code for a procedure call. Note can return se->post != NULL.
7207 : If se->direct_byref is set then se->expr contains the return parameter.
7208 : Return nonzero, if the call has alternate specifiers.
7209 : 'expr' is only needed for procedure pointer components. */
7210 :
7211 : int
7212 139089 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
7213 : gfc_actual_arglist * args, gfc_expr * expr,
7214 : vec<tree, va_gc> *append_args)
7215 : {
7216 139089 : gfc_interface_mapping mapping;
7217 139089 : vec<tree, va_gc> *arglist;
7218 139089 : vec<tree, va_gc> *retargs;
7219 139089 : tree tmp;
7220 139089 : tree fntype;
7221 139089 : gfc_se parmse;
7222 139089 : gfc_array_info *info;
7223 139089 : int byref;
7224 139089 : int parm_kind;
7225 139089 : tree type;
7226 139089 : tree var;
7227 139089 : tree len;
7228 139089 : tree base_object;
7229 139089 : vec<tree, va_gc> *stringargs;
7230 139089 : vec<tree, va_gc> *optionalargs;
7231 139089 : tree result = NULL;
7232 139089 : gfc_formal_arglist *formal;
7233 139089 : gfc_actual_arglist *arg;
7234 139089 : int has_alternate_specifier = 0;
7235 139089 : bool need_interface_mapping;
7236 139089 : bool is_builtin;
7237 139089 : bool callee_alloc;
7238 139089 : bool ulim_copy;
7239 139089 : gfc_typespec ts;
7240 139089 : gfc_charlen cl;
7241 139089 : gfc_expr *e;
7242 139089 : gfc_symbol *fsym;
7243 139089 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
7244 139089 : gfc_component *comp = NULL;
7245 139089 : int arglen;
7246 139089 : unsigned int argc;
7247 139089 : tree arg1_cntnr = NULL_TREE;
7248 139089 : bool call_needed_for_length = true;
7249 139089 : arglist = NULL;
7250 139089 : retargs = NULL;
7251 139089 : stringargs = NULL;
7252 139089 : optionalargs = NULL;
7253 139089 : var = NULL_TREE;
7254 139089 : len = NULL_TREE;
7255 139089 : gfc_clear_ts (&ts);
7256 139089 : gfc_intrinsic_sym *isym = expr && expr->rank ?
7257 : expr->value.function.isym : NULL;
7258 :
7259 139089 : comp = gfc_get_proc_ptr_comp (expr);
7260 :
7261 278178 : bool elemental_proc = (comp
7262 2055 : && comp->ts.interface
7263 2001 : && comp->ts.interface->attr.elemental)
7264 1856 : || (comp && comp->attr.elemental)
7265 140945 : || sym->attr.elemental;
7266 :
7267 139089 : if (se->ss != NULL)
7268 : {
7269 25361 : if (!elemental_proc)
7270 : {
7271 21796 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
7272 21796 : if (se->ss->info->useflags)
7273 : {
7274 5844 : gcc_assert ((!comp && gfc_return_by_reference (sym)
7275 : && sym->result->attr.dimension)
7276 : || (comp && comp->attr.dimension)
7277 : || gfc_is_class_array_function (expr));
7278 5844 : gcc_assert (se->loop != NULL);
7279 : /* Access the previously obtained result. */
7280 5844 : gfc_conv_tmp_array_ref (se);
7281 5844 : return 0;
7282 : }
7283 : }
7284 19517 : info = &se->ss->info->data.array;
7285 : }
7286 : else
7287 : info = NULL;
7288 :
7289 133245 : stmtblock_t post, clobbers, dealloc_blk;
7290 133245 : gfc_init_block (&post);
7291 133245 : gfc_init_block (&clobbers);
7292 133245 : gfc_init_block (&dealloc_blk);
7293 133245 : gfc_init_interface_mapping (&mapping);
7294 133245 : if (!comp)
7295 : {
7296 131239 : formal = gfc_sym_get_dummy_args (sym);
7297 246778 : need_interface_mapping = sym->attr.dimension ||
7298 115539 : (sym->ts.type == BT_CHARACTER
7299 3234 : && sym->ts.u.cl->length
7300 2482 : && sym->ts.u.cl->length->expr_type
7301 : != EXPR_CONSTANT)
7302 245181 : || has_value_array_dummy (formal);
7303 : }
7304 : else
7305 : {
7306 2006 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
7307 3943 : need_interface_mapping = comp->attr.dimension ||
7308 1937 : (comp->ts.type == BT_CHARACTER
7309 229 : && comp->ts.u.cl->length
7310 220 : && comp->ts.u.cl->length->expr_type
7311 : != EXPR_CONSTANT)
7312 3924 : || has_value_array_dummy (formal);
7313 : }
7314 :
7315 133245 : base_object = NULL_TREE;
7316 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7317 : is the third and fourth argument to such a function call a value
7318 : denoting the number of elements to copy (i.e., most of the time the
7319 : length of a deferred length string). */
7320 266490 : ulim_copy = (formal == NULL)
7321 32563 : && UNLIMITED_POLY (sym)
7322 133337 : && comp && (strcmp ("_copy", comp->name) == 0);
7323 :
7324 : /* Scan for allocatable actual arguments passed to allocatable dummy
7325 : arguments with INTENT(OUT). As the corresponding actual arguments are
7326 : deallocated before execution of the procedure, we evaluate actual
7327 : argument expressions to avoid problems with possible dependencies. */
7328 133245 : bool force_eval_args = false;
7329 133245 : gfc_formal_arglist *tmp_formal;
7330 407108 : for (arg = args, tmp_formal = formal; arg != NULL;
7331 240508 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7332 : {
7333 274386 : e = arg->expr;
7334 274386 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7335 260774 : if (e && fsym
7336 228846 : && e->expr_type == EXPR_VARIABLE
7337 100955 : && fsym->attr.intent == INTENT_OUT
7338 6534 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7339 6534 : ? CLASS_DATA (fsym)->attr.allocatable
7340 4886 : : fsym->attr.allocatable)
7341 523 : && e->symtree
7342 523 : && e->symtree->n.sym
7343 535160 : && gfc_variable_attr (e).allocatable)
7344 : {
7345 : force_eval_args = true;
7346 : break;
7347 : }
7348 : }
7349 :
7350 : /* Evaluate the arguments. */
7351 408045 : for (arg = args, argc = 0; arg != NULL;
7352 274800 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7353 : {
7354 274800 : bool finalized = false;
7355 274800 : tree derived_array = NULL_TREE;
7356 274800 : symbol_attribute *attr;
7357 :
7358 274800 : e = arg->expr;
7359 274800 : fsym = formal ? formal->sym : NULL;
7360 516245 : parm_kind = MISSING;
7361 :
7362 241445 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7363 : : fsym->attr)
7364 : : nullptr;
7365 : /* If the procedure requires an explicit interface, the actual
7366 : argument is passed according to the corresponding formal
7367 : argument. If the corresponding formal argument is a POINTER,
7368 : ALLOCATABLE or assumed shape, we do not use g77's calling
7369 : convention, and pass the address of the array descriptor
7370 : instead. Otherwise we use g77's calling convention, in other words
7371 : pass the array data pointer without descriptor. */
7372 241392 : bool nodesc_arg = fsym != NULL
7373 241392 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7374 232254 : && fsym->as
7375 41786 : && fsym->as->type != AS_ASSUMED_SHAPE
7376 25017 : && fsym->as->type != AS_ASSUMED_RANK;
7377 274800 : if (comp)
7378 2761 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7379 : else
7380 272039 : nodesc_arg
7381 : = nodesc_arg
7382 272039 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7383 :
7384 : /* Class array expressions are sometimes coming completely unadorned
7385 : with either arrayspec or _data component. Correct that here.
7386 : OOP-TODO: Move this to the frontend. */
7387 274800 : if (e && e->expr_type == EXPR_VARIABLE
7388 115082 : && !e->ref
7389 52375 : && e->ts.type == BT_CLASS
7390 2681 : && (CLASS_DATA (e)->attr.codimension
7391 2681 : || CLASS_DATA (e)->attr.dimension))
7392 : {
7393 0 : gfc_typespec temp_ts = e->ts;
7394 0 : gfc_add_class_array_ref (e);
7395 0 : e->ts = temp_ts;
7396 : }
7397 :
7398 274800 : if (e == NULL
7399 261182 : || (e->expr_type == EXPR_NULL
7400 763 : && fsym
7401 763 : && fsym->attr.value
7402 72 : && fsym->attr.optional
7403 72 : && !fsym->attr.dimension
7404 72 : && fsym->ts.type != BT_CLASS))
7405 : {
7406 13690 : if (se->ignore_optional)
7407 : {
7408 : /* Some intrinsics have already been resolved to the correct
7409 : parameters. */
7410 434 : continue;
7411 : }
7412 13492 : else if (arg->label)
7413 : {
7414 224 : has_alternate_specifier = 1;
7415 224 : continue;
7416 : }
7417 : else
7418 : {
7419 13268 : gfc_init_se (&parmse, NULL);
7420 :
7421 : /* For scalar arguments with VALUE attribute which are passed by
7422 : value, pass "0" and a hidden argument gives the optional
7423 : status. */
7424 13268 : if (fsym && fsym->attr.optional && fsym->attr.value
7425 475 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7426 : {
7427 439 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7428 : }
7429 : else
7430 : {
7431 : /* Pass a NULL pointer for an absent arg. */
7432 12829 : parmse.expr = null_pointer_node;
7433 :
7434 : /* Is it an absent character dummy? */
7435 12829 : bool absent_char = false;
7436 12829 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7437 :
7438 : /* Fall back to inferred type only if no formal. */
7439 12829 : if (fsym)
7440 11771 : absent_char = (fsym->ts.type == BT_CHARACTER);
7441 1058 : else if (dummy_arg)
7442 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7443 : == BT_CHARACTER);
7444 12829 : if (absent_char)
7445 1133 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7446 : 0);
7447 : }
7448 : }
7449 : }
7450 261110 : else if (e->expr_type == EXPR_NULL
7451 691 : && fsym && attr && (attr->pointer || attr->allocatable)
7452 534 : && ((fsym->ts.type == BT_DERIVED
7453 210 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED))
7454 324 : || (fsym->attr.allocatable && fsym->ts.type != BT_CLASS
7455 18 : && fsym->ts.type != BT_CHARACTER)))
7456 : {
7457 228 : gfc_init_se (&parmse, NULL);
7458 228 : gfc_conv_expr_reference (&parmse, e);
7459 228 : conv_null_actual (&parmse, e, fsym);
7460 : }
7461 260882 : else if (arg->expr->expr_type == EXPR_NULL
7462 463 : && fsym && !fsym->attr.pointer
7463 163 : && (fsym->ts.type != BT_CLASS
7464 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7465 : {
7466 : /* Pass a NULL pointer to denote an absent arg. */
7467 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7468 : && (fsym->ts.type != BT_CLASS
7469 : || !CLASS_DATA (fsym)->attr.allocatable));
7470 163 : gfc_init_se (&parmse, NULL);
7471 163 : parmse.expr = null_pointer_node;
7472 163 : if (fsym->ts.type == BT_CHARACTER)
7473 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7474 : }
7475 260719 : else if (fsym && fsym->ts.type == BT_CLASS
7476 11519 : && e->ts.type == BT_DERIVED)
7477 : {
7478 : /* The derived type needs to be converted to a temporary
7479 : CLASS object. */
7480 4796 : gfc_init_se (&parmse, se);
7481 4796 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7482 4796 : fsym->attr.optional
7483 1008 : && e->expr_type == EXPR_VARIABLE
7484 1008 : && e->symtree->n.sym->attr.optional,
7485 4796 : CLASS_DATA (fsym)->attr.class_pointer
7486 4609 : || CLASS_DATA (fsym)->attr.allocatable,
7487 : sym->name, &derived_array);
7488 : }
7489 223995 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7490 954 : && e->ts.type != BT_PROCEDURE
7491 930 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7492 930 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7493 : {
7494 : /* The intrinsic type needs to be converted to a temporary
7495 : CLASS object for the unlimited polymorphic formal. */
7496 930 : gfc_find_vtab (&e->ts);
7497 930 : gfc_init_se (&parmse, se);
7498 930 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7499 :
7500 : }
7501 254993 : else if (se->ss && se->ss->info->useflags)
7502 : {
7503 5849 : gfc_ss *ss;
7504 :
7505 5849 : ss = se->ss;
7506 :
7507 : /* An elemental function inside a scalarized loop. */
7508 5849 : gfc_init_se (&parmse, se);
7509 5849 : parm_kind = ELEMENTAL;
7510 :
7511 : /* When no fsym is present, ulim_copy is set and this is a third or
7512 : fourth argument, use call-by-value instead of by reference to
7513 : hand the length properties to the copy routine (i.e., most of the
7514 : time this will be a call to a __copy_character_* routine where the
7515 : third and fourth arguments are the lengths of a deferred length
7516 : char array). */
7517 5849 : if ((fsym && fsym->attr.value)
7518 5615 : || (ulim_copy && (argc == 2 || argc == 3)))
7519 234 : gfc_conv_expr (&parmse, e);
7520 5615 : else if (e->expr_type == EXPR_ARRAY)
7521 : {
7522 306 : gfc_conv_expr (&parmse, e);
7523 306 : if (e->ts.type != BT_CHARACTER)
7524 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7525 : }
7526 : else
7527 5309 : gfc_conv_expr_reference (&parmse, e);
7528 :
7529 5849 : if (e->ts.type == BT_CHARACTER && !e->rank
7530 174 : && e->expr_type == EXPR_FUNCTION)
7531 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7532 : parmse.expr);
7533 :
7534 5799 : if (fsym && fsym->ts.type == BT_DERIVED
7535 7477 : && gfc_is_class_container_ref (e))
7536 : {
7537 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7538 :
7539 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7540 24 : && e->symtree->n.sym->attr.optional)
7541 : {
7542 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7543 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7544 0 : TREE_TYPE (parmse.expr),
7545 : cond, parmse.expr,
7546 0 : fold_convert (TREE_TYPE (parmse.expr),
7547 : null_pointer_node));
7548 : }
7549 : }
7550 :
7551 : /* Scalar dummy arguments of intrinsic type or derived type with
7552 : VALUE attribute. */
7553 5849 : if (fsym
7554 5799 : && fsym->attr.value
7555 234 : && fsym->ts.type != BT_CLASS)
7556 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7557 :
7558 : /* If we are passing an absent array as optional dummy to an
7559 : elemental procedure, make sure that we pass NULL when the data
7560 : pointer is NULL. We need this extra conditional because of
7561 : scalarization which passes arrays elements to the procedure,
7562 : ignoring the fact that the array can be absent/unallocated/... */
7563 5615 : else if (ss->info->can_be_null_ref
7564 421 : && ss->info->type != GFC_SS_REFERENCE)
7565 : {
7566 199 : tree descriptor_data;
7567 :
7568 199 : descriptor_data = ss->info->data.array.data;
7569 199 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7570 : descriptor_data,
7571 199 : fold_convert (TREE_TYPE (descriptor_data),
7572 : null_pointer_node));
7573 199 : parmse.expr
7574 398 : = fold_build3_loc (input_location, COND_EXPR,
7575 199 : TREE_TYPE (parmse.expr),
7576 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7577 199 : fold_convert (TREE_TYPE (parmse.expr),
7578 : null_pointer_node),
7579 : parmse.expr);
7580 : }
7581 :
7582 : /* The scalarizer does not repackage the reference to a class
7583 : array - instead it returns a pointer to the data element. */
7584 5849 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7585 210 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7586 186 : fsym->attr.intent != INTENT_IN
7587 : && (CLASS_DATA (fsym)->attr.class_pointer
7588 24 : || CLASS_DATA (fsym)->attr.allocatable),
7589 186 : fsym->attr.optional
7590 0 : && e->expr_type == EXPR_VARIABLE
7591 0 : && e->symtree->n.sym->attr.optional,
7592 186 : CLASS_DATA (fsym)->attr.class_pointer
7593 186 : || CLASS_DATA (fsym)->attr.allocatable);
7594 : }
7595 : else
7596 : {
7597 249144 : bool scalar;
7598 249144 : gfc_ss *argss;
7599 :
7600 249144 : gfc_init_se (&parmse, NULL);
7601 :
7602 : /* Check whether the expression is a scalar or not; we cannot use
7603 : e->rank as it can be nonzero for functions arguments. */
7604 249144 : argss = gfc_walk_expr (e);
7605 249144 : scalar = argss == gfc_ss_terminator;
7606 249144 : if (!scalar)
7607 61602 : gfc_free_ss_chain (argss);
7608 :
7609 : /* Special handling for passing scalar polymorphic coarrays;
7610 : otherwise one passes "class->_data.data" instead of "&class". */
7611 249144 : if (e->rank == 0 && e->ts.type == BT_CLASS
7612 3635 : && fsym && fsym->ts.type == BT_CLASS
7613 3213 : && CLASS_DATA (fsym)->attr.codimension
7614 55 : && !CLASS_DATA (fsym)->attr.dimension)
7615 : {
7616 55 : gfc_add_class_array_ref (e);
7617 55 : parmse.want_coarray = 1;
7618 55 : scalar = false;
7619 : }
7620 :
7621 : /* A scalar or transformational function. */
7622 249144 : if (scalar)
7623 : {
7624 187487 : if (e->expr_type == EXPR_VARIABLE
7625 55786 : && e->symtree->n.sym->attr.cray_pointee
7626 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7627 : {
7628 : /* The Cray pointer needs to be converted to a pointer to
7629 : a type given by the expression. */
7630 6 : gfc_conv_expr (&parmse, e);
7631 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7632 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7633 6 : parmse.expr = convert (type, tmp);
7634 : }
7635 :
7636 187481 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7637 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7638 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7639 :
7640 186794 : else if (fsym && fsym->attr.value && fsym->attr.dimension)
7641 : /* Scalar actual argument sequence associated with a VALUE
7642 : array dummy. */
7643 36 : conv_seq_assoc_value_arg (&parmse, e, fsym, &mapping);
7644 :
7645 158503 : else if (fsym && fsym->attr.value)
7646 : {
7647 22220 : if (fsym->ts.type == BT_CHARACTER
7648 639 : && fsym->ts.is_c_interop
7649 229 : && fsym->ns->proc_name != NULL
7650 229 : && fsym->ns->proc_name->attr.is_bind_c)
7651 : {
7652 220 : parmse.expr = NULL;
7653 220 : conv_scalar_char_value (fsym, &parmse, &e);
7654 220 : if (parmse.expr == NULL)
7655 166 : gfc_conv_expr (&parmse, e);
7656 : }
7657 : else
7658 : {
7659 22000 : gfc_conv_expr (&parmse, e);
7660 22000 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7661 : }
7662 : }
7663 :
7664 164538 : else if (arg->name && arg->name[0] == '%')
7665 : /* Argument list functions %VAL, %LOC and %REF are signalled
7666 : through arg->name. */
7667 5846 : conv_arglist_function (&parmse, arg->expr, arg->name);
7668 158692 : else if ((e->expr_type == EXPR_FUNCTION)
7669 8305 : && ((e->value.function.esym
7670 2154 : && e->value.function.esym->result->attr.pointer)
7671 8210 : || (!e->value.function.esym
7672 6151 : && e->symtree->n.sym->attr.pointer))
7673 95 : && fsym && fsym->attr.target)
7674 : /* Make sure the function only gets called once. */
7675 8 : gfc_conv_expr_reference (&parmse, e);
7676 158684 : else if (e->expr_type == EXPR_FUNCTION
7677 8297 : && e->symtree->n.sym->result
7678 7262 : && e->symtree->n.sym->result != e->symtree->n.sym
7679 138 : && e->symtree->n.sym->result->attr.proc_pointer)
7680 : {
7681 : /* Functions returning procedure pointers. */
7682 18 : gfc_conv_expr (&parmse, e);
7683 18 : if (fsym && fsym->attr.proc_pointer)
7684 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7685 : }
7686 :
7687 : else
7688 : {
7689 158666 : bool defer_to_dealloc_blk = false;
7690 158666 : if (e->ts.type == BT_CLASS && fsym
7691 3568 : && fsym->ts.type == BT_CLASS
7692 3146 : && (!CLASS_DATA (fsym)->as
7693 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7694 2790 : && CLASS_DATA (e)->attr.codimension)
7695 : {
7696 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7697 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7698 48 : gfc_add_class_array_ref (e);
7699 48 : parmse.want_coarray = 1;
7700 48 : gfc_conv_expr_reference (&parmse, e);
7701 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7702 48 : fsym->attr.optional
7703 48 : && e->expr_type == EXPR_VARIABLE);
7704 : }
7705 158618 : else if (e->ts.type == BT_CLASS && fsym
7706 3520 : && fsym->ts.type == BT_CLASS
7707 3098 : && !CLASS_DATA (fsym)->as
7708 2742 : && !CLASS_DATA (e)->as
7709 2632 : && strcmp (fsym->ts.u.derived->name,
7710 : e->ts.u.derived->name))
7711 : {
7712 1649 : type = gfc_typenode_for_spec (&fsym->ts);
7713 1649 : var = gfc_create_var (type, fsym->name);
7714 1649 : gfc_conv_expr (&parmse, e);
7715 1649 : if (fsym->attr.optional
7716 153 : && e->expr_type == EXPR_VARIABLE
7717 153 : && e->symtree->n.sym->attr.optional)
7718 : {
7719 66 : stmtblock_t block;
7720 66 : tree cond;
7721 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7722 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7723 : logical_type_node, tmp,
7724 66 : fold_convert (TREE_TYPE (tmp),
7725 : null_pointer_node));
7726 66 : gfc_start_block (&block);
7727 66 : gfc_add_modify (&block, var,
7728 : fold_build1_loc (input_location,
7729 : VIEW_CONVERT_EXPR,
7730 : type, parmse.expr));
7731 66 : gfc_add_expr_to_block (&parmse.pre,
7732 : fold_build3_loc (input_location,
7733 : COND_EXPR, void_type_node,
7734 : cond, gfc_finish_block (&block),
7735 : build_empty_stmt (input_location)));
7736 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7737 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7738 66 : TREE_TYPE (parmse.expr),
7739 : cond, parmse.expr,
7740 66 : fold_convert (TREE_TYPE (parmse.expr),
7741 : null_pointer_node));
7742 66 : }
7743 : else
7744 : {
7745 : /* Since the internal representation of unlimited
7746 : polymorphic expressions includes an extra field
7747 : that other class objects do not, a cast to the
7748 : formal type does not work. */
7749 1583 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7750 : {
7751 91 : tree efield;
7752 :
7753 : /* Evaluate arguments just once, when they have
7754 : side effects. */
7755 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7756 : {
7757 25 : tree cldata, zero;
7758 :
7759 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7760 : &parmse.pre);
7761 :
7762 : /* Prevent memory leak, when old component
7763 : was allocated already. */
7764 25 : cldata = gfc_class_data_get (parmse.expr);
7765 25 : zero = build_int_cst (TREE_TYPE (cldata),
7766 : 0);
7767 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7768 : logical_type_node,
7769 : cldata, zero);
7770 25 : tmp = build3_v (COND_EXPR, tmp,
7771 : gfc_call_free (cldata),
7772 : build_empty_stmt (
7773 : input_location));
7774 25 : gfc_add_expr_to_block (&parmse.finalblock,
7775 : tmp);
7776 25 : gfc_add_modify (&parmse.finalblock,
7777 : cldata, zero);
7778 : }
7779 :
7780 : /* Set the _data field. */
7781 91 : tmp = gfc_class_data_get (var);
7782 91 : efield = fold_convert (TREE_TYPE (tmp),
7783 : gfc_class_data_get (parmse.expr));
7784 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7785 :
7786 : /* Set the _vptr field. */
7787 91 : tmp = gfc_class_vptr_get (var);
7788 91 : efield = fold_convert (TREE_TYPE (tmp),
7789 : gfc_class_vptr_get (parmse.expr));
7790 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7791 :
7792 : /* Set the _len field. */
7793 91 : tmp = gfc_class_len_get (var);
7794 91 : gfc_add_modify (&parmse.pre, tmp,
7795 91 : build_int_cst (TREE_TYPE (tmp), 0));
7796 91 : }
7797 : else
7798 : {
7799 1492 : tmp = fold_build1_loc (input_location,
7800 : VIEW_CONVERT_EXPR,
7801 : type, parmse.expr);
7802 1492 : gfc_add_modify (&parmse.pre, var, tmp);
7803 1583 : ;
7804 : }
7805 1583 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7806 : }
7807 : }
7808 : else
7809 : {
7810 156969 : gfc_conv_expr_reference (&parmse, e);
7811 :
7812 156969 : gfc_symbol *dsym = fsym;
7813 156969 : gfc_dummy_arg *dummy;
7814 :
7815 : /* Use associated dummy as fallback for formal
7816 : argument if there is no explicit interface. */
7817 156969 : if (dsym == NULL
7818 27443 : && (dummy = arg->associated_dummy)
7819 24901 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7820 180463 : && dummy->u.non_intrinsic->sym)
7821 156969 : dsym = dummy->u.non_intrinsic->sym;
7822 :
7823 156969 : if (dsym
7824 153020 : && dsym->attr.intent == INTENT_OUT
7825 3327 : && !dsym->attr.allocatable
7826 3184 : && !dsym->attr.pointer
7827 3166 : && e->expr_type == EXPR_VARIABLE
7828 3165 : && e->ref == NULL
7829 3050 : && e->symtree
7830 3050 : && e->symtree->n.sym
7831 3050 : && !e->symtree->n.sym->attr.dimension
7832 3050 : && e->ts.type != BT_CHARACTER
7833 2948 : && e->ts.type != BT_CLASS
7834 2712 : && (e->ts.type != BT_DERIVED
7835 516 : || (dsym->ts.type == BT_DERIVED
7836 516 : && e->ts.u.derived == dsym->ts.u.derived
7837 : /* Types with allocatable components are
7838 : excluded from clobbering because we need
7839 : the unclobbered pointers to free the
7840 : allocatable components in the callee.
7841 : Same goes for finalizable types or types
7842 : with finalizable components, we need to
7843 : pass the unclobbered values to the
7844 : finalization routines.
7845 : For parameterized types, it's less clear
7846 : but they may not have a constant size
7847 : so better exclude them in any case. */
7848 501 : && !e->ts.u.derived->attr.alloc_comp
7849 375 : && !e->ts.u.derived->attr.pdt_type
7850 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7851 2505 : && e->ts.type != BT_PROCEDURE
7852 159438 : && !sym->attr.elemental)
7853 : {
7854 1136 : tree var;
7855 1136 : var = build_fold_indirect_ref_loc (input_location,
7856 : parmse.expr);
7857 1136 : tree clobber = build_clobber (TREE_TYPE (var));
7858 1136 : gfc_add_modify (&clobbers, var, clobber);
7859 : }
7860 : }
7861 : /* Catch base objects that are not variables. */
7862 158666 : if (e->ts.type == BT_CLASS
7863 3568 : && e->expr_type != EXPR_VARIABLE
7864 306 : && expr && e == expr->base_expr)
7865 80 : base_object = build_fold_indirect_ref_loc (input_location,
7866 : parmse.expr);
7867 :
7868 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7869 : allocated on entry, it must be deallocated. */
7870 131223 : if (fsym && fsym->attr.intent == INTENT_OUT
7871 3256 : && (fsym->attr.allocatable
7872 3113 : || (fsym->ts.type == BT_CLASS
7873 265 : && CLASS_DATA (fsym)->attr.allocatable))
7874 158964 : && !is_CFI_desc (fsym, NULL))
7875 : {
7876 298 : stmtblock_t block;
7877 298 : tree ptr;
7878 :
7879 298 : defer_to_dealloc_blk = true;
7880 :
7881 298 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7882 : &parmse.pre);
7883 :
7884 298 : if (parmse.class_container != NULL_TREE)
7885 162 : parmse.class_container
7886 162 : = gfc_evaluate_data_ref_now (parmse.class_container,
7887 : &parmse.pre);
7888 :
7889 298 : gfc_init_block (&block);
7890 298 : ptr = parmse.expr;
7891 298 : if (e->ts.type == BT_CLASS)
7892 162 : ptr = gfc_class_data_get (ptr);
7893 :
7894 298 : tree cls = parmse.class_container;
7895 298 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7896 : NULL_TREE, true,
7897 : e, e->ts, cls);
7898 298 : gfc_add_expr_to_block (&block, tmp);
7899 298 : gfc_add_modify (&block, ptr,
7900 298 : fold_convert (TREE_TYPE (ptr),
7901 : null_pointer_node));
7902 :
7903 298 : if (fsym->ts.type == BT_CLASS)
7904 155 : gfc_reset_vptr (&block, nullptr,
7905 : build_fold_indirect_ref (parmse.expr),
7906 155 : fsym->ts.u.derived);
7907 :
7908 298 : if (fsym->attr.optional
7909 42 : && e->expr_type == EXPR_VARIABLE
7910 42 : && e->symtree->n.sym->attr.optional)
7911 : {
7912 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7913 : void_type_node,
7914 18 : gfc_conv_expr_present (e->symtree->n.sym),
7915 : gfc_finish_block (&block),
7916 : build_empty_stmt (input_location));
7917 : }
7918 : else
7919 280 : tmp = gfc_finish_block (&block);
7920 :
7921 298 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7922 : }
7923 :
7924 : /* A class array element needs converting back to be a
7925 : class object, if the formal argument is a class object. */
7926 158666 : if (fsym && fsym->ts.type == BT_CLASS
7927 3170 : && e->ts.type == BT_CLASS
7928 3146 : && ((CLASS_DATA (fsym)->as
7929 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7930 2790 : || CLASS_DATA (e)->attr.dimension))
7931 : {
7932 466 : gfc_se class_se = parmse;
7933 466 : gfc_init_block (&class_se.pre);
7934 466 : gfc_init_block (&class_se.post);
7935 :
7936 733 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7937 466 : fsym->attr.intent != INTENT_IN
7938 : && (CLASS_DATA (fsym)->attr.class_pointer
7939 267 : || CLASS_DATA (fsym)->attr.allocatable),
7940 466 : fsym->attr.optional
7941 198 : && e->expr_type == EXPR_VARIABLE
7942 198 : && e->symtree->n.sym->attr.optional,
7943 466 : CLASS_DATA (fsym)->attr.class_pointer
7944 430 : || CLASS_DATA (fsym)->attr.allocatable);
7945 :
7946 466 : parmse.expr = class_se.expr;
7947 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7948 466 : ? &dealloc_blk
7949 : : &parmse.pre;
7950 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7951 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7952 : }
7953 :
7954 131223 : if (fsym && (fsym->ts.type == BT_DERIVED
7955 119205 : || fsym->ts.type == BT_ASSUMED)
7956 12885 : && e->ts.type == BT_CLASS
7957 410 : && !CLASS_DATA (e)->attr.dimension
7958 374 : && !CLASS_DATA (e)->attr.codimension)
7959 : {
7960 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7961 : /* The result is a class temporary, whose _data component
7962 : must be freed to avoid a memory leak. */
7963 374 : if (e->expr_type == EXPR_FUNCTION
7964 23 : && CLASS_DATA (e)->attr.allocatable)
7965 : {
7966 19 : tree zero;
7967 :
7968 : /* Finalize the expression. */
7969 19 : gfc_finalize_tree_expr (&parmse, NULL,
7970 19 : gfc_expr_attr (e), e->rank);
7971 19 : gfc_add_block_to_block (&parmse.post,
7972 : &parmse.finalblock);
7973 :
7974 : /* Then free the class _data. */
7975 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7976 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7977 : logical_type_node,
7978 : parmse.expr, zero);
7979 19 : tmp = build3_v (COND_EXPR, tmp,
7980 : gfc_call_free (parmse.expr),
7981 : build_empty_stmt (input_location));
7982 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7983 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7984 : }
7985 : }
7986 :
7987 : /* Wrap scalar variable in a descriptor. We need to convert
7988 : the address of a pointer back to the pointer itself before,
7989 : we can assign it to the data field. */
7990 :
7991 131223 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7992 1344 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7993 : {
7994 1272 : tmp = parmse.expr;
7995 1272 : if (TREE_CODE (tmp) == ADDR_EXPR)
7996 754 : tmp = TREE_OPERAND (tmp, 0);
7997 1272 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7998 : fsym->attr);
7999 1272 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
8000 : parmse.expr);
8001 : }
8002 129951 : else if (fsym && e->expr_type != EXPR_NULL
8003 129653 : && ((fsym->attr.pointer
8004 1740 : && fsym->attr.flavor != FL_PROCEDURE)
8005 127919 : || (fsym->attr.proc_pointer
8006 199 : && !(e->expr_type == EXPR_VARIABLE
8007 199 : && e->symtree->n.sym->attr.dummy))
8008 127732 : || (fsym->attr.proc_pointer
8009 12 : && e->expr_type == EXPR_VARIABLE
8010 12 : && gfc_is_proc_ptr_comp (e))
8011 127726 : || (fsym->attr.allocatable
8012 1041 : && fsym->attr.flavor != FL_PROCEDURE)))
8013 : {
8014 : /* Scalar pointer dummy args require an extra level of
8015 : indirection. The null pointer already contains
8016 : this level of indirection. */
8017 2962 : parm_kind = SCALAR_POINTER;
8018 2962 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
8019 : }
8020 : }
8021 : }
8022 61657 : else if (e->ts.type == BT_CLASS
8023 2843 : && fsym && fsym->ts.type == BT_CLASS
8024 2425 : && (CLASS_DATA (fsym)->attr.dimension
8025 55 : || CLASS_DATA (fsym)->attr.codimension))
8026 : {
8027 : /* Pass a class array. */
8028 2425 : gfc_conv_expr_descriptor (&parmse, e);
8029 2425 : bool defer_to_dealloc_blk = false;
8030 :
8031 2425 : if (fsym->attr.optional
8032 798 : && e->expr_type == EXPR_VARIABLE
8033 798 : && e->symtree->n.sym->attr.optional)
8034 : {
8035 438 : stmtblock_t block;
8036 :
8037 438 : gfc_init_block (&block);
8038 438 : gfc_add_block_to_block (&block, &parmse.pre);
8039 :
8040 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
8041 : void_type_node,
8042 438 : gfc_conv_expr_present (e->symtree->n.sym),
8043 : gfc_finish_block (&block),
8044 : build_empty_stmt (input_location));
8045 :
8046 438 : gfc_add_expr_to_block (&parmse.pre, t);
8047 : }
8048 :
8049 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8050 : allocated on entry, it must be deallocated. */
8051 2425 : if (fsym->attr.intent == INTENT_OUT
8052 153 : && CLASS_DATA (fsym)->attr.allocatable)
8053 : {
8054 122 : stmtblock_t block;
8055 122 : tree ptr;
8056 :
8057 : /* In case the data reference to deallocate is dependent on
8058 : its own content, save the resulting pointer to a variable
8059 : and only use that variable from now on, before the
8060 : expression becomes invalid. */
8061 122 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
8062 : &parmse.pre);
8063 :
8064 122 : if (parmse.class_container != NULL_TREE)
8065 122 : parmse.class_container
8066 122 : = gfc_evaluate_data_ref_now (parmse.class_container,
8067 : &parmse.pre);
8068 :
8069 122 : gfc_init_block (&block);
8070 122 : ptr = parmse.expr;
8071 122 : ptr = gfc_class_data_get (ptr);
8072 :
8073 122 : tree cls = parmse.class_container;
8074 122 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
8075 : NULL_TREE, NULL_TREE,
8076 : NULL_TREE, true, e,
8077 : GFC_CAF_COARRAY_NOCOARRAY,
8078 : cls);
8079 122 : gfc_add_expr_to_block (&block, tmp);
8080 122 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8081 : void_type_node, ptr,
8082 : null_pointer_node);
8083 122 : gfc_add_expr_to_block (&block, tmp);
8084 122 : gfc_reset_vptr (&block, e, parmse.class_container);
8085 :
8086 122 : if (fsym->attr.optional
8087 30 : && e->expr_type == EXPR_VARIABLE
8088 30 : && (!e->ref
8089 30 : || (e->ref->type == REF_ARRAY
8090 0 : && e->ref->u.ar.type != AR_FULL))
8091 0 : && e->symtree->n.sym->attr.optional)
8092 : {
8093 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
8094 : void_type_node,
8095 0 : gfc_conv_expr_present (e->symtree->n.sym),
8096 : gfc_finish_block (&block),
8097 : build_empty_stmt (input_location));
8098 : }
8099 : else
8100 122 : tmp = gfc_finish_block (&block);
8101 :
8102 122 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8103 122 : defer_to_dealloc_blk = true;
8104 : }
8105 :
8106 2425 : gfc_se class_se = parmse;
8107 2425 : gfc_init_block (&class_se.pre);
8108 2425 : gfc_init_block (&class_se.post);
8109 :
8110 2425 : if (e->expr_type != EXPR_VARIABLE)
8111 : {
8112 : int n;
8113 : /* Set the bounds and offset correctly. */
8114 60 : for (n = 0; n < e->rank; n++)
8115 30 : gfc_conv_shift_descriptor_lbound (&class_se.pre,
8116 : class_se.expr,
8117 : n, gfc_index_one_node);
8118 : }
8119 :
8120 : /* The conversion does not repackage the reference to a class
8121 : array - _data descriptor. */
8122 3852 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
8123 2425 : fsym->attr.intent != INTENT_IN
8124 : && (CLASS_DATA (fsym)->attr.class_pointer
8125 1241 : || CLASS_DATA (fsym)->attr.allocatable),
8126 2425 : fsym->attr.optional
8127 798 : && e->expr_type == EXPR_VARIABLE
8128 798 : && e->symtree->n.sym->attr.optional,
8129 2425 : CLASS_DATA (fsym)->attr.class_pointer
8130 1999 : || CLASS_DATA (fsym)->attr.allocatable);
8131 :
8132 2425 : parmse.expr = class_se.expr;
8133 2303 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
8134 2425 : ? &dealloc_blk
8135 : : &parmse.pre;
8136 2425 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
8137 2425 : gfc_add_block_to_block (&parmse.post, &class_se.post);
8138 :
8139 2425 : if (e->expr_type == EXPR_OP
8140 12 : && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
8141 2437 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
8142 : {
8143 12 : tree cond;
8144 12 : tree dealloc_expr = gfc_finish_block (&parmse.post);
8145 12 : tmp = TREE_OPERAND (parmse.expr, 0);
8146 12 : gfc_init_block (&parmse.post);
8147 12 : cond = gfc_class_data_get (tmp);
8148 12 : tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
8149 : tmp, e->rank, true);
8150 12 : gfc_add_expr_to_block (&parmse.post, tmp);
8151 12 : cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
8152 12 : cond = gfc_conv_descriptor_data_get (cond);
8153 12 : cond = fold_build2_loc (input_location, NE_EXPR,
8154 : logical_type_node, cond,
8155 12 : build_int_cst (TREE_TYPE (cond), 0));
8156 12 : tmp = build3_v (COND_EXPR, cond, dealloc_expr,
8157 : build_empty_stmt (input_location));
8158 :
8159 : /* This specific case should not be processed further and so
8160 : bundle everything up and proceed to the next argument. */
8161 12 : if (fsym && need_interface_mapping && e)
8162 12 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8163 12 : gfc_add_expr_to_block (&parmse.post, tmp);
8164 12 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8165 12 : gfc_add_block_to_block (&post, &parmse.post);
8166 12 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8167 12 : vec_safe_push (arglist, parmse.expr);
8168 12 : continue;
8169 12 : }
8170 2413 : }
8171 : else
8172 : {
8173 : /* If the argument is a function call that may not create
8174 : a temporary for the result, we have to check that we
8175 : can do it, i.e. that there is no alias between this
8176 : argument and another one. */
8177 59232 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
8178 : {
8179 406 : gfc_expr *iarg;
8180 406 : sym_intent intent;
8181 :
8182 406 : if (fsym != NULL)
8183 397 : intent = fsym->attr.intent;
8184 : else
8185 : intent = INTENT_UNKNOWN;
8186 :
8187 406 : if (gfc_check_fncall_dependency (e, intent, sym, args,
8188 : NOT_ELEMENTAL))
8189 21 : parmse.force_tmp = 1;
8190 :
8191 406 : iarg = e->value.function.actual->expr;
8192 :
8193 : /* Temporary needed if aliasing due to host association. */
8194 406 : if (sym->attr.contained
8195 168 : && !sym->attr.pure
8196 168 : && !sym->attr.implicit_pure
8197 84 : && !sym->attr.use_assoc
8198 84 : && iarg->expr_type == EXPR_VARIABLE
8199 84 : && sym->ns == iarg->symtree->n.sym->ns)
8200 36 : parmse.force_tmp = 1;
8201 :
8202 : /* Ditto within module. */
8203 406 : if (sym->attr.use_assoc
8204 6 : && !sym->attr.pure
8205 6 : && !sym->attr.implicit_pure
8206 0 : && iarg->expr_type == EXPR_VARIABLE
8207 0 : && sym->module == iarg->symtree->n.sym->module)
8208 0 : parmse.force_tmp = 1;
8209 : }
8210 :
8211 : /* Special case for assumed-rank arrays: when passing an
8212 : argument to a nonallocatable/nonpointer dummy, the bounds have
8213 : to be reset as otherwise a last-dim ubound of -1 is
8214 : indistinguishable from an assumed-size array in the callee. */
8215 59232 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
8216 36117 : && fsym->as->type == AS_ASSUMED_RANK
8217 12013 : && e->rank != -1
8218 11692 : && e->expr_type == EXPR_VARIABLE
8219 11227 : && ((fsym->ts.type == BT_CLASS
8220 0 : && !CLASS_DATA (fsym)->attr.class_pointer
8221 0 : && !CLASS_DATA (fsym)->attr.allocatable)
8222 11227 : || (fsym->ts.type != BT_CLASS
8223 11227 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
8224 : {
8225 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
8226 10684 : gfc_ref *ref;
8227 10948 : for (ref = e->ref; ref->next; ref = ref->next)
8228 : {
8229 342 : if (ref->next->type == REF_INQUIRY)
8230 : break;
8231 294 : if (ref->type == REF_ARRAY
8232 30 : && ref->u.ar.type != AR_ELEMENT)
8233 : break;
8234 10684 : };
8235 10684 : if (ref->u.ar.type == AR_FULL
8236 9934 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
8237 9814 : ref->u.ar.type = AR_SECTION;
8238 : }
8239 :
8240 59232 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
8241 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
8242 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
8243 :
8244 53382 : else if (fsym && fsym->attr.value && fsym->attr.dimension
8245 102 : && e->rank != -1)
8246 : /* VALUE array dummy: pass a private copy of the actual
8247 : argument. Allocatable components are copied deeply, so
8248 : that the callee cannot reach the actual argument's data.
8249 : The symbol passed is that of the actual argument, so that
8250 : the copy is suppressed and a null pointer passed when an
8251 : optional actual argument is absent. */
8252 102 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, INTENT_IN,
8253 : false, fsym, sym->name,
8254 102 : e->expr_type == EXPR_VARIABLE
8255 102 : ? e->symtree->n.sym : NULL,
8256 : false, true);
8257 :
8258 53280 : else if (pointer_array_result_p (e)
8259 157 : && !(fsym && fsym->attr.pointer)
8260 53431 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8261 : /* A pointer function result is copied into a temporary when
8262 : its elements are not spaced by the element size. */
8263 : {
8264 145 : gfc_expr *var = pointer_result_var (&parmse.pre, e);
8265 283 : gfc_conv_subref_array_arg (&parmse, var, nodesc_arg,
8266 138 : fsym ? fsym->attr.intent : INTENT_INOUT,
8267 : false, fsym, sym->name, NULL, true, false,
8268 : dummy_accepts_strided_arg (fsym, nodesc_arg));
8269 145 : gfc_symtree *st = var->symtree;
8270 145 : gfc_free_expr (var);
8271 145 : gfc_free_symbol (st->n.sym);
8272 145 : XDELETE (st);
8273 : }
8274 :
8275 53135 : else if (e->expr_type == EXPR_VARIABLE
8276 41546 : && is_subref_array (e)
8277 1253 : && !(fsym && fsym->attr.pointer)
8278 54102 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8279 : /* The actual argument is a component reference to an
8280 : array of derived types. In this case, the argument
8281 : is converted to a temporary, which is passed and then
8282 : written back after the procedure call. The elements of
8283 : a span addressed dummy passed on as a whole are usually
8284 : contiguous, so the copy is made conditional. A dummy that
8285 : has a descriptor takes any stride, so for it the condition
8286 : is only that the span be the element length. */
8287 : {
8288 799 : bool whole_span = is_whole_span_addressed_dummy (e);
8289 1568 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8290 757 : fsym ? fsym->attr.intent : INTENT_INOUT,
8291 757 : fsym && fsym->attr.pointer, fsym, sym->name,
8292 : NULL, whole_span, false,
8293 : whole_span
8294 12 : && dummy_accepts_strided_arg (fsym,
8295 : nodesc_arg));
8296 : }
8297 :
8298 52336 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
8299 417 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
8300 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
8301 : /* An assumed size class actual argument being passed to
8302 : a 'no descriptor' formal argument just requires the
8303 : data pointer to be passed. For class dummy arguments
8304 : this is stored in the symbol backend decl.. */
8305 6 : parmse.expr = e->symtree->n.sym->backend_decl;
8306 :
8307 52330 : else if (gfc_is_class_array_ref (e, NULL)
8308 410 : && fsym && fsym->ts.type == BT_DERIVED
8309 52516 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8310 : /* The actual argument is a component reference to an
8311 : array of derived types. In this case, the argument
8312 : is converted to a temporary, which is passed and then
8313 : written back after the procedure call. */
8314 114 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8315 114 : fsym->attr.intent,
8316 114 : fsym->attr.pointer);
8317 :
8318 52216 : else if (gfc_is_class_array_function (e)
8319 13 : && fsym && fsym->ts.type == BT_DERIVED
8320 52229 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8321 : /* See previous comment. For function actual argument,
8322 : the write out is not needed so the intent is set as
8323 : intent in. */
8324 : {
8325 13 : e->must_finalize = 1;
8326 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8327 13 : INTENT_IN, fsym->attr.pointer);
8328 : }
8329 48629 : else if (fsym && fsym->attr.contiguous
8330 90 : && (fsym->attr.target
8331 1751 : ? gfc_is_not_contiguous (e)
8332 1661 : : !gfc_is_simply_contiguous (e, false, true))
8333 351 : && gfc_expr_is_variable (e)
8334 54293 : && e->rank != -1)
8335 : {
8336 327 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8337 327 : fsym->attr.intent,
8338 327 : fsym->attr.pointer);
8339 : }
8340 : else
8341 : {
8342 : /* Having declined copy-in/copy-out above, a subobject of an
8343 : array is described by a spanned descriptor. */
8344 51876 : if (e->expr_type == EXPR_VARIABLE && is_subref_array (e))
8345 454 : parmse.force_no_tmp = 1;
8346 :
8347 : /* This is where we introduce a temporary to store the
8348 : result of a non-lvalue array expression. */
8349 51876 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
8350 : sym->name, NULL);
8351 : }
8352 :
8353 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8354 : allocated on entry, it must be deallocated.
8355 : CFI descriptors are handled elsewhere. */
8356 55609 : if (fsym && fsym->attr.allocatable
8357 1787 : && fsym->attr.intent == INTENT_OUT
8358 58981 : && !is_CFI_desc (fsym, NULL))
8359 : {
8360 161 : if (fsym->ts.type == BT_DERIVED
8361 47 : && fsym->ts.u.derived->attr.alloc_comp)
8362 : {
8363 : // deallocate the components first
8364 11 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
8365 : parmse.expr, e->rank);
8366 : /* But check whether dummy argument is optional. */
8367 11 : if (tmp != NULL_TREE
8368 11 : && fsym->attr.optional
8369 6 : && e->expr_type == EXPR_VARIABLE
8370 6 : && e->symtree->n.sym->attr.optional)
8371 : {
8372 6 : tree present;
8373 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
8374 6 : tmp = build3_v (COND_EXPR, present, tmp,
8375 : build_empty_stmt (input_location));
8376 : }
8377 11 : if (tmp != NULL_TREE)
8378 11 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8379 : }
8380 :
8381 161 : tmp = parmse.expr;
8382 : /* With bind(C), the actual argument is replaced by a bind-C
8383 : descriptor; in this case, the data component arrives here,
8384 : which shall not be dereferenced, but still freed and
8385 : nullified. */
8386 161 : if (TREE_TYPE(tmp) != pvoid_type_node)
8387 161 : tmp = build_fold_indirect_ref_loc (input_location,
8388 : parmse.expr);
8389 161 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8390 : NULL_TREE, NULL_TREE, true,
8391 : e,
8392 : GFC_CAF_COARRAY_NOCOARRAY);
8393 161 : if (fsym->attr.optional
8394 48 : && e->expr_type == EXPR_VARIABLE
8395 48 : && e->symtree->n.sym->attr.optional)
8396 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
8397 : void_type_node,
8398 24 : gfc_conv_expr_present (e->symtree->n.sym),
8399 : tmp, build_empty_stmt (input_location));
8400 161 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8401 : }
8402 : }
8403 : }
8404 : /* Special case for an assumed-rank dummy argument. */
8405 274366 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
8406 58000 : && (fsym->ts.type == BT_CLASS
8407 58000 : ? (CLASS_DATA (fsym)->as
8408 4702 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
8409 53298 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8410 : {
8411 12843 : if (fsym->ts.type == BT_CLASS
8412 12843 : ? (CLASS_DATA (fsym)->attr.class_pointer
8413 1067 : || CLASS_DATA (fsym)->attr.allocatable)
8414 11776 : : (fsym->attr.pointer || fsym->attr.allocatable))
8415 : {
8416 : /* Unallocated allocatable arrays and unassociated pointer
8417 : arrays need their dtype setting if they are argument
8418 : associated with assumed rank dummies to set the rank. */
8419 891 : set_dtype_for_unallocated (&parmse, e);
8420 : }
8421 11952 : else if (e->expr_type == EXPR_VARIABLE
8422 11449 : && e->symtree->n.sym->attr.dummy
8423 722 : && (e->ts.type == BT_CLASS
8424 915 : ? (e->ref && e->ref->next
8425 193 : && e->ref->next->type == REF_ARRAY
8426 193 : && e->ref->next->u.ar.type == AR_FULL
8427 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8428 529 : : (e->ref && e->ref->type == REF_ARRAY
8429 529 : && e->ref->u.ar.type == AR_FULL
8430 757 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8431 : {
8432 : /* Assumed-size actual to assumed-rank dummy requires
8433 : dim[rank-1].ubound = -1. */
8434 180 : tree minus_one;
8435 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8436 180 : if (fsym->ts.type == BT_CLASS)
8437 60 : tmp = gfc_class_data_get (tmp);
8438 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8439 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8440 180 : gfc_rank_cst[e->rank - 1],
8441 : minus_one);
8442 : }
8443 : }
8444 :
8445 : /* The case with fsym->attr.optional is that of a user subroutine
8446 : with an interface indicating an optional argument. When we call
8447 : an intrinsic subroutine, however, fsym is NULL, but we might still
8448 : have an optional argument, so we proceed to the substitution
8449 : just in case. Arguments passed to bind(c) procedures via CFI
8450 : descriptors are handled elsewhere. */
8451 261170 : if (e && (fsym == NULL || fsym->attr.optional)
8452 335053 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8453 : {
8454 : /* If an optional argument is itself an optional dummy argument,
8455 : check its presence and substitute a null if absent. This is
8456 : only needed when passing an array to an elemental procedure
8457 : as then array elements are accessed - or no NULL pointer is
8458 : allowed and a "1" or "0" should be passed if not present.
8459 : When passing a non-array-descriptor full array to a
8460 : non-array-descriptor dummy, no check is needed. For
8461 : array-descriptor actual to array-descriptor dummy, see
8462 : PR 41911 for why a check has to be inserted.
8463 : fsym == NULL is checked as intrinsics required the descriptor
8464 : but do not always set fsym.
8465 : Also, it is necessary to pass a NULL pointer to library routines
8466 : which usually ignore optional arguments, so they can handle
8467 : these themselves. */
8468 59593 : if (e->expr_type == EXPR_VARIABLE
8469 26618 : && e->symtree->n.sym->attr.optional
8470 2469 : && (((e->rank != 0 && elemental_proc)
8471 2288 : || e->representation.length || e->ts.type == BT_CHARACTER
8472 2044 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8473 1934 : || (e->rank != 0
8474 1094 : && (fsym == NULL
8475 1058 : || (fsym->as
8476 296 : && (fsym->as->type == AS_ASSUMED_SHAPE
8477 241 : || fsym->as->type == AS_ASSUMED_RANK
8478 123 : || fsym->as->type == AS_DEFERRED)))))
8479 1691 : || se->ignore_optional))
8480 806 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8481 806 : e->representation.length);
8482 : }
8483 :
8484 : /* Make the class container for the first argument available with class
8485 : valued transformational functions. */
8486 274366 : if (argc == 0 && e && e->ts.type == BT_CLASS
8487 5165 : && isym && isym->transformational
8488 84 : && se->ss && se->ss->info)
8489 : {
8490 84 : arg1_cntnr = parmse.expr;
8491 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8492 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8493 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8494 84 : se->ss->info->class_container = arg1_cntnr;
8495 : }
8496 :
8497 : /* Obtain the character length of an assumed character length procedure
8498 : from the typespec of the actual argument. */
8499 274366 : if (e
8500 261170 : && parmse.string_length == NULL_TREE
8501 225350 : && e->ts.type == BT_PROCEDURE
8502 1941 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8503 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8504 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8505 : {
8506 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8507 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8508 : }
8509 :
8510 274366 : if (fsym && e)
8511 : {
8512 : /* Obtain the character length for a NULL() actual with a character
8513 : MOLD argument. Otherwise substitute a suitable dummy length.
8514 : Here we handle non-optional dummies of non-bind(c) procedures. */
8515 229242 : if (e->expr_type == EXPR_NULL
8516 763 : && fsym->ts.type == BT_CHARACTER
8517 296 : && !fsym->attr.optional
8518 229460 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8519 216 : conv_null_actual (&parmse, e, fsym);
8520 : }
8521 :
8522 : /* If any actual argument of the procedure is allocatable and passed
8523 : to an allocatable dummy with INTENT(OUT), we conservatively
8524 : evaluate actual argument expressions before deallocations are
8525 : performed and the procedure is executed. May create temporaries.
8526 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8527 261170 : if (e && fsym && force_eval_args
8528 1144 : && fsym->attr.intent != INTENT_OUT
8529 274793 : && !gfc_is_constant_expr (e))
8530 274 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8531 :
8532 274366 : if (fsym && need_interface_mapping && e)
8533 40744 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8534 :
8535 274366 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8536 274366 : gfc_add_block_to_block (&post, &parmse.post);
8537 274366 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8538 :
8539 : /* Allocated allocatable components of derived types must be
8540 : deallocated for non-variable scalars, array arguments to elemental
8541 : procedures, and array arguments with descriptor to non-elemental
8542 : procedures. As bounds information for descriptorless arrays is no
8543 : longer available here, they are dealt with in trans-array.cc
8544 : (gfc_conv_array_parameter). */
8545 261170 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8546 29004 : && e->ts.u.derived->attr.alloc_comp
8547 7708 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8548 281930 : && !expr_may_alias_variables (e, elemental_proc))
8549 : {
8550 372 : int parm_rank;
8551 : /* It is known the e returns a structure type with at least one
8552 : allocatable component. When e is a function, ensure that the
8553 : function is called once only by using a temporary variable. */
8554 372 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8555 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8556 : parmse.expr, &se->pre);
8557 :
8558 372 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8559 152 : tmp = parmse.expr;
8560 : else
8561 220 : tmp = build_fold_indirect_ref_loc (input_location,
8562 : parmse.expr);
8563 :
8564 372 : parm_rank = e->rank;
8565 372 : switch (parm_kind)
8566 : {
8567 : case (ELEMENTAL):
8568 : case (SCALAR):
8569 372 : parm_rank = 0;
8570 : break;
8571 :
8572 0 : case (SCALAR_POINTER):
8573 0 : tmp = build_fold_indirect_ref_loc (input_location,
8574 : tmp);
8575 0 : break;
8576 : }
8577 :
8578 372 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8579 : {
8580 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8581 : Therefore, class actuals can be handled correctly but derived
8582 : types passed to class formals need the _data component. */
8583 82 : tmp = gfc_class_data_get (tmp);
8584 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8585 : {
8586 56 : if (UNLIMITED_POLY (fsym))
8587 : {
8588 12 : tree type = gfc_typenode_for_spec (&e->ts);
8589 12 : type = build_pointer_type (type);
8590 12 : tmp = fold_convert (type, tmp);
8591 : }
8592 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8593 : }
8594 : }
8595 :
8596 372 : if (e->expr_type == EXPR_OP
8597 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8598 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8599 : {
8600 24 : tree local_tmp;
8601 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8602 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8603 : parm_rank, 0);
8604 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8605 : }
8606 :
8607 : /* Items of array expressions passed to a polymorphic formal arguments
8608 : create their own clean up, so prevent double free. */
8609 372 : if (!finalized && !e->must_finalize
8610 371 : && !(e->expr_type == EXPR_ARRAY && fsym
8611 86 : && fsym->ts.type == BT_CLASS))
8612 : {
8613 351 : bool scalar_res_outside_loop;
8614 1041 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8615 151 : && parm_rank == 0
8616 490 : && parmse.loop;
8617 :
8618 : /* Scalars passed to an assumed rank argument are converted to
8619 : a descriptor. Obtain the data field before deallocating any
8620 : allocatable components. */
8621 298 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8622 612 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8623 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8624 :
8625 351 : if (scalar_res_outside_loop)
8626 : {
8627 : /* Go through the ss chain to find the argument and use
8628 : the stored value. */
8629 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8630 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8631 60 : if (tmp_ss->info
8632 48 : && tmp_ss->info->expr == e
8633 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8634 : {
8635 18 : tmp = tmp_ss->info->data.scalar.value;
8636 18 : break;
8637 : }
8638 : }
8639 :
8640 351 : STRIP_NOPS (tmp);
8641 :
8642 351 : if (derived_array != NULL_TREE)
8643 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8644 : derived_array,
8645 : parm_rank);
8646 351 : else if ((e->ts.type == BT_CLASS
8647 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8648 351 : || e->ts.type == BT_DERIVED)
8649 351 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8650 : parm_rank, 0, true);
8651 0 : else if (e->ts.type == BT_CLASS)
8652 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8653 : tmp, parm_rank);
8654 :
8655 351 : if (scalar_res_outside_loop)
8656 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8657 : else
8658 321 : gfc_prepend_expr_to_block (&post, tmp);
8659 : }
8660 : }
8661 :
8662 : /* Add argument checking of passing an unallocated/NULL actual to
8663 : a nonallocatable/nonpointer dummy. */
8664 :
8665 274366 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8666 : {
8667 6546 : symbol_attribute attr;
8668 6546 : char *msg;
8669 6546 : tree cond;
8670 6546 : tree tmp;
8671 6546 : symbol_attribute fsym_attr;
8672 :
8673 6546 : if (fsym)
8674 : {
8675 6385 : if (fsym->ts.type == BT_CLASS)
8676 : {
8677 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8678 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8679 : }
8680 : else
8681 6064 : fsym_attr = fsym->attr;
8682 : }
8683 :
8684 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8685 4094 : attr = gfc_expr_attr (e);
8686 : else
8687 6081 : goto end_pointer_check;
8688 :
8689 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8690 : allocatable to an optional dummy, cf. 12.5.2.12. */
8691 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8692 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8693 1032 : goto end_pointer_check;
8694 :
8695 3062 : if (attr.optional)
8696 : {
8697 : /* If the actual argument is an optional pointer/allocatable and
8698 : the formal argument takes an nonpointer optional value,
8699 : it is invalid to pass a non-present argument on, even
8700 : though there is no technical reason for this in gfortran.
8701 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8702 96 : tree present, null_ptr, type;
8703 :
8704 96 : if (attr.allocatable
8705 12 : && (fsym == NULL || !fsym_attr.allocatable))
8706 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8707 : "allocated or not present",
8708 0 : e->symtree->n.sym->name);
8709 96 : else if (attr.pointer
8710 24 : && (fsym == NULL || !fsym_attr.pointer))
8711 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8712 : "associated or not present",
8713 12 : e->symtree->n.sym->name);
8714 84 : else if (attr.proc_pointer && !e->value.function.actual
8715 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8716 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8717 : "associated or not present",
8718 0 : e->symtree->n.sym->name);
8719 : else
8720 84 : goto end_pointer_check;
8721 :
8722 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8723 12 : type = TREE_TYPE (present);
8724 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8725 : logical_type_node, present,
8726 : fold_convert (type,
8727 : null_pointer_node));
8728 12 : type = TREE_TYPE (parmse.expr);
8729 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8730 : logical_type_node, parmse.expr,
8731 : fold_convert (type,
8732 : null_pointer_node));
8733 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8734 : logical_type_node, present, null_ptr);
8735 : }
8736 : else
8737 : {
8738 2966 : if (attr.allocatable
8739 244 : && (fsym == NULL || !fsym_attr.allocatable))
8740 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8741 190 : "allocated", e->symtree->n.sym->name);
8742 2776 : else if (attr.pointer
8743 260 : && (fsym == NULL || !fsym_attr.pointer))
8744 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8745 184 : "associated", e->symtree->n.sym->name);
8746 2592 : else if (attr.proc_pointer && !e->value.function.actual
8747 80 : && (fsym == NULL
8748 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8749 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8750 79 : "associated", e->symtree->n.sym->name);
8751 : else
8752 2513 : goto end_pointer_check;
8753 :
8754 453 : tmp = parmse.expr;
8755 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8756 : {
8757 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8758 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8759 76 : tmp = gfc_class_data_get (tmp);
8760 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8761 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8762 : }
8763 :
8764 : /* If the argument is passed by value, we need to strip the
8765 : INDIRECT_REF. */
8766 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8767 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8768 :
8769 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8770 : logical_type_node, tmp,
8771 453 : fold_convert (TREE_TYPE (tmp),
8772 : null_pointer_node));
8773 : }
8774 :
8775 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8776 : msg);
8777 465 : free (msg);
8778 : }
8779 267820 : end_pointer_check:
8780 :
8781 : /* Deferred length dummies pass the character length by reference
8782 : so that the value can be returned. */
8783 274366 : if (parmse.string_length && fsym && fsym->ts.deferred)
8784 : {
8785 795 : if (INDIRECT_REF_P (parmse.string_length))
8786 : {
8787 : /* In chains of functions/procedure calls the string_length already
8788 : is a pointer to the variable holding the length. Therefore
8789 : remove the deref on call. */
8790 90 : tmp = parmse.string_length;
8791 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8792 : }
8793 : else
8794 : {
8795 705 : tmp = parmse.string_length;
8796 705 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8797 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8798 705 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8799 : }
8800 :
8801 795 : if (e && e->expr_type == EXPR_VARIABLE
8802 638 : && fsym->attr.allocatable
8803 368 : && e->ts.u.cl->backend_decl
8804 368 : && VAR_P (e->ts.u.cl->backend_decl))
8805 : {
8806 284 : if (INDIRECT_REF_P (tmp))
8807 0 : tmp = TREE_OPERAND (tmp, 0);
8808 284 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8809 : fold_convert (gfc_charlen_type_node, tmp));
8810 : }
8811 : }
8812 :
8813 : /* Character strings are passed as two parameters, a length and a
8814 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8815 : An unlimited polymorphic formal argument likewise does not
8816 : need the length. */
8817 274366 : if (parmse.string_length != NULL_TREE
8818 37248 : && !sym->attr.is_bind_c
8819 36498 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8820 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8821 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8822 30613 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8823 30504 : && !(fsym && UNLIMITED_POLY (fsym)))
8824 36208 : vec_safe_push (stringargs, parmse.string_length);
8825 :
8826 : /* When calling __copy for character expressions to unlimited
8827 : polymorphic entities, the dst argument needs a string length. */
8828 52185 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8829 5326 : && startswith (sym->name, "__vtab_CHARACTER")
8830 0 : && arg->next && arg->next->expr
8831 0 : && (arg->next->expr->ts.type == BT_DERIVED
8832 0 : || arg->next->expr->ts.type == BT_CLASS)
8833 274366 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8834 0 : vec_safe_push (stringargs, parmse.string_length);
8835 :
8836 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8837 : pass the token and the offset as additional arguments. */
8838 274366 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8839 144 : && attr->codimension && !attr->allocatable)
8840 : {
8841 : /* Token and offset. */
8842 5 : vec_safe_push (stringargs, null_pointer_node);
8843 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8844 5 : gcc_assert (fsym->attr.optional);
8845 : }
8846 241375 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8847 145 : && !attr->allocatable)
8848 : {
8849 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8850 123 : tree offset, tmp2;
8851 :
8852 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8853 123 : caf_type = TREE_TYPE (caf_decl);
8854 123 : if (POINTER_TYPE_P (caf_type)
8855 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8856 3 : caf_desc = TREE_TYPE (caf_type);
8857 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8858 : caf_desc = caf_type;
8859 :
8860 51 : if (caf_desc
8861 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8862 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8863 : {
8864 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8865 54 : ? build_fold_indirect_ref (caf_decl)
8866 : : caf_decl;
8867 51 : tmp = gfc_conv_descriptor_token (tmp);
8868 : }
8869 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8870 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8871 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8872 : else
8873 : {
8874 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8875 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8876 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8877 : }
8878 :
8879 123 : vec_safe_push (stringargs, tmp);
8880 :
8881 123 : if (caf_desc
8882 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8883 51 : offset = build_int_cst (gfc_array_index_type, 0);
8884 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8885 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8886 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8887 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8888 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8889 : else
8890 60 : offset = build_int_cst (gfc_array_index_type, 0);
8891 :
8892 123 : if (caf_desc)
8893 : {
8894 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8895 54 : ? build_fold_indirect_ref (caf_decl)
8896 : : caf_decl;
8897 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8898 : }
8899 : else
8900 : {
8901 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8902 72 : tmp = caf_decl;
8903 : }
8904 :
8905 108 : tmp2 = fsym->ts.type == BT_CLASS
8906 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8907 123 : if ((fsym->ts.type != BT_CLASS
8908 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8909 59 : || fsym->as->type == AS_ASSUMED_RANK))
8910 74 : || (fsym->ts.type == BT_CLASS
8911 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8912 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8913 : {
8914 54 : if (fsym->ts.type == BT_CLASS)
8915 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8916 : else
8917 : {
8918 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8919 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8920 : }
8921 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8922 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8923 : }
8924 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8925 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8926 : else
8927 : {
8928 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8929 : }
8930 :
8931 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8932 : gfc_array_index_type,
8933 : fold_convert (gfc_array_index_type, tmp2),
8934 : fold_convert (gfc_array_index_type, tmp));
8935 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8936 : gfc_array_index_type, offset, tmp);
8937 :
8938 123 : vec_safe_push (stringargs, offset);
8939 : }
8940 :
8941 274366 : vec_safe_push (arglist, parmse.expr);
8942 : }
8943 :
8944 133245 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8945 133245 : gfc_add_block_to_block (&se->pre, &clobbers);
8946 133245 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8947 :
8948 133245 : if (comp)
8949 2006 : ts = comp->ts;
8950 131239 : else if (sym->ts.type == BT_CLASS)
8951 875 : ts = CLASS_DATA (sym)->ts;
8952 : else
8953 130364 : ts = sym->ts;
8954 :
8955 133245 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8956 210 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8957 133035 : else if (ts.type == BT_CHARACTER)
8958 : {
8959 5118 : if (ts.u.cl->length == NULL)
8960 : {
8961 : /* Assumed character length results are not allowed by C418 of the 2003
8962 : standard and are trapped in resolve.cc; except in the case of SPREAD
8963 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8964 : we take the character length of the first argument for the result.
8965 : For dummies, we have to look through the formal argument list for
8966 : this function and use the character length found there.
8967 : Likewise, we handle the case of deferred-length character dummy
8968 : arguments to intrinsics that determine the characteristics of
8969 : the result, which cannot be deferred-length. */
8970 2333 : if (expr->value.function.isym)
8971 1703 : ts.deferred = false;
8972 2333 : if (ts.deferred)
8973 623 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8974 1710 : else if (!sym->attr.dummy)
8975 1703 : cl.backend_decl = (*stringargs)[0];
8976 : else
8977 : {
8978 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8979 26 : for (; formal; formal = formal->next)
8980 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8981 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8982 : }
8983 : len = cl.backend_decl;
8984 : }
8985 : else
8986 : {
8987 2785 : tree tmp;
8988 :
8989 : /* Calculate the length of the returned string. */
8990 2785 : gfc_init_se (&parmse, NULL);
8991 2785 : if (need_interface_mapping)
8992 1909 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8993 : else
8994 876 : gfc_conv_expr (&parmse, ts.u.cl->length);
8995 2785 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8996 2785 : gfc_add_block_to_block (&se->post, &parmse.post);
8997 2785 : tmp = parmse.expr;
8998 : /* TODO: It would be better to have the charlens as
8999 : gfc_charlen_type_node already when the interface is
9000 : created instead of converting it here (see PR 84615). */
9001 2785 : tmp = fold_build2_loc (input_location, MAX_EXPR,
9002 : gfc_charlen_type_node,
9003 : fold_convert (gfc_charlen_type_node, tmp),
9004 : build_zero_cst (gfc_charlen_type_node));
9005 2785 : cl.backend_decl = tmp;
9006 :
9007 : /* The length was fully computed above from the specification
9008 : expression, without needing the callee to actually run. */
9009 2785 : call_needed_for_length = false;
9010 : }
9011 :
9012 : /* Set up a charlen structure for it. */
9013 5118 : cl.next = NULL;
9014 5118 : cl.length = NULL;
9015 5118 : ts.u.cl = &cl;
9016 :
9017 5118 : len = cl.backend_decl;
9018 : }
9019 :
9020 2006 : byref = (comp && (comp->attr.dimension
9021 1937 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
9022 133245 : || (!comp && gfc_return_by_reference (sym));
9023 :
9024 : if (byref)
9025 : {
9026 19083 : if (se->direct_byref)
9027 : {
9028 : /* Sometimes, too much indirection can be applied; e.g. for
9029 : function_result = array_valued_recursive_function. */
9030 7023 : if (TREE_TYPE (TREE_TYPE (se->expr))
9031 7023 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
9032 7041 : && GFC_DESCRIPTOR_TYPE_P
9033 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
9034 18 : se->expr = build_fold_indirect_ref_loc (input_location,
9035 : se->expr);
9036 :
9037 : /* If the lhs of an assignment x = f(..) is allocatable and
9038 : f2003 is allowed, we must do the automatic reallocation.
9039 : TODO - deal with intrinsics, without using a temporary. */
9040 7023 : if (flag_realloc_lhs
9041 6948 : && se->ss && se->ss->loop_chain
9042 203 : && se->ss->loop_chain->is_alloc_lhs
9043 203 : && !expr->value.function.isym
9044 203 : && sym->result->as != NULL)
9045 : {
9046 : /* Evaluate the bounds of the result, if known. */
9047 203 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
9048 : sym->result->as);
9049 :
9050 : /* Perform the automatic reallocation. */
9051 203 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
9052 : expr, NULL);
9053 203 : gfc_add_expr_to_block (&se->pre, tmp);
9054 :
9055 : /* Pass the temporary as the first argument. */
9056 203 : result = info->descriptor;
9057 : }
9058 : else
9059 6820 : result = build_fold_indirect_ref_loc (input_location,
9060 : se->expr);
9061 7023 : vec_safe_push (retargs, se->expr);
9062 : }
9063 12060 : else if (comp && comp->attr.dimension)
9064 : {
9065 66 : gcc_assert (se->loop && info);
9066 :
9067 : /* Set the type of the array. vtable charlens are not always reliable.
9068 : Use the interface, if possible. */
9069 66 : if (comp->ts.type == BT_CHARACTER
9070 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
9071 1 : && comp->ts.interface && comp->ts.interface->result)
9072 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
9073 : else
9074 65 : tmp = gfc_typenode_for_spec (&comp->ts);
9075 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
9076 :
9077 : /* Evaluate the bounds of the result, if known. */
9078 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
9079 :
9080 : /* If the lhs of an assignment x = f(..) is allocatable and
9081 : f2003 is allowed, we must not generate the function call
9082 : here but should just send back the results of the mapping.
9083 : This is signalled by the function ss being flagged. */
9084 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
9085 : {
9086 0 : gfc_free_interface_mapping (&mapping);
9087 0 : return has_alternate_specifier;
9088 : }
9089 :
9090 : /* Create a temporary to store the result. In case the function
9091 : returns a pointer, the temporary will be a shallow copy and
9092 : mustn't be deallocated. */
9093 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
9094 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
9095 : tmp, NULL_TREE, false,
9096 : !comp->attr.pointer, callee_alloc,
9097 66 : &se->ss->info->expr->where);
9098 :
9099 : /* Index a pointer result by the span the callee returns. */
9100 66 : if (comp->attr.pointer && VAR_P (info->descriptor))
9101 0 : GFC_DECL_PTR_ARRAY_P (info->descriptor) = 1;
9102 :
9103 : /* Pass the temporary as the first argument. */
9104 66 : result = info->descriptor;
9105 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
9106 66 : vec_safe_push (retargs, tmp);
9107 : }
9108 11765 : else if (!comp && sym->result->attr.dimension)
9109 : {
9110 8680 : gcc_assert (se->loop && info);
9111 :
9112 : /* Set the type of the array. */
9113 8680 : tmp = gfc_typenode_for_spec (&ts);
9114 8680 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
9115 8680 : gcc_assert (se->ss->dimen == se->loop->dimen);
9116 :
9117 : /* Evaluate the bounds of the result, if known. */
9118 8680 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
9119 :
9120 : /* If the lhs of an assignment x = f(..) is allocatable and
9121 : f2003 is allowed, we must not generate the function call
9122 : here but should just send back the results of the mapping.
9123 : This is signalled by the function ss being flagged. */
9124 8680 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
9125 : {
9126 0 : gfc_free_interface_mapping (&mapping);
9127 0 : return has_alternate_specifier;
9128 : }
9129 :
9130 : /* Create a temporary to store the result. In case the function
9131 : returns a pointer, the temporary will be a shallow copy and
9132 : mustn't be deallocated. */
9133 8680 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
9134 8680 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
9135 : tmp, NULL_TREE, false,
9136 : !sym->attr.pointer, callee_alloc,
9137 8680 : &se->ss->info->expr->where);
9138 :
9139 : /* Index a pointer result by the span the callee returns. */
9140 8680 : if (sym->attr.pointer && VAR_P (info->descriptor))
9141 356 : GFC_DECL_PTR_ARRAY_P (info->descriptor) = 1;
9142 :
9143 : /* Pass the temporary as the first argument. */
9144 8680 : result = info->descriptor;
9145 8680 : tmp = gfc_build_addr_expr (NULL_TREE, result);
9146 8680 : vec_safe_push (retargs, tmp);
9147 : }
9148 3314 : else if (ts.type == BT_CHARACTER)
9149 : {
9150 : /* Pass the string length. */
9151 3253 : type = gfc_get_character_type (ts.kind, ts.u.cl);
9152 3253 : type = build_pointer_type (type);
9153 :
9154 : /* Emit a DECL_EXPR for the VLA type. */
9155 3253 : tmp = TREE_TYPE (type);
9156 3253 : if (TYPE_SIZE (tmp)
9157 3253 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
9158 : {
9159 1935 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
9160 1935 : DECL_ARTIFICIAL (tmp) = 1;
9161 1935 : DECL_IGNORED_P (tmp) = 1;
9162 1935 : tmp = fold_build1_loc (input_location, DECL_EXPR,
9163 1935 : TREE_TYPE (tmp), tmp);
9164 1935 : gfc_add_expr_to_block (&se->pre, tmp);
9165 : }
9166 :
9167 : /* Return an address to a char[0:len-1]* temporary for
9168 : character pointers. */
9169 3253 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9170 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9171 : {
9172 648 : var = gfc_create_var (type, "pstr");
9173 :
9174 648 : if ((!comp && sym->attr.allocatable)
9175 21 : || (comp && comp->attr.allocatable))
9176 : {
9177 361 : gfc_add_modify (&se->pre, var,
9178 361 : fold_convert (TREE_TYPE (var),
9179 : null_pointer_node));
9180 361 : tmp = gfc_call_free (var);
9181 361 : gfc_add_expr_to_block (&se->post, tmp);
9182 : }
9183 :
9184 : /* Provide an address expression for the function arguments. */
9185 648 : var = gfc_build_addr_expr (NULL_TREE, var);
9186 : }
9187 : else
9188 2605 : var = gfc_conv_string_tmp (se, type, len);
9189 :
9190 3253 : vec_safe_push (retargs, var);
9191 : }
9192 : else
9193 : {
9194 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
9195 :
9196 61 : type = gfc_get_complex_type (ts.kind);
9197 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
9198 61 : vec_safe_push (retargs, var);
9199 : }
9200 :
9201 : /* Add the string length to the argument list. */
9202 19083 : if (ts.type == BT_CHARACTER && ts.deferred)
9203 : {
9204 623 : tmp = len;
9205 623 : if (!VAR_P (tmp))
9206 0 : tmp = gfc_evaluate_now (len, &se->pre);
9207 623 : TREE_STATIC (tmp) = 1;
9208 623 : gfc_add_modify (&se->pre, tmp,
9209 623 : build_int_cst (TREE_TYPE (tmp), 0));
9210 623 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
9211 623 : vec_safe_push (retargs, tmp);
9212 : }
9213 18460 : else if (ts.type == BT_CHARACTER)
9214 4495 : vec_safe_push (retargs, len);
9215 : }
9216 :
9217 133245 : gfc_free_interface_mapping (&mapping);
9218 :
9219 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
9220 247819 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
9221 158860 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
9222 133245 : vec_safe_reserve (retargs, arglen);
9223 :
9224 : /* Add the return arguments. */
9225 133245 : vec_safe_splice (retargs, arglist);
9226 :
9227 : /* Add the hidden present status for optional+value to the arguments. */
9228 133245 : vec_safe_splice (retargs, optionalargs);
9229 :
9230 : /* Add the hidden string length parameters to the arguments. */
9231 133245 : vec_safe_splice (retargs, stringargs);
9232 :
9233 : /* We may want to append extra arguments here. This is used e.g. for
9234 : calls to libgfortran_matmul_??, which need extra information. */
9235 133245 : vec_safe_splice (retargs, append_args);
9236 :
9237 133245 : arglist = retargs;
9238 :
9239 : /* Generate the actual call. */
9240 133245 : is_builtin = false;
9241 133245 : if (base_object == NULL_TREE)
9242 133165 : conv_function_val (se, &is_builtin, sym, expr, args);
9243 : else
9244 80 : conv_base_obj_fcn_val (se, base_object, expr);
9245 :
9246 : /* If there are alternate return labels, function type should be
9247 : integer. Can't modify the type in place though, since it can be shared
9248 : with other functions. For dummy arguments, the typing is done to
9249 : this result, even if it has to be repeated for each call. */
9250 133245 : if (has_alternate_specifier
9251 133245 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
9252 : {
9253 7 : if (!sym->attr.dummy)
9254 : {
9255 0 : TREE_TYPE (sym->backend_decl)
9256 0 : = build_function_type (integer_type_node,
9257 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
9258 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
9259 : }
9260 : else
9261 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
9262 : }
9263 :
9264 133245 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
9265 133245 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
9266 :
9267 133245 : if (is_builtin)
9268 567 : se->expr = update_builtin_function (se->expr, sym);
9269 :
9270 : /* Allocatable scalar function results must be freed and nullified
9271 : after use. This necessitates the creation of a temporary to
9272 : hold the result to prevent duplicate calls. */
9273 133245 : symbol_attribute attr = comp ? comp->attr : sym->attr;
9274 133245 : bool allocatable = attr.allocatable && !attr.dimension;
9275 136627 : gfc_symbol *der = comp ?
9276 2006 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
9277 : :
9278 131239 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
9279 3382 : bool finalizable = der != NULL && der->ns->proc_name
9280 6761 : && gfc_is_finalizable (der, NULL);
9281 :
9282 133245 : if (!byref && finalizable)
9283 188 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9284 :
9285 133245 : if (!byref && sym->ts.type != BT_CHARACTER
9286 113952 : && allocatable && !finalizable)
9287 : {
9288 236 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
9289 236 : gfc_add_modify (&se->pre, tmp, se->expr);
9290 236 : se->expr = tmp;
9291 236 : tmp = gfc_call_free (tmp);
9292 236 : gfc_add_expr_to_block (&post, tmp);
9293 236 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
9294 : }
9295 :
9296 : /* If we have a pointer function, but we don't want a pointer, e.g.
9297 : something like
9298 : x = f()
9299 : where f is pointer valued, we have to dereference the result. */
9300 133245 : if (!se->want_pointer && !byref
9301 113554 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9302 1664 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
9303 462 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9304 :
9305 : /* f2c calling conventions require a scalar default real function to
9306 : return a double precision result. Convert this back to default
9307 : real. We only care about the cases that can happen in Fortran 77.
9308 : */
9309 133245 : if (flag_f2c && sym->ts.type == BT_REAL
9310 98 : && sym->ts.kind == gfc_default_real_kind
9311 74 : && !sym->attr.pointer
9312 55 : && !sym->attr.allocatable
9313 43 : && !sym->attr.always_explicit)
9314 43 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
9315 :
9316 : /* A pure function may still have side-effects - it may modify its
9317 : parameters. */
9318 133245 : TREE_SIDE_EFFECTS (se->expr) = 1;
9319 : #if 0
9320 : if (!sym->attr.pure)
9321 : TREE_SIDE_EFFECTS (se->expr) = 1;
9322 : #endif
9323 :
9324 133245 : if (byref)
9325 : {
9326 : /* Add the function call to the pre chain. There is no expression. */
9327 19083 : if (!se->no_function_call || call_needed_for_length)
9328 19051 : gfc_add_expr_to_block (&se->pre, se->expr);
9329 :
9330 19083 : se->expr = NULL_TREE;
9331 :
9332 19083 : if (!se->direct_byref)
9333 : {
9334 12060 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
9335 : {
9336 8746 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
9337 : {
9338 : /* Check the data pointer hasn't been modified. This would
9339 : happen in a function returning a pointer. */
9340 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9341 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
9342 : logical_type_node,
9343 : tmp, info->data);
9344 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
9345 : gfc_msg_fault);
9346 : }
9347 8746 : se->expr = info->descriptor;
9348 : /* Bundle in the string length. */
9349 8746 : se->string_length = len;
9350 :
9351 8746 : if (finalizable)
9352 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9353 : }
9354 3314 : else if (ts.type == BT_CHARACTER)
9355 : {
9356 : /* Dereference for character pointer results. */
9357 3253 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9358 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9359 648 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9360 : else
9361 2605 : se->expr = var;
9362 :
9363 3253 : se->string_length = len;
9364 : }
9365 : else
9366 : {
9367 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
9368 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9369 : }
9370 : }
9371 : }
9372 :
9373 : /* Associate the rhs class object's meta-data with the result, when the
9374 : result is a temporary. */
9375 114579 : if (args && args->expr && args->expr->ts.type == BT_CLASS
9376 5177 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
9377 133277 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
9378 : {
9379 32 : gfc_se parmse;
9380 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
9381 :
9382 32 : gfc_init_se (&parmse, NULL);
9383 32 : parmse.data_not_needed = 1;
9384 32 : gfc_conv_expr (&parmse, class_expr);
9385 32 : if (!DECL_LANG_SPECIFIC (result))
9386 32 : gfc_allocate_lang_decl (result);
9387 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
9388 32 : gfc_free_expr (class_expr);
9389 : /* -fcheck= can add diagnostic code, which has to be placed before
9390 : the call. */
9391 32 : if (parmse.pre.head != NULL)
9392 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
9393 32 : gcc_assert (parmse.post.head == NULL_TREE);
9394 : }
9395 :
9396 : /* Follow the function call with the argument post block. */
9397 133245 : if (byref)
9398 : {
9399 : /* Transformational functions of derived types with allocatable
9400 : components must have the result allocatable components copied
9401 : BEFORE the argument post block is appended. Copying the result
9402 : first, then freeing the argument, gives the correct order. */
9403 19083 : arg = expr->value.function.actual;
9404 19083 : if (result && arg && expr->rank
9405 14730 : && isym && isym->transformational
9406 13143 : && isym->id != GFC_ISYM_REDUCE
9407 13017 : && arg->expr
9408 12957 : && arg->expr->ts.type == BT_DERIVED
9409 241 : && arg->expr->ts.u.derived->attr.alloc_comp)
9410 : {
9411 48 : tree tmp2;
9412 : /* Copy the allocatable components. We have to use a
9413 : temporary here to prevent source allocatable components
9414 : from being corrupted. */
9415 48 : tmp2 = gfc_evaluate_now (result, &se->pre);
9416 48 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
9417 : result, tmp2, expr->rank, 0);
9418 48 : gfc_add_expr_to_block (&se->pre, tmp);
9419 48 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
9420 : expr->rank);
9421 48 : gfc_add_expr_to_block (&se->pre, tmp);
9422 :
9423 : /* Finally free the temporary's data field. */
9424 48 : tmp = gfc_conv_descriptor_data_get (tmp2);
9425 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9426 : NULL_TREE, NULL_TREE, true,
9427 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9428 48 : gfc_add_expr_to_block (&se->pre, tmp);
9429 : }
9430 :
9431 19083 : gfc_add_block_to_block (&se->pre, &post);
9432 : }
9433 : else
9434 : {
9435 : /* For a function with a class array result, save the result as
9436 : a temporary, set the info fields needed by the scalarizer and
9437 : call the finalization function of the temporary. Note that the
9438 : nullification of allocatable components needed by the result
9439 : is done in gfc_trans_assignment_1. */
9440 35689 : if (expr && (gfc_is_class_array_function (expr)
9441 35355 : || gfc_is_alloc_class_scalar_function (expr))
9442 865 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9443 115015 : && expr->must_finalize)
9444 : {
9445 : /* TODO Eliminate the doubling of temporaries. This
9446 : one is necessary to ensure no memory leakage. */
9447 333 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9448 :
9449 : /* Finalize the result, if necessary. */
9450 666 : attr = expr->value.function.esym
9451 333 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9452 14 : : CLASS_DATA (expr)->attr;
9453 333 : if (!((gfc_is_class_array_function (expr)
9454 120 : || gfc_is_alloc_class_scalar_function (expr))
9455 333 : && attr.pointer))
9456 288 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9457 : }
9458 114162 : gfc_add_block_to_block (&se->post, &post);
9459 : }
9460 :
9461 : return has_alternate_specifier;
9462 : }
9463 :
9464 :
9465 : /* Fill a character string with spaces. */
9466 :
9467 : static tree
9468 31342 : fill_with_spaces (tree start, tree type, tree size)
9469 : {
9470 31342 : stmtblock_t block, loop;
9471 31342 : tree i, el, exit_label, cond, tmp;
9472 :
9473 : /* For a simple char type, we can call memset(). */
9474 31342 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9475 52060 : return build_call_expr_loc (input_location,
9476 : builtin_decl_explicit (BUILT_IN_MEMSET),
9477 : 3, start,
9478 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9479 26030 : lang_hooks.to_target_charset (' ')),
9480 : fold_convert (size_type_node, size));
9481 :
9482 : /* Otherwise, we use a loop:
9483 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9484 : *el = (type) ' ';
9485 : */
9486 :
9487 : /* Initialize variables. */
9488 5312 : gfc_init_block (&block);
9489 5312 : i = gfc_create_var (sizetype, "i");
9490 5312 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9491 5312 : el = gfc_create_var (build_pointer_type (type), "el");
9492 5312 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9493 5312 : exit_label = gfc_build_label_decl (NULL_TREE);
9494 5312 : TREE_USED (exit_label) = 1;
9495 :
9496 :
9497 : /* Loop body. */
9498 5312 : gfc_init_block (&loop);
9499 :
9500 : /* Exit condition. */
9501 5312 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9502 : build_zero_cst (sizetype));
9503 5312 : tmp = build1_v (GOTO_EXPR, exit_label);
9504 5312 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9505 : build_empty_stmt (input_location));
9506 5312 : gfc_add_expr_to_block (&loop, tmp);
9507 :
9508 : /* Assignment. */
9509 5312 : gfc_add_modify (&loop,
9510 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9511 5312 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9512 :
9513 : /* Increment loop variables. */
9514 5312 : gfc_add_modify (&loop, i,
9515 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9516 5312 : TYPE_SIZE_UNIT (type)));
9517 5312 : gfc_add_modify (&loop, el,
9518 : fold_build_pointer_plus_loc (input_location,
9519 5312 : el, TYPE_SIZE_UNIT (type)));
9520 :
9521 : /* Making the loop... actually loop! */
9522 5312 : tmp = gfc_finish_block (&loop);
9523 5312 : tmp = build1_v (LOOP_EXPR, tmp);
9524 5312 : gfc_add_expr_to_block (&block, tmp);
9525 :
9526 : /* The exit label. */
9527 5312 : tmp = build1_v (LABEL_EXPR, exit_label);
9528 5312 : gfc_add_expr_to_block (&block, tmp);
9529 :
9530 :
9531 5312 : return gfc_finish_block (&block);
9532 : }
9533 :
9534 :
9535 : /* Generate code to copy a string. */
9536 :
9537 : void
9538 36595 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9539 : int dkind, tree slength, tree src, int skind)
9540 : {
9541 36595 : tree tmp, dlen, slen;
9542 36595 : tree dsc;
9543 36595 : tree ssc;
9544 36595 : tree cond;
9545 36595 : tree cond2;
9546 36595 : tree tmp2;
9547 36595 : tree tmp3;
9548 36595 : tree tmp4;
9549 36595 : tree chartype;
9550 36595 : stmtblock_t tempblock;
9551 :
9552 36595 : gcc_assert (dkind == skind);
9553 :
9554 36595 : if (slength != NULL_TREE)
9555 : {
9556 36595 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9557 36595 : ssc = gfc_string_to_single_character (slen, src, skind);
9558 : }
9559 : else
9560 : {
9561 0 : slen = build_one_cst (gfc_charlen_type_node);
9562 0 : ssc = src;
9563 : }
9564 :
9565 36595 : if (dlength != NULL_TREE)
9566 : {
9567 36595 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9568 36595 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9569 : }
9570 : else
9571 : {
9572 0 : dlen = build_one_cst (gfc_charlen_type_node);
9573 0 : dsc = dest;
9574 : }
9575 :
9576 : /* Assign directly if the types are compatible. */
9577 36595 : if (dsc != NULL_TREE && ssc != NULL_TREE
9578 36595 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9579 : {
9580 5253 : gfc_add_modify (block, dsc, ssc);
9581 5253 : return;
9582 : }
9583 :
9584 : /* The string copy algorithm below generates code like
9585 :
9586 : if (destlen > 0)
9587 : {
9588 : if (srclen < destlen)
9589 : {
9590 : memmove (dest, src, srclen);
9591 : // Pad with spaces.
9592 : memset (&dest[srclen], ' ', destlen - srclen);
9593 : }
9594 : else
9595 : {
9596 : // Truncate if too long.
9597 : memmove (dest, src, destlen);
9598 : }
9599 : }
9600 : */
9601 :
9602 : /* Do nothing if the destination length is zero. */
9603 31342 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9604 31342 : build_zero_cst (TREE_TYPE (dlen)));
9605 :
9606 : /* For non-default character kinds, we have to multiply the string
9607 : length by the base type size. */
9608 31342 : chartype = gfc_get_char_type (dkind);
9609 31342 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9610 : slen,
9611 31342 : fold_convert (TREE_TYPE (slen),
9612 : TYPE_SIZE_UNIT (chartype)));
9613 31342 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9614 : dlen,
9615 31342 : fold_convert (TREE_TYPE (dlen),
9616 : TYPE_SIZE_UNIT (chartype)));
9617 :
9618 31342 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9619 31294 : dest = fold_convert (pvoid_type_node, dest);
9620 : else
9621 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9622 :
9623 31342 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9624 31338 : src = fold_convert (pvoid_type_node, src);
9625 : else
9626 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9627 :
9628 : /* Truncate string if source is too long. */
9629 31342 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9630 : dlen);
9631 :
9632 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9633 31342 : if (!CONSTANT_CLASS_P (cond2))
9634 : {
9635 9730 : dest = gfc_evaluate_now (dest, block);
9636 9730 : src = gfc_evaluate_now (src, block);
9637 : }
9638 :
9639 : /* Copy and pad with spaces. */
9640 31342 : tmp3 = build_call_expr_loc (input_location,
9641 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9642 : 3, dest, src,
9643 : fold_convert (size_type_node, slen));
9644 :
9645 : /* Wstringop-overflow appears at -O3 even though this warning is not
9646 : explicitly available in fortran nor can it be switched off. If the
9647 : source length is a constant, its negative appears as a very large
9648 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9649 : the result of the MINUS_EXPR suppresses this spurious warning. */
9650 31342 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9651 31342 : TREE_TYPE(dlen), dlen, slen);
9652 31342 : if (slength && TREE_CONSTANT (slength))
9653 27696 : tmp = gfc_evaluate_now (tmp, block);
9654 :
9655 31342 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9656 31342 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9657 :
9658 31342 : gfc_init_block (&tempblock);
9659 31342 : gfc_add_expr_to_block (&tempblock, tmp3);
9660 31342 : gfc_add_expr_to_block (&tempblock, tmp4);
9661 31342 : tmp3 = gfc_finish_block (&tempblock);
9662 :
9663 : /* The truncated memmove if the slen >= dlen. */
9664 31342 : tmp2 = build_call_expr_loc (input_location,
9665 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9666 : 3, dest, src,
9667 : fold_convert (size_type_node, dlen));
9668 :
9669 : /* The whole copy_string function is there. */
9670 31342 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9671 : tmp3, tmp2);
9672 31342 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9673 : build_empty_stmt (input_location));
9674 31342 : gfc_add_expr_to_block (block, tmp);
9675 : }
9676 :
9677 :
9678 : /* Translate a statement function.
9679 : The value of a statement function reference is obtained by evaluating the
9680 : expression using the values of the actual arguments for the values of the
9681 : corresponding dummy arguments. */
9682 :
9683 : static void
9684 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9685 : {
9686 269 : gfc_symbol *sym;
9687 269 : gfc_symbol *fsym;
9688 269 : gfc_formal_arglist *fargs;
9689 269 : gfc_actual_arglist *args;
9690 269 : gfc_se lse;
9691 269 : gfc_se rse;
9692 269 : gfc_saved_var *saved_vars;
9693 269 : tree *temp_vars;
9694 269 : tree type;
9695 269 : tree tmp;
9696 269 : int n;
9697 :
9698 269 : sym = expr->symtree->n.sym;
9699 269 : args = expr->value.function.actual;
9700 269 : gfc_init_se (&lse, NULL);
9701 269 : gfc_init_se (&rse, NULL);
9702 :
9703 269 : n = 0;
9704 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9705 458 : n++;
9706 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9707 269 : temp_vars = XCNEWVEC (tree, n);
9708 :
9709 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9710 458 : fargs = fargs->next, n++)
9711 : {
9712 : /* Each dummy shall be specified, explicitly or implicitly, to be
9713 : scalar. */
9714 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9715 458 : fsym = fargs->sym;
9716 :
9717 458 : if (fsym->ts.type == BT_CHARACTER)
9718 : {
9719 : /* Copy string arguments. */
9720 48 : tree arglen;
9721 :
9722 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9723 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9724 :
9725 : /* Create a temporary to hold the value. */
9726 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9727 1 : fsym->ts.u.cl->backend_decl
9728 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9729 :
9730 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9731 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9732 :
9733 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9734 :
9735 48 : gfc_conv_expr (&rse, args->expr);
9736 48 : gfc_conv_string_parameter (&rse);
9737 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9738 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9739 :
9740 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9741 : rse.string_length, rse.expr, fsym->ts.kind);
9742 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9743 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9744 : }
9745 : else
9746 : {
9747 : /* For everything else, just evaluate the expression. */
9748 :
9749 : /* Create a temporary to hold the value. */
9750 410 : type = gfc_typenode_for_spec (&fsym->ts);
9751 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9752 :
9753 410 : gfc_conv_expr (&lse, args->expr);
9754 :
9755 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9756 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9757 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9758 : }
9759 :
9760 458 : args = args->next;
9761 : }
9762 :
9763 : /* Use the temporary variables in place of the real ones. */
9764 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9765 458 : fargs = fargs->next, n++)
9766 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9767 :
9768 269 : gfc_conv_expr (se, sym->value);
9769 :
9770 269 : if (sym->ts.type == BT_CHARACTER)
9771 : {
9772 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9773 :
9774 : /* Force the expression to the correct length. */
9775 55 : if (!INTEGER_CST_P (se->string_length)
9776 101 : || tree_int_cst_lt (se->string_length,
9777 46 : sym->ts.u.cl->backend_decl))
9778 : {
9779 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9780 31 : tmp = gfc_create_var (type, sym->name);
9781 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9782 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9783 : sym->ts.kind, se->string_length, se->expr,
9784 : sym->ts.kind);
9785 31 : se->expr = tmp;
9786 : }
9787 55 : se->string_length = sym->ts.u.cl->backend_decl;
9788 : }
9789 :
9790 : /* Restore the original variables. */
9791 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9792 458 : fargs = fargs->next, n++)
9793 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9794 269 : free (temp_vars);
9795 269 : free (saved_vars);
9796 269 : }
9797 :
9798 :
9799 : /* Translate a function expression. */
9800 :
9801 : static void
9802 320115 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9803 : {
9804 320115 : gfc_symbol *sym;
9805 :
9806 320115 : if (expr->value.function.isym)
9807 : {
9808 268416 : gfc_conv_intrinsic_function (se, expr);
9809 268416 : return;
9810 : }
9811 :
9812 : /* expr.value.function.esym is the resolved (specific) function symbol for
9813 : most functions. However this isn't set for dummy procedures. */
9814 51699 : sym = expr->value.function.esym;
9815 51699 : if (!sym)
9816 1646 : sym = expr->symtree->n.sym;
9817 :
9818 : /* The IEEE_ARITHMETIC functions are caught here. */
9819 51699 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9820 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9821 : return;
9822 :
9823 : /* We distinguish statement functions from general functions to improve
9824 : runtime performance. */
9825 39242 : if (sym->attr.proc == PROC_ST_FUNCTION)
9826 : {
9827 269 : gfc_conv_statement_function (se, expr);
9828 269 : return;
9829 : }
9830 :
9831 38973 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9832 : NULL);
9833 : }
9834 :
9835 :
9836 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9837 :
9838 : static bool
9839 40407 : is_zero_initializer_p (gfc_expr * expr)
9840 : {
9841 40407 : if (expr->expr_type != EXPR_CONSTANT)
9842 : return false;
9843 :
9844 : /* We ignore constants with prescribed memory representations for now. */
9845 11595 : if (expr->representation.string)
9846 : return false;
9847 :
9848 11577 : switch (expr->ts.type)
9849 : {
9850 5412 : case BT_INTEGER:
9851 5412 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9852 :
9853 4857 : case BT_REAL:
9854 4857 : return mpfr_zero_p (expr->value.real)
9855 4857 : && MPFR_SIGN (expr->value.real) >= 0;
9856 :
9857 931 : case BT_LOGICAL:
9858 931 : return expr->value.logical == 0;
9859 :
9860 243 : case BT_COMPLEX:
9861 243 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9862 155 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9863 155 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9864 386 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9865 :
9866 : default:
9867 : break;
9868 : }
9869 : return false;
9870 : }
9871 :
9872 :
9873 : static void
9874 36820 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9875 : {
9876 36820 : gfc_ss *ss;
9877 :
9878 36820 : ss = se->ss;
9879 36820 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9880 36820 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9881 :
9882 36820 : gfc_conv_tmp_array_ref (se);
9883 36820 : }
9884 :
9885 :
9886 : /* Build a static initializer. EXPR is the expression for the initial value.
9887 : The other parameters describe the variable of the component being
9888 : initialized. EXPR may be null. */
9889 :
9890 : tree
9891 139913 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9892 : bool array, bool pointer, bool procptr)
9893 : {
9894 139913 : gfc_se se;
9895 :
9896 139913 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9897 43918 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9898 171 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9899 59 : return build_constructor (type, NULL);
9900 :
9901 139854 : if (!(expr || pointer || procptr))
9902 : return NULL_TREE;
9903 :
9904 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9905 : (these are the only two iso_c_binding derived types that can be
9906 : used as initialization expressions). If so, we need to modify
9907 : the 'expr' to be that for a (void *). */
9908 131356 : if (expr != NULL && expr->ts.type == BT_DERIVED
9909 39594 : && expr->ts.is_iso_c && expr->ts.u.derived)
9910 : {
9911 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9912 4 : return build_constructor (type, NULL);
9913 182 : else if (POINTER_TYPE_P (type))
9914 182 : return build_int_cst (type, 0);
9915 : else
9916 0 : gcc_unreachable ();
9917 : }
9918 :
9919 131170 : if (array && !procptr)
9920 : {
9921 8954 : tree ctor;
9922 : /* Arrays need special handling. */
9923 8954 : if (pointer)
9924 815 : ctor = gfc_build_null_descriptor (type);
9925 : /* Special case assigning an array to zero. */
9926 8139 : else if (is_zero_initializer_p (expr))
9927 226 : ctor = build_constructor (type, NULL);
9928 : else
9929 7913 : ctor = gfc_conv_array_initializer (type, expr);
9930 8954 : TREE_STATIC (ctor) = 1;
9931 8954 : return ctor;
9932 : }
9933 122216 : else if (pointer || procptr)
9934 : {
9935 57424 : if (ts->type == BT_CLASS && !procptr)
9936 : {
9937 1822 : gfc_init_se (&se, NULL);
9938 1822 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9939 1822 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9940 1822 : TREE_STATIC (se.expr) = 1;
9941 1822 : return se.expr;
9942 : }
9943 55602 : else if (!expr || expr->expr_type == EXPR_NULL)
9944 29657 : return fold_convert (type, null_pointer_node);
9945 : else
9946 : {
9947 25945 : gfc_init_se (&se, NULL);
9948 25945 : se.want_pointer = 1;
9949 25945 : gfc_conv_expr (&se, expr);
9950 25945 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9951 : return se.expr;
9952 : }
9953 : }
9954 : else
9955 : {
9956 64792 : switch (ts->type)
9957 : {
9958 19056 : case_bt_struct:
9959 19056 : case BT_CLASS:
9960 19056 : gfc_init_se (&se, NULL);
9961 19056 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9962 821 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9963 : else
9964 18235 : gfc_conv_structure (&se, expr, 1);
9965 19056 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9966 19056 : TREE_STATIC (se.expr) = 1;
9967 19056 : return se.expr;
9968 :
9969 2735 : case BT_CHARACTER:
9970 2735 : if (expr->expr_type == EXPR_CONSTANT)
9971 : {
9972 2734 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9973 2734 : TREE_STATIC (ctor) = 1;
9974 2734 : return ctor;
9975 : }
9976 :
9977 : /* Fallthrough. */
9978 43002 : default:
9979 43002 : gfc_init_se (&se, NULL);
9980 43002 : gfc_conv_constant (&se, expr);
9981 43002 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9982 : return se.expr;
9983 : }
9984 : }
9985 : }
9986 :
9987 : static tree
9988 986 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9989 : {
9990 986 : gfc_se rse;
9991 986 : gfc_se lse;
9992 986 : gfc_ss *rss;
9993 986 : gfc_ss *lss;
9994 986 : gfc_array_info *lss_array;
9995 986 : stmtblock_t body;
9996 986 : stmtblock_t block;
9997 986 : gfc_loopinfo loop;
9998 986 : int n;
9999 986 : tree tmp;
10000 :
10001 986 : gfc_start_block (&block);
10002 :
10003 : /* Initialize the scalarizer. */
10004 986 : gfc_init_loopinfo (&loop);
10005 :
10006 986 : gfc_init_se (&lse, NULL);
10007 986 : gfc_init_se (&rse, NULL);
10008 :
10009 : /* Walk the rhs. */
10010 986 : rss = gfc_walk_expr (expr);
10011 986 : if (rss == gfc_ss_terminator)
10012 : /* The rhs is scalar. Add a ss for the expression. */
10013 238 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
10014 :
10015 : /* Create a SS for the destination. */
10016 986 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
10017 : GFC_SS_COMPONENT);
10018 986 : lss_array = &lss->info->data.array;
10019 986 : lss_array->shape = gfc_get_shape (cm->as->rank);
10020 986 : lss_array->descriptor = dest;
10021 986 : lss_array->data = gfc_conv_array_data (dest);
10022 986 : lss_array->offset = gfc_conv_array_offset (dest);
10023 2035 : for (n = 0; n < cm->as->rank; n++)
10024 : {
10025 1049 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
10026 1049 : lss_array->stride[n] = gfc_index_one_node;
10027 :
10028 1049 : mpz_init (lss_array->shape[n]);
10029 1049 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
10030 1049 : cm->as->lower[n]->value.integer);
10031 1049 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
10032 : }
10033 :
10034 : /* Associate the SS with the loop. */
10035 986 : gfc_add_ss_to_loop (&loop, lss);
10036 986 : gfc_add_ss_to_loop (&loop, rss);
10037 :
10038 : /* Calculate the bounds of the scalarization. */
10039 986 : gfc_conv_ss_startstride (&loop);
10040 :
10041 : /* Setup the scalarizing loops. */
10042 986 : gfc_conv_loop_setup (&loop, &expr->where);
10043 :
10044 : /* Setup the gfc_se structures. */
10045 986 : gfc_copy_loopinfo_to_se (&lse, &loop);
10046 986 : gfc_copy_loopinfo_to_se (&rse, &loop);
10047 :
10048 986 : rse.ss = rss;
10049 986 : gfc_mark_ss_chain_used (rss, 1);
10050 986 : lse.ss = lss;
10051 986 : gfc_mark_ss_chain_used (lss, 1);
10052 :
10053 : /* Start the scalarized loop body. */
10054 986 : gfc_start_scalarized_body (&loop, &body);
10055 :
10056 986 : gfc_conv_tmp_array_ref (&lse);
10057 986 : if (cm->ts.type == BT_CHARACTER)
10058 176 : lse.string_length = cm->ts.u.cl->backend_decl;
10059 :
10060 986 : gfc_conv_expr (&rse, expr);
10061 :
10062 986 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
10063 986 : gfc_add_expr_to_block (&body, tmp);
10064 :
10065 986 : gcc_assert (rse.ss == gfc_ss_terminator);
10066 :
10067 : /* Generate the copying loops. */
10068 986 : gfc_trans_scalarizing_loops (&loop, &body);
10069 :
10070 : /* Wrap the whole thing up. */
10071 986 : gfc_add_block_to_block (&block, &loop.pre);
10072 986 : gfc_add_block_to_block (&block, &loop.post);
10073 :
10074 986 : gcc_assert (lss_array->shape != NULL);
10075 986 : gfc_free_shape (&lss_array->shape, cm->as->rank);
10076 986 : gfc_cleanup_loop (&loop);
10077 :
10078 986 : return gfc_finish_block (&block);
10079 : }
10080 :
10081 :
10082 : static stmtblock_t *final_block;
10083 :
10084 :
10085 : /* Get the address of element index of contiguous character array data whose elements
10086 : are len characters of ksize bytes each. */
10087 :
10088 : static tree
10089 196 : gfc_char_elem_addr (tree char_ptr, tree data, tree idx, tree len, tree ksize)
10090 : {
10091 196 : tree offset = fold_build2_loc (input_location, MULT_EXPR,
10092 : gfc_array_index_type, len, ksize);
10093 196 : offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10094 : idx, offset);
10095 196 : return fold_build_pointer_plus_loc (input_location,
10096 196 : fold_convert (char_ptr, data), offset);
10097 : }
10098 :
10099 :
10100 : /* Copy a deferred-shape allocatable character array component in a structure
10101 : constructor when the source element length (SRC_LEN) may differ from the
10102 : component's declared length. Like gfc_duplicate_allocatable, a
10103 : contiguous source layout is assumed. DEST and SRC are array descriptors;
10104 : DEST already carries the source's bounds. */
10105 :
10106 : static tree
10107 98 : gfc_trans_alloc_char_subarray_assign (tree dest, gfc_component *cm, tree src,
10108 : tree src_len, int rank)
10109 : {
10110 98 : stmtblock_t block, body;
10111 98 : tree dlen, slen, ksize, nelems, idx, size, tmp, pchar, cond;
10112 :
10113 98 : gfc_init_block (&block);
10114 :
10115 98 : pchar = gfc_get_pchar_type (cm->ts.kind);
10116 98 : ksize = fold_convert (gfc_array_index_type,
10117 : TYPE_SIZE_UNIT (gfc_get_char_type (cm->ts.kind)));
10118 98 : dlen = fold_convert (gfc_array_index_type, cm->ts.u.cl->backend_decl);
10119 98 : slen = fold_convert (gfc_array_index_type, src_len);
10120 98 : nelems = gfc_full_array_size (&block, src, rank);
10121 98 : nelems = gfc_evaluate_now (nelems, &block);
10122 :
10123 : /* Allocate the destination data: nelems elements of the component length. */
10124 98 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10125 : nelems, dlen);
10126 98 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10127 : size, ksize);
10128 98 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (dest));
10129 98 : gfc_conv_descriptor_data_set (&block, dest,
10130 : gfc_call_malloc (&block, tmp, size));
10131 :
10132 : /* Copy element IDX, padding or truncating to the component length. */
10133 98 : idx = gfc_create_var (gfc_array_index_type, "idx");
10134 98 : gfc_init_block (&body);
10135 98 : gfc_trans_string_copy (&body, cm->ts.u.cl->backend_decl,
10136 : gfc_char_elem_addr (pchar,
10137 : gfc_conv_descriptor_data_get (dest),
10138 : idx, dlen, ksize),
10139 : cm->ts.kind, src_len,
10140 : gfc_char_elem_addr (pchar,
10141 : gfc_conv_descriptor_data_get (src),
10142 : idx, slen, ksize),
10143 : cm->ts.kind);
10144 98 : gfc_simple_for_loop (&block, idx, gfc_index_zero_node, nelems, LT_EXPR,
10145 : gfc_index_one_node, gfc_finish_block (&body));
10146 :
10147 98 : tmp = gfc_finish_block (&block);
10148 :
10149 : /* Null the destination if the source is unallocated. */
10150 98 : gfc_init_block (&body);
10151 98 : gfc_conv_descriptor_data_set (&body, dest, null_pointer_node);
10152 98 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10153 : fold_convert (pvoid_type_node,
10154 : gfc_conv_descriptor_data_get (src)),
10155 : null_pointer_node);
10156 98 : return build3_v (COND_EXPR, cond, tmp, gfc_finish_block (&body));
10157 : }
10158 :
10159 :
10160 : static tree
10161 1372 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
10162 : gfc_expr * expr)
10163 : {
10164 1372 : gfc_se se;
10165 1372 : stmtblock_t block;
10166 1372 : tree offset;
10167 1372 : int n;
10168 1372 : tree tmp;
10169 1372 : tree tmp2;
10170 1372 : gfc_array_spec *as;
10171 1372 : gfc_expr *arg = NULL;
10172 :
10173 1372 : gfc_start_block (&block);
10174 1372 : gfc_init_se (&se, NULL);
10175 :
10176 : /* Get the descriptor for the expressions. */
10177 1372 : se.want_pointer = 0;
10178 1372 : gfc_conv_expr_descriptor (&se, expr);
10179 1372 : gfc_add_block_to_block (&block, &se.pre);
10180 1372 : gfc_add_modify (&block, dest, se.expr);
10181 1372 : if (cm->ts.type == BT_CHARACTER
10182 1372 : && gfc_deferred_strlen (cm, &tmp))
10183 : {
10184 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10185 30 : TREE_TYPE (tmp),
10186 30 : TREE_OPERAND (dest, 0),
10187 : tmp, NULL_TREE);
10188 30 : gfc_add_modify (&block, tmp,
10189 30 : fold_convert (TREE_TYPE (tmp),
10190 : se.string_length));
10191 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
10192 : "slen");
10193 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
10194 : }
10195 :
10196 : /* Deal with arrays of derived types with allocatable components. */
10197 1372 : if (gfc_bt_struct (cm->ts.type)
10198 199 : && cm->ts.u.derived->attr.alloc_comp)
10199 : // TODO: Fix caf_mode
10200 113 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
10201 : se.expr, dest,
10202 113 : cm->as->rank, 0);
10203 1259 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
10204 36 : && CLASS_DATA(cm)->attr.allocatable)
10205 : {
10206 36 : if (cm->ts.u.derived->attr.alloc_comp)
10207 : // TODO: Fix caf_mode
10208 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
10209 : se.expr, dest,
10210 : expr->rank, 0);
10211 : else
10212 : {
10213 36 : tmp = TREE_TYPE (dest);
10214 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10215 : tmp, expr->rank, NULL_TREE);
10216 : }
10217 : }
10218 1223 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10219 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10220 : gfc_typenode_for_spec (&cm->ts),
10221 30 : cm->as->rank, NULL_TREE);
10222 1193 : else if (cm->ts.type == BT_CHARACTER)
10223 : /* Explicit-length character: the source element length may differ from
10224 : the component length, so a bitwise duplicate would copy the wrong
10225 : bytes. Copy element by element with padding/truncation. */
10226 98 : tmp = gfc_trans_alloc_char_subarray_assign (dest, cm, se.expr,
10227 : se.string_length,
10228 98 : cm->as->rank);
10229 : else
10230 1095 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10231 1095 : TREE_TYPE(cm->backend_decl),
10232 1095 : cm->as->rank, NULL_TREE);
10233 :
10234 :
10235 1372 : gfc_add_expr_to_block (&block, tmp);
10236 1372 : gfc_add_block_to_block (&block, &se.post);
10237 :
10238 1372 : if (final_block && !cm->attr.allocatable
10239 108 : && expr->expr_type == EXPR_ARRAY)
10240 : {
10241 108 : tree data_ptr;
10242 108 : data_ptr = gfc_conv_descriptor_data_get (dest);
10243 108 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
10244 108 : }
10245 1264 : else if (final_block && cm->attr.allocatable)
10246 162 : gfc_add_block_to_block (final_block, &se.finalblock);
10247 :
10248 1372 : if (expr->expr_type != EXPR_VARIABLE)
10249 : {
10250 1233 : if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp)
10251 : {
10252 214 : tmp = gfc_deallocate_alloc_comp_no_caf (cm->ts.u.derived,
10253 107 : se.expr, cm->as->rank, true);
10254 107 : gfc_add_expr_to_block (&block, tmp);
10255 : }
10256 1233 : gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
10257 : }
10258 :
10259 : /* We need to know if the argument of a conversion function is a
10260 : variable, so that the correct lower bound can be used. */
10261 1372 : if (expr->expr_type == EXPR_FUNCTION
10262 68 : && expr->value.function.isym
10263 56 : && expr->value.function.isym->conversion
10264 56 : && expr->value.function.actual->expr
10265 56 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
10266 56 : arg = expr->value.function.actual->expr;
10267 :
10268 : /* Obtain the array spec of full array references. */
10269 56 : if (arg)
10270 56 : as = gfc_get_full_arrayspec_from_expr (arg);
10271 : else
10272 1316 : as = gfc_get_full_arrayspec_from_expr (expr);
10273 :
10274 : /* Shift the lbound and ubound of temporaries to being unity,
10275 : rather than zero, based. Always calculate the offset. */
10276 1372 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
10277 1372 : offset = gfc_conv_descriptor_offset_get (dest);
10278 1372 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
10279 :
10280 4172 : for (n = 0; n < expr->rank; n++)
10281 : {
10282 1428 : tree span;
10283 1428 : tree lbound;
10284 :
10285 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
10286 : TODO It looks as if gfc_conv_expr_descriptor should return
10287 : the correct bounds and that the following should not be
10288 : necessary. This would simplify gfc_conv_intrinsic_bound
10289 : as well. */
10290 1428 : if (as && as->lower[n])
10291 : {
10292 92 : gfc_se lbse;
10293 92 : gfc_init_se (&lbse, NULL);
10294 92 : gfc_conv_expr (&lbse, as->lower[n]);
10295 92 : gfc_add_block_to_block (&block, &lbse.pre);
10296 92 : lbound = gfc_evaluate_now (lbse.expr, &block);
10297 92 : }
10298 1336 : else if (as && arg)
10299 : {
10300 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
10301 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
10302 : gfc_rank_cst[n]);
10303 : }
10304 1302 : else if (as)
10305 82 : lbound = gfc_conv_descriptor_lbound_get (dest,
10306 : gfc_rank_cst[n]);
10307 : else
10308 1220 : lbound = gfc_index_one_node;
10309 :
10310 1428 : lbound = fold_convert (gfc_array_index_type, lbound);
10311 :
10312 : /* Shift the bounds and set the offset accordingly. */
10313 1428 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
10314 1428 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10315 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
10316 1428 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
10317 : span, lbound);
10318 1428 : gfc_conv_descriptor_ubound_set (&block, dest,
10319 : gfc_rank_cst[n], tmp);
10320 1428 : gfc_conv_descriptor_lbound_set (&block, dest,
10321 : gfc_rank_cst[n], lbound);
10322 :
10323 1428 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10324 : gfc_conv_descriptor_lbound_get (dest,
10325 : gfc_rank_cst[n]),
10326 : gfc_conv_descriptor_stride_get (dest,
10327 : gfc_rank_cst[n]));
10328 1428 : gfc_add_modify (&block, tmp2, tmp);
10329 1428 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10330 : offset, tmp2);
10331 1428 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
10332 : }
10333 :
10334 1372 : if (arg)
10335 : {
10336 : /* If a conversion expression has a null data pointer
10337 : argument, nullify the allocatable component. */
10338 56 : tree non_null_expr;
10339 56 : tree null_expr;
10340 :
10341 56 : if (arg->symtree->n.sym->attr.allocatable
10342 24 : || arg->symtree->n.sym->attr.pointer)
10343 : {
10344 32 : non_null_expr = gfc_finish_block (&block);
10345 32 : gfc_start_block (&block);
10346 32 : gfc_conv_descriptor_data_set (&block, dest,
10347 : null_pointer_node);
10348 32 : null_expr = gfc_finish_block (&block);
10349 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
10350 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
10351 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
10352 32 : return build3_v (COND_EXPR, tmp,
10353 : null_expr, non_null_expr);
10354 : }
10355 : }
10356 :
10357 1340 : return gfc_finish_block (&block);
10358 : }
10359 :
10360 :
10361 : /* Allocate or reallocate scalar component, as necessary. */
10362 :
10363 : static void
10364 464 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
10365 : gfc_component *cm, gfc_expr *expr2,
10366 : tree slen)
10367 : {
10368 464 : tree tmp;
10369 464 : tree ptr;
10370 464 : tree size;
10371 464 : tree size_in_bytes;
10372 464 : tree lhs_cl_size = NULL_TREE;
10373 464 : gfc_se se;
10374 :
10375 464 : if (!comp)
10376 0 : return;
10377 :
10378 464 : if (!expr2 || expr2->rank)
10379 : return;
10380 :
10381 464 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10382 :
10383 464 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10384 : {
10385 145 : gcc_assert (expr2->ts.type == BT_CHARACTER);
10386 145 : size = expr2->ts.u.cl->backend_decl;
10387 145 : if (!size || !VAR_P (size))
10388 145 : size = gfc_create_var (TREE_TYPE (slen), "slen");
10389 145 : gfc_add_modify (block, size, slen);
10390 :
10391 145 : gfc_deferred_strlen (cm, &tmp);
10392 145 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
10393 : gfc_charlen_type_node,
10394 145 : TREE_OPERAND (comp, 0),
10395 : tmp, NULL_TREE);
10396 :
10397 145 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
10398 145 : tmp = TYPE_SIZE_UNIT (tmp);
10399 290 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10400 145 : TREE_TYPE (tmp), tmp,
10401 145 : fold_convert (TREE_TYPE (tmp), size));
10402 : }
10403 319 : else if (cm->ts.type == BT_CLASS)
10404 : {
10405 121 : if (expr2->ts.type != BT_CLASS)
10406 : {
10407 121 : if (expr2->ts.type == BT_CHARACTER)
10408 : {
10409 24 : gfc_init_se (&se, NULL);
10410 24 : gfc_conv_expr (&se, expr2);
10411 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
10412 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10413 : gfc_charlen_type_node,
10414 : se.string_length, size);
10415 24 : size = fold_convert (size_type_node, size);
10416 : }
10417 : else
10418 : {
10419 97 : tmp = gfc_typenode_for_spec (&expr2->ts);
10420 97 : size = TYPE_SIZE_UNIT (tmp);
10421 : }
10422 : }
10423 : else
10424 : {
10425 0 : gfc_expr *e2vtab;
10426 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
10427 0 : gfc_add_vptr_component (e2vtab);
10428 0 : gfc_add_size_component (e2vtab);
10429 0 : gfc_init_se (&se, NULL);
10430 0 : gfc_conv_expr (&se, e2vtab);
10431 0 : gfc_add_block_to_block (block, &se.pre);
10432 0 : size = fold_convert (size_type_node, se.expr);
10433 0 : gfc_free_expr (e2vtab);
10434 : }
10435 : size_in_bytes = size;
10436 : }
10437 : else
10438 : {
10439 : /* Otherwise use the length in bytes of the rhs. */
10440 198 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
10441 198 : size_in_bytes = size;
10442 : }
10443 :
10444 464 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10445 : size_in_bytes, size_one_node);
10446 :
10447 464 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
10448 : {
10449 6 : tmp = build_call_expr_loc (input_location,
10450 : builtin_decl_explicit (BUILT_IN_CALLOC),
10451 : 2, build_one_cst (size_type_node),
10452 : size_in_bytes);
10453 6 : tmp = fold_convert (TREE_TYPE (comp), tmp);
10454 6 : gfc_add_modify (block, comp, tmp);
10455 : }
10456 : else
10457 : {
10458 458 : tmp = build_call_expr_loc (input_location,
10459 : builtin_decl_explicit (BUILT_IN_MALLOC),
10460 : 1, size_in_bytes);
10461 458 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
10462 121 : ptr = gfc_class_data_get (comp);
10463 : else
10464 : ptr = comp;
10465 458 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
10466 458 : gfc_add_modify (block, ptr, tmp);
10467 : }
10468 :
10469 464 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10470 : /* Update the lhs character length. */
10471 145 : gfc_add_modify (block, lhs_cl_size,
10472 145 : fold_convert (TREE_TYPE (lhs_cl_size), size));
10473 : }
10474 :
10475 :
10476 : /* Assign a single component of a derived type constructor. */
10477 :
10478 : static tree
10479 31726 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
10480 : gfc_expr * expr, bool init)
10481 : {
10482 31726 : gfc_se se;
10483 31726 : gfc_se lse;
10484 31726 : stmtblock_t block;
10485 31726 : tree tmp;
10486 31726 : tree vtab;
10487 :
10488 31726 : gfc_start_block (&block);
10489 :
10490 31726 : if (cm->attr.pointer || cm->attr.proc_pointer)
10491 : {
10492 : /* Only care about pointers here, not about allocatables. */
10493 2704 : gfc_init_se (&se, NULL);
10494 : /* Pointer component. */
10495 2704 : if ((cm->attr.dimension || cm->attr.codimension)
10496 682 : && !cm->attr.proc_pointer)
10497 : {
10498 : /* Array pointer. */
10499 666 : if (expr->expr_type == EXPR_NULL)
10500 660 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10501 : else
10502 : {
10503 6 : se.direct_byref = 1;
10504 6 : se.expr = dest;
10505 6 : gfc_conv_expr_descriptor (&se, expr);
10506 6 : gfc_add_block_to_block (&block, &se.pre);
10507 6 : gfc_add_block_to_block (&block, &se.post);
10508 : }
10509 : }
10510 : else
10511 : {
10512 : /* Scalar pointers. */
10513 2038 : se.want_pointer = 1;
10514 2038 : gfc_conv_expr (&se, expr);
10515 2038 : gfc_add_block_to_block (&block, &se.pre);
10516 :
10517 2038 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10518 12 : && expr->symtree->n.sym->attr.dummy)
10519 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10520 :
10521 2038 : gfc_add_modify (&block, dest,
10522 2038 : fold_convert (TREE_TYPE (dest), se.expr));
10523 2038 : gfc_add_block_to_block (&block, &se.post);
10524 : }
10525 : }
10526 29022 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10527 : {
10528 : /* NULL initialization for CLASS components. */
10529 976 : tmp = gfc_trans_structure_assign (dest,
10530 : gfc_class_initializer (&cm->ts, expr),
10531 : false);
10532 976 : gfc_add_expr_to_block (&block, tmp);
10533 : }
10534 28046 : else if (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.class_pointer
10535 30 : && expr->ts.type != BT_CLASS)
10536 : {
10537 : /* Associate a CLASS pointer component with a non-class target. */
10538 30 : gfc_init_se (&se, NULL);
10539 30 : if (CLASS_DATA (cm)->attr.dimension)
10540 : {
10541 12 : se.direct_byref = 1;
10542 12 : se.expr = gfc_class_data_get (dest);
10543 12 : gfc_conv_expr_descriptor (&se, expr);
10544 12 : gfc_add_block_to_block (&block, &se.pre);
10545 : }
10546 : else
10547 : {
10548 18 : gfc_conv_expr_reference (&se, expr);
10549 18 : gfc_add_block_to_block (&block, &se.pre);
10550 18 : tmp = gfc_class_data_get (dest);
10551 18 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), se.expr));
10552 : }
10553 30 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10554 30 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10555 30 : tmp = gfc_class_vptr_get (dest);
10556 30 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), vtab));
10557 30 : if (UNLIMITED_POLY (cm))
10558 : {
10559 18 : tmp = gfc_class_len_get (dest);
10560 18 : gfc_add_modify (&block, tmp,
10561 18 : expr->ts.type == BT_CHARACTER
10562 12 : ? fold_convert (TREE_TYPE (tmp), se.string_length)
10563 6 : : build_zero_cst (TREE_TYPE (tmp)));
10564 : }
10565 30 : gfc_add_block_to_block (&block, &se.post);
10566 : }
10567 28016 : else if ((cm->attr.dimension || cm->attr.codimension)
10568 : && !cm->attr.proc_pointer)
10569 : {
10570 5201 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10571 : {
10572 2879 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10573 2879 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10574 2 : gfc_conv_descriptor_token_set (&block, dest, null_pointer_node);
10575 : }
10576 2322 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10577 : {
10578 1336 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10579 1336 : gfc_add_expr_to_block (&block, tmp);
10580 : }
10581 : else
10582 : {
10583 986 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10584 986 : gfc_add_expr_to_block (&block, tmp);
10585 : }
10586 : }
10587 22815 : else if (cm->ts.type == BT_CLASS
10588 169 : && CLASS_DATA (cm)->attr.dimension
10589 36 : && CLASS_DATA (cm)->attr.allocatable
10590 36 : && expr->ts.type == BT_DERIVED)
10591 : {
10592 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10593 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10594 36 : tmp = gfc_class_vptr_get (dest);
10595 36 : gfc_add_modify (&block, tmp,
10596 36 : fold_convert (TREE_TYPE (tmp), vtab));
10597 36 : tmp = gfc_class_data_get (dest);
10598 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10599 36 : gfc_add_expr_to_block (&block, tmp);
10600 : }
10601 22779 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10602 1862 : && (init
10603 1735 : || (cm->ts.type == BT_CHARACTER
10604 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10605 : {
10606 : /* NULL initialization for allocatable components.
10607 : Deferred-length character is dealt with later. */
10608 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10609 : null_pointer_node));
10610 : }
10611 22628 : else if (init && (cm->attr.allocatable
10612 14339 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10613 133 : && expr->ts.type != BT_CLASS)))
10614 : {
10615 464 : tree size;
10616 464 : tree tmp2;
10617 :
10618 464 : gfc_init_se (&se, NULL);
10619 464 : gfc_conv_expr (&se, expr);
10620 :
10621 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10622 : if (!cm->attr.dimension) part above. */
10623 464 : gfc_add_block_to_block (&block, &se.pre);
10624 : /* Take care about non-array allocatable components here. The alloc_*
10625 : routine below is motivated by the alloc_scalar_allocatable_for_
10626 : assignment() routine, but with the realloc portions removed and
10627 : different input. */
10628 464 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10629 : se.string_length);
10630 :
10631 464 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10632 0 : && expr->symtree->n.sym->attr.dummy)
10633 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10634 :
10635 464 : if (cm->ts.type == BT_CLASS)
10636 : {
10637 121 : tmp = gfc_class_data_get (dest);
10638 121 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10639 121 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10640 121 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10641 121 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10642 121 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10643 : }
10644 : else
10645 343 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10646 :
10647 : /* For deferred strings insert a memcpy. */
10648 464 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10649 : {
10650 145 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10651 145 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10652 : ? se.string_length
10653 0 : : expr->ts.u.cl->backend_decl);
10654 145 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10655 145 : gfc_add_expr_to_block (&block, tmp);
10656 : }
10657 319 : else if (cm->ts.type == BT_CLASS)
10658 : {
10659 : /* Fix the expression for memcpy. */
10660 121 : if (expr->expr_type != EXPR_VARIABLE)
10661 85 : se.expr = gfc_evaluate_now (se.expr, &block);
10662 :
10663 121 : if (expr->ts.type == BT_CHARACTER)
10664 : {
10665 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10666 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10667 : gfc_charlen_type_node,
10668 : se.string_length, size);
10669 24 : size = fold_convert (size_type_node, size);
10670 : }
10671 : else
10672 97 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10673 :
10674 : /* Now copy the expression to the constructor component _data. */
10675 121 : gfc_add_expr_to_block (&block,
10676 : gfc_build_memcpy_call (tmp, se.expr, size));
10677 :
10678 121 : if (expr->ts.type == BT_DERIVED
10679 66 : && expr->ts.u.derived->attr.alloc_comp
10680 6 : && expr->expr_type != EXPR_NULL)
10681 : {
10682 6 : tmp2 = gfc_class_data_get (dest);
10683 6 : tmp2 = gfc_copy_alloc_comp (expr->ts.u.derived, tmp2,
10684 : gfc_class_data_get (dest),
10685 : expr->rank, 0);
10686 6 : gfc_add_expr_to_block (&block, tmp2);
10687 : }
10688 :
10689 : /* Fill the unlimited polymorphic _len field. */
10690 121 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10691 : {
10692 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10693 24 : gfc_add_modify (&block, tmp,
10694 24 : fold_convert (TREE_TYPE (tmp),
10695 : se.string_length));
10696 : }
10697 : }
10698 198 : else if (cm->ts.type == BT_CHARACTER)
10699 : {
10700 : /* Copy into the explicit-length allocatable character component. */
10701 24 : gfc_conv_string_parameter (&se);
10702 24 : gfc_trans_string_copy (&block, cm->ts.u.cl->backend_decl, dest,
10703 : cm->ts.kind, se.string_length, se.expr,
10704 : expr->ts.kind);
10705 : }
10706 : else
10707 : {
10708 174 : gfc_add_modify (&block, tmp,
10709 174 : fold_convert (TREE_TYPE (tmp), se.expr));
10710 174 : if (expr->ts.type == BT_DERIVED
10711 32 : && expr->ts.u.derived->attr.alloc_comp
10712 6 : && expr->expr_type != EXPR_NULL)
10713 : {
10714 6 : tmp2 = build_fold_indirect_ref_loc (input_location, dest);
10715 6 : tmp2 = gfc_copy_alloc_comp (cm->ts.u.derived, tmp2,
10716 : se.expr, expr->rank, 0);
10717 6 : gfc_add_expr_to_block (&block, tmp2);
10718 : }
10719 : }
10720 :
10721 464 : gfc_add_block_to_block (&block, &se.post);
10722 464 : }
10723 22164 : else if (expr->ts.type == BT_UNION)
10724 : {
10725 13 : tree tmp;
10726 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10727 : /* We mark that the entire union should be initialized with a contrived
10728 : EXPR_NULL expression at the beginning. */
10729 13 : if (c != NULL && c->n.component == NULL
10730 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10731 : {
10732 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10733 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10734 6 : gfc_add_expr_to_block (&block, tmp);
10735 6 : c = gfc_constructor_next (c);
10736 : }
10737 : /* The following constructor expression, if any, represents a specific
10738 : map initializer, as given by the user. */
10739 13 : if (c != NULL && c->expr != NULL)
10740 : {
10741 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10742 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10743 6 : gfc_add_expr_to_block (&block, tmp);
10744 : }
10745 : }
10746 22151 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10747 : {
10748 3609 : if (expr->expr_type != EXPR_STRUCTURE)
10749 : {
10750 494 : tree dealloc = NULL_TREE;
10751 494 : gfc_init_se (&se, NULL);
10752 494 : gfc_conv_expr (&se, expr);
10753 494 : gfc_add_block_to_block (&block, &se.pre);
10754 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10755 : expression in a temporary variable and deallocate the allocatable
10756 : components. Then we can the copy the expression to the result. */
10757 494 : if (cm->ts.u.derived->attr.alloc_comp
10758 372 : && expr->expr_type != EXPR_VARIABLE)
10759 : {
10760 336 : se.expr = gfc_evaluate_now (se.expr, &block);
10761 336 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10762 : expr->rank);
10763 : }
10764 494 : gfc_add_modify (&block, dest,
10765 494 : fold_convert (TREE_TYPE (dest), se.expr));
10766 494 : if (cm->ts.u.derived->attr.alloc_comp
10767 372 : && expr->expr_type != EXPR_NULL)
10768 : {
10769 : // TODO: Fix caf_mode
10770 54 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10771 : dest, expr->rank, 0);
10772 54 : gfc_add_expr_to_block (&block, tmp);
10773 54 : if (dealloc != NULL_TREE)
10774 18 : gfc_add_expr_to_block (&block, dealloc);
10775 : }
10776 494 : gfc_add_block_to_block (&block, &se.post);
10777 : }
10778 : else
10779 : {
10780 : /* Nested constructors. */
10781 3115 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10782 3115 : gfc_add_expr_to_block (&block, tmp);
10783 : }
10784 : }
10785 18542 : else if (gfc_deferred_strlen (cm, &tmp))
10786 : {
10787 125 : tree strlen;
10788 125 : strlen = tmp;
10789 125 : gcc_assert (strlen);
10790 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10791 125 : TREE_TYPE (strlen),
10792 125 : TREE_OPERAND (dest, 0),
10793 : strlen, NULL_TREE);
10794 :
10795 125 : if (expr->expr_type == EXPR_NULL)
10796 : {
10797 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10798 107 : gfc_add_modify (&block, dest, tmp);
10799 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10800 107 : gfc_add_modify (&block, strlen, tmp);
10801 : }
10802 : else
10803 : {
10804 18 : tree size;
10805 18 : gfc_init_se (&se, NULL);
10806 18 : gfc_conv_expr (&se, expr);
10807 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10808 18 : size = fold_convert (size_type_node, size);
10809 18 : tmp = build_call_expr_loc (input_location,
10810 : builtin_decl_explicit (BUILT_IN_MALLOC),
10811 : 1, size);
10812 18 : gfc_add_modify (&block, dest,
10813 18 : fold_convert (TREE_TYPE (dest), tmp));
10814 18 : gfc_add_modify (&block, strlen,
10815 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10816 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10817 18 : gfc_add_expr_to_block (&block, tmp);
10818 : }
10819 : }
10820 18417 : else if (cm->ts.type == BT_CLASS
10821 12 : && !CLASS_DATA (cm)->as
10822 12 : && expr->ts.type == BT_CLASS)
10823 : {
10824 12 : tree vptr1, vptr2;
10825 12 : tree data1, data2;
10826 12 : tree size, fcn;
10827 :
10828 12 : gfc_init_se (&se, NULL);
10829 :
10830 12 : gfc_conv_expr (&se, expr);
10831 :
10832 : /* Copy the _vptr to the destination.... */
10833 12 : vptr1 = gfc_class_vptr_get (dest);
10834 12 : vptr2 = gfc_class_vptr_get (se.expr);
10835 12 : gfc_add_modify (&block, vptr1,
10836 12 : fold_convert (TREE_TYPE (vptr1), vptr2));
10837 :
10838 : /* ....and the _len field if necessary. */
10839 12 : size = gfc_vptr_size_get (vptr2);
10840 12 : if (UNLIMITED_POLY (cm) && UNLIMITED_POLY (expr))
10841 : {
10842 0 : gfc_add_modify (&block, gfc_class_len_get (dest),
10843 : gfc_class_len_get (se.expr));
10844 0 : size = gfc_resize_class_size_with_len (&block, se.expr, size);
10845 : }
10846 :
10847 : /* Allocate the destination data. */
10848 12 : data1 = gfc_class_data_get (dest);
10849 12 : data2 = gfc_class_data_get (se.expr);
10850 12 : tmp = gfc_call_malloc (&block, TREE_TYPE (data1), size);
10851 12 : gfc_add_modify (&block, data1, tmp);
10852 :
10853 : /* Now call the copy function. */
10854 12 : fcn = gfc_vptr_copy_get (vptr2);
10855 12 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10856 12 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
10857 12 : tmp = build_call_expr_loc (input_location, fcn, 2,
10858 : data2, data1);
10859 12 : gfc_add_expr_to_block (&block, tmp);
10860 12 : }
10861 18405 : else if (!cm->attr.artificial)
10862 : {
10863 : /* Scalar component (excluding deferred parameters). */
10864 18284 : gfc_init_se (&se, NULL);
10865 18284 : gfc_init_se (&lse, NULL);
10866 :
10867 18284 : gfc_conv_expr (&se, expr);
10868 18284 : if (cm->ts.type == BT_CHARACTER)
10869 1087 : lse.string_length = cm->ts.u.cl->backend_decl;
10870 18284 : lse.expr = dest;
10871 18284 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10872 18284 : gfc_add_expr_to_block (&block, tmp);
10873 : }
10874 31726 : return gfc_finish_block (&block);
10875 : }
10876 :
10877 : /* Assign a derived type constructor to a variable. */
10878 :
10879 : tree
10880 21784 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10881 : {
10882 21784 : gfc_constructor *c;
10883 21784 : gfc_component *cm;
10884 21784 : stmtblock_t block;
10885 21784 : tree field;
10886 21784 : tree tmp;
10887 21784 : gfc_se se;
10888 :
10889 21784 : gfc_start_block (&block);
10890 :
10891 21784 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10892 179 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10893 13 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10894 : {
10895 179 : gfc_se lse;
10896 :
10897 179 : gfc_init_se (&se, NULL);
10898 179 : gfc_init_se (&lse, NULL);
10899 179 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10900 179 : lse.expr = dest;
10901 179 : gfc_add_modify (&block, lse.expr,
10902 179 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10903 :
10904 179 : return gfc_finish_block (&block);
10905 : }
10906 :
10907 : /* Make sure that the derived type has been completely built. */
10908 21605 : if (!expr->ts.u.derived->backend_decl
10909 21605 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10910 : {
10911 230 : tmp = gfc_typenode_for_spec (&expr->ts);
10912 230 : gcc_assert (tmp);
10913 : }
10914 :
10915 21605 : cm = expr->ts.u.derived->components;
10916 :
10917 :
10918 21605 : if (coarray)
10919 225 : gfc_init_se (&se, NULL);
10920 :
10921 21605 : for (c = gfc_constructor_first (expr->value.constructor);
10922 56577 : c; c = gfc_constructor_next (c), cm = cm->next)
10923 : {
10924 : /* Skip absent members in default initializers. */
10925 34972 : if (!c->expr && !cm->attr.allocatable)
10926 3246 : continue;
10927 :
10928 : /* Register the component with the caf-lib before it is initialized.
10929 : Register only allocatable components, that are not coarray'ed
10930 : components (%comp[*]). Only register when the constructor is the
10931 : null-expression. */
10932 31726 : if (coarray && !cm->attr.codimension
10933 515 : && (cm->attr.allocatable || cm->attr.pointer)
10934 179 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10935 : {
10936 177 : tree token, desc, size;
10937 354 : bool is_array = cm->ts.type == BT_CLASS
10938 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10939 :
10940 177 : field = cm->backend_decl;
10941 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
10942 177 : TREE_TYPE (field), dest, field, NULL_TREE);
10943 177 : if (cm->ts.type == BT_CLASS)
10944 0 : field = gfc_class_data_get (field);
10945 :
10946 177 : token
10947 : = is_array
10948 177 : ? gfc_conv_descriptor_token (field)
10949 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10950 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10951 52 : gfc_comp_caf_token (cm), NULL_TREE);
10952 :
10953 177 : if (is_array)
10954 : {
10955 : /* The _caf_register routine looks at the rank of the array
10956 : descriptor to decide whether the data registered is an array
10957 : or not. */
10958 125 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10959 125 : : cm->as->rank;
10960 : /* When the rank is not known just set a positive rank, which
10961 : suffices to recognize the data as array. */
10962 125 : if (rank < 0)
10963 0 : rank = 1;
10964 125 : size = build_zero_cst (size_type_node);
10965 125 : desc = field;
10966 125 : gfc_conv_descriptor_rank_set (&block, desc, rank);
10967 : }
10968 : else
10969 : {
10970 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10971 52 : cm->ts.type == BT_CLASS
10972 52 : ? CLASS_DATA (cm)->attr
10973 : : cm->attr);
10974 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10975 : }
10976 177 : gfc_add_block_to_block (&block, &se.pre);
10977 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10978 : 7, size, build_int_cst (
10979 : integer_type_node,
10980 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10981 : gfc_build_addr_expr (pvoid_type_node,
10982 : token),
10983 : gfc_build_addr_expr (NULL_TREE, desc),
10984 : null_pointer_node, null_pointer_node,
10985 : integer_zero_node);
10986 177 : gfc_add_expr_to_block (&block, tmp);
10987 : }
10988 31726 : field = cm->backend_decl;
10989 31726 : gcc_assert(field);
10990 31726 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10991 : dest, field, NULL_TREE);
10992 31726 : if (!c->expr)
10993 : {
10994 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10995 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10996 0 : gfc_free_expr (e);
10997 : }
10998 : else
10999 31726 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
11000 31726 : gfc_add_expr_to_block (&block, tmp);
11001 : }
11002 21605 : return gfc_finish_block (&block);
11003 : }
11004 :
11005 : static void
11006 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
11007 : gfc_component *un, gfc_expr *init)
11008 : {
11009 21 : gfc_constructor *ctor;
11010 :
11011 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
11012 : return;
11013 :
11014 21 : ctor = gfc_constructor_first (init->value.constructor);
11015 :
11016 21 : if (ctor == NULL || ctor->expr == NULL)
11017 : return;
11018 :
11019 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
11020 :
11021 : /* If we have an 'initialize all' constructor, do it first. */
11022 21 : if (ctor->expr->expr_type == EXPR_NULL)
11023 : {
11024 9 : tree union_type = TREE_TYPE (un->backend_decl);
11025 9 : tree val = build_constructor (union_type, NULL);
11026 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
11027 9 : ctor = gfc_constructor_next (ctor);
11028 : }
11029 :
11030 : /* Add the map initializer on top. */
11031 21 : if (ctor != NULL && ctor->expr != NULL)
11032 : {
11033 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
11034 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
11035 12 : TREE_TYPE (un->backend_decl),
11036 12 : un->attr.dimension, un->attr.pointer,
11037 12 : un->attr.proc_pointer);
11038 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
11039 : }
11040 : }
11041 :
11042 : /* Build an expression for a constructor. If init is nonzero then
11043 : this is part of a static variable initializer. */
11044 :
11045 : void
11046 40049 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
11047 : {
11048 40049 : gfc_constructor *c;
11049 40049 : gfc_component *cm;
11050 40049 : tree val;
11051 40049 : tree type;
11052 40049 : tree tmp;
11053 40049 : vec<constructor_elt, va_gc> *v = NULL;
11054 :
11055 40049 : gcc_assert (se->ss == NULL);
11056 40049 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
11057 40049 : type = gfc_typenode_for_spec (&expr->ts);
11058 :
11059 40049 : if (!init)
11060 : {
11061 16848 : if (IS_PDT (expr) && expr->must_finalize)
11062 288 : final_block = &se->finalblock;
11063 :
11064 : /* Create a temporary variable and fill it in. */
11065 16848 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
11066 : /* The symtree in expr is NULL, if the code to generate is for
11067 : initializing the static members only. */
11068 33696 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
11069 16848 : se->want_coarray);
11070 16848 : gfc_add_expr_to_block (&se->pre, tmp);
11071 16848 : final_block = NULL;
11072 16848 : return;
11073 : }
11074 :
11075 23201 : cm = expr->ts.u.derived->components;
11076 :
11077 23201 : for (c = gfc_constructor_first (expr->value.constructor);
11078 118887 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
11079 : {
11080 : /* Skip absent members in default initializers and allocatable
11081 : components. Although the latter have a default initializer
11082 : of EXPR_NULL,... by default, the static nullify is not needed
11083 : since this is done every time we come into scope. */
11084 104731 : if (!c->expr
11085 93227 : || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)
11086 182495 : || (IS_PDT (cm) && has_parameterized_comps (cm->ts.u.derived)))
11087 9045 : continue;
11088 :
11089 86641 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
11090 50395 : && strcmp (cm->name, "_extends") == 0
11091 1411 : && cm->initializer->symtree)
11092 : {
11093 1411 : tree vtab;
11094 1411 : gfc_symbol *vtabs;
11095 1411 : vtabs = cm->initializer->symtree->n.sym;
11096 1411 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
11097 1411 : vtab = unshare_expr_without_location (vtab);
11098 1411 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
11099 1411 : }
11100 85230 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
11101 : {
11102 9243 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
11103 9243 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
11104 : fold_convert (TREE_TYPE (cm->backend_decl),
11105 : val));
11106 9243 : }
11107 75987 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
11108 449 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
11109 : fold_convert (TREE_TYPE (cm->backend_decl),
11110 449 : integer_zero_node));
11111 75538 : else if (cm->ts.type == BT_UNION)
11112 21 : gfc_conv_union_initializer (v, cm, c->expr);
11113 : else
11114 : {
11115 75517 : val = gfc_conv_initializer (c->expr, &cm->ts,
11116 75517 : TREE_TYPE (cm->backend_decl),
11117 75517 : cm->attr.dimension, cm->attr.pointer,
11118 75517 : cm->attr.proc_pointer);
11119 75517 : val = unshare_expr_without_location (val);
11120 :
11121 : /* Append it to the constructor list. */
11122 171203 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
11123 : }
11124 : }
11125 :
11126 23201 : se->expr = build_constructor (type, v);
11127 23201 : if (init)
11128 23201 : TREE_CONSTANT (se->expr) = 1;
11129 : }
11130 :
11131 :
11132 : /* Translate a substring expression. */
11133 :
11134 : static void
11135 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
11136 : {
11137 258 : gfc_ref *ref;
11138 :
11139 258 : ref = expr->ref;
11140 :
11141 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
11142 :
11143 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
11144 258 : expr->value.character.length,
11145 258 : expr->value.character.string);
11146 :
11147 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
11148 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
11149 :
11150 258 : if (ref)
11151 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
11152 258 : }
11153 :
11154 :
11155 : /* Entry point for expression translation. Evaluates a scalar quantity.
11156 : EXPR is the expression to be translated, and SE is the state structure if
11157 : called from within the scalarized. */
11158 :
11159 : void
11160 3726516 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
11161 : {
11162 3726516 : gfc_ss *ss;
11163 :
11164 3726516 : ss = se->ss;
11165 3726516 : if (ss && ss->info->expr == expr
11166 243932 : && (ss->info->type == GFC_SS_SCALAR
11167 : || ss->info->type == GFC_SS_REFERENCE))
11168 : {
11169 41248 : gfc_ss_info *ss_info;
11170 :
11171 41248 : ss_info = ss->info;
11172 : /* Substitute a scalar expression evaluated outside the scalarization
11173 : loop. */
11174 41248 : se->expr = ss_info->data.scalar.value;
11175 41248 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
11176 844 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
11177 :
11178 41248 : se->string_length = ss_info->string_length;
11179 41248 : gfc_advance_se_ss_chain (se);
11180 41248 : return;
11181 : }
11182 :
11183 : /* We need to convert the expressions for the iso_c_binding derived types.
11184 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
11185 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
11186 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
11187 : updated to be an integer with a kind equal to the size of a (void *). */
11188 3685268 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
11189 14938 : && expr->ts.u.derived->attr.is_bind_c)
11190 : {
11191 14029 : if (expr->expr_type == EXPR_VARIABLE
11192 9572 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
11193 9572 : || expr->symtree->n.sym->intmod_sym_id
11194 : == ISOCBINDING_NULL_FUNPTR))
11195 : {
11196 : /* Set expr_type to EXPR_NULL, which will result in
11197 : null_pointer_node being used below. */
11198 0 : expr->expr_type = EXPR_NULL;
11199 : }
11200 : else
11201 : {
11202 : /* Update the type/kind of the expression to be what the new
11203 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
11204 14029 : expr->ts.type = BT_INTEGER;
11205 14029 : expr->ts.f90_type = BT_VOID;
11206 14029 : expr->ts.kind = gfc_index_integer_kind;
11207 : }
11208 : }
11209 :
11210 3685268 : gfc_fix_class_refs (expr);
11211 :
11212 3685268 : switch (expr->expr_type)
11213 : {
11214 514194 : case EXPR_OP:
11215 514194 : gfc_conv_expr_op (se, expr);
11216 514194 : break;
11217 :
11218 159 : case EXPR_CONDITIONAL:
11219 159 : gfc_conv_conditional_expr (se, expr);
11220 159 : break;
11221 :
11222 313199 : case EXPR_FUNCTION:
11223 313199 : gfc_conv_function_expr (se, expr);
11224 313199 : break;
11225 :
11226 1160776 : case EXPR_CONSTANT:
11227 1160776 : gfc_conv_constant (se, expr);
11228 1160776 : break;
11229 :
11230 1638676 : case EXPR_VARIABLE:
11231 1638676 : gfc_conv_variable (se, expr);
11232 1638676 : break;
11233 :
11234 4338 : case EXPR_NULL:
11235 4338 : se->expr = null_pointer_node;
11236 4338 : break;
11237 :
11238 258 : case EXPR_SUBSTRING:
11239 258 : gfc_conv_substring_expr (se, expr);
11240 258 : break;
11241 :
11242 16848 : case EXPR_STRUCTURE:
11243 16848 : gfc_conv_structure (se, expr, 0);
11244 : /* F2008 4.5.6.3 para 5: If an executable construct references a
11245 : structure constructor or array constructor, the entity created by
11246 : the constructor is finalized after execution of the innermost
11247 : executable construct containing the reference. This, in fact,
11248 : was later deleted by the Combined Technical Corrigenda 1 TO 4 for
11249 : fortran 2008 (f08/0011). */
11250 16848 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
11251 16848 : && !(gfc_option.allow_std & GFC_STD_GNU)
11252 139 : && expr->must_finalize
11253 16860 : && gfc_may_be_finalized (expr->ts))
11254 : {
11255 12 : locus loc;
11256 12 : gfc_locus_from_location (&loc, input_location);
11257 12 : gfc_warning (0, "The structure constructor at %L has been"
11258 : " finalized. This feature was removed by f08/0011."
11259 : " Use -std=f2018 or -std=gnu to eliminate the"
11260 : " finalization.", &loc);
11261 12 : symbol_attribute attr;
11262 12 : attr.allocatable = attr.pointer = 0;
11263 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
11264 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
11265 : }
11266 : break;
11267 :
11268 36820 : case EXPR_ARRAY:
11269 36820 : gfc_conv_array_constructor_expr (se, expr);
11270 36820 : gfc_add_block_to_block (&se->post, &se->finalblock);
11271 36820 : break;
11272 :
11273 0 : default:
11274 0 : gcc_unreachable ();
11275 3726516 : break;
11276 : }
11277 : }
11278 :
11279 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
11280 : of an assignment. */
11281 : void
11282 382372 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
11283 : {
11284 382372 : gfc_conv_expr (se, expr);
11285 : /* All numeric lvalues should have empty post chains. If not we need to
11286 : figure out a way of rewriting an lvalue so that it has no post chain. */
11287 382372 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
11288 382372 : }
11289 :
11290 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
11291 : numeric expressions. Used for scalar values where inserting cleanup code
11292 : is inconvenient. */
11293 : void
11294 1055061 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
11295 : {
11296 1055061 : tree val;
11297 :
11298 1055061 : gcc_assert (expr->ts.type != BT_CHARACTER);
11299 1055061 : gfc_conv_expr (se, expr);
11300 1055061 : if (se->post.head)
11301 : {
11302 2625 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
11303 2625 : gfc_add_modify (&se->pre, val, se->expr);
11304 2625 : se->expr = val;
11305 2625 : gfc_add_block_to_block (&se->pre, &se->post);
11306 : }
11307 1055061 : }
11308 :
11309 : /* Helper to translate an expression and convert it to a particular type. */
11310 : void
11311 299850 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
11312 : {
11313 299850 : gfc_conv_expr_val (se, expr);
11314 299850 : se->expr = convert (type, se->expr);
11315 299850 : }
11316 :
11317 :
11318 : /* Converts an expression so that it can be passed by reference. Scalar
11319 : values only. */
11320 :
11321 : void
11322 231130 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
11323 : {
11324 231130 : gfc_ss *ss;
11325 231130 : tree var;
11326 :
11327 231130 : ss = se->ss;
11328 231130 : if (ss && ss->info->expr == expr
11329 8065 : && ss->info->type == GFC_SS_REFERENCE)
11330 : {
11331 : /* Returns a reference to the scalar evaluated outside the loop
11332 : for this case. */
11333 907 : gfc_conv_expr (se, expr);
11334 :
11335 907 : if (expr->ts.type == BT_CHARACTER
11336 114 : && expr->expr_type != EXPR_FUNCTION)
11337 102 : gfc_conv_string_parameter (se);
11338 : else
11339 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11340 :
11341 : return;
11342 : }
11343 :
11344 230223 : if (expr->ts.type == BT_CHARACTER)
11345 : {
11346 50076 : gfc_conv_expr (se, expr);
11347 50076 : gfc_conv_string_parameter (se);
11348 50076 : return;
11349 : }
11350 :
11351 180147 : if (expr->expr_type == EXPR_VARIABLE)
11352 : {
11353 71975 : se->want_pointer = 1;
11354 71975 : gfc_conv_expr (se, expr);
11355 71975 : if (se->post.head)
11356 : {
11357 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11358 0 : gfc_add_modify (&se->pre, var, se->expr);
11359 0 : gfc_add_block_to_block (&se->pre, &se->post);
11360 0 : se->expr = var;
11361 : }
11362 : return;
11363 : }
11364 :
11365 108172 : if (expr->expr_type == EXPR_CONDITIONAL)
11366 : {
11367 18 : se->want_pointer = 1;
11368 18 : gfc_conv_expr (se, expr);
11369 18 : return;
11370 : }
11371 :
11372 108154 : if (expr->expr_type == EXPR_FUNCTION
11373 13930 : && ((expr->value.function.esym
11374 2107 : && expr->value.function.esym->result
11375 2106 : && expr->value.function.esym->result->attr.pointer
11376 83 : && !expr->value.function.esym->result->attr.dimension)
11377 13853 : || (!expr->value.function.esym && !expr->ref
11378 11717 : && expr->symtree->n.sym->attr.pointer
11379 0 : && !expr->symtree->n.sym->attr.dimension)))
11380 : {
11381 77 : se->want_pointer = 1;
11382 77 : gfc_conv_expr (se, expr);
11383 77 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11384 77 : gfc_add_modify (&se->pre, var, se->expr);
11385 77 : se->expr = var;
11386 77 : return;
11387 : }
11388 :
11389 108077 : gfc_conv_expr (se, expr);
11390 :
11391 : /* Create a temporary var to hold the value. */
11392 108077 : if (TREE_CONSTANT (se->expr))
11393 : {
11394 : tree tmp = se->expr;
11395 85508 : STRIP_TYPE_NOPS (tmp);
11396 85508 : var = build_decl (input_location,
11397 85508 : CONST_DECL, NULL, TREE_TYPE (tmp));
11398 85508 : DECL_INITIAL (var) = tmp;
11399 85508 : TREE_STATIC (var) = 1;
11400 85508 : pushdecl (var);
11401 : }
11402 : else
11403 : {
11404 22569 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11405 22569 : gfc_add_modify (&se->pre, var, se->expr);
11406 : }
11407 :
11408 108077 : if (!expr->must_finalize)
11409 107981 : gfc_add_block_to_block (&se->pre, &se->post);
11410 :
11411 : /* Take the address of that value. */
11412 108077 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
11413 : }
11414 :
11415 :
11416 : /* Get the _len component for an unlimited polymorphic expression. */
11417 :
11418 : static tree
11419 1974 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
11420 : {
11421 1974 : gfc_se se;
11422 1974 : gfc_ref *ref = expr->ref;
11423 :
11424 1974 : gfc_init_se (&se, NULL);
11425 4062 : while (ref && ref->next)
11426 : ref = ref->next;
11427 1974 : gfc_add_len_component (expr);
11428 1974 : gfc_conv_expr (&se, expr);
11429 1974 : gfc_add_block_to_block (block, &se.pre);
11430 1974 : gcc_assert (se.post.head == NULL_TREE);
11431 1974 : if (ref)
11432 : {
11433 298 : gfc_free_ref_list (ref->next);
11434 298 : ref->next = NULL;
11435 : }
11436 : else
11437 : {
11438 1676 : gfc_free_ref_list (expr->ref);
11439 1676 : expr->ref = NULL;
11440 : }
11441 1974 : return se.expr;
11442 : }
11443 :
11444 :
11445 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
11446 : statement-list outside of the scalarizer-loop. When code is generated, that
11447 : depends on the scalarized expression, it is added to RSE.PRE.
11448 : Returns le's _vptr tree and when set the len expressions in to_lenp and
11449 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
11450 : expression. */
11451 :
11452 : static tree
11453 4830 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
11454 : gfc_expr * re, gfc_se *rse,
11455 : tree * to_lenp, tree * from_lenp,
11456 : tree * from_vptrp)
11457 : {
11458 4830 : gfc_se se;
11459 4830 : gfc_expr * vptr_expr;
11460 4830 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
11461 4830 : bool set_vptr = false, temp_rhs = false;
11462 4830 : stmtblock_t *pre = block;
11463 4830 : tree class_expr = NULL_TREE;
11464 4830 : tree from_vptr = NULL_TREE;
11465 :
11466 : /* Create a temporary for complicated expressions. */
11467 4830 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
11468 1359 : && rse->expr != NULL_TREE)
11469 : {
11470 1359 : if (!DECL_P (rse->expr))
11471 : {
11472 410 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11473 37 : class_expr = gfc_get_class_from_expr (rse->expr);
11474 :
11475 410 : if (rse->loop)
11476 159 : pre = &rse->loop->pre;
11477 : else
11478 251 : pre = &rse->pre;
11479 :
11480 410 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
11481 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
11482 : else
11483 373 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
11484 :
11485 410 : rse->expr = tmp;
11486 : }
11487 : else
11488 949 : pre = &rse->pre;
11489 :
11490 : temp_rhs = true;
11491 : }
11492 :
11493 : /* Get the _vptr for the left-hand side expression. */
11494 4830 : gfc_init_se (&se, NULL);
11495 4830 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
11496 4830 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
11497 : {
11498 : /* Care about _len for unlimited polymorphic entities. */
11499 4830 : if (UNLIMITED_POLY (vptr_expr)
11500 3738 : || (vptr_expr->ts.type == BT_DERIVED
11501 2611 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11502 1642 : to_len = trans_get_upoly_len (block, vptr_expr);
11503 4830 : gfc_add_vptr_component (vptr_expr);
11504 4830 : set_vptr = true;
11505 : }
11506 : else
11507 0 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11508 4830 : se.want_pointer = 1;
11509 4830 : gfc_conv_expr (&se, vptr_expr);
11510 4830 : gfc_free_expr (vptr_expr);
11511 4830 : gfc_add_block_to_block (block, &se.pre);
11512 4830 : gcc_assert (se.post.head == NULL_TREE);
11513 4830 : lhs_vptr = se.expr;
11514 4830 : STRIP_NOPS (lhs_vptr);
11515 :
11516 : /* Set the _vptr only when the left-hand side of the assignment is a
11517 : class-object. */
11518 4830 : if (set_vptr)
11519 : {
11520 : /* Get the vptr from the rhs expression only, when it is variable.
11521 : Functions are expected to be assigned to a temporary beforehand. */
11522 3342 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
11523 5720 : ? gfc_find_and_cut_at_last_class_ref (re)
11524 : : NULL;
11525 890 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
11526 : {
11527 890 : if (to_len != NULL_TREE)
11528 : {
11529 : /* Get the _len information from the rhs. */
11530 347 : if (UNLIMITED_POLY (vptr_expr)
11531 : || (vptr_expr->ts.type == BT_DERIVED
11532 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11533 320 : from_len = trans_get_upoly_len (block, vptr_expr);
11534 : }
11535 890 : gfc_add_vptr_component (vptr_expr);
11536 : }
11537 : else
11538 : {
11539 3940 : if (re->expr_type == EXPR_VARIABLE
11540 2452 : && DECL_P (re->symtree->n.sym->backend_decl)
11541 2452 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
11542 834 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
11543 4007 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
11544 : re->symtree->n.sym->backend_decl))))
11545 : {
11546 43 : vptr_expr = NULL;
11547 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
11548 : re->symtree->n.sym->backend_decl));
11549 43 : if (to_len && UNLIMITED_POLY (re))
11550 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
11551 : re->symtree->n.sym->backend_decl));
11552 : }
11553 3897 : else if (temp_rhs && re->ts.type == BT_CLASS)
11554 : {
11555 245 : vptr_expr = NULL;
11556 245 : if (class_expr)
11557 : tmp = class_expr;
11558 208 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11559 0 : tmp = gfc_get_class_from_expr (rse->expr);
11560 : else
11561 : tmp = rse->expr;
11562 :
11563 245 : se.expr = gfc_class_vptr_get (tmp);
11564 245 : from_vptr = se.expr;
11565 245 : if (UNLIMITED_POLY (re))
11566 86 : from_len = gfc_class_len_get (tmp);
11567 :
11568 : }
11569 3652 : else if (re->expr_type != EXPR_NULL)
11570 : /* Only when rhs is non-NULL use its declared type for vptr
11571 : initialisation. */
11572 3523 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
11573 : else
11574 : /* When the rhs is NULL use the vtab of lhs' declared type. */
11575 129 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11576 : }
11577 :
11578 4628 : if (vptr_expr)
11579 : {
11580 4542 : gfc_init_se (&se, NULL);
11581 4542 : se.want_pointer = 1;
11582 4542 : gfc_conv_expr (&se, vptr_expr);
11583 4542 : gfc_free_expr (vptr_expr);
11584 4542 : gfc_add_block_to_block (block, &se.pre);
11585 4542 : gcc_assert (se.post.head == NULL_TREE);
11586 4542 : from_vptr = se.expr;
11587 : }
11588 4830 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
11589 : se.expr));
11590 :
11591 4830 : if (to_len != NULL_TREE)
11592 : {
11593 : /* The _len component needs to be set. Figure how to get the
11594 : value of the right-hand side. */
11595 1642 : if (from_len == NULL_TREE)
11596 : {
11597 1236 : if (rse->string_length != NULL_TREE)
11598 : from_len = rse->string_length;
11599 778 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
11600 : {
11601 0 : gfc_init_se (&se, NULL);
11602 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
11603 0 : gfc_add_block_to_block (block, &se.pre);
11604 0 : gcc_assert (se.post.head == NULL_TREE);
11605 0 : from_len = gfc_evaluate_now (se.expr, block);
11606 : }
11607 : else
11608 778 : from_len = build_zero_cst (gfc_charlen_type_node);
11609 : }
11610 1642 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
11611 : from_len));
11612 : }
11613 : }
11614 :
11615 : /* Return the _len and _vptr trees only, when requested. */
11616 4830 : if (to_lenp)
11617 3554 : *to_lenp = to_len;
11618 4830 : if (from_lenp)
11619 3554 : *from_lenp = from_len;
11620 4830 : if (from_vptrp)
11621 3554 : *from_vptrp = from_vptr;
11622 4830 : return lhs_vptr;
11623 : }
11624 :
11625 :
11626 : /* Assign tokens for pointer components. */
11627 :
11628 : static void
11629 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11630 : gfc_expr *expr2)
11631 : {
11632 12 : symbol_attribute lhs_attr, rhs_attr;
11633 12 : tree tmp, lhs_tok, rhs_tok;
11634 : /* Flag to indicated component refs on the rhs. */
11635 12 : bool rhs_cr;
11636 :
11637 12 : lhs_attr = gfc_caf_attr (expr1);
11638 12 : if (expr2->expr_type != EXPR_NULL)
11639 : {
11640 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11641 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11642 : {
11643 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11644 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11645 :
11646 4 : if (rhs_cr)
11647 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11648 : else
11649 : {
11650 4 : tree caf_decl;
11651 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11652 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11653 : NULL_TREE, NULL);
11654 : }
11655 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11656 : lhs_tok,
11657 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11658 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11659 : }
11660 : }
11661 4 : else if (lhs_attr.codimension)
11662 : {
11663 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11664 4 : if (!lhs_tok)
11665 : {
11666 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11667 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11668 : }
11669 : else
11670 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11671 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11672 : lhs_tok, null_pointer_node);
11673 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11674 : }
11675 12 : }
11676 :
11677 :
11678 : /* Do everything that is needed for a CLASS function expr2. */
11679 :
11680 : static tree
11681 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11682 : gfc_expr *expr1, gfc_expr *expr2)
11683 : {
11684 18 : tree expr1_vptr = NULL_TREE;
11685 18 : tree tmp;
11686 :
11687 18 : gfc_conv_function_expr (rse, expr2);
11688 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11689 :
11690 18 : if (expr1->ts.type != BT_CLASS)
11691 12 : rse->expr = gfc_class_data_get (rse->expr);
11692 : else
11693 : {
11694 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11695 : expr2, rse,
11696 : NULL, NULL, NULL);
11697 6 : gfc_add_block_to_block (block, &rse->pre);
11698 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11699 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11700 :
11701 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11702 6 : fold_convert (TREE_TYPE (expr1_vptr),
11703 : gfc_class_vptr_get (tmp)));
11704 6 : rse->expr = gfc_class_data_get (tmp);
11705 : }
11706 :
11707 18 : return expr1_vptr;
11708 : }
11709 :
11710 :
11711 : tree
11712 10435 : gfc_trans_pointer_assign (gfc_code * code)
11713 : {
11714 10435 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11715 : }
11716 :
11717 :
11718 : /* Generate code for a pointer assignment. */
11719 :
11720 : tree
11721 10490 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11722 : {
11723 10490 : gfc_se lse;
11724 10490 : gfc_se rse;
11725 10490 : stmtblock_t block;
11726 10490 : tree desc;
11727 10490 : tree tmp;
11728 10490 : tree expr1_vptr = NULL_TREE;
11729 10490 : bool scalar, non_proc_ptr_assign;
11730 10490 : gfc_ss *ss;
11731 :
11732 10490 : gfc_start_block (&block);
11733 :
11734 10490 : gfc_init_se (&lse, NULL);
11735 :
11736 : /* Usually testing whether this is not a proc pointer assignment. */
11737 10490 : non_proc_ptr_assign
11738 10490 : = !(gfc_expr_attr (expr1).proc_pointer
11739 1225 : && ((expr2->expr_type == EXPR_VARIABLE
11740 987 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11741 288 : || expr2->expr_type == EXPR_NULL));
11742 :
11743 : /* Check whether the expression is a scalar or not; we cannot use
11744 : expr1->rank as it can be nonzero for proc pointers. */
11745 10490 : ss = gfc_walk_expr (expr1);
11746 10490 : scalar = ss == gfc_ss_terminator;
11747 10490 : if (!scalar)
11748 4600 : gfc_free_ss_chain (ss);
11749 :
11750 10490 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11751 96 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11752 : {
11753 72 : gfc_add_data_component (expr2);
11754 : /* The following is required as gfc_add_data_component doesn't
11755 : update ts.type if there is a trailing REF_ARRAY. */
11756 72 : expr2->ts.type = BT_DERIVED;
11757 : }
11758 :
11759 10490 : if (scalar)
11760 : {
11761 : /* Scalar pointers. */
11762 5890 : lse.want_pointer = 1;
11763 5890 : gfc_conv_expr (&lse, expr1);
11764 5890 : gfc_init_se (&rse, NULL);
11765 5890 : rse.want_pointer = 1;
11766 5890 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11767 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11768 : else
11769 5884 : gfc_conv_expr (&rse, expr2);
11770 :
11771 5890 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11772 : {
11773 769 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11774 : NULL, NULL);
11775 769 : lse.expr = gfc_class_data_get (lse.expr);
11776 : }
11777 :
11778 5890 : if (expr1->symtree->n.sym->attr.proc_pointer
11779 863 : && expr1->symtree->n.sym->attr.dummy)
11780 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11781 : lse.expr);
11782 :
11783 5890 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11784 47 : && expr2->symtree->n.sym->attr.dummy)
11785 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11786 : rse.expr);
11787 :
11788 5890 : gfc_add_block_to_block (&block, &lse.pre);
11789 5890 : gfc_add_block_to_block (&block, &rse.pre);
11790 :
11791 : /* Check character lengths if character expression. The test is only
11792 : really added if -fbounds-check is enabled. Exclude deferred
11793 : character length lefthand sides. */
11794 960 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11795 786 : && !expr1->ts.deferred
11796 371 : && !expr1->symtree->n.sym->attr.proc_pointer
11797 6254 : && !gfc_is_proc_ptr_comp (expr1))
11798 : {
11799 345 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11800 345 : gcc_assert (lse.string_length && rse.string_length);
11801 345 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11802 : lse.string_length, rse.string_length,
11803 : &block);
11804 : }
11805 :
11806 : /* The assignment to an deferred character length sets the string
11807 : length to that of the rhs. */
11808 5890 : if (expr1->ts.deferred)
11809 : {
11810 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11811 413 : gfc_add_modify (&block, lse.string_length,
11812 413 : fold_convert (TREE_TYPE (lse.string_length),
11813 : rse.string_length));
11814 117 : else if (lse.string_length != NULL)
11815 115 : gfc_add_modify (&block, lse.string_length,
11816 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11817 : }
11818 :
11819 5890 : gfc_add_modify (&block, lse.expr,
11820 5890 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11821 :
11822 5890 : if (flag_coarray == GFC_FCOARRAY_LIB)
11823 : {
11824 350 : if (expr1->ref)
11825 : /* Also set the tokens for pointer components in derived typed
11826 : coarrays. */
11827 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11828 338 : else if (gfc_caf_attr (expr1).codimension)
11829 : {
11830 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11831 :
11832 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11833 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11834 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11835 : NULL_TREE, expr1);
11836 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11837 : NULL_TREE, expr2);
11838 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11839 : }
11840 : }
11841 :
11842 5890 : gfc_add_block_to_block (&block, &rse.post);
11843 5890 : gfc_add_block_to_block (&block, &lse.post);
11844 : }
11845 : else
11846 : {
11847 4600 : gfc_ref* remap;
11848 4600 : bool rank_remap;
11849 4600 : tree strlen_lhs;
11850 4600 : tree strlen_rhs = NULL_TREE;
11851 :
11852 : /* Array pointer. Find the last reference on the LHS and if it is an
11853 : array section ref, we're dealing with bounds remapping. In this case,
11854 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11855 : not see it and process the bounds remapping afterwards explicitly. */
11856 10238 : for (remap = expr1->ref; remap; remap = remap->next)
11857 6017 : if (!remap->next && remap->type == REF_ARRAY
11858 4600 : && remap->u.ar.type == AR_SECTION)
11859 : break;
11860 4600 : rank_remap = (remap && remap->u.ar.end[0]);
11861 :
11862 379 : if (remap && expr2->expr_type == EXPR_NULL)
11863 : {
11864 2 : gfc_error ("If bounds remapping is specified at %L, "
11865 : "the pointer target shall not be NULL", &expr1->where);
11866 2 : return NULL_TREE;
11867 : }
11868 :
11869 4598 : gfc_init_se (&lse, NULL);
11870 4598 : if (remap)
11871 377 : lse.descriptor_only = 1;
11872 4598 : gfc_conv_expr_descriptor (&lse, expr1);
11873 4598 : strlen_lhs = lse.string_length;
11874 4598 : desc = lse.expr;
11875 :
11876 4598 : if (expr2->expr_type == EXPR_NULL)
11877 : {
11878 : /* Just set the data pointer to null. */
11879 692 : gfc_nullify_descriptor (&lse.pre, lse.expr);
11880 : }
11881 3906 : else if (rank_remap)
11882 : {
11883 : /* If we are rank-remapping, just get the RHS's descriptor and
11884 : process this later on. */
11885 254 : gfc_init_se (&rse, NULL);
11886 254 : rse.direct_byref = 1;
11887 254 : rse.byref_noassign = 1;
11888 :
11889 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11890 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11891 : expr1, expr2);
11892 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11893 : {
11894 : tree bound[GFC_MAX_DIMENSIONS];
11895 : int i;
11896 :
11897 26 : for (i = 0; i < expr2->rank; i++)
11898 13 : bound[i] = NULL_TREE;
11899 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11900 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11901 : bound, bound, 0,
11902 : GFC_ARRAY_POINTER_CONT, false);
11903 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11904 13 : rse.descriptor_only = 0;
11905 13 : rse.expr = tmp;
11906 13 : rse.direct_byref = 1;
11907 13 : gfc_conv_expr_descriptor (&rse, expr2);
11908 13 : strlen_rhs = rse.string_length;
11909 13 : rse.expr = tmp;
11910 : }
11911 : else
11912 : {
11913 229 : gfc_conv_expr_descriptor (&rse, expr2);
11914 229 : strlen_rhs = rse.string_length;
11915 229 : if (expr1->ts.type == BT_CLASS)
11916 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11917 : expr2, &rse,
11918 : NULL, NULL,
11919 : NULL);
11920 : }
11921 : }
11922 3652 : else if (expr2->expr_type == EXPR_VARIABLE)
11923 : {
11924 : /* Assign directly to the LHS's descriptor. */
11925 3502 : lse.descriptor_only = 0;
11926 3502 : lse.direct_byref = 1;
11927 3502 : gfc_conv_expr_descriptor (&lse, expr2);
11928 3502 : strlen_rhs = lse.string_length;
11929 3502 : gfc_init_se (&rse, NULL);
11930 :
11931 3502 : if (expr1->ts.type == BT_CLASS)
11932 : {
11933 422 : rse.expr = NULL_TREE;
11934 422 : rse.string_length = strlen_rhs;
11935 422 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11936 : NULL, NULL, NULL);
11937 : }
11938 :
11939 3502 : if (remap == NULL)
11940 : {
11941 : /* If the target is not a whole array, use the target array
11942 : reference for remap. */
11943 7105 : for (remap = expr2->ref; remap; remap = remap->next)
11944 3984 : if (remap->type == REF_ARRAY
11945 3439 : && remap->u.ar.type == AR_FULL
11946 2740 : && remap->next)
11947 : break;
11948 : }
11949 : }
11950 150 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11951 : {
11952 31 : gfc_init_se (&rse, NULL);
11953 31 : rse.want_pointer = 1;
11954 31 : gfc_conv_function_expr (&rse, expr2);
11955 31 : if (expr1->ts.type != BT_CLASS)
11956 : {
11957 12 : rse.expr = gfc_class_data_get (rse.expr);
11958 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11959 : }
11960 : else
11961 : {
11962 19 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11963 : expr2, &rse, NULL,
11964 : NULL, NULL);
11965 19 : gfc_add_block_to_block (&block, &rse.pre);
11966 19 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11967 19 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11968 :
11969 38 : gfc_add_modify (&lse.pre, expr1_vptr,
11970 19 : fold_convert (TREE_TYPE (expr1_vptr),
11971 : gfc_class_vptr_get (tmp)));
11972 19 : rse.expr = gfc_class_data_get (tmp);
11973 19 : gfc_add_modify (&lse.pre, desc, rse.expr);
11974 : }
11975 : }
11976 : else
11977 : {
11978 : /* Assign to a temporary descriptor and then copy that
11979 : temporary to the pointer. */
11980 119 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11981 119 : lse.descriptor_only = 0;
11982 119 : lse.expr = tmp;
11983 119 : lse.direct_byref = 1;
11984 119 : gfc_conv_expr_descriptor (&lse, expr2);
11985 119 : strlen_rhs = lse.string_length;
11986 119 : gfc_add_modify (&lse.pre, desc, tmp);
11987 : }
11988 :
11989 4598 : if (expr1->ts.type == BT_CHARACTER
11990 620 : && expr1->ts.deferred)
11991 : {
11992 344 : gfc_symbol *psym = expr1->symtree->n.sym;
11993 344 : tmp = NULL_TREE;
11994 344 : if (psym->ts.type == BT_CHARACTER
11995 343 : && psym->ts.u.cl->backend_decl)
11996 343 : tmp = psym->ts.u.cl->backend_decl;
11997 1 : else if (expr1->ts.u.cl->backend_decl
11998 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11999 0 : tmp = expr1->ts.u.cl->backend_decl;
12000 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
12001 : {
12002 1 : gfc_ref *ref = expr1->ref;
12003 3 : for (;ref; ref = ref->next)
12004 : {
12005 2 : if (ref->type == REF_COMPONENT
12006 1 : && ref->u.c.component->ts.type == BT_CHARACTER
12007 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
12008 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
12009 1 : TREE_TYPE (tmp),
12010 1 : TREE_OPERAND (lse.expr, 0),
12011 : tmp, NULL_TREE);
12012 : }
12013 : }
12014 :
12015 344 : gcc_assert (tmp);
12016 :
12017 344 : if (expr2->expr_type != EXPR_NULL)
12018 332 : gfc_add_modify (&block, tmp,
12019 332 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
12020 : else
12021 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
12022 : }
12023 :
12024 4598 : gfc_add_block_to_block (&block, &lse.pre);
12025 4598 : if (rank_remap)
12026 254 : gfc_add_block_to_block (&block, &rse.pre);
12027 :
12028 : /* If we do bounds remapping, update LHS descriptor accordingly. */
12029 4598 : if (remap)
12030 : {
12031 635 : int dim;
12032 635 : gcc_assert (remap->u.ar.dimen == expr1->rank);
12033 :
12034 : /* Always set dtype. */
12035 635 : gfc_conv_descriptor_dtype_set (&block, desc,
12036 635 : gfc_get_dtype (TREE_TYPE (desc)));
12037 :
12038 : /* For unlimited polymorphic LHS use elem_len from RHS. */
12039 635 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
12040 : {
12041 66 : tree elem_len;
12042 66 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12043 66 : elem_len = fold_convert (gfc_array_index_type, tmp);
12044 66 : elem_len = gfc_evaluate_now (elem_len, &block);
12045 66 : gfc_conv_descriptor_elem_len_set (&block, desc, elem_len);
12046 : }
12047 :
12048 635 : if (rank_remap)
12049 : {
12050 : /* Do rank remapping. We already have the RHS's descriptor
12051 : converted in rse and now have to build the correct LHS
12052 : descriptor for it. */
12053 :
12054 254 : tree data, span;
12055 254 : tree offs, stride;
12056 254 : tree lbound, ubound;
12057 :
12058 : /* Copy data pointer. */
12059 254 : data = gfc_conv_descriptor_data_get (rse.expr);
12060 254 : gfc_conv_descriptor_data_set (&block, desc, data);
12061 :
12062 : /* Copy the span. */
12063 254 : if (VAR_P (rse.expr)
12064 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
12065 12 : span = gfc_conv_descriptor_span_get (rse.expr);
12066 : else
12067 : {
12068 242 : tmp = TREE_TYPE (rse.expr);
12069 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
12070 242 : span = fold_convert (gfc_array_index_type, tmp);
12071 : }
12072 254 : gfc_conv_descriptor_span_set (&block, desc, span);
12073 :
12074 : /* Copy offset but adjust it such that it would correspond
12075 : to a lbound of zero. */
12076 254 : if (expr2->rank == -1)
12077 42 : gfc_conv_descriptor_offset_set (&block, desc,
12078 : gfc_index_zero_node);
12079 : else
12080 : {
12081 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
12082 654 : for (dim = 0; dim < expr2->rank; ++dim)
12083 : {
12084 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
12085 : gfc_rank_cst[dim]);
12086 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
12087 : gfc_rank_cst[dim]);
12088 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12089 : gfc_array_index_type, stride,
12090 : lbound);
12091 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
12092 : gfc_array_index_type, offs, tmp);
12093 : }
12094 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
12095 : }
12096 : /* Set the bounds as declared for the LHS and calculate strides as
12097 : well as another offset update accordingly. */
12098 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
12099 : gfc_rank_cst[0]);
12100 895 : for (dim = 0; dim < expr1->rank; ++dim)
12101 : {
12102 387 : gfc_se lower_se;
12103 387 : gfc_se upper_se;
12104 :
12105 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
12106 :
12107 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
12108 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
12109 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
12110 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
12111 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
12112 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
12113 :
12114 : /* Convert declared bounds. */
12115 387 : gfc_init_se (&lower_se, NULL);
12116 387 : gfc_init_se (&upper_se, NULL);
12117 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
12118 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
12119 :
12120 387 : gfc_add_block_to_block (&block, &lower_se.pre);
12121 387 : gfc_add_block_to_block (&block, &upper_se.pre);
12122 :
12123 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
12124 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
12125 :
12126 387 : lbound = gfc_evaluate_now (lbound, &block);
12127 387 : ubound = gfc_evaluate_now (ubound, &block);
12128 :
12129 387 : gfc_add_block_to_block (&block, &lower_se.post);
12130 387 : gfc_add_block_to_block (&block, &upper_se.post);
12131 :
12132 : /* Set bounds in descriptor. */
12133 387 : gfc_conv_descriptor_lbound_set (&block, desc,
12134 : gfc_rank_cst[dim], lbound);
12135 387 : gfc_conv_descriptor_ubound_set (&block, desc,
12136 : gfc_rank_cst[dim], ubound);
12137 :
12138 : /* Set stride. */
12139 387 : stride = gfc_evaluate_now (stride, &block);
12140 387 : gfc_conv_descriptor_stride_set (&block, desc,
12141 : gfc_rank_cst[dim], stride);
12142 :
12143 : /* Update offset. */
12144 387 : offs = gfc_conv_descriptor_offset_get (desc);
12145 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12146 : gfc_array_index_type, lbound, stride);
12147 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
12148 : gfc_array_index_type, offs, tmp);
12149 387 : offs = gfc_evaluate_now (offs, &block);
12150 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
12151 :
12152 : /* Update stride. */
12153 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
12154 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
12155 : gfc_array_index_type, stride, tmp);
12156 : }
12157 : }
12158 : else
12159 : {
12160 : /* Bounds remapping. Just shift the lower bounds. */
12161 :
12162 381 : gcc_assert (expr1->rank == expr2->rank);
12163 :
12164 876 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
12165 : {
12166 495 : gfc_se lbound_se;
12167 :
12168 495 : gcc_assert (!remap->u.ar.end[dim]);
12169 495 : gfc_init_se (&lbound_se, NULL);
12170 495 : if (remap->u.ar.start[dim])
12171 : {
12172 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
12173 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
12174 : }
12175 : else
12176 : /* This remap arises from a target that is not a whole
12177 : array. The start expressions will be NULL but we need
12178 : the lbounds to be one. */
12179 270 : lbound_se.expr = gfc_index_one_node;
12180 495 : gfc_conv_shift_descriptor_lbound (&block, desc,
12181 : dim, lbound_se.expr);
12182 495 : gfc_add_block_to_block (&block, &lbound_se.post);
12183 : }
12184 : }
12185 : }
12186 :
12187 : /* If rank remapping was done, check with -fcheck=bounds that
12188 : the target is at least as large as the pointer. */
12189 4598 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
12190 72 : && expr2->rank != -1)
12191 : {
12192 54 : tree lsize, rsize;
12193 54 : tree fault;
12194 54 : const char* msg;
12195 :
12196 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
12197 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
12198 :
12199 54 : lsize = gfc_evaluate_now (lsize, &block);
12200 54 : rsize = gfc_evaluate_now (rsize, &block);
12201 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
12202 : rsize, lsize);
12203 :
12204 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
12205 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
12206 : msg, rsize, lsize);
12207 : }
12208 :
12209 : /* Check string lengths if applicable. The check is only really added
12210 : to the output code if -fbounds-check is enabled. */
12211 4598 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
12212 : {
12213 554 : gcc_assert (expr2->ts.type == BT_CHARACTER);
12214 554 : gcc_assert (strlen_lhs && strlen_rhs);
12215 554 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
12216 : strlen_lhs, strlen_rhs, &block);
12217 : }
12218 :
12219 4598 : gfc_add_block_to_block (&block, &lse.post);
12220 4598 : if (rank_remap)
12221 254 : gfc_add_block_to_block (&block, &rse.post);
12222 : }
12223 :
12224 10488 : return gfc_finish_block (&block);
12225 : }
12226 :
12227 :
12228 : /* Makes sure se is suitable for passing as a function string parameter. */
12229 : /* TODO: Need to check all callers of this function. It may be abused. */
12230 :
12231 : void
12232 250225 : gfc_conv_string_parameter (gfc_se * se)
12233 : {
12234 250225 : tree type;
12235 :
12236 250225 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
12237 250225 : && integer_onep (se->string_length))
12238 : {
12239 697 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
12240 697 : return;
12241 : }
12242 :
12243 249528 : if (TREE_CODE (se->expr) == STRING_CST)
12244 : {
12245 104106 : type = TREE_TYPE (TREE_TYPE (se->expr));
12246 104106 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
12247 104106 : return;
12248 : }
12249 :
12250 145422 : if (TREE_CODE (se->expr) == COND_EXPR)
12251 : {
12252 478 : tree cond = TREE_OPERAND (se->expr, 0);
12253 478 : tree lhs = TREE_OPERAND (se->expr, 1);
12254 478 : tree rhs = TREE_OPERAND (se->expr, 2);
12255 :
12256 478 : gfc_se lse, rse;
12257 478 : gfc_init_se (&lse, NULL);
12258 478 : gfc_init_se (&rse, NULL);
12259 :
12260 478 : lse.expr = lhs;
12261 478 : lse.string_length = se->string_length;
12262 478 : gfc_conv_string_parameter (&lse);
12263 :
12264 478 : rse.expr = rhs;
12265 478 : rse.string_length = se->string_length;
12266 478 : gfc_conv_string_parameter (&rse);
12267 :
12268 478 : se->expr
12269 478 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
12270 : cond, lse.expr, rse.expr);
12271 : }
12272 :
12273 145422 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
12274 47384 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
12275 145797 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
12276 : {
12277 98413 : type = TREE_TYPE (se->expr);
12278 98413 : if (TREE_CODE (se->expr) != INDIRECT_REF)
12279 83398 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
12280 : else
12281 : {
12282 15015 : if (TREE_CODE (type) == ARRAY_TYPE)
12283 14736 : type = TREE_TYPE (type);
12284 15015 : type = gfc_get_character_type_len_for_eltype (type,
12285 : se->string_length);
12286 15015 : type = build_pointer_type (type);
12287 15015 : se->expr = gfc_build_addr_expr (type, se->expr);
12288 : }
12289 : }
12290 :
12291 145422 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
12292 : }
12293 :
12294 :
12295 : /* Generate code for assignment of scalar variables. Includes character
12296 : strings and derived types with allocatable components.
12297 : If you know that the LHS has no allocations, set dealloc to false.
12298 :
12299 : DEEP_COPY has no effect if the typespec TS is not a derived type with
12300 : allocatable components. Otherwise, if it is set, an explicit copy of each
12301 : allocatable component is made. This is necessary as a simple copy of the
12302 : whole object would copy array descriptors as is, so that the lhs's
12303 : allocatable components would point to the rhs's after the assignment.
12304 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
12305 : necessary if the rhs is a non-pointer function, as the allocatable components
12306 : are not accessible by other means than the function's result after the
12307 : function has returned. It is even more subtle when temporaries are involved,
12308 : as the two following examples show:
12309 : 1. When we evaluate an array constructor, a temporary is created. Thus
12310 : there is theoretically no alias possible. However, no deep copy is
12311 : made for this temporary, so that if the constructor is made of one or
12312 : more variable with allocatable components, those components still point
12313 : to the variable's: DEEP_COPY should be set for the assignment from the
12314 : temporary to the lhs in that case.
12315 : 2. When assigning a scalar to an array, we evaluate the scalar value out
12316 : of the loop, store it into a temporary variable, and assign from that.
12317 : In that case, deep copying when assigning to the temporary would be a
12318 : waste of resources; however deep copies should happen when assigning from
12319 : the temporary to each array element: again DEEP_COPY should be set for
12320 : the assignment from the temporary to the lhs. */
12321 :
12322 : tree
12323 346531 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
12324 : bool deep_copy, bool dealloc, bool in_coarray,
12325 : bool assoc_assign)
12326 : {
12327 346531 : stmtblock_t block;
12328 346531 : tree tmp;
12329 346531 : tree cond;
12330 346531 : int caf_mode;
12331 :
12332 346531 : gfc_init_block (&block);
12333 :
12334 346531 : if (ts.type == BT_CHARACTER)
12335 : {
12336 34051 : tree rlen = NULL;
12337 34051 : tree llen = NULL;
12338 :
12339 34051 : if (lse->string_length != NULL_TREE)
12340 : {
12341 34051 : gfc_conv_string_parameter (lse);
12342 34051 : gfc_add_block_to_block (&block, &lse->pre);
12343 34051 : llen = lse->string_length;
12344 : }
12345 :
12346 34051 : if (rse->string_length != NULL_TREE)
12347 : {
12348 34051 : gfc_conv_string_parameter (rse);
12349 34051 : gfc_add_block_to_block (&block, &rse->pre);
12350 34051 : rlen = rse->string_length;
12351 : }
12352 :
12353 34051 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
12354 : rse->expr, ts.kind);
12355 : }
12356 292287 : else if (gfc_bt_struct (ts.type)
12357 312480 : && (ts.u.derived->attr.alloc_comp
12358 13147 : || (deep_copy && has_parameterized_comps (ts.u.derived))))
12359 : {
12360 7316 : tree tmp_var = NULL_TREE;
12361 7316 : cond = NULL_TREE;
12362 :
12363 : /* Are the rhs and the lhs the same? */
12364 7316 : if (deep_copy)
12365 : {
12366 4440 : if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
12367 3227 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
12368 4440 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12369 : gfc_build_addr_expr (NULL_TREE, lse->expr),
12370 : gfc_build_addr_expr (NULL_TREE, rse->expr));
12371 4440 : cond = gfc_evaluate_now (cond, &lse->pre);
12372 : }
12373 :
12374 : /* Deallocate the lhs allocated components as long as it is not
12375 : the same as the rhs. This must be done following the assignment
12376 : to prevent deallocating data that could be used in the rhs
12377 : expression. */
12378 7316 : if (dealloc)
12379 : {
12380 2085 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
12381 2085 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
12382 : 0, gfc_may_be_finalized (ts));
12383 2085 : if (deep_copy)
12384 881 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12385 : tmp);
12386 2085 : gfc_add_expr_to_block (&lse->post, tmp);
12387 : }
12388 :
12389 7316 : gfc_add_block_to_block (&block, &rse->pre);
12390 :
12391 : /* Skip finalization for self-assignment. */
12392 7316 : if (deep_copy && lse->finalblock.head)
12393 : {
12394 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12395 : gfc_finish_block (&lse->finalblock));
12396 24 : gfc_add_expr_to_block (&block, tmp);
12397 : }
12398 : else
12399 7292 : gfc_add_block_to_block (&block, &lse->finalblock);
12400 :
12401 7316 : gfc_add_block_to_block (&block, &lse->pre);
12402 :
12403 7316 : if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
12404 7316 : == TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)))
12405 6974 : gfc_add_modify (&block, lse->expr,
12406 6974 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12407 : else
12408 : {
12409 342 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12410 342 : TREE_TYPE (lse->expr), rse->expr);
12411 342 : gfc_add_modify (&block, lse->expr, tmp);
12412 : }
12413 :
12414 : /* Restore pointer address of coarray components. */
12415 7316 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
12416 : {
12417 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
12418 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12419 : tmp);
12420 5 : gfc_add_expr_to_block (&block, tmp);
12421 : }
12422 :
12423 : /* Do a deep copy if the rhs is a variable, if it is not the
12424 : same as the lhs. */
12425 7316 : if (deep_copy)
12426 : {
12427 4440 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
12428 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
12429 4440 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
12430 : caf_mode);
12431 4440 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12432 : tmp);
12433 4440 : gfc_add_expr_to_block (&block, tmp);
12434 : }
12435 : }
12436 305164 : else if (gfc_bt_struct (ts.type))
12437 : {
12438 12877 : gfc_add_block_to_block (&block, &rse->pre);
12439 12877 : gfc_add_block_to_block (&block, &lse->finalblock);
12440 12877 : gfc_add_block_to_block (&block, &lse->pre);
12441 12877 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12442 12877 : TREE_TYPE (lse->expr), rse->expr);
12443 12877 : gfc_add_modify (&block, lse->expr, tmp);
12444 : }
12445 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
12446 292287 : else if (ts.type == BT_CLASS)
12447 : {
12448 745 : gfc_add_block_to_block (&block, &lse->pre);
12449 745 : gfc_add_block_to_block (&block, &rse->pre);
12450 745 : gfc_add_block_to_block (&block, &lse->finalblock);
12451 :
12452 745 : if (!trans_scalar_class_assign (&block, lse, rse))
12453 : {
12454 : /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
12455 : for the lhs which ensures that class data rhs cast as a string
12456 : assigns correctly. */
12457 599 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12458 599 : TREE_TYPE (rse->expr), lse->expr);
12459 599 : gfc_add_modify (&block, tmp, rse->expr);
12460 :
12461 : /* Copy allocatable components but guard against class pointer
12462 : assign, which arrives here. */
12463 : #define DATA_DT ts.u.derived->components->ts.u.derived
12464 599 : if (deep_copy
12465 158 : && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
12466 0 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
12467 158 : && ts.u.derived->components
12468 757 : && DATA_DT && DATA_DT->attr.alloc_comp)
12469 : {
12470 6 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
12471 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
12472 : : 0;
12473 6 : tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
12474 : caf_mode);
12475 6 : gfc_add_expr_to_block (&block, tmp);
12476 : }
12477 : #undef DATA_DT
12478 : }
12479 : }
12480 291542 : else if (ts.type != BT_CLASS)
12481 : {
12482 291542 : gfc_add_block_to_block (&block, &lse->pre);
12483 291542 : gfc_add_block_to_block (&block, &rse->pre);
12484 :
12485 291542 : if (in_coarray)
12486 : {
12487 901 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
12488 : {
12489 0 : tree rtype = TREE_TYPE (TREE_TYPE (rse->expr));
12490 0 : tree rtoken = TYPE_LANG_SPECIFIC (rtype)->caf_token;
12491 0 : gfc_conv_descriptor_token_set (&block, lse->expr, rtoken);
12492 : }
12493 901 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
12494 0 : lse->expr = gfc_conv_array_data (lse->expr);
12495 292 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
12496 901 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
12497 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
12498 : }
12499 291542 : gfc_add_modify (&block, lse->expr,
12500 291542 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12501 : }
12502 :
12503 346531 : gfc_add_block_to_block (&block, &lse->post);
12504 346531 : gfc_add_block_to_block (&block, &rse->post);
12505 :
12506 346531 : return gfc_finish_block (&block);
12507 : }
12508 :
12509 :
12510 : /* There are quite a lot of restrictions on the optimisation in using an
12511 : array function assign without a temporary. */
12512 :
12513 : static bool
12514 14484 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
12515 : {
12516 14484 : gfc_ref * ref;
12517 14484 : bool seen_array_ref;
12518 14484 : bool c = false;
12519 14484 : gfc_symbol *sym = expr1->symtree->n.sym;
12520 :
12521 : /* Play it safe with class functions assigned to a derived type. */
12522 14484 : if (gfc_is_class_array_function (expr2)
12523 14484 : && expr1->ts.type == BT_DERIVED)
12524 : return true;
12525 :
12526 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
12527 14460 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
12528 : return true;
12529 :
12530 : /* Elemental functions are scalarized so that they don't need a
12531 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
12532 : they would need special treatment in gfc_trans_arrayfunc_assign. */
12533 8531 : if (expr2->value.function.esym != NULL
12534 1595 : && expr2->value.function.esym->attr.elemental)
12535 : return true;
12536 :
12537 : /* Need a temporary if rhs is not FULL or a contiguous section. */
12538 8166 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
12539 : return true;
12540 :
12541 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
12542 7916 : if (gfc_ref_needs_temporary_p (expr1->ref))
12543 : return true;
12544 :
12545 : /* Functions returning pointers or allocatables need temporaries. */
12546 7904 : if (gfc_expr_attr (expr2).pointer
12547 7904 : || gfc_expr_attr (expr2).allocatable)
12548 : return true;
12549 :
12550 : /* Character array functions need temporaries unless the
12551 : character lengths are the same. */
12552 7528 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
12553 : {
12554 562 : if (UNLIMITED_POLY (expr1))
12555 : return true;
12556 :
12557 556 : if (expr1->ts.u.cl->length == NULL
12558 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12559 : return true;
12560 :
12561 493 : if (expr2->ts.u.cl->length == NULL
12562 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12563 : return true;
12564 :
12565 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
12566 475 : expr2->ts.u.cl->length->value.integer) != 0)
12567 : return true;
12568 : }
12569 :
12570 : /* Check that no LHS component references appear during an array
12571 : reference. This is needed because we do not have the means to
12572 : span any arbitrary stride with an array descriptor. This check
12573 : is not needed for the rhs because the function result has to be
12574 : a complete type. */
12575 7435 : seen_array_ref = false;
12576 14870 : for (ref = expr1->ref; ref; ref = ref->next)
12577 : {
12578 7448 : if (ref->type == REF_ARRAY)
12579 : seen_array_ref= true;
12580 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
12581 : return true;
12582 : }
12583 :
12584 : /* Check for a dependency. */
12585 7422 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
12586 : expr2->value.function.esym,
12587 : expr2->value.function.actual,
12588 : NOT_ELEMENTAL))
12589 : return true;
12590 :
12591 : /* If we have reached here with an intrinsic function, we do not
12592 : need a temporary except in the particular case that reallocation
12593 : on assignment is active and the lhs is allocatable and a target,
12594 : or a pointer which may be a subref pointer. FIXME: The last
12595 : condition can go away when we use span in the intrinsics
12596 : directly.*/
12597 6985 : if (expr2->value.function.isym)
12598 6107 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
12599 12268 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
12600 :
12601 : /* If the LHS is a dummy, we need a temporary if it is not
12602 : INTENT(OUT). */
12603 803 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
12604 : return true;
12605 :
12606 : /* If the lhs has been host_associated, is in common, a pointer or is
12607 : a target and the function is not using a RESULT variable, aliasing
12608 : can occur and a temporary is needed. */
12609 797 : if ((sym->attr.host_assoc
12610 743 : || sym->attr.in_common
12611 737 : || sym->attr.pointer
12612 731 : || sym->attr.cray_pointee
12613 731 : || sym->attr.target)
12614 66 : && expr2->symtree != NULL
12615 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
12616 : return true;
12617 :
12618 : /* A PURE function can unconditionally be called without a temporary. */
12619 755 : if (expr2->value.function.esym != NULL
12620 730 : && expr2->value.function.esym->attr.pure)
12621 : return false;
12622 :
12623 : /* Implicit_pure functions are those which could legally be declared
12624 : to be PURE. */
12625 727 : if (expr2->value.function.esym != NULL
12626 702 : && expr2->value.function.esym->attr.implicit_pure)
12627 : return false;
12628 :
12629 444 : if (!sym->attr.use_assoc
12630 444 : && !sym->attr.in_common
12631 444 : && !sym->attr.pointer
12632 438 : && !sym->attr.target
12633 438 : && !sym->attr.cray_pointee
12634 438 : && expr2->value.function.esym)
12635 : {
12636 : /* A temporary is not needed if the function is not contained and
12637 : the variable is local or host associated and not a pointer or
12638 : a target. */
12639 413 : if (!expr2->value.function.esym->attr.contained)
12640 : return false;
12641 :
12642 : /* A temporary is not needed if the lhs has never been host
12643 : associated and the procedure is contained. */
12644 164 : else if (!sym->attr.host_assoc)
12645 : return false;
12646 :
12647 : /* A temporary is not needed if the variable is local and not
12648 : a pointer, a target or a result. */
12649 6 : if (sym->ns->parent
12650 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12651 0 : return false;
12652 : }
12653 :
12654 : /* Default to temporary use. */
12655 : return true;
12656 : }
12657 :
12658 :
12659 : /* Provide the loop info so that the lhs descriptor can be built for
12660 : reallocatable assignments from extrinsic function calls. */
12661 :
12662 : static void
12663 203 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12664 : gfc_loopinfo *loop)
12665 : {
12666 : /* Signal that the function call should not be made by
12667 : gfc_conv_loop_setup. */
12668 203 : se->ss->is_alloc_lhs = 1;
12669 203 : gfc_init_loopinfo (loop);
12670 203 : gfc_add_ss_to_loop (loop, *ss);
12671 203 : gfc_add_ss_to_loop (loop, se->ss);
12672 203 : gfc_conv_ss_startstride (loop);
12673 203 : gfc_conv_loop_setup (loop, where);
12674 203 : gfc_copy_loopinfo_to_se (se, loop);
12675 203 : gfc_add_block_to_block (&se->pre, &loop->pre);
12676 203 : gfc_add_block_to_block (&se->pre, &loop->post);
12677 203 : se->ss->is_alloc_lhs = 0;
12678 203 : }
12679 :
12680 :
12681 : /* For assignment to a reallocatable lhs from intrinsic functions,
12682 : replace the se.expr (ie. the result) with a temporary descriptor.
12683 : Null the data field so that the library allocates space for the
12684 : result. Free the data of the original descriptor after the function,
12685 : in case it appears in an argument expression and transfer the
12686 : result to the original descriptor. */
12687 :
12688 : static void
12689 2137 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12690 : {
12691 2137 : tree desc;
12692 2137 : tree res_desc;
12693 2137 : tree tmp;
12694 2137 : tree offset;
12695 2137 : tree zero_cond;
12696 2137 : tree not_same_shape;
12697 2137 : stmtblock_t shape_block;
12698 2137 : int n;
12699 :
12700 : /* Use the allocation done by the library. Substitute the lhs
12701 : descriptor with a copy, whose data field is nulled.*/
12702 2137 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12703 2137 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12704 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12705 :
12706 2137 : res_desc = gfc_create_unallocated_library_result_descriptor (&se->pre, desc,
12707 : dtype);
12708 2137 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12709 :
12710 : /* Free the lhs after the function call and copy the result data to
12711 : the lhs descriptor. */
12712 2137 : tmp = gfc_conv_descriptor_data_get (desc);
12713 2137 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12714 : logical_type_node, tmp,
12715 2137 : build_int_cst (TREE_TYPE (tmp), 0));
12716 2137 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12717 2137 : tmp = gfc_call_free (tmp);
12718 2137 : gfc_add_expr_to_block (&se->post, tmp);
12719 :
12720 2137 : tmp = gfc_conv_descriptor_data_get (res_desc);
12721 2137 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12722 :
12723 : /* Check that the shapes are the same between lhs and expression.
12724 : The evaluation of the shape is done in 'shape_block' to avoid
12725 : uninitialized warnings from the lhs bounds. */
12726 2137 : not_same_shape = boolean_false_node;
12727 2137 : gfc_start_block (&shape_block);
12728 9015 : for (n = 0 ; n < rank; n++)
12729 : {
12730 4741 : tree tmp1;
12731 4741 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12732 4741 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12733 4741 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12734 : gfc_array_index_type, tmp, tmp1);
12735 4741 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12736 4741 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12737 : gfc_array_index_type, tmp, tmp1);
12738 4741 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12739 4741 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12740 : gfc_array_index_type, tmp, tmp1);
12741 4741 : tmp = fold_build2_loc (input_location, NE_EXPR,
12742 : logical_type_node, tmp,
12743 : gfc_index_zero_node);
12744 4741 : tmp = gfc_evaluate_now (tmp, &shape_block);
12745 4741 : if (n == 0)
12746 : not_same_shape = tmp;
12747 : else
12748 2604 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12749 : logical_type_node, tmp,
12750 : not_same_shape);
12751 : }
12752 :
12753 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12754 : shapes being different. */
12755 2137 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12756 : zero_cond, not_same_shape);
12757 2137 : gfc_add_modify (&shape_block, zero_cond, tmp);
12758 2137 : tmp = gfc_finish_block (&shape_block);
12759 2137 : tmp = build3_v (COND_EXPR, zero_cond,
12760 : build_empty_stmt (input_location), tmp);
12761 2137 : gfc_add_expr_to_block (&se->post, tmp);
12762 :
12763 : /* Now reset the bounds returned from the function call to bounds based
12764 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12765 : of 'variable and 'expr' are different. Set the offset accordingly. */
12766 2137 : offset = gfc_index_zero_node;
12767 6878 : for (n = 0 ; n < rank; n++)
12768 : {
12769 4741 : tree lbound;
12770 :
12771 4741 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12772 4741 : lbound = fold_build3_loc (input_location, COND_EXPR,
12773 : gfc_array_index_type, zero_cond,
12774 : gfc_index_one_node, lbound);
12775 4741 : lbound = gfc_evaluate_now (lbound, &se->post);
12776 :
12777 4741 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12778 4741 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12779 : gfc_array_index_type, tmp, lbound);
12780 4741 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12781 : gfc_rank_cst[n], lbound);
12782 4741 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12783 : gfc_rank_cst[n], tmp);
12784 :
12785 : /* Set stride and accumulate the offset. */
12786 4741 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12787 4741 : gfc_conv_descriptor_stride_set (&se->post, desc,
12788 : gfc_rank_cst[n], tmp);
12789 4741 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12790 : gfc_array_index_type, lbound, tmp);
12791 4741 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12792 : gfc_array_index_type, offset, tmp);
12793 4741 : offset = gfc_evaluate_now (offset, &se->post);
12794 : }
12795 :
12796 2137 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12797 2137 : }
12798 :
12799 :
12800 :
12801 : /* Try to translate array(:) = func (...), where func is a transformational
12802 : array function, without using a temporary. Returns NULL if this isn't the
12803 : case. */
12804 :
12805 : static tree
12806 14524 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12807 : {
12808 14524 : gfc_se se;
12809 14524 : gfc_ss *ss = NULL;
12810 14524 : gfc_component *comp = NULL;
12811 14524 : gfc_loopinfo loop;
12812 14524 : tree tmp;
12813 14524 : tree lhs;
12814 14524 : gfc_se final_se;
12815 14524 : gfc_symbol *sym = expr1->symtree->n.sym;
12816 14524 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12817 :
12818 : /* If the symbol is host associated and has not been referenced in its name
12819 : space, it might be lacking a backend_decl and vtable. */
12820 14524 : if (sym->backend_decl == NULL_TREE)
12821 : return NULL_TREE;
12822 :
12823 14484 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12824 : return NULL_TREE;
12825 :
12826 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12827 : functions. */
12828 6867 : comp = gfc_get_proc_ptr_comp (expr2);
12829 :
12830 6867 : if (!(expr2->value.function.isym
12831 718 : || (comp && comp->attr.dimension)
12832 718 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12833 718 : && expr2->value.function.esym->result->attr.dimension)))
12834 : return NULL_TREE;
12835 :
12836 6867 : gfc_init_se (&se, NULL);
12837 6867 : gfc_start_block (&se.pre);
12838 6867 : se.want_pointer = 1;
12839 :
12840 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12841 : backend decl, stash the original away for the finalization so that the
12842 : value used is that before the assignment. This is necessary because
12843 : evaluation of the rhs expression using direct by reference can change
12844 : the value. However, the standard mandates that the finalization must occur
12845 : after evaluation of the rhs. */
12846 6867 : gfc_init_se (&final_se, NULL);
12847 :
12848 6867 : if (finalizable)
12849 : {
12850 45 : tmp = sym->backend_decl;
12851 45 : lhs = sym->backend_decl;
12852 45 : if (INDIRECT_REF_P (tmp))
12853 0 : tmp = TREE_OPERAND (tmp, 0);
12854 45 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12855 45 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12856 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12857 : {
12858 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12859 : expr1->rank, 0);
12860 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12861 : }
12862 : }
12863 :
12864 45 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12865 : {
12866 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12867 45 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12868 : }
12869 :
12870 6867 : if (finalizable)
12871 45 : sym->backend_decl = lhs;
12872 :
12873 6867 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12874 :
12875 6867 : if (expr1->ts.type == BT_DERIVED
12876 264 : && expr1->ts.u.derived->attr.alloc_comp)
12877 : {
12878 110 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12879 110 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12880 : expr1->rank);
12881 110 : gfc_add_expr_to_block (&se.pre, tmp);
12882 : }
12883 :
12884 6867 : se.direct_byref = 1;
12885 6867 : se.ss = gfc_walk_expr (expr2);
12886 6867 : gcc_assert (se.ss != gfc_ss_terminator);
12887 :
12888 : /* Since this is a direct by reference call, references to the lhs can be
12889 : used for finalization of the function result just as long as the blocks
12890 : from final_se are added at the right time. */
12891 6867 : gfc_init_se (&final_se, NULL);
12892 6867 : if (finalizable && expr2->value.function.esym)
12893 : {
12894 32 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12895 32 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12896 32 : expr2->value.function.esym->attr,
12897 : expr2->rank);
12898 : }
12899 :
12900 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12901 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12902 : Clearly, this cannot be done for an allocatable function result, since
12903 : the shape of the result is unknown and, in any case, the function must
12904 : correctly take care of the reallocation internally. For intrinsic
12905 : calls, the array data is freed and the library takes care of allocation.
12906 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12907 : to the library. */
12908 6867 : if (flag_realloc_lhs
12909 6792 : && gfc_is_reallocatable_lhs (expr1)
12910 9207 : && !gfc_expr_attr (expr1).codimension
12911 2340 : && !gfc_is_coindexed (expr1)
12912 9207 : && !(expr2->value.function.esym
12913 203 : && expr2->value.function.esym->result->attr.allocatable))
12914 : {
12915 2340 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12916 :
12917 2340 : if (!expr2->value.function.isym)
12918 : {
12919 203 : ss = gfc_walk_expr (expr1);
12920 203 : gcc_assert (ss != gfc_ss_terminator);
12921 :
12922 203 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12923 203 : ss->is_alloc_lhs = 1;
12924 : }
12925 : else
12926 : {
12927 2137 : tree dtype = NULL_TREE;
12928 2137 : tree type = gfc_typenode_for_spec (&expr2->ts);
12929 2137 : if (expr1->ts.type == BT_CLASS)
12930 : {
12931 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12932 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12933 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12934 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12935 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12936 : }
12937 2137 : fcncall_realloc_result (&se, expr1->rank, dtype);
12938 : }
12939 : }
12940 :
12941 6867 : gfc_conv_function_expr (&se, expr2);
12942 :
12943 : /* Fix the result. */
12944 6867 : gfc_add_block_to_block (&se.pre, &se.post);
12945 6867 : if (finalizable)
12946 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12947 :
12948 : /* Do the finalization, including final calls from function arguments. */
12949 45 : if (finalizable)
12950 : {
12951 45 : gfc_add_block_to_block (&se.pre, &final_se.post);
12952 45 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12953 45 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12954 : }
12955 :
12956 6867 : if (ss)
12957 203 : gfc_cleanup_loop (&loop);
12958 : else
12959 6664 : gfc_free_ss_chain (se.ss);
12960 :
12961 6867 : return gfc_finish_block (&se.pre);
12962 : }
12963 :
12964 :
12965 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12966 : can't be done. */
12967 :
12968 : static tree
12969 4060 : gfc_trans_zero_assign (gfc_expr * expr)
12970 : {
12971 4060 : tree dest, len, type;
12972 4060 : tree tmp;
12973 4060 : gfc_symbol *sym;
12974 :
12975 4060 : sym = expr->symtree->n.sym;
12976 4060 : dest = gfc_get_symbol_decl (sym);
12977 :
12978 4060 : type = TREE_TYPE (dest);
12979 4060 : if (POINTER_TYPE_P (type))
12980 255 : type = TREE_TYPE (type);
12981 4060 : if (GFC_ARRAY_TYPE_P (type))
12982 : {
12983 : /* Determine the length of the array. */
12984 2850 : len = GFC_TYPE_ARRAY_SIZE (type);
12985 2850 : if (!len || TREE_CODE (len) != INTEGER_CST)
12986 : return NULL_TREE;
12987 : }
12988 1210 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12989 1210 : && gfc_is_simply_contiguous (expr, false, false))
12990 : {
12991 1098 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12992 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12993 1098 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12994 1098 : dest = gfc_conv_descriptor_data_get (dest);
12995 : }
12996 : else
12997 : return NULL_TREE;
12998 :
12999 : /* If we are zeroing a local array avoid taking its address by emitting
13000 : a = {} instead. */
13001 3763 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
13002 2622 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
13003 2622 : dest, build_constructor (TREE_TYPE (dest),
13004 2622 : NULL));
13005 :
13006 : /* Multiply len by element size. */
13007 1141 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
13008 1141 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
13009 : len, fold_convert (gfc_array_index_type, tmp));
13010 :
13011 : /* Convert arguments to the correct types. */
13012 1141 : dest = fold_convert (pvoid_type_node, dest);
13013 1141 : len = fold_convert (size_type_node, len);
13014 :
13015 : /* Construct call to __builtin_memset. */
13016 1141 : tmp = build_call_expr_loc (input_location,
13017 : builtin_decl_explicit (BUILT_IN_MEMSET),
13018 : 3, dest, integer_zero_node, len);
13019 1141 : return fold_convert (void_type_node, tmp);
13020 : }
13021 :
13022 :
13023 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
13024 : that constructs the call to __builtin_memcpy. */
13025 :
13026 : tree
13027 8208 : gfc_build_memcpy_call (tree dst, tree src, tree len)
13028 : {
13029 8208 : tree tmp;
13030 :
13031 : /* Convert arguments to the correct types. */
13032 8208 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
13033 7793 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
13034 : else
13035 415 : dst = fold_convert (pvoid_type_node, dst);
13036 :
13037 8208 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
13038 7710 : src = gfc_build_addr_expr (pvoid_type_node, src);
13039 : else
13040 498 : src = fold_convert (pvoid_type_node, src);
13041 :
13042 8208 : len = fold_convert (size_type_node, len);
13043 :
13044 : /* Construct call to __builtin_memcpy. */
13045 8208 : tmp = build_call_expr_loc (input_location,
13046 : builtin_decl_explicit (BUILT_IN_MEMCPY),
13047 : 3, dst, src, len);
13048 8208 : return fold_convert (void_type_node, tmp);
13049 : }
13050 :
13051 :
13052 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
13053 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
13054 : source/rhs, both are gfc_full_array_ref_p which have been checked for
13055 : dependencies. */
13056 :
13057 : static tree
13058 2603 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
13059 : {
13060 2603 : tree dst, dlen, dtype;
13061 2603 : tree src, slen, stype;
13062 2603 : tree tmp;
13063 :
13064 2603 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
13065 2603 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
13066 :
13067 2603 : dtype = TREE_TYPE (dst);
13068 2603 : if (POINTER_TYPE_P (dtype))
13069 265 : dtype = TREE_TYPE (dtype);
13070 2603 : stype = TREE_TYPE (src);
13071 2603 : if (POINTER_TYPE_P (stype))
13072 293 : stype = TREE_TYPE (stype);
13073 :
13074 2603 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
13075 : return NULL_TREE;
13076 :
13077 : /* Determine the lengths of the arrays. */
13078 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
13079 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
13080 : return NULL_TREE;
13081 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
13082 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
13083 : dlen, fold_convert (gfc_array_index_type, tmp));
13084 :
13085 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
13086 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
13087 : return NULL_TREE;
13088 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
13089 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
13090 : slen, fold_convert (gfc_array_index_type, tmp));
13091 :
13092 : /* Sanity check that they are the same. This should always be
13093 : the case, as we should already have checked for conformance. */
13094 1486 : if (!tree_int_cst_equal (slen, dlen))
13095 : return NULL_TREE;
13096 :
13097 1486 : return gfc_build_memcpy_call (dst, src, dlen);
13098 : }
13099 :
13100 :
13101 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
13102 : this can't be done. EXPR1 is the destination/lhs for which
13103 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
13104 :
13105 : static tree
13106 8355 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
13107 : {
13108 8355 : unsigned HOST_WIDE_INT nelem;
13109 8355 : tree dst, dtype;
13110 8355 : tree src, stype;
13111 8355 : tree len;
13112 8355 : tree tmp;
13113 :
13114 8355 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
13115 8355 : if (nelem == 0)
13116 : return NULL_TREE;
13117 :
13118 6917 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
13119 6917 : dtype = TREE_TYPE (dst);
13120 6917 : if (POINTER_TYPE_P (dtype))
13121 271 : dtype = TREE_TYPE (dtype);
13122 6917 : if (!GFC_ARRAY_TYPE_P (dtype))
13123 : return NULL_TREE;
13124 :
13125 : /* Determine the lengths of the array. */
13126 6057 : len = GFC_TYPE_ARRAY_SIZE (dtype);
13127 6057 : if (!len || TREE_CODE (len) != INTEGER_CST)
13128 : return NULL_TREE;
13129 :
13130 : /* Confirm that the constructor is the same size. */
13131 5953 : if (compare_tree_int (len, nelem) != 0)
13132 : return NULL_TREE;
13133 :
13134 5953 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
13135 5953 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
13136 : fold_convert (gfc_array_index_type, tmp));
13137 :
13138 5953 : stype = gfc_typenode_for_spec (&expr2->ts);
13139 5953 : src = gfc_build_constant_array_constructor (expr2, stype);
13140 :
13141 5953 : return gfc_build_memcpy_call (dst, src, len);
13142 : }
13143 :
13144 :
13145 : /* Tells whether the expression is to be treated as a variable reference. */
13146 :
13147 : bool
13148 320932 : gfc_expr_is_variable (gfc_expr *expr)
13149 : {
13150 321210 : gfc_expr *arg;
13151 321210 : gfc_component *comp;
13152 321210 : gfc_symbol *func_ifc;
13153 :
13154 321210 : if (expr->expr_type == EXPR_VARIABLE)
13155 : return true;
13156 :
13157 284872 : arg = gfc_get_noncopying_intrinsic_argument (expr);
13158 284872 : if (arg)
13159 : {
13160 278 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
13161 : return gfc_expr_is_variable (arg);
13162 : }
13163 :
13164 : /* A data-pointer-returning function should be considered as a variable
13165 : too. */
13166 284594 : if (expr->expr_type == EXPR_FUNCTION
13167 37897 : && expr->ref == NULL)
13168 : {
13169 37508 : if (expr->value.function.isym != NULL)
13170 : return false;
13171 :
13172 9781 : if (expr->value.function.esym != NULL)
13173 : {
13174 9772 : func_ifc = expr->value.function.esym;
13175 9772 : goto found_ifc;
13176 : }
13177 9 : gcc_assert (expr->symtree);
13178 9 : func_ifc = expr->symtree->n.sym;
13179 9 : goto found_ifc;
13180 : }
13181 :
13182 247086 : comp = gfc_get_proc_ptr_comp (expr);
13183 247086 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
13184 389 : && comp)
13185 : {
13186 275 : func_ifc = comp->ts.interface;
13187 275 : goto found_ifc;
13188 : }
13189 :
13190 246811 : if (expr->expr_type == EXPR_COMPCALL)
13191 : {
13192 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
13193 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
13194 0 : goto found_ifc;
13195 : }
13196 :
13197 : return false;
13198 :
13199 10056 : found_ifc:
13200 10056 : gcc_assert (func_ifc->attr.function
13201 : && func_ifc->result != NULL);
13202 10056 : return func_ifc->result->attr.pointer;
13203 : }
13204 :
13205 :
13206 : /* Is the lhs OK for automatic reallocation? */
13207 :
13208 : static bool
13209 271315 : is_scalar_reallocatable_lhs (gfc_expr *expr)
13210 : {
13211 271315 : gfc_ref * ref;
13212 :
13213 : /* An allocatable variable with no reference. */
13214 271315 : if (expr->symtree->n.sym->attr.allocatable
13215 6890 : && !expr->ref)
13216 : return true;
13217 :
13218 : /* All that can be left are allocatable components. However, we do
13219 : not check for allocatable components here because the expression
13220 : could be an allocatable component of a pointer component. */
13221 268464 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
13222 244701 : && expr->symtree->n.sym->ts.type != BT_CLASS)
13223 : return false;
13224 :
13225 : /* Find an allocatable component ref last. */
13226 42160 : for (ref = expr->ref; ref; ref = ref->next)
13227 17351 : if (ref->type == REF_COMPONENT
13228 12809 : && !ref->next
13229 9821 : && ref->u.c.component->attr.allocatable)
13230 : return true;
13231 :
13232 : return false;
13233 : }
13234 :
13235 :
13236 : /* Allocate or reallocate scalar lhs, as necessary. */
13237 :
13238 : static void
13239 3733 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
13240 : tree string_length,
13241 : gfc_expr *expr1,
13242 : gfc_expr *expr2)
13243 :
13244 : {
13245 3733 : tree cond;
13246 3733 : tree tmp;
13247 3733 : tree size;
13248 3733 : tree size_in_bytes;
13249 3733 : tree jump_label1;
13250 3733 : tree jump_label2;
13251 3733 : gfc_se lse;
13252 3733 : gfc_ref *ref;
13253 :
13254 3733 : if (!expr1 || expr1->rank)
13255 0 : return;
13256 :
13257 3733 : if (!expr2 || expr2->rank)
13258 : return;
13259 :
13260 5241 : for (ref = expr1->ref; ref; ref = ref->next)
13261 1508 : if (ref->type == REF_SUBSTRING)
13262 : return;
13263 :
13264 3733 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
13265 :
13266 : /* Since this is a scalar lhs, we can afford to do this. That is,
13267 : there is no risk of side effects being repeated. */
13268 3733 : gfc_init_se (&lse, NULL);
13269 3733 : lse.want_pointer = 1;
13270 3733 : gfc_conv_expr (&lse, expr1);
13271 :
13272 3733 : jump_label1 = gfc_build_label_decl (NULL_TREE);
13273 3733 : jump_label2 = gfc_build_label_decl (NULL_TREE);
13274 :
13275 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
13276 3733 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
13277 3733 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
13278 : lse.expr, tmp);
13279 3733 : tmp = build3_v (COND_EXPR, cond,
13280 : build1_v (GOTO_EXPR, jump_label1),
13281 : build_empty_stmt (input_location));
13282 3733 : gfc_add_expr_to_block (block, tmp);
13283 :
13284 3733 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13285 : {
13286 : /* Use the rhs string length and the lhs element size. Note that 'size' is
13287 : used below for the string-length comparison, only. */
13288 1578 : size = string_length;
13289 1578 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
13290 3156 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
13291 1578 : TREE_TYPE (tmp), tmp,
13292 1578 : fold_convert (TREE_TYPE (tmp), size));
13293 : }
13294 : else
13295 : {
13296 : /* Otherwise use the length in bytes of the rhs. */
13297 2155 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
13298 2155 : size_in_bytes = size;
13299 : }
13300 :
13301 3733 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13302 : size_in_bytes, size_one_node);
13303 :
13304 3733 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
13305 : {
13306 32 : tree caf_decl, token;
13307 32 : gfc_se caf_se;
13308 32 : symbol_attribute attr;
13309 :
13310 32 : gfc_clear_attr (&attr);
13311 32 : gfc_init_se (&caf_se, NULL);
13312 :
13313 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
13314 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
13315 : NULL);
13316 32 : gfc_add_block_to_block (block, &caf_se.pre);
13317 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
13318 : gfc_build_addr_expr (NULL_TREE, token),
13319 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
13320 : expr1, 1);
13321 : }
13322 3701 : else if (expr1->ts.type == BT_DERIVED
13323 3701 : && (expr1->ts.u.derived->attr.alloc_comp
13324 220 : || has_parameterized_comps (expr1->ts.u.derived)))
13325 : {
13326 128 : tmp = build_call_expr_loc (input_location,
13327 : builtin_decl_explicit (BUILT_IN_CALLOC),
13328 : 2, build_one_cst (size_type_node),
13329 : size_in_bytes);
13330 128 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13331 128 : gfc_add_modify (block, lse.expr, tmp);
13332 : }
13333 : else
13334 : {
13335 3573 : tmp = build_call_expr_loc (input_location,
13336 : builtin_decl_explicit (BUILT_IN_MALLOC),
13337 : 1, size_in_bytes);
13338 3573 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13339 3573 : gfc_add_modify (block, lse.expr, tmp);
13340 : }
13341 :
13342 3733 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13343 : {
13344 : /* Deferred characters need checking for lhs and rhs string
13345 : length. Other deferred parameter variables will have to
13346 : come here too. */
13347 1578 : tmp = build1_v (GOTO_EXPR, jump_label2);
13348 1578 : gfc_add_expr_to_block (block, tmp);
13349 : }
13350 3733 : tmp = build1_v (LABEL_EXPR, jump_label1);
13351 3733 : gfc_add_expr_to_block (block, tmp);
13352 :
13353 : /* For a deferred length character, reallocate if lengths of lhs and
13354 : rhs are different. */
13355 3733 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13356 : {
13357 1578 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13358 : lse.string_length,
13359 1578 : fold_convert (TREE_TYPE (lse.string_length),
13360 : size));
13361 : /* Jump past the realloc if the lengths are the same. */
13362 1578 : tmp = build3_v (COND_EXPR, cond,
13363 : build1_v (GOTO_EXPR, jump_label2),
13364 : build_empty_stmt (input_location));
13365 1578 : gfc_add_expr_to_block (block, tmp);
13366 1578 : tmp = build_call_expr_loc (input_location,
13367 : builtin_decl_explicit (BUILT_IN_REALLOC),
13368 : 2, fold_convert (pvoid_type_node, lse.expr),
13369 : size_in_bytes);
13370 1578 : tree omp_cond = NULL_TREE;
13371 1578 : if (flag_openmp_allocators)
13372 : {
13373 1 : tree omp_tmp;
13374 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
13375 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
13376 :
13377 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
13378 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
13379 : fold_convert (pvoid_type_node,
13380 : lse.expr), size_in_bytes,
13381 : build_zero_cst (ptr_type_node),
13382 : build_zero_cst (ptr_type_node));
13383 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
13384 : omp_cond, omp_tmp, tmp);
13385 : }
13386 1578 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13387 1578 : gfc_add_modify (block, lse.expr, tmp);
13388 1578 : if (omp_cond)
13389 1 : gfc_add_expr_to_block (block,
13390 : build3_loc (input_location, COND_EXPR,
13391 : void_type_node, omp_cond,
13392 : gfc_omp_call_add_alloc (lse.expr),
13393 : build_empty_stmt (input_location)));
13394 1578 : tmp = build1_v (LABEL_EXPR, jump_label2);
13395 1578 : gfc_add_expr_to_block (block, tmp);
13396 :
13397 : /* Update the lhs character length. */
13398 1578 : size = string_length;
13399 1578 : gfc_add_modify (block, lse.string_length,
13400 1578 : fold_convert (TREE_TYPE (lse.string_length), size));
13401 : }
13402 : }
13403 :
13404 : /* Check for assignments of the type
13405 :
13406 : a = a + 4
13407 :
13408 : to make sure we do not check for reallocation unnecessarily. */
13409 :
13410 :
13411 : /* Strip parentheses from an expression to get the underlying variable.
13412 : This is needed for self-assignment detection since (a) creates a
13413 : parentheses operator node. */
13414 :
13415 : static gfc_expr *
13416 8105 : strip_parentheses (gfc_expr *expr)
13417 : {
13418 0 : while (expr->expr_type == EXPR_OP
13419 322421 : && expr->value.op.op == INTRINSIC_PARENTHESES)
13420 602 : expr = expr->value.op.op1;
13421 321148 : return expr;
13422 : }
13423 :
13424 :
13425 : static bool
13426 7628 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
13427 : {
13428 8105 : gfc_actual_arglist *a;
13429 8105 : gfc_expr *e1, *e2;
13430 :
13431 : /* Strip parentheses to handle cases like a = (a). */
13432 16261 : expr1 = strip_parentheses (expr1);
13433 8105 : expr2 = strip_parentheses (expr2);
13434 :
13435 8105 : switch (expr2->expr_type)
13436 : {
13437 2218 : case EXPR_VARIABLE:
13438 2218 : return gfc_dep_compare_expr (expr1, expr2) == 0;
13439 :
13440 2839 : case EXPR_FUNCTION:
13441 2839 : if (expr2->value.function.esym
13442 305 : && expr2->value.function.esym->attr.elemental)
13443 : {
13444 75 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
13445 : {
13446 74 : e1 = a->expr;
13447 74 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
13448 : return false;
13449 : }
13450 : return true;
13451 : }
13452 2777 : else if (expr2->value.function.isym
13453 2520 : && expr2->value.function.isym->elemental)
13454 : {
13455 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
13456 : {
13457 322 : e1 = a->expr;
13458 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
13459 : return false;
13460 : }
13461 : return true;
13462 : }
13463 :
13464 : break;
13465 :
13466 671 : case EXPR_OP:
13467 671 : switch (expr2->value.op.op)
13468 : {
13469 19 : case INTRINSIC_NOT:
13470 19 : case INTRINSIC_UPLUS:
13471 19 : case INTRINSIC_UMINUS:
13472 19 : case INTRINSIC_PARENTHESES:
13473 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
13474 :
13475 627 : case INTRINSIC_PLUS:
13476 627 : case INTRINSIC_MINUS:
13477 627 : case INTRINSIC_TIMES:
13478 627 : case INTRINSIC_DIVIDE:
13479 627 : case INTRINSIC_POWER:
13480 627 : case INTRINSIC_AND:
13481 627 : case INTRINSIC_OR:
13482 627 : case INTRINSIC_EQV:
13483 627 : case INTRINSIC_NEQV:
13484 627 : case INTRINSIC_EQ:
13485 627 : case INTRINSIC_NE:
13486 627 : case INTRINSIC_GT:
13487 627 : case INTRINSIC_GE:
13488 627 : case INTRINSIC_LT:
13489 627 : case INTRINSIC_LE:
13490 627 : case INTRINSIC_EQ_OS:
13491 627 : case INTRINSIC_NE_OS:
13492 627 : case INTRINSIC_GT_OS:
13493 627 : case INTRINSIC_GE_OS:
13494 627 : case INTRINSIC_LT_OS:
13495 627 : case INTRINSIC_LE_OS:
13496 :
13497 627 : e1 = expr2->value.op.op1;
13498 627 : e2 = expr2->value.op.op2;
13499 :
13500 627 : if (e1->rank == 0 && e2->rank > 0)
13501 : return is_runtime_conformable (expr1, e2);
13502 569 : else if (e1->rank > 0 && e2->rank == 0)
13503 : return is_runtime_conformable (expr1, e1);
13504 169 : else if (e1->rank > 0 && e2->rank > 0)
13505 169 : return is_runtime_conformable (expr1, e1)
13506 169 : && is_runtime_conformable (expr1, e2);
13507 : break;
13508 :
13509 : default:
13510 : break;
13511 :
13512 : }
13513 :
13514 : break;
13515 :
13516 : default:
13517 : break;
13518 : }
13519 : return false;
13520 : }
13521 :
13522 :
13523 : static tree
13524 3554 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
13525 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
13526 : bool class_realloc)
13527 : {
13528 3554 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
13529 3554 : vec<tree, va_gc> *args = NULL;
13530 3554 : bool final_expr;
13531 :
13532 3554 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
13533 3554 : if (final_expr)
13534 : {
13535 521 : if (rse->loop)
13536 244 : gfc_prepend_expr_to_block (&rse->loop->pre,
13537 : gfc_finish_block (&lse->finalblock));
13538 : else
13539 277 : gfc_add_block_to_block (block, &lse->finalblock);
13540 : }
13541 :
13542 : /* Store the old vptr so that dynamic types can be compared for
13543 : reallocation to occur or not. */
13544 3554 : if (class_realloc)
13545 : {
13546 313 : tmp = lse->expr;
13547 313 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13548 0 : tmp = gfc_get_class_from_expr (tmp);
13549 : }
13550 :
13551 3554 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
13552 : &from_len, &rhs_vptr);
13553 3554 : if (rhs_vptr == NULL_TREE)
13554 43 : rhs_vptr = vptr;
13555 :
13556 : /* Generate (re)allocation of the lhs. */
13557 3554 : if (class_realloc)
13558 : {
13559 313 : stmtblock_t alloc, re_alloc;
13560 313 : tree class_han, re, size;
13561 :
13562 313 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13563 313 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
13564 : else
13565 0 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
13566 :
13567 313 : size = gfc_vptr_size_get (rhs_vptr);
13568 :
13569 : /* Take into account _len of unlimited polymorphic entities.
13570 : TODO: handle class(*) allocatable function results on rhs. */
13571 313 : if (UNLIMITED_POLY (rhs))
13572 : {
13573 18 : tree len;
13574 18 : if (rhs->expr_type == EXPR_VARIABLE)
13575 12 : len = trans_get_upoly_len (block, rhs);
13576 : else
13577 6 : len = gfc_class_len_get (tmp);
13578 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13579 : fold_convert (size_type_node, len),
13580 : size_one_node);
13581 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
13582 18 : size, fold_convert (TREE_TYPE (size), len));
13583 18 : }
13584 295 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
13585 27 : size = fold_build2_loc (input_location, MULT_EXPR,
13586 : gfc_charlen_type_node, size,
13587 : rse->string_length);
13588 :
13589 :
13590 313 : tmp = lse->expr;
13591 313 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
13592 313 : ? gfc_class_data_get (tmp) : tmp;
13593 :
13594 313 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
13595 0 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
13596 :
13597 : /* Allocate block. */
13598 313 : gfc_init_block (&alloc);
13599 313 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
13600 :
13601 : /* Reallocate if dynamic types are different. */
13602 313 : gfc_init_block (&re_alloc);
13603 313 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
13604 : {
13605 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
13606 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
13607 : }
13608 : else
13609 : {
13610 286 : tmp = fold_convert (pvoid_type_node, class_han);
13611 286 : re = build_call_expr_loc (input_location,
13612 : builtin_decl_explicit (BUILT_IN_REALLOC),
13613 : 2, tmp, size);
13614 286 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
13615 : tmp, re);
13616 286 : tmp = fold_build2_loc (input_location, NE_EXPR,
13617 : logical_type_node, rhs_vptr, old_vptr);
13618 286 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13619 : tmp, re, build_empty_stmt (input_location));
13620 286 : gfc_add_expr_to_block (&re_alloc, re);
13621 : }
13622 313 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
13623 313 : gfc_finish_block (&re_alloc) :
13624 0 : build_empty_stmt (input_location);
13625 :
13626 : /* Allocate if _data is NULL, reallocate otherwise. */
13627 313 : tmp = fold_build2_loc (input_location, EQ_EXPR,
13628 : logical_type_node, class_han,
13629 : build_int_cst (prvoid_type_node, 0));
13630 313 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13631 : gfc_unlikely (tmp,
13632 : PRED_FORTRAN_FAIL_ALLOC),
13633 : gfc_finish_block (&alloc),
13634 : realloc_expr);
13635 313 : gfc_add_expr_to_block (&lse->pre, tmp);
13636 : }
13637 :
13638 3554 : fcn = gfc_vptr_copy_get (vptr);
13639 :
13640 3554 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
13641 3554 : ? gfc_class_data_get (rse->expr) : rse->expr;
13642 3554 : if (use_vptr_copy)
13643 : {
13644 5890 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13645 578 : || INDIRECT_REF_P (tmp)
13646 421 : || (rhs->ts.type == BT_DERIVED
13647 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13648 0 : && !rhs->ts.u.derived->attr.pointer
13649 0 : && !rhs->ts.u.derived->attr.allocatable)
13650 3652 : || (UNLIMITED_POLY (rhs)
13651 134 : && !CLASS_DATA (rhs)->attr.pointer
13652 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13653 2810 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13654 : else
13655 421 : vec_safe_push (args, tmp);
13656 3231 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13657 3231 : ? gfc_class_data_get (lse->expr) : lse->expr;
13658 5604 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13659 858 : || INDIRECT_REF_P (tmp)
13660 313 : || (lhs->ts.type == BT_DERIVED
13661 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13662 0 : && !lhs->ts.u.derived->attr.pointer
13663 0 : && !lhs->ts.u.derived->attr.allocatable)
13664 3544 : || (UNLIMITED_POLY (lhs)
13665 125 : && !CLASS_DATA (lhs)->attr.pointer
13666 125 : && !CLASS_DATA (lhs)->attr.allocatable))
13667 2918 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13668 : else
13669 313 : vec_safe_push (args, tmp);
13670 :
13671 3231 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13672 :
13673 3231 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13674 : {
13675 442 : tree extcopy;
13676 442 : vec_safe_push (args, from_len);
13677 442 : vec_safe_push (args, to_len);
13678 442 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13679 :
13680 442 : tmp = fold_build2_loc (input_location, GT_EXPR,
13681 : logical_type_node, from_len,
13682 442 : build_zero_cst (TREE_TYPE (from_len)));
13683 442 : return fold_build3_loc (input_location, COND_EXPR,
13684 : void_type_node, tmp,
13685 442 : extcopy, stdcopy);
13686 : }
13687 : else
13688 : return stdcopy;
13689 : }
13690 : else
13691 : {
13692 323 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13693 323 : ? gfc_class_data_get (lse->expr) : lse->expr;
13694 323 : stmtblock_t tblock;
13695 323 : gfc_init_block (&tblock);
13696 323 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13697 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13698 323 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13699 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13700 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13701 323 : gfc_add_modify_loc (input_location, &tblock, rhst,
13702 323 : fold_convert (TREE_TYPE (rhst), tmp));
13703 323 : return gfc_finish_block (&tblock);
13704 : }
13705 : }
13706 :
13707 : bool
13708 315144 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13709 : {
13710 315144 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13711 : return false;
13712 :
13713 32858 : return lhs->symtree->n.sym->assoc
13714 32858 : && lhs->symtree->n.sym->assoc->target == rhs;
13715 : }
13716 :
13717 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13718 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13719 : init_flag indicates initialization expressions and dealloc that no
13720 : deallocate prior assignment is needed (if in doubt, set true).
13721 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13722 : routine instead of a pointer assignment. Alias resolution is only done,
13723 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13724 : where it is known, that newly allocated memory on the lhs can never be
13725 : an alias of the rhs. */
13726 :
13727 : static tree
13728 315144 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13729 : bool dealloc, bool use_vptr_copy, bool may_alias)
13730 : {
13731 315144 : gfc_se lse;
13732 315144 : gfc_se rse;
13733 315144 : gfc_ss *lss;
13734 315144 : gfc_ss *lss_section;
13735 315144 : gfc_ss *rss;
13736 315144 : gfc_loopinfo loop;
13737 315144 : tree tmp;
13738 315144 : stmtblock_t block;
13739 315144 : stmtblock_t body;
13740 315144 : bool final_expr;
13741 315144 : bool l_is_temp;
13742 315144 : bool scalar_to_array;
13743 315144 : tree string_length;
13744 315144 : int n;
13745 315144 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13746 315144 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr, rhs_attr;
13747 315144 : bool is_poly_assign;
13748 315144 : bool realloc_flag;
13749 315144 : bool assoc_assign = false;
13750 315144 : bool dummy_class_array_copy;
13751 :
13752 : /* Assignment of the form lhs = rhs. */
13753 315144 : gfc_start_block (&block);
13754 :
13755 315144 : gfc_init_se (&lse, NULL);
13756 315144 : gfc_init_se (&rse, NULL);
13757 :
13758 315144 : gfc_fix_class_refs (expr1);
13759 :
13760 630288 : realloc_flag = flag_realloc_lhs
13761 308804 : && gfc_is_reallocatable_lhs (expr1)
13762 8458 : && expr2->rank
13763 322112 : && !is_runtime_conformable (expr1, expr2);
13764 :
13765 : /* Walk the lhs. */
13766 315144 : lss = gfc_walk_expr (expr1);
13767 315144 : if (realloc_flag)
13768 : {
13769 6585 : lss->no_bounds_check = 1;
13770 6585 : lss->is_alloc_lhs = 1;
13771 : }
13772 : else
13773 308559 : lss->no_bounds_check = expr1->no_bounds_check;
13774 :
13775 315144 : rss = NULL;
13776 :
13777 315144 : if (expr2->expr_type != EXPR_VARIABLE
13778 315144 : && expr2->expr_type != EXPR_CONSTANT
13779 315144 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13780 : {
13781 924 : expr2->must_finalize = 1;
13782 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13783 : function, the result is finalized after execution of the innermost
13784 : executable construct containing the reference. */
13785 924 : if (expr2->expr_type == EXPR_FUNCTION
13786 924 : && (gfc_expr_attr (expr2).pointer
13787 310 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13788 147 : expr2->must_finalize = 0;
13789 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13790 : structure constructor or array constructor, the entity created by
13791 : the constructor is finalized after execution of the innermost
13792 : executable construct containing the reference.
13793 : These finalizations were later deleted by the Combined Technical
13794 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13795 777 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13796 777 : && (expr2->expr_type == EXPR_STRUCTURE
13797 734 : || expr2->expr_type == EXPR_ARRAY))
13798 405 : expr2->must_finalize = 0;
13799 : }
13800 :
13801 :
13802 : /* Checking whether a class assignment is desired is quite complicated and
13803 : needed at two locations, so do it once only before the information is
13804 : needed. */
13805 315144 : lhs_attr = gfc_expr_attr (expr1);
13806 315144 : rhs_attr = gfc_expr_attr (expr2);
13807 315144 : dummy_class_array_copy
13808 630288 : = (expr2->expr_type == EXPR_VARIABLE
13809 32858 : && expr2->rank > 0
13810 8504 : && expr2->symtree != NULL
13811 8504 : && expr2->symtree->n.sym->attr.dummy
13812 1507 : && expr2->ts.type == BT_CLASS
13813 163 : && !rhs_attr.pointer
13814 163 : && !rhs_attr.allocatable
13815 150 : && !CLASS_DATA (expr2)->attr.class_pointer
13816 315294 : && !CLASS_DATA (expr2)->attr.allocatable);
13817 :
13818 : /* What can be sent to trans_class_assignment includes all the obvious
13819 : candidates but scalar assignment of a class expression to a derived type
13820 : must be done using gfc_trans_scalar_assign; partly because it is simpler
13821 : and partly because some cases fail, eg. class assignment to derived_type
13822 : select type temporaries. */
13823 315144 : is_poly_assign
13824 315144 : = (use_vptr_copy
13825 297380 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13826 23819 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13827 21660 : || gfc_is_class_scalar_expr (expr1)
13828 20253 : || gfc_is_class_array_ref (expr2, NULL)
13829 20253 : || (gfc_is_class_scalar_expr (expr2)
13830 42 : && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
13831 318710 : && lhs_attr.flavor != FL_PROCEDURE;
13832 :
13833 315144 : assoc_assign = is_assoc_assign (expr1, expr2);
13834 :
13835 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13836 : mode. Avoid false-positive uninitialized diagnostics with initializing
13837 : the codimension flag unconditionally. */
13838 315144 : lhs_caf_attr.codimension = false;
13839 315144 : rhs_caf_attr.codimension = false;
13840 315144 : if (flag_coarray == GFC_FCOARRAY_LIB)
13841 : {
13842 6995 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13843 6995 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13844 : }
13845 :
13846 315144 : tree reallocation = NULL_TREE;
13847 315144 : if (lss != gfc_ss_terminator)
13848 : {
13849 : /* The assignment needs scalarization. */
13850 : lss_section = lss;
13851 :
13852 : /* Find a non-scalar SS from the lhs. */
13853 : while (lss_section != gfc_ss_terminator
13854 40916 : && lss_section->info->type != GFC_SS_SECTION)
13855 0 : lss_section = lss_section->next;
13856 :
13857 40916 : gcc_assert (lss_section != gfc_ss_terminator);
13858 :
13859 : /* Initialize the scalarizer. */
13860 40916 : gfc_init_loopinfo (&loop);
13861 :
13862 : /* Walk the rhs. */
13863 40916 : rss = gfc_walk_expr (expr2);
13864 40916 : if (rss == gfc_ss_terminator)
13865 : {
13866 : /* The rhs is scalar. Add a ss for the expression. */
13867 15389 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13868 15389 : lss->is_alloc_lhs = 0;
13869 : }
13870 :
13871 : /* When doing a class assign, then the handle to the rhs needs to be a
13872 : pointer to allow for polymorphism. */
13873 40916 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13874 515 : rss->info->type = GFC_SS_REFERENCE;
13875 :
13876 40916 : rss->no_bounds_check = expr2->no_bounds_check;
13877 : /* Associate the SS with the loop. */
13878 40916 : gfc_add_ss_to_loop (&loop, lss);
13879 40916 : gfc_add_ss_to_loop (&loop, rss);
13880 :
13881 : /* Calculate the bounds of the scalarization. */
13882 40916 : gfc_conv_ss_startstride (&loop);
13883 : /* Enable loop reversal. */
13884 695572 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13885 613740 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13886 : /* Resolve any data dependencies in the statement. */
13887 40916 : if (may_alias)
13888 38577 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13889 : /* Setup the scalarizing loops. */
13890 40916 : gfc_conv_loop_setup (&loop, &expr2->where);
13891 :
13892 : /* Setup the gfc_se structures. */
13893 40916 : gfc_copy_loopinfo_to_se (&lse, &loop);
13894 40916 : gfc_copy_loopinfo_to_se (&rse, &loop);
13895 :
13896 40916 : rse.ss = rss;
13897 40916 : gfc_mark_ss_chain_used (rss, 1);
13898 40916 : if (loop.temp_ss == NULL)
13899 : {
13900 39802 : lse.ss = lss;
13901 39802 : gfc_mark_ss_chain_used (lss, 1);
13902 : }
13903 : else
13904 : {
13905 1114 : lse.ss = loop.temp_ss;
13906 1114 : gfc_mark_ss_chain_used (lss, 3);
13907 1114 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13908 : }
13909 :
13910 : /* Allow the scalarizer to workshare array assignments. */
13911 40916 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13912 : == OMPWS_WORKSHARE_FLAG
13913 85 : && loop.temp_ss == NULL)
13914 : {
13915 73 : maybe_workshare = true;
13916 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13917 : }
13918 :
13919 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13920 40916 : if (realloc_flag)
13921 : {
13922 6585 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13923 6585 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13924 6585 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13925 : expr2);
13926 : }
13927 :
13928 : /* Start the scalarized loop body. */
13929 40916 : gfc_start_scalarized_body (&loop, &body);
13930 : }
13931 : else
13932 274228 : gfc_init_block (&body);
13933 :
13934 315144 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13935 :
13936 : /* Translate the expression. */
13937 630288 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13938 315144 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13939 315144 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13940 315144 : gfc_conv_expr (&rse, expr2);
13941 :
13942 : /* Deal with the case of a scalar class function assigned to a derived type.
13943 : */
13944 315144 : if (gfc_is_alloc_class_scalar_function (expr2)
13945 315144 : && expr1->ts.type == BT_DERIVED)
13946 : {
13947 60 : rse.expr = gfc_class_data_get (rse.expr);
13948 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13949 : }
13950 :
13951 : /* Stabilize a string length for temporaries. */
13952 315144 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13953 25022 : && !(VAR_P (rse.string_length)
13954 : || TREE_CODE (rse.string_length) == PARM_DECL
13955 : || INDIRECT_REF_P (rse.string_length)))
13956 24134 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13957 291010 : else if (expr2->ts.type == BT_CHARACTER)
13958 : {
13959 4508 : if (expr1->ts.deferred
13960 7013 : && gfc_expr_attr (expr1).allocatable
13961 7133 : && gfc_check_dependency (expr1, expr2, true))
13962 120 : rse.string_length =
13963 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13964 4508 : string_length = rse.string_length;
13965 : }
13966 : else
13967 : string_length = NULL_TREE;
13968 :
13969 315144 : if (l_is_temp)
13970 : {
13971 1114 : gfc_conv_tmp_array_ref (&lse);
13972 1114 : if (expr2->ts.type == BT_CHARACTER)
13973 123 : lse.string_length = string_length;
13974 : }
13975 : else
13976 : {
13977 314030 : gfc_conv_expr (&lse, expr1);
13978 : /* For some expression (e.g. complex numbers) fold_convert uses a
13979 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13980 : not updated when assigned to. */
13981 314030 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13982 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13983 :
13984 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13985 320183 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13986 : {
13987 36 : tree cond;
13988 36 : const char* msg;
13989 :
13990 36 : tmp = INDIRECT_REF_P (lse.expr)
13991 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13992 36 : STRIP_NOPS (tmp);
13993 :
13994 : /* We should only get array references here. */
13995 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13996 : || TREE_CODE (tmp) == ARRAY_REF);
13997 :
13998 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13999 : or the array itself(ARRAY_REF). */
14000 36 : tmp = TREE_OPERAND (tmp, 0);
14001 :
14002 : /* Provide the address of the array. */
14003 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
14004 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
14005 :
14006 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
14007 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
14008 36 : msg = _("Assignment of scalar to unallocated array");
14009 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
14010 : &expr1->where, msg);
14011 : }
14012 :
14013 : /* Deallocate the lhs parameterized components if required. */
14014 314030 : if (dealloc
14015 294688 : && !expr1->symtree->n.sym->attr.associate_var
14016 292628 : && expr2->expr_type != EXPR_ARRAY
14017 286388 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
14018 : {
14019 445 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
14020 :
14021 445 : tmp = lse.expr;
14022 445 : if (pdt_dep)
14023 : {
14024 : /* Create a temporary for deallocation after assignment. */
14025 228 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
14026 228 : gfc_add_modify (&lse.pre, tmp, lse.expr);
14027 : }
14028 :
14029 445 : if (expr1->ts.type == BT_DERIVED)
14030 445 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
14031 : expr1->rank);
14032 0 : else if (expr1->ts.type == BT_CLASS)
14033 : {
14034 0 : tmp = gfc_class_data_get (tmp);
14035 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
14036 : tmp, expr1->rank);
14037 : }
14038 :
14039 445 : if (tmp && pdt_dep)
14040 116 : gfc_add_expr_to_block (&rse.post, tmp);
14041 329 : else if (tmp)
14042 85 : gfc_add_expr_to_block (&lse.pre, tmp);
14043 : }
14044 : }
14045 :
14046 : /* Assignments of scalar derived types with allocatable components
14047 : to arrays must be done with a deep copy and the rhs temporary
14048 : must have its components deallocated afterwards. */
14049 630288 : scalar_to_array = (expr2->ts.type == BT_DERIVED
14050 20484 : && expr2->ts.u.derived->attr.alloc_comp
14051 7078 : && !gfc_expr_is_variable (expr2)
14052 319003 : && expr1->rank && !expr2->rank);
14053 630288 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
14054 20779 : && expr1->rank
14055 3975 : && expr1->ts.u.derived->attr.alloc_comp
14056 316603 : && gfc_is_alloc_class_scalar_function (expr2));
14057 315144 : if (scalar_to_array && dealloc)
14058 : {
14059 59 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
14060 59 : gfc_prepend_expr_to_block (&loop.post, tmp);
14061 : }
14062 :
14063 : /* When assigning a character function result to a deferred-length variable,
14064 : the function call must happen before the (re)allocation of the lhs -
14065 : otherwise the character length of the result is not known.
14066 : NOTE 1: This relies on having the exact dependence of the length type
14067 : parameter available to the caller; gfortran saves it in the .mod files.
14068 : NOTE 2: Vector array references generate an index temporary that must
14069 : not go outside the loop. Otherwise, variables should not generate
14070 : a pre block.
14071 : NOTE 3: The concatenation operation generates a temporary pointer,
14072 : whose allocation must go to the innermost loop.
14073 : NOTE 4: Elemental functions may generate a temporary, too. */
14074 315144 : if (flag_realloc_lhs
14075 308804 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
14076 3086 : && !(lss != gfc_ss_terminator
14077 952 : && rss != gfc_ss_terminator
14078 952 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
14079 759 : || (expr2->expr_type == EXPR_FUNCTION
14080 160 : && expr2->value.function.esym != NULL
14081 26 : && expr2->value.function.esym->attr.elemental)
14082 746 : || (expr2->expr_type == EXPR_FUNCTION
14083 147 : && expr2->value.function.isym != NULL
14084 134 : && expr2->value.function.isym->elemental)
14085 690 : || (expr2->expr_type == EXPR_OP
14086 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
14087 2799 : gfc_add_block_to_block (&block, &rse.pre);
14088 :
14089 : /* Nullify the allocatable components corresponding to those of the lhs
14090 : derived type, so that the finalization of the function result does not
14091 : affect the lhs of the assignment. Prepend is used to ensure that the
14092 : nullification occurs before the call to the finalizer. In the case of
14093 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
14094 : as part of the deep copy. */
14095 314286 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
14096 335065 : && (gfc_is_class_array_function (expr2)
14097 19897 : || gfc_is_alloc_class_scalar_function (expr2)))
14098 : {
14099 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
14100 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
14101 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
14102 0 : gfc_add_block_to_block (&loop.post, &rse.post);
14103 : }
14104 :
14105 315144 : tmp = NULL_TREE;
14106 :
14107 315144 : if (is_poly_assign)
14108 : {
14109 10662 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
14110 636 : use_vptr_copy || (lhs_attr.allocatable
14111 313 : && !lhs_attr.dimension),
14112 3280 : !realloc_flag && flag_realloc_lhs
14113 636 : && !lhs_attr.pointer);
14114 3554 : if (expr2->expr_type == EXPR_FUNCTION
14115 244 : && expr2->ts.type == BT_DERIVED
14116 18 : && expr2->ts.u.derived->attr.alloc_comp)
14117 : {
14118 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
14119 : rse.expr, expr2->rank);
14120 18 : if (lss == gfc_ss_terminator)
14121 18 : gfc_add_expr_to_block (&rse.post, tmp2);
14122 : else
14123 0 : gfc_add_expr_to_block (&loop.post, tmp2);
14124 : }
14125 :
14126 3554 : expr1->must_finalize = 0;
14127 : }
14128 311590 : else if (!is_poly_assign
14129 311590 : && expr1->ts.type == BT_CLASS
14130 393 : && expr2->ts.type == BT_CLASS
14131 200 : && (expr2->must_finalize || dummy_class_array_copy))
14132 : {
14133 : /* This case comes about when the scalarizer provides array element
14134 : references to class temporaries or nonpointer dummy arrays. Use the
14135 : vptr copy function, since this does a deep copy of allocatable
14136 : components. */
14137 132 : tmp = gfc_get_vptr_from_expr (rse.expr);
14138 132 : if (tmp == NULL_TREE && dummy_class_array_copy)
14139 12 : tmp = gfc_get_vptr_from_expr (gfc_get_class_from_gfc_expr (expr2));
14140 132 : if (tmp != NULL_TREE)
14141 : {
14142 132 : tree fcn = gfc_vptr_copy_get (tmp);
14143 132 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
14144 132 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
14145 132 : tmp = build_call_expr_loc (input_location,
14146 : fcn, 2,
14147 : gfc_build_addr_expr (NULL, rse.expr),
14148 : gfc_build_addr_expr (NULL, lse.expr));
14149 : }
14150 : }
14151 :
14152 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
14153 : after evaluation of the rhs and before reallocation.
14154 : Skip finalization for self-assignment to avoid use-after-free.
14155 : Strip parentheses from both sides to handle cases like a = (a). */
14156 315144 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
14157 315144 : if (final_expr
14158 702 : && gfc_dep_compare_expr (strip_parentheses (expr1),
14159 : strip_parentheses (expr2)) != 0
14160 315822 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
14161 229 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
14162 : {
14163 678 : if (lss == gfc_ss_terminator)
14164 : {
14165 201 : gfc_add_block_to_block (&block, &rse.pre);
14166 201 : gfc_add_block_to_block (&block, &lse.finalblock);
14167 : }
14168 : else
14169 : {
14170 477 : gfc_add_block_to_block (&body, &rse.pre);
14171 477 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
14172 : &lse.finalblock);
14173 : }
14174 : }
14175 : else
14176 314466 : gfc_add_block_to_block (&body, &rse.pre);
14177 :
14178 315144 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
14179 3004 : && assoc_assign)
14180 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
14181 :
14182 : /* The finalization above is all that is wanted: the structure copy is done
14183 : component by component in generate_component_assignments. */
14184 315144 : if (expr1->finalize_only)
14185 24 : tmp = build_empty_stmt (input_location);
14186 :
14187 : /* If nothing else works, do it the old fashioned way! */
14188 315144 : if (tmp == NULL_TREE)
14189 : {
14190 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
14191 311434 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
14192 311434 : tmp
14193 622868 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
14194 311434 : gfc_expr_is_variable (expr2_stripped)
14195 280474 : || scalar_to_array
14196 279712 : || expr2->expr_type == EXPR_ARRAY,
14197 : !(l_is_temp || init_flag) && dealloc,
14198 311434 : expr1->symtree->n.sym->attr.codimension,
14199 : assoc_assign);
14200 : }
14201 :
14202 : /* Add the lse pre block to the body */
14203 315144 : gfc_add_block_to_block (&body, &lse.pre);
14204 315144 : gfc_add_expr_to_block (&body, tmp);
14205 :
14206 : /* Add the post blocks to the body. Scalar finalization must appear before
14207 : the post block in case any dellocations are done. */
14208 315144 : if (rse.finalblock.head
14209 315144 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
14210 154 : && gfc_expr_attr (expr2).elemental)))
14211 : {
14212 154 : gfc_add_block_to_block (&body, &rse.finalblock);
14213 154 : gfc_add_block_to_block (&body, &rse.post);
14214 : }
14215 : else
14216 314990 : gfc_add_block_to_block (&body, &rse.post);
14217 :
14218 315144 : gfc_add_block_to_block (&body, &lse.post);
14219 :
14220 315144 : if (lss == gfc_ss_terminator)
14221 : {
14222 : /* F2003: Add the code for reallocation on assignment. */
14223 271315 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
14224 277961 : && !is_poly_assign)
14225 3733 : alloc_scalar_allocatable_for_assignment (&block, string_length,
14226 : expr1, expr2);
14227 :
14228 : /* Use the scalar assignment as is. */
14229 274228 : gfc_add_block_to_block (&block, &body);
14230 : }
14231 : else
14232 : {
14233 40916 : gcc_assert (lse.ss == gfc_ss_terminator
14234 : && rse.ss == gfc_ss_terminator);
14235 :
14236 40916 : if (l_is_temp)
14237 : {
14238 1114 : gfc_trans_scalarized_loop_boundary (&loop, &body);
14239 :
14240 : /* We need to copy the temporary to the actual lhs. */
14241 1114 : gfc_init_se (&lse, NULL);
14242 1114 : gfc_init_se (&rse, NULL);
14243 1114 : gfc_copy_loopinfo_to_se (&lse, &loop);
14244 1114 : gfc_copy_loopinfo_to_se (&rse, &loop);
14245 :
14246 1114 : rse.ss = loop.temp_ss;
14247 1114 : lse.ss = lss;
14248 :
14249 1114 : gfc_conv_tmp_array_ref (&rse);
14250 1114 : gfc_conv_expr (&lse, expr1);
14251 :
14252 1114 : gcc_assert (lse.ss == gfc_ss_terminator
14253 : && rse.ss == gfc_ss_terminator);
14254 :
14255 1114 : if (expr2->ts.type == BT_CHARACTER)
14256 123 : rse.string_length = string_length;
14257 :
14258 1114 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
14259 : false, dealloc);
14260 1114 : gfc_add_expr_to_block (&body, tmp);
14261 : }
14262 :
14263 40916 : if (reallocation != NULL_TREE)
14264 6585 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
14265 :
14266 40916 : if (maybe_workshare)
14267 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
14268 :
14269 : /* Generate the copying loops. */
14270 40916 : gfc_trans_scalarizing_loops (&loop, &body);
14271 :
14272 : /* Wrap the whole thing up. */
14273 40916 : gfc_add_block_to_block (&block, &loop.pre);
14274 40916 : gfc_add_block_to_block (&block, &loop.post);
14275 :
14276 40916 : gfc_cleanup_loop (&loop);
14277 : }
14278 :
14279 : /* Since parameterized components cannot have default initializers,
14280 : the default PDT constructor leaves them unallocated. Do the
14281 : allocation now. */
14282 315144 : if (init_flag && IS_PDT (expr1)
14283 473 : && !expr1->symtree->n.sym->attr.allocatable
14284 473 : && !expr1->symtree->n.sym->attr.dummy)
14285 : {
14286 79 : gfc_symbol *sym = expr1->symtree->n.sym;
14287 79 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
14288 : sym->backend_decl,
14289 79 : sym->as ? sym->as->rank : 0,
14290 79 : sym->param_list);
14291 79 : gfc_add_expr_to_block (&block, tmp);
14292 : }
14293 :
14294 315144 : return gfc_finish_block (&block);
14295 : }
14296 :
14297 :
14298 : /* Check whether EXPR is a copyable array. */
14299 :
14300 : static bool
14301 998531 : copyable_array_p (gfc_expr * expr)
14302 : {
14303 998531 : if (expr->expr_type != EXPR_VARIABLE)
14304 : return false;
14305 :
14306 : /* First check it's an array. */
14307 974389 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
14308 : return false;
14309 :
14310 150619 : if (!gfc_full_array_ref_p (expr->ref, NULL))
14311 : return false;
14312 :
14313 : /* Next check that it's of a simple enough type. */
14314 117878 : switch (expr->ts.type)
14315 : {
14316 : case BT_INTEGER:
14317 : case BT_REAL:
14318 : case BT_COMPLEX:
14319 : case BT_LOGICAL:
14320 : return true;
14321 :
14322 : case BT_CHARACTER:
14323 : return false;
14324 :
14325 6929 : case_bt_struct:
14326 6929 : return (!expr->ts.u.derived->attr.alloc_comp
14327 6929 : && !expr->ts.u.derived->attr.pdt_type);
14328 :
14329 : default:
14330 : break;
14331 : }
14332 :
14333 : return false;
14334 : }
14335 :
14336 : /* Translate an assignment. */
14337 :
14338 : tree
14339 333213 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
14340 : bool dealloc, bool use_vptr_copy, bool may_alias)
14341 : {
14342 333213 : tree tmp;
14343 :
14344 : /* Special case a single function returning an array. */
14345 333213 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
14346 : {
14347 14524 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
14348 14524 : if (tmp)
14349 : return tmp;
14350 : }
14351 :
14352 : /* Special case assigning an array to zero. */
14353 326346 : if (copyable_array_p (expr1)
14354 326346 : && is_zero_initializer_p (expr2))
14355 : {
14356 4060 : tmp = gfc_trans_zero_assign (expr1);
14357 4060 : if (tmp)
14358 : return tmp;
14359 : }
14360 :
14361 : /* Special case copying one array to another. */
14362 322583 : if (copyable_array_p (expr1)
14363 28505 : && copyable_array_p (expr2)
14364 2699 : && gfc_compare_types (&expr1->ts, &expr2->ts)
14365 325282 : && !gfc_check_dependency (expr1, expr2, 0))
14366 : {
14367 2603 : tmp = gfc_trans_array_copy (expr1, expr2);
14368 2603 : if (tmp)
14369 : return tmp;
14370 : }
14371 :
14372 : /* Special case initializing an array from a constant array constructor. */
14373 321097 : if (copyable_array_p (expr1)
14374 27019 : && expr2->expr_type == EXPR_ARRAY
14375 329452 : && gfc_compare_types (&expr1->ts, &expr2->ts))
14376 : {
14377 8355 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
14378 8355 : if (tmp)
14379 : return tmp;
14380 : }
14381 :
14382 315144 : if (UNLIMITED_POLY (expr1) && expr1->rank)
14383 315144 : use_vptr_copy = true;
14384 :
14385 : /* Fallback to the scalarizer to generate explicit loops. */
14386 315144 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
14387 315144 : use_vptr_copy, may_alias);
14388 : }
14389 :
14390 : tree
14391 13791 : gfc_trans_init_assign (gfc_code * code)
14392 : {
14393 13791 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
14394 : }
14395 :
14396 : tree
14397 310785 : gfc_trans_assign (gfc_code * code)
14398 : {
14399 310785 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
14400 : }
14401 :
14402 : /* Generate a simple loop for internal use of the form
14403 : for (var = begin; var <cond> end; var += step)
14404 : body; */
14405 : void
14406 12281 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
14407 : enum tree_code cond, tree step, tree body)
14408 : {
14409 12281 : tree tmp;
14410 :
14411 : /* var = begin. */
14412 12281 : gfc_add_modify (block, var, begin);
14413 :
14414 : /* Loop: for (var = begin; var <cond> end; var += step). */
14415 12281 : tree label_loop = gfc_build_label_decl (NULL_TREE);
14416 12281 : tree label_cond = gfc_build_label_decl (NULL_TREE);
14417 12281 : TREE_USED (label_loop) = 1;
14418 12281 : TREE_USED (label_cond) = 1;
14419 :
14420 12281 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
14421 12281 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
14422 :
14423 : /* Loop body. */
14424 12281 : gfc_add_expr_to_block (block, body);
14425 :
14426 : /* End of loop body. */
14427 12281 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
14428 12281 : gfc_add_modify (block, var, tmp);
14429 12281 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
14430 12281 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
14431 12281 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
14432 : build_empty_stmt (input_location));
14433 12281 : gfc_add_expr_to_block (block, tmp);
14434 12281 : }
|
