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 36366 : gfc_get_character_len (tree type)
53 : {
54 36366 : tree len;
55 :
56 36366 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
57 : && TYPE_STRING_FLAG (type));
58 :
59 36366 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
60 36366 : len = (len) ? (len) : (integer_zero_node);
61 36366 : 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 36366 : gfc_get_character_len_in_bytes (tree type)
70 : {
71 36366 : tree tmp, len;
72 :
73 36366 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
74 : && TYPE_STRING_FLAG (type));
75 :
76 36366 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
77 72732 : tmp = (tmp && !integer_zerop (tmp))
78 72732 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
79 36366 : len = gfc_get_character_len (type);
80 36366 : if (tmp && len && !integer_zerop (len))
81 35552 : len = fold_build2_loc (input_location, MULT_EXPR,
82 : gfc_charlen_type_node, len, tmp);
83 36366 : return len;
84 : }
85 :
86 :
87 : tree
88 6338 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
89 : {
90 6338 : tree desc, type;
91 :
92 6338 : type = gfc_get_scalar_to_descriptor_type (TREE_TYPE (scalar), attr);
93 6338 : desc = gfc_create_var (type, "desc");
94 6338 : DECL_ARTIFICIAL (desc) = 1;
95 :
96 6338 : 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 6338 : 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 6338 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
109 2302 : gfc_add_modify (&se->post, scalar,
110 1151 : fold_convert (TREE_TYPE (scalar),
111 : gfc_conv_descriptor_data_get (desc)));
112 6338 : 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 552 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
121 : {
122 552 : gfc_symbol *sym = expr->symtree->n.sym;
123 1104 : bool is_coarray = sym->ts.type == BT_CLASS
124 552 : ? CLASS_DATA (sym)->attr.codimension
125 503 : : sym->attr.codimension;
126 552 : gfc_expr *caf_expr = gfc_copy_expr (expr);
127 552 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
128 :
129 1720 : while (ref)
130 : {
131 1168 : 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 1168 : last_caf_ref = ref;
136 1168 : ref = ref->next;
137 : }
138 :
139 552 : if (last_caf_ref == NULL)
140 : {
141 202 : gfc_free_expr (caf_expr);
142 202 : 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 33568 : gfc_class_data_get (tree decl)
216 : {
217 33568 : tree data;
218 33568 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
219 5603 : decl = build_fold_indirect_ref_loc (input_location, decl);
220 33568 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
221 : CLASS_DATA_FIELD);
222 33568 : return fold_build3_loc (input_location, COMPONENT_REF,
223 33568 : TREE_TYPE (data), decl, data,
224 33568 : NULL_TREE);
225 : }
226 :
227 :
228 : tree
229 47506 : gfc_class_vptr_get (tree decl)
230 : {
231 47506 : tree vptr;
232 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
233 : then available through the saved descriptor. */
234 29101 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
235 49528 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
236 1351 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
237 47506 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
238 2417 : decl = build_fold_indirect_ref_loc (input_location, decl);
239 47506 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
240 : CLASS_VPTR_FIELD);
241 47506 : return fold_build3_loc (input_location, COMPONENT_REF,
242 47506 : TREE_TYPE (vptr), decl, vptr,
243 47506 : NULL_TREE);
244 : }
245 :
246 :
247 : tree
248 7129 : gfc_class_len_get (tree decl)
249 : {
250 7129 : tree len;
251 : /* For class arrays decl may be a temporary descriptor handle, the len is
252 : then available through the saved descriptor. */
253 5057 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
254 7420 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
255 127 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
256 7129 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
257 704 : decl = build_fold_indirect_ref_loc (input_location, decl);
258 7129 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
259 : CLASS_LEN_FIELD);
260 7129 : return fold_build3_loc (input_location, COMPONENT_REF,
261 7129 : TREE_TYPE (len), decl, len,
262 7129 : 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 8556 : gfc_class_len_or_zero_get (tree decl)
271 : {
272 8556 : tree len;
273 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
274 : then available through the saved descriptor. */
275 4237 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
276 8730 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
277 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
278 8556 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
279 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
280 8556 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
281 : CLASS_LEN_FIELD);
282 11017 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
283 2461 : TREE_TYPE (len), decl, len,
284 : NULL_TREE)
285 6095 : : build_zero_cst (gfc_charlen_type_node);
286 : }
287 :
288 :
289 : tree
290 8374 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
291 : {
292 8374 : tree tmp;
293 8374 : tree tmp2;
294 8374 : tree type;
295 :
296 8374 : tmp = gfc_class_len_or_zero_get (class_expr);
297 :
298 : /* Include the len value in the element size if present. */
299 8374 : if (!integer_zerop (tmp))
300 : {
301 2279 : type = TREE_TYPE (size);
302 2279 : if (block)
303 : {
304 1080 : size = gfc_evaluate_now (size, block);
305 1080 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
306 : }
307 : else
308 1199 : tmp = fold_convert (type , tmp);
309 2279 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
310 : type, size, tmp);
311 2279 : tmp = fold_build2_loc (input_location, GT_EXPR,
312 : logical_type_node, tmp,
313 : build_zero_cst (type));
314 2279 : size = fold_build3_loc (input_location, COND_EXPR,
315 : type, tmp, tmp2, size);
316 : }
317 : else
318 : return size;
319 :
320 2279 : if (block)
321 1080 : 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 22349 : vptr_field_get (tree vptr, int fieldno)
331 : {
332 22349 : tree field;
333 22349 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
334 22349 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
335 : fieldno);
336 22349 : field = fold_build3_loc (input_location, COMPONENT_REF,
337 22349 : TREE_TYPE (field), vptr, field,
338 : NULL_TREE);
339 22349 : gcc_assert (field);
340 22349 : return field;
341 : }
342 :
343 :
344 : /* Get the field from the class' vptr. */
345 :
346 : static tree
347 10368 : class_vtab_field_get (tree decl, int fieldno)
348 : {
349 10368 : tree vptr;
350 10368 : vptr = gfc_class_vptr_get (decl);
351 10368 : 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 4582 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
373 1914 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
374 1167 : 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 8252 : gfc_class_vtab_size_get (tree cl)
382 : {
383 8252 : tree size;
384 8252 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
385 : /* Always return size as an array index type. */
386 8252 : size = fold_convert (gfc_array_index_type, size);
387 8252 : gcc_assert (size);
388 8252 : return size;
389 : }
390 :
391 : tree
392 6251 : gfc_vptr_size_get (tree vptr)
393 : {
394 6251 : tree size;
395 6251 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
396 : /* Always return size as an array index type. */
397 6251 : size = fold_convert (gfc_array_index_type, size);
398 6251 : gcc_assert (size);
399 6251 : 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 10040 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
427 : gfc_typespec **ts)
428 : {
429 10040 : gfc_expr *base_expr;
430 10040 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
431 :
432 : /* Find the last class reference. */
433 10040 : class_ref = NULL;
434 10040 : array_ref = NULL;
435 :
436 10040 : 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 25147 : for (ref = e->ref; ref; ref = ref->next)
446 : {
447 15575 : 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 14435 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
468 14435 : array_ref = ref;
469 :
470 14435 : if (ref->type == REF_COMPONENT
471 8685 : && 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 1715 : 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 10030 : if (ts && *ts == NULL)
486 : return NULL;
487 :
488 : /* Remove and store all subsequent references after the
489 : CLASS reference. */
490 10005 : if (class_ref)
491 : {
492 1513 : tail = class_ref->next;
493 1513 : class_ref->next = NULL;
494 : }
495 8492 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
496 : {
497 8492 : tail = e->ref;
498 8492 : e->ref = NULL;
499 : }
500 :
501 10005 : if (is_mold)
502 61 : base_expr = gfc_expr_to_initialize (e);
503 : else
504 9944 : base_expr = gfc_copy_expr (e);
505 :
506 : /* Restore the original tail expression. */
507 10005 : if (class_ref)
508 : {
509 1513 : gfc_free_ref_list (class_ref->next);
510 1513 : class_ref->next = tail;
511 : }
512 8492 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
513 : {
514 8492 : gfc_free_ref_list (e->ref);
515 8492 : 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 11584 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
527 : gfc_symbol *class_type)
528 : {
529 11584 : tree vptr = NULL_TREE;
530 :
531 11584 : if (class_container != NULL_TREE)
532 6890 : vptr = gfc_get_vptr_from_expr (class_container);
533 :
534 6890 : if (vptr == NULL_TREE)
535 : {
536 4701 : gfc_se se;
537 4701 : gcc_assert (e);
538 :
539 : /* Evaluate the expression and obtain the vptr from it. */
540 4701 : gfc_init_se (&se, NULL);
541 4701 : if (e->rank)
542 2336 : gfc_conv_expr_descriptor (&se, e);
543 : else
544 2365 : gfc_conv_expr (&se, e);
545 4701 : gfc_add_block_to_block (block, &se.pre);
546 :
547 4701 : vptr = gfc_get_vptr_from_expr (se.expr);
548 : }
549 :
550 : /* If a vptr is not found, we can do nothing more. */
551 4701 : if (vptr == NULL_TREE)
552 : return;
553 :
554 11574 : if (UNLIMITED_POLY (e)
555 10502 : || 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 1583 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
559 1583 : && class_type->components && class_type->components->ts.u.derived
560 1577 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
561 1252 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
562 : else
563 : {
564 10322 : gfc_symbol *vtab, *type = nullptr;
565 10322 : tree vtable;
566 :
567 10322 : if (e)
568 8919 : type = e->ts.u.derived;
569 1403 : else if (class_type)
570 : {
571 1403 : 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 8919 : gcc_assert (type);
577 : /* Return the vptr to the address of the declared type. */
578 10322 : vtab = gfc_find_derived_vtab (type);
579 10322 : vtable = vtab->backend_decl;
580 10322 : if (vtable == NULL_TREE)
581 100 : vtable = gfc_get_symbol_decl (vtab);
582 10322 : vtable = gfc_build_addr_expr (NULL, vtable);
583 10322 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
584 10322 : 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 657 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
647 : {
648 657 : gfc_expr *e;
649 657 : gfc_se se_len;
650 657 : e = gfc_find_and_cut_at_last_class_ref (expr);
651 657 : if (e == NULL)
652 : return;
653 657 : gfc_add_len_component (e);
654 657 : gfc_init_se (&se_len, NULL);
655 657 : gfc_conv_expr (&se_len, e);
656 657 : gfc_add_modify (block, se_len.expr,
657 657 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
658 657 : 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 1565 : gfc_get_class_from_gfc_expr (gfc_expr *e)
668 : {
669 1565 : gfc_expr *class_expr;
670 1565 : gfc_se cse;
671 1565 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
672 1565 : if (class_expr == NULL)
673 : return NULL_TREE;
674 1565 : gfc_init_se (&cse, NULL);
675 1565 : gfc_conv_expr (&cse, class_expr);
676 1565 : gfc_free_expr (class_expr);
677 1565 : 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 110362 : gfc_get_class_from_expr (tree expr)
686 : {
687 110362 : tree tmp;
688 110362 : tree type;
689 110362 : bool array_descr_found = false;
690 110362 : bool comp_after_descr_found = false;
691 :
692 284415 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
693 : {
694 284415 : if (CONSTANT_CLASS_P (tmp))
695 : return NULL_TREE;
696 :
697 284378 : type = TREE_TYPE (tmp);
698 329647 : while (type)
699 : {
700 321751 : if (GFC_CLASS_TYPE_P (type))
701 : return tmp;
702 301288 : if (GFC_DESCRIPTOR_TYPE_P (type))
703 36040 : array_descr_found = true;
704 301288 : if (type != TYPE_CANONICAL (type))
705 45269 : type = TYPE_CANONICAL (type);
706 : else
707 : type = NULL_TREE;
708 : }
709 263915 : 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 174053 : if (array_descr_found)
719 : {
720 7644 : if (comp_after_descr_found)
721 : {
722 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
723 : return NULL_TREE;
724 : }
725 7632 : else if (TREE_CODE (tmp) == COMPONENT_REF)
726 7644 : comp_after_descr_found = true;
727 : }
728 : }
729 :
730 89862 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
731 60297 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
732 :
733 89862 : 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 12251 : gfc_get_vptr_from_expr (tree expr)
745 : {
746 12251 : tree tmp;
747 :
748 12251 : tmp = gfc_get_class_from_expr (expr);
749 :
750 12251 : if (tmp != NULL_TREE)
751 12180 : return gfc_class_vptr_get (tmp);
752 :
753 : return NULL_TREE;
754 : }
755 :
756 : void
757 1971 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
758 : bool lhs_type)
759 : {
760 1971 : tree lhs_dim, rhs_dim, type;
761 :
762 1971 : gfc_conv_descriptor_data_set (block, lhs_desc,
763 : gfc_conv_descriptor_data_get (rhs_desc));
764 1971 : gfc_conv_descriptor_offset_set (block, lhs_desc,
765 : gfc_conv_descriptor_offset_get (rhs_desc));
766 :
767 1971 : gfc_conv_descriptor_dtype_set (block, lhs_desc,
768 : gfc_conv_descriptor_dtype_get (rhs_desc));
769 1971 : 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 1971 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
774 1971 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
775 :
776 1971 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
777 1971 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
778 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
779 1971 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
780 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
781 1971 : gfc_add_modify (block, lhs_dim, rhs_dim);
782 :
783 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
784 1971 : gfc_copy_coarray_desc_part (block, lhs_desc, rhs_desc);
785 1971 : }
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 5313 : 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 5313 : tree cond_optional = NULL_TREE;
802 5313 : gfc_ss *ss;
803 5313 : tree ctree;
804 5313 : tree var;
805 5313 : tree tmp;
806 5313 : tree packed = NULL_TREE;
807 :
808 : /* The derived type needs to be converted to a temporary CLASS object. */
809 5313 : tmp = gfc_typenode_for_spec (&fsym->ts);
810 5313 : var = gfc_create_var (tmp, "class");
811 :
812 : /* Set the vptr. */
813 5313 : if (opt_vptr_src)
814 128 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
815 : else
816 5185 : gfc_reset_vptr (&parmse->pre, e, var);
817 :
818 : /* Now set the data field. */
819 5313 : ctree = gfc_class_data_get (var);
820 :
821 5313 : 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 5313 : if (optional)
832 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
833 :
834 : /* Set the _len as early as possible. */
835 5313 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
836 5313 : && fsym->ts.u.derived->components->ts.u.derived->attr
837 5313 : .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 5313 : 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 4778 : 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 4333 : ss = gfc_walk_expr (e);
887 4333 : if (ss == gfc_ss_terminator)
888 : {
889 3073 : parmse->ss = NULL;
890 3073 : gfc_conv_expr_reference (parmse, e);
891 :
892 : /* Scalar to an assumed-rank array. */
893 3073 : 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 2739 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
899 2739 : 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 2739 : gfc_add_modify (&parmse->pre, ctree, tmp);
905 : }
906 : }
907 : else
908 : {
909 1260 : stmtblock_t block;
910 1260 : gfc_init_block (&block);
911 1260 : gfc_ref *ref;
912 1260 : int dim;
913 1260 : 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 2369 : for (ref = e->ref; ref; ref = ref->next)
918 1259 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
919 : break;
920 1260 : 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 2513 : for (ref = e->ref; ref; ref = ref->next)
928 1259 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
929 1217 : && 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 1260 : if (ref || e->expr_type != EXPR_VARIABLE)
940 49 : lbshift = gfc_index_one_node;
941 :
942 1260 : parmse->expr = var;
943 1260 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
944 : &lbshift, &packed);
945 :
946 1260 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
947 : {
948 1164 : *derived_array
949 1164 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
950 1164 : 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 1086 : gfc_add_modify (&block, *derived_array, parmse->expr);
983 : }
984 :
985 1260 : 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 912 : gfc_add_block_to_block (&parmse->pre, &block);
1000 : }
1001 : }
1002 :
1003 : /* Pass the address of the class object. */
1004 5313 : if (packed)
1005 : parmse->expr = packed;
1006 : else
1007 5217 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1008 :
1009 5313 : 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 5313 : }
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 3714 : 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 3714 : tree ctree;
1260 3714 : tree var;
1261 3714 : tree tmp;
1262 3714 : tree vptr;
1263 3714 : tree cond = NULL_TREE;
1264 3714 : tree slen = NULL_TREE;
1265 3714 : gfc_ref *ref;
1266 3714 : gfc_ref *class_ref;
1267 3714 : stmtblock_t block;
1268 3714 : 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 3714 : 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 3750 : && 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 3678 : gfc_init_block (&block);
1285 :
1286 3678 : class_ref = NULL;
1287 7429 : for (ref = e->ref; ref; ref = ref->next)
1288 : {
1289 7053 : if (ref->type == REF_COMPONENT
1290 3784 : && ref->u.c.component->ts.type == BT_CLASS)
1291 7053 : class_ref = ref;
1292 :
1293 7053 : if (ref->next == NULL)
1294 : break;
1295 : }
1296 :
1297 3678 : if ((ref == NULL || class_ref == ref)
1298 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1299 4148 : && (!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 3540 : if (e->rank == 0
1305 3896 : && ((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 3129 : gfc_is_class_array_ref (e, &full_array);
1311 :
1312 : /* The derived type needs to be converted to a temporary
1313 : CLASS object. */
1314 3540 : tmp = gfc_typenode_for_spec (&class_ts);
1315 3540 : var = gfc_create_var (tmp, "class");
1316 :
1317 : /* Set the data. */
1318 3540 : ctree = gfc_class_data_get (var);
1319 3540 : if (class_ts.u.derived->components->as
1320 3256 : && 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 2563 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1330 1499 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1331 1499 : TREE_TYPE (ctree), parmse->expr);
1332 2563 : 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 3540 : if (!elemental && full_array && copyback)
1339 : {
1340 1188 : if (class_ts.u.derived->components->as
1341 1188 : && 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 918 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1356 : }
1357 :
1358 : /* Set the vptr. */
1359 3540 : 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 3540 : tmp = NULL_TREE;
1365 3540 : if (gfc_is_class_array_function (e)
1366 3540 : && parmse->class_vptr != NULL_TREE)
1367 : tmp = parmse->class_vptr;
1368 3522 : else if (class_ref == NULL
1369 3023 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1370 : {
1371 3023 : tmp = e->symtree->n.sym->backend_decl;
1372 :
1373 3023 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1374 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1375 :
1376 3023 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1377 397 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1378 :
1379 3023 : slen = build_zero_cst (size_type_node);
1380 : }
1381 499 : 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 18 : gfc_se tmpse;
1390 18 : ref = class_ref->next;
1391 18 : class_ref->next = NULL;
1392 18 : gfc_init_se (&tmpse, NULL);
1393 18 : gfc_conv_expr (&tmpse, e);
1394 18 : class_ref->next = ref;
1395 18 : tmp = tmpse.expr;
1396 18 : slen = tmpse.string_length;
1397 : }
1398 :
1399 3540 : gcc_assert (tmp != NULL_TREE);
1400 :
1401 : /* Dereference if needs be. */
1402 3540 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1403 345 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1404 :
1405 3540 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1406 3522 : vptr = gfc_class_vptr_get (tmp);
1407 : else
1408 : vptr = tmp;
1409 :
1410 3540 : gfc_add_modify (&block, ctree,
1411 3540 : 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 3540 : if (!elemental && full_array && copyback)
1416 1188 : gfc_add_modify (&parmse->post, vptr,
1417 1188 : fold_convert (TREE_TYPE (vptr), ctree));
1418 :
1419 : /* For unlimited polymorphic objects also set the _len component. */
1420 3540 : if (class_ts.type == BT_CLASS
1421 3540 : && class_ts.u.derived->components
1422 3540 : && class_ts.u.derived->components->ts.u
1423 3540 : .derived->attr.unlimited_polymorphic)
1424 : {
1425 1206 : ctree = gfc_class_len_get (var);
1426 1206 : if (UNLIMITED_POLY (e))
1427 1003 : 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 1206 : gfc_add_modify (&parmse->pre, ctree,
1436 1206 : 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 1206 : if (!elemental && full_array && copyback
1441 471 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1442 458 : gfc_add_modify (&parmse->post, tmp,
1443 458 : fold_convert (TREE_TYPE (tmp), ctree));
1444 : }
1445 :
1446 3540 : 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 3030 : gfc_add_block_to_block (&parmse->pre, &block);
1485 :
1486 : /* Pass the address of the class object. */
1487 3540 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1488 :
1489 3540 : 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 13062 : realloc_lhs_warning (bt type, bool array, locus *where)
2036 : {
2037 13062 : 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 13037 : 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 13062 : }
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 1298330 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2055 : {
2056 1298330 : dest->ss = src->ss;
2057 1298330 : 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 4717099 : gfc_init_se (gfc_se * se, gfc_se * parent)
2069 : {
2070 4717099 : memset (se, 0, sizeof (gfc_se));
2071 4717099 : gfc_init_block (&se->pre);
2072 4717099 : gfc_init_block (&se->finalblock);
2073 4717099 : gfc_init_block (&se->post);
2074 :
2075 4717099 : se->parent = parent;
2076 :
2077 4717099 : if (parent)
2078 1298330 : gfc_copy_se_loopvars (se, parent);
2079 4717099 : }
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 246737 : gfc_advance_se_ss_chain (gfc_se * se)
2088 : {
2089 246737 : gfc_se *p;
2090 :
2091 246737 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2092 :
2093 : p = se;
2094 : /* Walk down the parent chain. */
2095 647316 : while (p != NULL)
2096 : {
2097 : /* Simple consistency check. */
2098 400579 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2099 : || p->parent->ss->nested_ss == p->ss);
2100 :
2101 400579 : p->ss = p->ss->next;
2102 :
2103 400579 : p = p->parent;
2104 : }
2105 246737 : }
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 8244 : gfc_make_safe_expr (gfc_se * se)
2113 : {
2114 8244 : tree var;
2115 :
2116 8244 : 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 11904 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2131 : {
2132 11904 : tree decl, orig_decl, cond;
2133 :
2134 11904 : gcc_assert (sym->attr.dummy);
2135 11904 : 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 11904 : 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 10822 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2166 : {
2167 882 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2168 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2169 882 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2170 : }
2171 :
2172 10822 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2173 10822 : 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 10822 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2185 7679 : && !sym->attr.allocatable
2186 6467 : && ((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 4378 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2191 6 : || sym->ts.type == BT_CLASS))
2192 : {
2193 4372 : tree tmp;
2194 :
2195 4372 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2196 1525 : || sym->as->type == AS_ASSUMED_RANK
2197 1437 : || sym->attr.codimension))
2198 3450 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2199 : {
2200 1099 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2201 1099 : if (sym->ts.type == BT_CLASS)
2202 177 : tmp = gfc_class_data_get (tmp);
2203 1099 : tmp = gfc_conv_array_data (tmp);
2204 : }
2205 3273 : else if (sym->ts.type == BT_CLASS)
2206 36 : tmp = gfc_class_data_get (decl);
2207 : else
2208 : tmp = NULL_TREE;
2209 :
2210 1135 : if (tmp != NULL_TREE)
2211 : {
2212 1135 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2213 1135 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2214 1135 : 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 20200 : gfc_get_expr_charlen (gfc_expr *e)
2286 : {
2287 20200 : gfc_ref *r;
2288 20200 : tree length;
2289 20200 : tree previous = NULL_TREE;
2290 20200 : gfc_se se;
2291 :
2292 20200 : gcc_assert (e->expr_type == EXPR_VARIABLE
2293 : && e->ts.type == BT_CHARACTER);
2294 :
2295 20200 : length = NULL; /* To silence compiler warning. */
2296 :
2297 20200 : if (is_subref_array (e) && e->ts.u.cl->length)
2298 : {
2299 773 : gfc_se tmpse;
2300 773 : gfc_init_se (&tmpse, NULL);
2301 773 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2302 773 : e->ts.u.cl->backend_decl = tmpse.expr;
2303 773 : 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 19427 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2310 19115 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2311 :
2312 : /* Look through the reference chain for component references. */
2313 39009 : for (r = e->ref; r; r = r->next)
2314 : {
2315 19582 : previous = length;
2316 19582 : 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 19582 : break;
2346 : }
2347 : }
2348 :
2349 19427 : 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 2128 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2358 : {
2359 2128 : tree caf_decl;
2360 2128 : bool found = false;
2361 2128 : gfc_ref *ref;
2362 :
2363 2128 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2364 :
2365 : /* Not-implemented diagnostic. */
2366 2128 : 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 4517 : for (ref = expr->ref; ref; ref = ref->next)
2373 2389 : 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 2128 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2384 2128 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2385 : : expr->symtree->n.sym->backend_decl;
2386 :
2387 2128 : 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 2098 : 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 1999 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2458 : tree se_expr, gfc_expr *expr)
2459 : {
2460 1999 : tree tmp;
2461 :
2462 1999 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2463 :
2464 : /* Coarray token. */
2465 1999 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2466 624 : *token = gfc_conv_descriptor_token (caf_decl);
2467 1373 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2468 1574 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2469 6 : *token = GFC_DECL_TOKEN (caf_decl);
2470 : else
2471 : {
2472 1369 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2473 : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2474 1369 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2475 : }
2476 :
2477 1999 : if (offset == NULL)
2478 : return;
2479 :
2480 : /* Offset between the coarray base address and the address wanted. */
2481 179 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2482 179 : && (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 179 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2486 179 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2487 0 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2488 179 : 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 179 : *offset = build_int_cst (gfc_array_index_type, 0);
2492 :
2493 179 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2494 179 : && 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 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2500 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2501 : else
2502 : {
2503 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2504 : tmp = se_expr;
2505 : }
2506 :
2507 179 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2508 : *offset, fold_convert (gfc_array_index_type, tmp));
2509 :
2510 179 : 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 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2551 0 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2552 179 : else if (INDIRECT_REF_P (caf_decl))
2553 0 : tmp = TREE_OPERAND (caf_decl, 0);
2554 : else
2555 : {
2556 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2557 : tmp = caf_decl;
2558 : }
2559 :
2560 179 : *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 1710 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2572 : {
2573 1710 : gfc_ref *ref;
2574 1710 : tree lbound, ubound, extent, tmp, img_idx;
2575 1710 : gfc_se se;
2576 1710 : int i;
2577 :
2578 1771 : for (ref = e->ref; ref; ref = ref->next)
2579 1771 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2580 : break;
2581 1710 : gcc_assert (ref != NULL);
2582 :
2583 1710 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2584 171 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2585 171 : null_pointer_node);
2586 :
2587 1539 : img_idx = build_zero_cst (gfc_array_index_type);
2588 1539 : extent = build_one_cst (gfc_array_index_type);
2589 1539 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2590 630 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2591 : {
2592 321 : gfc_init_se (&se, NULL);
2593 321 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2594 321 : gfc_add_block_to_block (block, &se.pre);
2595 321 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2596 321 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2597 321 : TREE_TYPE (lbound), se.expr, lbound);
2598 321 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2599 : extent, tmp);
2600 321 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2601 321 : TREE_TYPE (tmp), img_idx, tmp);
2602 321 : 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 2476 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2612 : {
2613 1246 : gfc_init_se (&se, NULL);
2614 1246 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2615 1246 : gfc_add_block_to_block (block, &se.pre);
2616 1246 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2617 1246 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2618 1246 : TREE_TYPE (lbound), se.expr, lbound);
2619 1246 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2620 : extent, tmp);
2621 1246 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2622 : img_idx, tmp);
2623 1246 : 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 1539 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2635 1539 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2636 1539 : 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 3915 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2711 : {
2712 3915 : gfc_se se;
2713 :
2714 3915 : gfc_init_se (&se, NULL);
2715 :
2716 3915 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2717 1373 : 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 2635 : 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 2459 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2744 2459 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2745 : gfc_charlen_type_node, se.expr,
2746 2459 : build_zero_cst (TREE_TYPE (se.expr)));
2747 2459 : gfc_add_block_to_block (pblock, &se.pre);
2748 : }
2749 :
2750 2542 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2751 1624 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2752 : else
2753 918 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2754 : }
2755 :
2756 :
2757 : static void
2758 7333 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2759 : const char *name, locus *where)
2760 : {
2761 7333 : tree tmp;
2762 7333 : tree type;
2763 7333 : tree fault;
2764 7333 : gfc_se start;
2765 7333 : gfc_se end;
2766 7333 : char *msg;
2767 7333 : mpz_t length;
2768 :
2769 7333 : type = gfc_get_character_type (kind, ref->u.ss.length);
2770 7333 : type = build_pointer_type (type);
2771 :
2772 7333 : gfc_init_se (&start, se);
2773 7333 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2774 7333 : gfc_add_block_to_block (&se->pre, &start.pre);
2775 :
2776 7333 : if (integer_onep (start.expr))
2777 2798 : gfc_conv_string_parameter (se);
2778 : else
2779 : {
2780 4535 : tmp = start.expr;
2781 4535 : STRIP_NOPS (tmp);
2782 : /* Avoid multiple evaluation of substring start. */
2783 4535 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2784 1700 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2785 :
2786 : /* Change the start of the string. */
2787 4535 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2788 1125 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2789 3530 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2790 5540 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2791 1005 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2792 : tmp = se->expr;
2793 : else
2794 997 : tmp = build_fold_indirect_ref_loc (input_location,
2795 : se->expr);
2796 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2797 4535 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2798 : {
2799 4407 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2800 4407 : 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 7333 : gfc_init_se (&end, se);
2815 7333 : if (ref->u.ss.end == NULL)
2816 202 : end.expr = se->string_length;
2817 : else
2818 : {
2819 7131 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2820 7131 : gfc_add_block_to_block (&se->pre, &end.pre);
2821 : }
2822 7333 : tmp = end.expr;
2823 7333 : STRIP_NOPS (tmp);
2824 7333 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2825 2304 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2826 :
2827 7333 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2828 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2829 7788 : && !gfc_contains_implied_index_p (ref->u.ss.end))
2830 : {
2831 455 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2832 : logical_type_node, start.expr,
2833 : end.expr);
2834 :
2835 : /* Check lower bound. */
2836 455 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2837 : start.expr,
2838 455 : build_one_cst (TREE_TYPE (start.expr)));
2839 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2840 : logical_type_node, nonempty, fault);
2841 455 : if (name)
2842 454 : 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 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2848 : fold_convert (long_integer_type_node,
2849 : start.expr));
2850 455 : free (msg);
2851 :
2852 : /* Check upper bound. */
2853 455 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2854 : end.expr, se->string_length);
2855 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2856 : logical_type_node, nonempty, fault);
2857 455 : if (name)
2858 454 : 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 455 : 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 455 : free (msg);
2868 : }
2869 :
2870 : /* Try to calculate the length from the start and end expressions. */
2871 7333 : if (ref->u.ss.end
2872 7333 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2873 : {
2874 6111 : HOST_WIDE_INT i_len;
2875 :
2876 6111 : i_len = gfc_mpz_get_hwi (length) + 1;
2877 6111 : if (i_len < 0)
2878 : i_len = 0;
2879 :
2880 6111 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2881 6111 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2882 : }
2883 : else
2884 : {
2885 1222 : 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 1222 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2889 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2890 1222 : 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 7333 : se->string_length = tmp;
2895 7333 : }
2896 :
2897 :
2898 : /* Convert a derived type component reference. */
2899 :
2900 : void
2901 183431 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2902 : {
2903 183431 : gfc_component *c;
2904 183431 : tree tmp;
2905 183431 : tree decl;
2906 183431 : tree field;
2907 183431 : tree context;
2908 :
2909 183431 : c = ref->u.c.component;
2910 :
2911 183431 : 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 183431 : field = c->backend_decl;
2916 183431 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2917 183431 : decl = se->expr;
2918 183431 : 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 183431 : if (context != TREE_TYPE (decl)
2930 183431 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2931 14152 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2932 : {
2933 14152 : tree f2 = c->norestrict_decl;
2934 24018 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2935 8569 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2936 8569 : if (TREE_CODE (f2) == FIELD_DECL
2937 8569 : && DECL_NAME (f2) == DECL_NAME (field))
2938 : break;
2939 14152 : gcc_assert (f2);
2940 14152 : c->norestrict_decl = f2;
2941 14152 : field = f2;
2942 : }
2943 :
2944 183431 : 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 183431 : se->class_vptr = NULL_TREE;
2953 :
2954 183431 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2955 : decl, field, NULL_TREE);
2956 :
2957 183431 : se->expr = tmp;
2958 :
2959 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2960 : strlen () conditional below. */
2961 183431 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2962 9174 : && !c->ts.deferred
2963 5896 : && !c->attr.pdt_string)
2964 : {
2965 5572 : tmp = c->ts.u.cl->backend_decl;
2966 : /* Components must always be constant length. */
2967 5572 : gcc_assert (tmp && INTEGER_CST_P (tmp));
2968 5572 : se->string_length = tmp;
2969 : }
2970 :
2971 183431 : if (gfc_deferred_strlen (c, &field))
2972 : {
2973 3602 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2974 3602 : TREE_TYPE (field),
2975 : decl, field, NULL_TREE);
2976 3602 : se->string_length = tmp;
2977 : }
2978 :
2979 183431 : if (((c->attr.pointer || c->attr.allocatable)
2980 107157 : && (!c->attr.dimension && !c->attr.codimension)
2981 57649 : && c->ts.type != BT_CHARACTER)
2982 128059 : || c->attr.proc_pointer)
2983 61936 : se->expr = build_fold_indirect_ref_loc (input_location,
2984 : se->expr);
2985 183431 : }
2986 :
2987 :
2988 : /* This function deals with component references to components of the
2989 : parent type for derived type extensions. */
2990 : void
2991 67293 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2992 : {
2993 67293 : gfc_component *c;
2994 67293 : gfc_component *cmp;
2995 67293 : gfc_symbol *dt;
2996 67293 : gfc_ref parent;
2997 :
2998 67293 : dt = ref->u.c.sym;
2999 67293 : c = ref->u.c.component;
3000 :
3001 : /* Return if the component is in this type, i.e. not in the parent type. */
3002 118073 : for (cmp = dt->components; cmp; cmp = cmp->next)
3003 107002 : if (c == cmp)
3004 56222 : return;
3005 :
3006 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3007 11071 : parent.type = REF_COMPONENT;
3008 11071 : parent.next = NULL;
3009 11071 : parent.u.c.sym = dt;
3010 11071 : parent.u.c.component = dt->components;
3011 :
3012 11071 : if (dt->backend_decl == NULL)
3013 0 : gfc_get_derived_type (dt);
3014 :
3015 : /* Build the reference and call self. */
3016 11071 : gfc_conv_component_ref (se, &parent);
3017 11071 : parent.u.c.sym = dt->components->ts.u.derived;
3018 11071 : parent.u.c.component = c;
3019 11071 : 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 1474047 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3063 : bool is_classarray)
3064 : {
3065 1474047 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3066 : return var;
3067 300262 : 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 288370 : if (sym->ts.type == BT_CHARACTER)
3073 : {
3074 : /* Dereference character pointer dummy arguments
3075 : or results. */
3076 33310 : if ((sym->attr.pointer || sym->attr.allocatable
3077 19232 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3078 14414 : && (sym->attr.dummy
3079 11098 : || sym->attr.function
3080 10700 : || sym->attr.result))
3081 4399 : var = build_fold_indirect_ref_loc (input_location, var);
3082 : }
3083 255060 : else if (!sym->attr.value)
3084 : {
3085 : /* Dereference temporaries for class array dummy arguments. */
3086 176037 : if (sym->attr.dummy && is_classarray
3087 262063 : && 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 253962 : if (sym->attr.dummy && !sym->attr.dimension
3097 106724 : && !(sym->attr.codimension && sym->attr.allocatable)
3098 106658 : && (sym->ts.type != BT_CLASS
3099 20400 : || (!CLASS_DATA (sym)->attr.dimension
3100 11817 : && !(CLASS_DATA (sym)->attr.codimension
3101 283 : && CLASS_DATA (sym)->attr.allocatable))))
3102 97934 : var = build_fold_indirect_ref_loc (input_location, var);
3103 :
3104 : /* Dereference scalar hidden result. */
3105 253962 : 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 253962 : if (!is_classarray
3114 245415 : && (sym->attr.pointer || sym->attr.allocatable
3115 195344 : || gfc_is_associate_pointer (sym)
3116 190494 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3117 332427 : && (sym->attr.dummy
3118 36973 : || sym->attr.function
3119 36043 : || sym->attr.result
3120 34937 : || (!sym->attr.dimension
3121 34932 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3122 78460 : var = build_fold_indirect_ref_loc (input_location, var);
3123 : /* Now treat the class array pointer variables accordingly. */
3124 175502 : else if (sym->ts.type == BT_CLASS
3125 20846 : && sym->attr.dummy
3126 20400 : && (CLASS_DATA (sym)->attr.dimension
3127 11817 : || CLASS_DATA (sym)->attr.codimension)
3128 8866 : && ((CLASS_DATA (sym)->as
3129 8866 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3130 7803 : || CLASS_DATA (sym)->attr.allocatable
3131 6394 : || CLASS_DATA (sym)->attr.class_pointer))
3132 3063 : 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 172439 : else if (sym->ts.type == BT_CLASS
3139 17783 : && !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 1629229 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3158 : {
3159 1629229 : gfc_ss *ss;
3160 1629229 : gfc_ref *ref;
3161 1629229 : gfc_symbol *sym;
3162 1629229 : tree parent_decl = NULL_TREE;
3163 1629229 : int parent_flag;
3164 1629229 : bool return_value;
3165 1629229 : bool alternate_entry;
3166 1629229 : bool entry_master;
3167 1629229 : bool is_classarray;
3168 1629229 : bool first_time = true;
3169 :
3170 1629229 : sym = expr->symtree->n.sym;
3171 1629229 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3172 1629229 : ss = se->ss;
3173 1629229 : if (ss != NULL)
3174 : {
3175 135090 : gfc_ss_info *ss_info = ss->info;
3176 :
3177 : /* Check that something hasn't gone horribly wrong. */
3178 135090 : gcc_assert (ss != gfc_ss_terminator);
3179 135090 : gcc_assert (ss_info->expr == expr);
3180 :
3181 : /* A scalarized term. We already know the descriptor. */
3182 135090 : se->expr = ss_info->data.array.descriptor;
3183 135090 : se->string_length = ss_info->string_length;
3184 135090 : ref = ss_info->data.array.ref;
3185 135090 : if (ref)
3186 134736 : 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 1494139 : tree se_expr = NULL_TREE;
3194 :
3195 1494139 : 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 1494139 : return_value = sym->attr.function && sym->result == sym;
3200 19515 : alternate_entry = sym->attr.function && sym->attr.entry
3201 1495278 : && sym->result == sym;
3202 2988278 : entry_master = sym->attr.result
3203 14980 : && sym->ns->proc_name->attr.entry_master
3204 1494520 : && !gfc_return_by_reference (sym->ns->proc_name);
3205 1494139 : if (current_function_decl)
3206 1475428 : parent_decl = DECL_CONTEXT (current_function_decl);
3207 :
3208 1494139 : if ((se->expr == parent_decl && return_value)
3209 1494022 : || (sym->ns && sym->ns->proc_name
3210 1489028 : && parent_decl
3211 1470317 : && sym->ns->proc_name->backend_decl == parent_decl
3212 38827 : && (alternate_entry || entry_master)))
3213 : parent_flag = 1;
3214 : else
3215 1493989 : 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 1494139 : if (return_value && (se->expr == current_function_decl || parent_flag))
3220 10540 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3221 :
3222 : /* Similarly for alternate entry points. */
3223 1483599 : 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 1482493 : 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 11941 : if (se_expr)
3243 11941 : se->expr = se_expr;
3244 :
3245 : /* Procedure actual arguments. Look out for temporary variables
3246 : with the same attributes as function values. */
3247 1482198 : else if (!sym->attr.temporary
3248 1482130 : && sym->attr.flavor == FL_PROCEDURE
3249 22237 : && se->expr != current_function_decl)
3250 : {
3251 22170 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3252 : {
3253 20458 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3254 20458 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3255 : }
3256 : return;
3257 : }
3258 :
3259 1471969 : if (sym->ts.type == BT_CLASS
3260 75114 : && sym->attr.class_ok
3261 74872 : && sym->ts.u.derived->attr.is_class)
3262 : {
3263 29040 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3264 82988 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3265 5803 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3266 : else
3267 69069 : se->class_container = se->expr;
3268 : }
3269 :
3270 : /* Dereference the expression, where needed. */
3271 1471969 : 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 1471059 : se->expr
3278 1471059 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3279 : is_classarray);
3280 :
3281 1471969 : ref = expr->ref;
3282 : }
3283 :
3284 : /* For character variables, also get the length. */
3285 1607059 : 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 167616 : 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 167616 : se->string_length = sym->ts.u.cl->backend_decl;
3293 167616 : 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 167622 : && 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 1607059 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3306 90708 : && (gfc_option.allow_std & GFC_STD_F202Y)
3307 1607293 : && 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 1607059 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3330 418 : gfc_fixup_inferred_type_refs (expr);
3331 :
3332 1607059 : gfc_typespec *ts = &sym->ts;
3333 2052899 : while (ref)
3334 : {
3335 801540 : switch (ref->type)
3336 : {
3337 621574 : case REF_ARRAY:
3338 : /* Return the descriptor if that's what we want and this is an array
3339 : section reference. */
3340 621574 : 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 275487 : if (se->want_pointer
3345 24526 : && ref->next == NULL && (se->descriptor_only))
3346 : return;
3347 :
3348 265874 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3349 : /* Return a pointer to an element. */
3350 265874 : break;
3351 :
3352 172270 : case REF_COMPONENT:
3353 172270 : ts = &ref->u.c.component->ts;
3354 172270 : 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 169541 : if (ref->u.c.sym->attr.extension)
3365 56131 : conv_parent_component_references (se, ref);
3366 :
3367 169541 : gfc_conv_component_ref (se, ref);
3368 :
3369 169541 : if (ref->u.c.component->ts.type == BT_CLASS
3370 12528 : && ref->u.c.component->attr.class_ok
3371 12528 : && ref->u.c.component->ts.u.derived->attr.is_class)
3372 12528 : se->class_container = se->expr;
3373 157013 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3374 154519 : && ref->u.c.sym->attr.is_class))
3375 86556 : se->class_container = NULL_TREE;
3376 :
3377 169541 : if (!ref->next && ref->u.c.sym->attr.codimension
3378 0 : && se->want_pointer && se->descriptor_only)
3379 : return;
3380 :
3381 : break;
3382 :
3383 7075 : case REF_SUBSTRING:
3384 7075 : gfc_conv_substring (se, ref, expr->ts.kind,
3385 7075 : expr->symtree->name, &expr->where);
3386 7075 : 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 445840 : break;
3395 : }
3396 445840 : first_time = false;
3397 445840 : ref = ref->next;
3398 : }
3399 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3400 : separately. */
3401 1251359 : if (se->want_pointer)
3402 : {
3403 135935 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3404 8138 : gfc_conv_string_parameter (se);
3405 : else
3406 127797 : 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 28947 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3415 : {
3416 28947 : gfc_se operand;
3417 28947 : tree type;
3418 :
3419 28947 : gcc_assert (expr->ts.type != BT_CHARACTER);
3420 : /* Initialize the operand. */
3421 28947 : gfc_init_se (&operand, se);
3422 28947 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3423 28947 : gfc_add_block_to_block (&se->pre, &operand.pre);
3424 :
3425 28947 : 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 28947 : if (code == TRUTH_NOT_EXPR)
3431 20322 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3432 : build_int_cst (type, 0));
3433 : else
3434 8625 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3435 :
3436 28947 : }
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 4910 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4070 : {
4071 4910 : tree var;
4072 4910 : tree tmp;
4073 :
4074 4910 : if (gfc_can_put_var_on_stack (len))
4075 : {
4076 : /* Create a temporary variable to hold the result. */
4077 4622 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4078 2311 : TREE_TYPE (len), len,
4079 2311 : build_int_cst (TREE_TYPE (len), 1));
4080 2311 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4081 :
4082 2311 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4083 2311 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4084 : else
4085 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
4086 :
4087 2311 : var = gfc_create_var (tmp, "str");
4088 2311 : var = gfc_build_addr_expr (type, var);
4089 : }
4090 : else
4091 : {
4092 : /* Allocate a temporary to hold the result. */
4093 2599 : var = gfc_create_var (type, "pstr");
4094 2599 : gcc_assert (POINTER_TYPE_P (type));
4095 2599 : tmp = TREE_TYPE (type);
4096 2599 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4097 2599 : tmp = TREE_TYPE (tmp);
4098 2599 : tmp = TYPE_SIZE_UNIT (tmp);
4099 2599 : 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 2599 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4103 2599 : gfc_add_modify (&se->pre, var, tmp);
4104 :
4105 : /* Free the temporary afterwards. */
4106 2599 : tmp = gfc_call_free (var);
4107 2599 : gfc_add_expr_to_block (&se->post, tmp);
4108 : }
4109 :
4110 4910 : 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 1294 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4119 : {
4120 1294 : gfc_se lse, rse;
4121 1294 : tree len, type, var, tmp, fndecl;
4122 :
4123 1294 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4124 : && expr->value.op.op2->ts.type == BT_CHARACTER);
4125 1294 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4126 :
4127 1294 : gfc_init_se (&lse, se);
4128 1294 : gfc_conv_expr (&lse, expr->value.op.op1);
4129 1294 : gfc_conv_string_parameter (&lse);
4130 1294 : gfc_init_se (&rse, se);
4131 1294 : gfc_conv_expr (&rse, expr->value.op.op2);
4132 1294 : gfc_conv_string_parameter (&rse);
4133 :
4134 1294 : gfc_add_block_to_block (&se->pre, &lse.pre);
4135 1294 : gfc_add_block_to_block (&se->pre, &rse.pre);
4136 :
4137 1294 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4138 1294 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4139 1294 : if (len == NULL_TREE)
4140 : {
4141 1075 : 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 1294 : type = build_pointer_type (type);
4150 :
4151 1294 : var = gfc_conv_string_tmp (se, type, len);
4152 :
4153 : /* Do the actual concatenation. */
4154 1294 : if (expr->ts.kind == 1)
4155 1203 : 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 1294 : tmp = build_call_expr_loc (input_location,
4162 : fndecl, 6, len, var, lse.string_length, lse.expr,
4163 : rse.string_length, rse.expr);
4164 1294 : gfc_add_expr_to_block (&se->pre, tmp);
4165 :
4166 : /* Add the cleanup for the operands. */
4167 1294 : gfc_add_block_to_block (&se->pre, &rse.post);
4168 1294 : gfc_add_block_to_block (&se->pre, &lse.post);
4169 :
4170 1294 : se->expr = var;
4171 1294 : se->string_length = len;
4172 1294 : }
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 512811 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4184 : {
4185 512811 : enum tree_code code;
4186 512811 : gfc_se lse;
4187 512811 : gfc_se rse;
4188 512811 : tree tmp, type;
4189 512811 : int lop;
4190 512811 : int checkstring;
4191 :
4192 512811 : checkstring = 0;
4193 512811 : lop = 0;
4194 512811 : switch (expr->value.op.op)
4195 : {
4196 15621 : case INTRINSIC_PARENTHESES:
4197 15621 : 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 91383 : return;
4203 : }
4204 :
4205 : /* Fallthrough. */
4206 11959 : case INTRINSIC_UPLUS:
4207 11959 : gfc_conv_expr (se, expr->value.op.op1);
4208 11959 : return;
4209 :
4210 4957 : case INTRINSIC_UMINUS:
4211 4957 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4212 4957 : return;
4213 :
4214 20322 : case INTRINSIC_NOT:
4215 20322 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4216 20322 : return;
4217 :
4218 : case INTRINSIC_PLUS:
4219 : code = PLUS_EXPR;
4220 : break;
4221 :
4222 29733 : case INTRINSIC_MINUS:
4223 29733 : code = MINUS_EXPR;
4224 29733 : break;
4225 :
4226 33445 : case INTRINSIC_TIMES:
4227 33445 : code = MULT_EXPR;
4228 33445 : break;
4229 :
4230 7091 : 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 7091 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4235 : code = TRUNC_DIV_EXPR;
4236 : else
4237 421428 : code = RDIV_EXPR;
4238 : break;
4239 :
4240 49183 : case INTRINSIC_POWER:
4241 49183 : gfc_conv_power_op (se, expr);
4242 49183 : return;
4243 :
4244 1294 : case INTRINSIC_CONCAT:
4245 1294 : gfc_conv_concat_op (se, expr);
4246 1294 : return;
4247 :
4248 4876 : case INTRINSIC_AND:
4249 4876 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4250 : lop = 1;
4251 : break;
4252 :
4253 56119 : case INTRINSIC_OR:
4254 56119 : 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 12754 : case INTRINSIC_EQ:
4261 12754 : case INTRINSIC_EQ_OS:
4262 12754 : case INTRINSIC_EQV:
4263 12754 : code = EQ_EXPR;
4264 12754 : checkstring = 1;
4265 12754 : lop = 1;
4266 12754 : break;
4267 :
4268 209558 : case INTRINSIC_NE:
4269 209558 : case INTRINSIC_NE_OS:
4270 209558 : case INTRINSIC_NEQV:
4271 209558 : code = NE_EXPR;
4272 209558 : checkstring = 1;
4273 209558 : lop = 1;
4274 209558 : break;
4275 :
4276 12183 : case INTRINSIC_GT:
4277 12183 : case INTRINSIC_GT_OS:
4278 12183 : code = GT_EXPR;
4279 12183 : checkstring = 1;
4280 12183 : lop = 1;
4281 12183 : 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 4388 : case INTRINSIC_LT:
4291 4388 : case INTRINSIC_LT_OS:
4292 4388 : code = LT_EXPR;
4293 4388 : checkstring = 1;
4294 4388 : lop = 1;
4295 4388 : 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 421428 : return;
4312 : }
4313 :
4314 : /* The only exception to this is **, which is handled separately anyway. */
4315 421428 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4316 :
4317 421428 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4318 387020 : checkstring = 0;
4319 :
4320 : /* lhs */
4321 421428 : gfc_init_se (&lse, se);
4322 421428 : gfc_conv_expr (&lse, expr->value.op.op1);
4323 421428 : gfc_add_block_to_block (&se->pre, &lse.pre);
4324 :
4325 : /* rhs */
4326 421428 : gfc_init_se (&rse, se);
4327 421428 : gfc_conv_expr (&rse, expr->value.op.op2);
4328 421428 : gfc_add_block_to_block (&se->pre, &rse.pre);
4329 :
4330 421428 : if (checkstring)
4331 : {
4332 34408 : gfc_conv_string_parameter (&lse);
4333 34408 : gfc_conv_string_parameter (&rse);
4334 :
4335 68816 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4336 : rse.string_length, rse.expr,
4337 34408 : expr->value.op.op1->ts.kind,
4338 : code);
4339 34408 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4340 34408 : gfc_add_block_to_block (&lse.post, &rse.post);
4341 : }
4342 :
4343 421428 : type = gfc_typenode_for_spec (&expr->ts);
4344 :
4345 421428 : if (lop)
4346 : {
4347 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4348 304167 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4349 171877 : && expr->value.op.op1->ts.type == BT_INTEGER
4350 74502 : && expr->value.op.op1->symtree
4351 74502 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4352 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4353 :
4354 304167 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4355 72715 : && expr->value.op.op2->ts.type == BT_INTEGER
4356 13240 : && expr->value.op.op2->symtree
4357 13240 : && 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 304167 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4362 : lse.expr, rse.expr);
4363 304167 : se->expr = convert (type, tmp);
4364 : }
4365 : else
4366 117261 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4367 :
4368 : /* Add the post blocks. */
4369 421428 : gfc_add_block_to_block (&se->post, &rse.post);
4370 421428 : 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 142226 : gfc_string_to_single_character (tree len, tree str, int kind)
4434 : {
4435 :
4436 142226 : if (len == NULL
4437 142226 : || !tree_fits_uhwi_p (len)
4438 261211 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4439 : return NULL_TREE;
4440 :
4441 118933 : if (TREE_INT_CST_LOW (len) == 1)
4442 : {
4443 22737 : str = fold_convert (gfc_get_pchar_type (kind), str);
4444 22737 : return build_fold_indirect_ref_loc (input_location, str);
4445 : }
4446 :
4447 96196 : if (kind == 1
4448 78724 : && TREE_CODE (str) == ADDR_EXPR
4449 67915 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4450 48585 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4451 30005 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4452 30005 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4453 30005 : && TREE_INT_CST_LOW (len) > 1
4454 124361 : && TREE_INT_CST_LOW (len)
4455 : == (unsigned HOST_WIDE_INT)
4456 28165 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4457 : {
4458 28165 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4459 28165 : ret = build_fold_indirect_ref_loc (input_location, ret);
4460 28165 : if (TREE_CODE (ret) == INTEGER_CST)
4461 : {
4462 28165 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4463 28165 : int i, length = TREE_STRING_LENGTH (string_cst);
4464 28165 : const char *ptr = TREE_STRING_POINTER (string_cst);
4465 :
4466 42293 : for (i = 1; i < length; i++)
4467 41601 : 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 172 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4480 : {
4481 172 : 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 172 : 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 172 : 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 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4505 : {
4506 6 : if ((*expr)->ref == NULL)
4507 : {
4508 6 : se->expr = gfc_string_to_single_character
4509 6 : (integer_one_node,
4510 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4511 : gfc_get_symbol_decl
4512 6 : ((*expr)->symtree->n.sym)),
4513 : (*expr)->ts.kind);
4514 : }
4515 : else
4516 : {
4517 0 : gfc_conv_variable (se, *expr);
4518 0 : se->expr = gfc_string_to_single_character
4519 0 : (integer_one_node,
4520 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4521 : se->expr),
4522 0 : (*expr)->ts.kind);
4523 : }
4524 : }
4525 172 : }
4526 :
4527 : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4528 : if STR is a string literal, otherwise return -1. */
4529 :
4530 : static int
4531 32606 : gfc_optimize_len_trim (tree len, tree str, int kind)
4532 : {
4533 32606 : if (kind == 1
4534 27524 : && TREE_CODE (str) == ADDR_EXPR
4535 24171 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4536 15430 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4537 9944 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4538 9944 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4539 9944 : && tree_fits_uhwi_p (len)
4540 9944 : && tree_to_uhwi (len) >= 1
4541 32606 : && tree_to_uhwi (len)
4542 9900 : == (unsigned HOST_WIDE_INT)
4543 9900 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4544 : {
4545 9900 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4546 9900 : folded = build_fold_indirect_ref_loc (input_location, folded);
4547 9900 : if (TREE_CODE (folded) == INTEGER_CST)
4548 : {
4549 9900 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4550 9900 : int length = TREE_STRING_LENGTH (string_cst);
4551 9900 : const char *ptr = TREE_STRING_POINTER (string_cst);
4552 :
4553 14819 : for (; length > 0; length--)
4554 14819 : if (ptr[length - 1] != ' ')
4555 : break;
4556 :
4557 : return length;
4558 : }
4559 : }
4560 : return -1;
4561 : }
4562 :
4563 : /* Helper to build a call to memcmp. */
4564 :
4565 : static tree
4566 13273 : build_memcmp_call (tree s1, tree s2, tree n)
4567 : {
4568 13273 : tree tmp;
4569 :
4570 13273 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4571 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4572 : else
4573 13273 : s1 = fold_convert (pvoid_type_node, s1);
4574 :
4575 13273 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4576 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4577 : else
4578 13273 : s2 = fold_convert (pvoid_type_node, s2);
4579 :
4580 13273 : n = fold_convert (size_type_node, n);
4581 :
4582 13273 : tmp = build_call_expr_loc (input_location,
4583 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4584 : 3, s1, s2, n);
4585 :
4586 13273 : return fold_convert (integer_type_node, tmp);
4587 : }
4588 :
4589 : /* Compare two strings. If they are all single characters, the result is the
4590 : subtraction of them. Otherwise, we build a library call. */
4591 :
4592 : tree
4593 34507 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4594 : enum tree_code code)
4595 : {
4596 34507 : tree sc1;
4597 34507 : tree sc2;
4598 34507 : tree fndecl;
4599 :
4600 34507 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4601 34507 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4602 :
4603 34507 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4604 34507 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4605 :
4606 34507 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4607 : {
4608 : /* Deal with single character specially. */
4609 4851 : sc1 = fold_convert (integer_type_node, sc1);
4610 4851 : sc2 = fold_convert (integer_type_node, sc2);
4611 4851 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4612 4851 : sc1, sc2);
4613 : }
4614 :
4615 29656 : if ((code == EQ_EXPR || code == NE_EXPR)
4616 29094 : && optimize
4617 24369 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4618 : {
4619 : /* If one string is a string literal with LEN_TRIM longer
4620 : than the length of the second string, the strings
4621 : compare unequal. */
4622 16303 : int len = gfc_optimize_len_trim (len1, str1, kind);
4623 16303 : if (len > 0 && compare_tree_int (len2, len) < 0)
4624 0 : return integer_one_node;
4625 16303 : len = gfc_optimize_len_trim (len2, str2, kind);
4626 16303 : if (len > 0 && compare_tree_int (len1, len) < 0)
4627 0 : return integer_one_node;
4628 : }
4629 :
4630 : /* We can compare via memcpy if the strings are known to be equal
4631 : in length and they are
4632 : - kind=1
4633 : - kind=4 and the comparison is for (in)equality. */
4634 :
4635 19868 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4636 19530 : && tree_int_cst_equal (len1, len2)
4637 42989 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4638 : {
4639 13273 : tree tmp;
4640 13273 : tree chartype;
4641 :
4642 13273 : chartype = gfc_get_char_type (kind);
4643 13273 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4644 13273 : fold_convert (TREE_TYPE(len1),
4645 : TYPE_SIZE_UNIT(chartype)),
4646 : len1);
4647 13273 : return build_memcmp_call (str1, str2, tmp);
4648 : }
4649 :
4650 : /* Build a call for the comparison. */
4651 16383 : if (kind == 1)
4652 13534 : fndecl = gfor_fndecl_compare_string;
4653 2849 : else if (kind == 4)
4654 2849 : fndecl = gfor_fndecl_compare_string_char4;
4655 : else
4656 0 : gcc_unreachable ();
4657 :
4658 16383 : return build_call_expr_loc (input_location, fndecl, 4,
4659 16383 : len1, str1, len2, str2);
4660 : }
4661 :
4662 :
4663 : /* Return the backend_decl for a procedure pointer component. */
4664 :
4665 : static tree
4666 1920 : get_proc_ptr_comp (gfc_expr *e)
4667 : {
4668 1920 : gfc_se comp_se;
4669 1920 : gfc_expr *e2;
4670 1920 : expr_t old_type;
4671 :
4672 1920 : gfc_init_se (&comp_se, NULL);
4673 1920 : e2 = gfc_copy_expr (e);
4674 : /* We have to restore the expr type later so that gfc_free_expr frees
4675 : the exact same thing that was allocated.
4676 : TODO: This is ugly. */
4677 1920 : old_type = e2->expr_type;
4678 1920 : e2->expr_type = EXPR_VARIABLE;
4679 1920 : gfc_conv_expr (&comp_se, e2);
4680 1920 : e2->expr_type = old_type;
4681 1920 : gfc_free_expr (e2);
4682 1920 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4683 : }
4684 :
4685 :
4686 : /* Convert a typebound function reference from a class object. */
4687 : static void
4688 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4689 : {
4690 80 : gfc_ref *ref;
4691 80 : tree var;
4692 :
4693 80 : if (!VAR_P (base_object))
4694 : {
4695 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4696 0 : gfc_add_modify (&se->pre, var, base_object);
4697 : }
4698 80 : se->expr = gfc_class_vptr_get (base_object);
4699 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4700 80 : ref = expr->ref;
4701 308 : while (ref && ref->next)
4702 : ref = ref->next;
4703 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4704 80 : if (ref->u.c.sym->attr.extension)
4705 0 : conv_parent_component_references (se, ref);
4706 80 : gfc_conv_component_ref (se, ref);
4707 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4708 80 : }
4709 :
4710 : static tree
4711 129805 : get_builtin_fn (gfc_symbol * sym)
4712 : {
4713 129805 : if (!gfc_option.disable_omp_is_initial_device
4714 129801 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4715 631 : && !strcmp (sym->name, "omp_is_initial_device"))
4716 41 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4717 :
4718 129764 : if (!gfc_option.disable_omp_get_initial_device
4719 129757 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4720 4288 : && !strcmp (sym->name, "omp_get_initial_device"))
4721 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4722 :
4723 129735 : if (!gfc_option.disable_omp_get_num_devices
4724 129728 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4725 4259 : && !strcmp (sym->name, "omp_get_num_devices"))
4726 107 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4727 :
4728 129628 : if (!gfc_option.disable_acc_on_device
4729 129448 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4730 1169 : && !strcmp (sym->name, "acc_on_device_h"))
4731 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4732 :
4733 : return NULL_TREE;
4734 : }
4735 :
4736 : static tree
4737 567 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4738 : {
4739 567 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4740 :
4741 567 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4742 : /* In Fortran omp_is_initial_device returns logical(4)
4743 : but the builtin uses 'int'. */
4744 41 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4745 :
4746 526 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4747 : {
4748 : /* Likewise for the return type; additionally, the argument it a
4749 : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4750 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4751 390 : CALL_EXPR_ARG (fn_call, 0));
4752 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4753 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4754 : }
4755 : return fn_call;
4756 : }
4757 :
4758 : static void
4759 132551 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4760 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4761 : {
4762 132551 : tree tmp;
4763 :
4764 132551 : if (gfc_is_proc_ptr_comp (expr))
4765 1920 : tmp = get_proc_ptr_comp (expr);
4766 130631 : else if (sym->attr.dummy)
4767 : {
4768 826 : tmp = gfc_get_symbol_decl (sym);
4769 826 : if (sym->attr.proc_pointer)
4770 89 : tmp = build_fold_indirect_ref_loc (input_location,
4771 : tmp);
4772 826 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4773 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4774 : }
4775 : else
4776 : {
4777 129805 : if (!sym->backend_decl)
4778 32681 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4779 :
4780 129805 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4781 567 : *is_builtin = true;
4782 : else
4783 : {
4784 129238 : TREE_USED (sym->backend_decl) = 1;
4785 129238 : tmp = sym->backend_decl;
4786 : }
4787 :
4788 129805 : if (sym->attr.cray_pointee)
4789 : {
4790 : /* TODO - make the cray pointee a pointer to a procedure,
4791 : assign the pointer to it and use it for the call. This
4792 : will do for now! */
4793 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4794 19 : gfc_get_symbol_decl (sym->cp_pointer));
4795 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4796 : }
4797 :
4798 129805 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4799 : {
4800 129177 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4801 129177 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4802 : }
4803 : }
4804 132551 : se->expr = tmp;
4805 132551 : }
4806 :
4807 :
4808 : /* Initialize MAPPING. */
4809 :
4810 : void
4811 132668 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4812 : {
4813 132668 : mapping->syms = NULL;
4814 132668 : mapping->charlens = NULL;
4815 132668 : }
4816 :
4817 :
4818 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4819 :
4820 : void
4821 132668 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4822 : {
4823 132668 : gfc_interface_sym_mapping *sym;
4824 132668 : gfc_interface_sym_mapping *nextsym;
4825 132668 : gfc_charlen *cl;
4826 132668 : gfc_charlen *nextcl;
4827 :
4828 173414 : for (sym = mapping->syms; sym; sym = nextsym)
4829 : {
4830 40746 : nextsym = sym->next;
4831 40746 : sym->new_sym->n.sym->formal = NULL;
4832 40746 : gfc_free_symbol (sym->new_sym->n.sym);
4833 40746 : gfc_free_expr (sym->expr);
4834 40746 : free (sym->new_sym);
4835 40746 : free (sym);
4836 : }
4837 137356 : for (cl = mapping->charlens; cl; cl = nextcl)
4838 : {
4839 4688 : nextcl = cl->next;
4840 4688 : gfc_free_expr (cl->length);
4841 4688 : free (cl);
4842 : }
4843 132668 : }
4844 :
4845 :
4846 : /* Return a copy of gfc_charlen CL. Add the returned structure to
4847 : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4848 :
4849 : static gfc_charlen *
4850 4688 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4851 : gfc_charlen * cl)
4852 : {
4853 4688 : gfc_charlen *new_charlen;
4854 :
4855 4688 : new_charlen = gfc_get_charlen ();
4856 4688 : new_charlen->next = mapping->charlens;
4857 4688 : new_charlen->length = gfc_copy_expr (cl->length);
4858 :
4859 4688 : mapping->charlens = new_charlen;
4860 4688 : return new_charlen;
4861 : }
4862 :
4863 :
4864 : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4865 : array variable that can be used as the actual argument for dummy
4866 : argument SYM, except in the case of assumed rank dummies of
4867 : non-intrinsic functions where the descriptor must be passed. Add any
4868 : initialization code to BLOCK. PACKED is as for gfc_get_nodesc_array_type
4869 : and DATA points to the first element in the passed array. */
4870 :
4871 : static tree
4872 8454 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4873 : gfc_packed packed, tree data, tree len,
4874 : bool assumed_rank_formal)
4875 : {
4876 8454 : tree type;
4877 8454 : tree var;
4878 :
4879 8454 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4880 70 : type = gfc_get_character_type_len (sym->ts.kind, len);
4881 : else
4882 8384 : type = gfc_typenode_for_spec (&sym->ts);
4883 :
4884 8454 : if (assumed_rank_formal)
4885 13 : type = TREE_TYPE (data);
4886 : else
4887 8441 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4888 8441 : !sym->attr.target && !sym->attr.pointer
4889 8417 : && !sym->attr.proc_pointer);
4890 :
4891 8454 : var = gfc_create_var (type, "ifm");
4892 8454 : gfc_add_modify (block, var, fold_convert (type, data));
4893 :
4894 8454 : return var;
4895 : }
4896 :
4897 :
4898 : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4899 : and offset of descriptorless array type TYPE given that it has the same
4900 : size as DESC. Add any set-up code to BLOCK. */
4901 :
4902 : static void
4903 8124 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4904 : {
4905 8124 : int n;
4906 8124 : tree dim;
4907 8124 : tree offset;
4908 8124 : tree tmp;
4909 :
4910 8124 : offset = gfc_index_zero_node;
4911 9238 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4912 : {
4913 1114 : dim = gfc_rank_cst[n];
4914 1114 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4915 1114 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4916 : {
4917 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
4918 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
4919 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
4920 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
4921 : }
4922 1113 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4923 : {
4924 1087 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4925 : gfc_array_index_type,
4926 : gfc_conv_descriptor_ubound_get (desc, dim),
4927 : gfc_conv_descriptor_lbound_get (desc, dim));
4928 3261 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4929 : gfc_array_index_type,
4930 1087 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4931 1087 : tmp = gfc_evaluate_now (tmp, block);
4932 1087 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4933 : }
4934 4456 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4935 1114 : GFC_TYPE_ARRAY_LBOUND (type, n),
4936 1114 : GFC_TYPE_ARRAY_STRIDE (type, n));
4937 1114 : offset = fold_build2_loc (input_location, MINUS_EXPR,
4938 : gfc_array_index_type, offset, tmp);
4939 : }
4940 8124 : offset = gfc_evaluate_now (offset, block);
4941 8124 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
4942 8124 : }
4943 :
4944 :
4945 : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4946 : in SE. The caller may still use se->expr and se->string_length after
4947 : calling this function. */
4948 :
4949 : void
4950 40746 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4951 : gfc_symbol * sym, gfc_se * se,
4952 : gfc_expr *expr)
4953 : {
4954 40746 : gfc_interface_sym_mapping *sm;
4955 40746 : tree desc;
4956 40746 : tree tmp;
4957 40746 : tree value;
4958 40746 : gfc_symbol *new_sym;
4959 40746 : gfc_symtree *root;
4960 40746 : gfc_symtree *new_symtree;
4961 :
4962 : /* Create a new symbol to represent the actual argument. */
4963 40746 : new_sym = gfc_new_symbol (sym->name, NULL);
4964 40746 : new_sym->ts = sym->ts;
4965 40746 : new_sym->as = gfc_copy_array_spec (sym->as);
4966 40746 : new_sym->attr.referenced = 1;
4967 40746 : new_sym->attr.dimension = sym->attr.dimension;
4968 40746 : new_sym->attr.contiguous = sym->attr.contiguous;
4969 40746 : new_sym->attr.codimension = sym->attr.codimension;
4970 40746 : new_sym->attr.pointer = sym->attr.pointer;
4971 40746 : new_sym->attr.allocatable = sym->attr.allocatable;
4972 40746 : new_sym->attr.flavor = sym->attr.flavor;
4973 40746 : new_sym->attr.function = sym->attr.function;
4974 40746 : new_sym->attr.dummy = 0;
4975 :
4976 : /* Ensure that the interface is available and that
4977 : descriptors are passed for array actual arguments. */
4978 40746 : if (sym->attr.flavor == FL_PROCEDURE)
4979 : {
4980 36 : new_sym->formal = expr->symtree->n.sym->formal;
4981 36 : new_sym->attr.always_explicit
4982 36 : = expr->symtree->n.sym->attr.always_explicit;
4983 : }
4984 :
4985 : /* Create a fake symtree for it. */
4986 40746 : root = NULL;
4987 40746 : new_symtree = gfc_new_symtree (&root, sym->name);
4988 40746 : new_symtree->n.sym = new_sym;
4989 40746 : gcc_assert (new_symtree == root);
4990 :
4991 : /* Create a dummy->actual mapping. */
4992 40746 : sm = XCNEW (gfc_interface_sym_mapping);
4993 40746 : sm->next = mapping->syms;
4994 40746 : sm->old = sym;
4995 40746 : sm->new_sym = new_symtree;
4996 40746 : sm->expr = gfc_copy_expr (expr);
4997 40746 : mapping->syms = sm;
4998 :
4999 : /* Stabilize the argument's value. */
5000 40746 : if (!sym->attr.function && se)
5001 40648 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5002 :
5003 40746 : if (sym->ts.type == BT_CHARACTER)
5004 : {
5005 : /* Create a copy of the dummy argument's length. */
5006 2886 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
5007 2886 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
5008 :
5009 : /* If the length is specified as "*", record the length that
5010 : the caller is passing. We should use the callee's length
5011 : in all other cases. */
5012 2886 : if (!new_sym->ts.u.cl->length && se)
5013 : {
5014 2646 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5015 2646 : new_sym->ts.u.cl->backend_decl = se->string_length;
5016 : }
5017 : }
5018 :
5019 40732 : if (!se)
5020 62 : return;
5021 :
5022 : /* Use the passed value as-is if the argument is a function. */
5023 40684 : if (sym->attr.flavor == FL_PROCEDURE)
5024 36 : value = se->expr;
5025 :
5026 : /* If the argument is a pass-by-value scalar, use the value as is. */
5027 40648 : else if (!sym->attr.dimension && sym->attr.value)
5028 78 : value = se->expr;
5029 :
5030 : /* If the argument is either a string or a pointer to a string,
5031 : convert it to a boundless character type. */
5032 40570 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5033 : {
5034 1305 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5035 1305 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5036 1305 : tmp = build_pointer_type (tmp);
5037 1305 : if (sym->attr.pointer)
5038 126 : value = build_fold_indirect_ref_loc (input_location,
5039 : se->expr);
5040 : else
5041 1179 : value = se->expr;
5042 1305 : value = fold_convert (tmp, value);
5043 : }
5044 :
5045 : /* If the argument is a scalar, a pointer to an array or an allocatable,
5046 : dereference it. */
5047 39265 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5048 29314 : value = build_fold_indirect_ref_loc (input_location,
5049 : se->expr);
5050 :
5051 : /* For character(*), use the actual argument's descriptor. */
5052 9951 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5053 1497 : value = build_fold_indirect_ref_loc (input_location,
5054 : se->expr);
5055 :
5056 : /* If the argument is an array descriptor, use it to determine
5057 : information about the actual argument's shape. */
5058 8454 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5059 8454 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5060 : {
5061 8124 : bool assumed_rank_formal = false;
5062 :
5063 : /* Get the actual argument's descriptor. */
5064 8124 : desc = build_fold_indirect_ref_loc (input_location,
5065 : se->expr);
5066 :
5067 : /* Create the replacement variable. */
5068 8124 : if (sym->as && sym->as->type == AS_ASSUMED_RANK
5069 7334 : && !(sym->ns && sym->ns->proc_name
5070 7334 : && sym->ns->proc_name->attr.proc == PROC_INTRINSIC))
5071 : {
5072 : assumed_rank_formal = true;
5073 : tmp = desc;
5074 : }
5075 : else
5076 8111 : tmp = gfc_conv_descriptor_data_get (desc);
5077 :
5078 8124 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5079 : PACKED_NO, tmp,
5080 : se->string_length,
5081 : assumed_rank_formal);
5082 :
5083 : /* Use DESC to work out the upper bounds, strides and offset. */
5084 8124 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5085 : }
5086 : else
5087 : /* Otherwise we have a packed array. */
5088 330 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5089 : PACKED_FULL, se->expr,
5090 : se->string_length,
5091 : false);
5092 :
5093 40684 : new_sym->backend_decl = value;
5094 : }
5095 :
5096 :
5097 : /* Called once all dummy argument mappings have been added to MAPPING,
5098 : but before the mapping is used to evaluate expressions. Pre-evaluate
5099 : the length of each argument, adding any initialization code to PRE and
5100 : any finalization code to POST. */
5101 :
5102 : static void
5103 132631 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5104 : stmtblock_t * pre, stmtblock_t * post)
5105 : {
5106 132631 : gfc_interface_sym_mapping *sym;
5107 132631 : gfc_expr *expr;
5108 132631 : gfc_se se;
5109 :
5110 173315 : for (sym = mapping->syms; sym; sym = sym->next)
5111 40684 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5112 2872 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5113 : {
5114 226 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5115 226 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5116 226 : gfc_init_se (&se, NULL);
5117 226 : gfc_conv_expr (&se, expr);
5118 226 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5119 226 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5120 226 : gfc_add_block_to_block (pre, &se.pre);
5121 226 : gfc_add_block_to_block (post, &se.post);
5122 :
5123 226 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5124 : }
5125 132631 : }
5126 :
5127 :
5128 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5129 : constructor C. */
5130 :
5131 : static void
5132 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5133 : gfc_constructor_base base)
5134 : {
5135 47 : gfc_constructor *c;
5136 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5137 : {
5138 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5139 381 : if (c->iterator)
5140 : {
5141 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5142 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5143 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5144 : }
5145 : }
5146 47 : }
5147 :
5148 :
5149 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5150 : reference REF. */
5151 :
5152 : static void
5153 12729 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5154 : gfc_ref * ref)
5155 : {
5156 12729 : int n;
5157 :
5158 14214 : for (; ref; ref = ref->next)
5159 1485 : switch (ref->type)
5160 : {
5161 : case REF_ARRAY:
5162 2915 : for (n = 0; n < ref->u.ar.dimen; n++)
5163 : {
5164 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5165 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5166 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5167 : }
5168 : break;
5169 :
5170 : case REF_COMPONENT:
5171 : case REF_INQUIRY:
5172 : break;
5173 :
5174 43 : case REF_SUBSTRING:
5175 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5176 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5177 43 : break;
5178 : }
5179 12729 : }
5180 :
5181 :
5182 : /* Convert intrinsic function calls into result expressions. */
5183 :
5184 : static bool
5185 2232 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5186 : {
5187 2232 : gfc_symbol *sym;
5188 2232 : gfc_expr *new_expr;
5189 2232 : gfc_expr *arg1;
5190 2232 : gfc_expr *arg2;
5191 2232 : int d, dup;
5192 :
5193 2232 : arg1 = expr->value.function.actual->expr;
5194 2232 : if (expr->value.function.actual->next)
5195 2111 : arg2 = expr->value.function.actual->next->expr;
5196 : else
5197 : arg2 = NULL;
5198 :
5199 2232 : sym = arg1->symtree->n.sym;
5200 :
5201 2232 : if (sym->attr.dummy)
5202 : return false;
5203 :
5204 2208 : new_expr = NULL;
5205 :
5206 2208 : switch (expr->value.function.isym->id)
5207 : {
5208 947 : case GFC_ISYM_LEN:
5209 : /* TODO figure out why this condition is necessary. */
5210 947 : if (sym->attr.function
5211 43 : && (arg1->ts.u.cl->length == NULL
5212 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5213 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5214 : return false;
5215 :
5216 904 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5217 904 : break;
5218 :
5219 228 : case GFC_ISYM_LEN_TRIM:
5220 228 : new_expr = gfc_copy_expr (arg1);
5221 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5222 :
5223 228 : if (!new_expr)
5224 : return false;
5225 :
5226 228 : gfc_replace_expr (arg1, new_expr);
5227 228 : return true;
5228 :
5229 606 : case GFC_ISYM_SIZE:
5230 606 : if (!sym->as || sym->as->rank == 0)
5231 : return false;
5232 :
5233 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5234 : {
5235 360 : dup = mpz_get_si (arg2->value.integer);
5236 360 : d = dup - 1;
5237 : }
5238 : else
5239 : {
5240 530 : dup = sym->as->rank;
5241 530 : d = 0;
5242 : }
5243 :
5244 542 : for (; d < dup; d++)
5245 : {
5246 530 : gfc_expr *tmp;
5247 :
5248 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5249 : {
5250 518 : gfc_free_expr (new_expr);
5251 518 : return false;
5252 : }
5253 :
5254 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5255 : gfc_get_int_expr (gfc_default_integer_kind,
5256 : NULL, 1));
5257 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5258 12 : if (new_expr)
5259 0 : new_expr = gfc_multiply (new_expr, tmp);
5260 : else
5261 : new_expr = tmp;
5262 : }
5263 : break;
5264 :
5265 44 : case GFC_ISYM_LBOUND:
5266 44 : case GFC_ISYM_UBOUND:
5267 : /* TODO These implementations of lbound and ubound do not limit if
5268 : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5269 :
5270 44 : if (!sym->as || sym->as->rank == 0)
5271 : return false;
5272 :
5273 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5274 38 : d = mpz_get_si (arg2->value.integer) - 1;
5275 : else
5276 : return false;
5277 :
5278 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5279 : {
5280 23 : if (sym->as->lower[d])
5281 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5282 : }
5283 : else
5284 : {
5285 15 : if (sym->as->upper[d])
5286 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5287 : }
5288 : break;
5289 :
5290 : default:
5291 : break;
5292 : }
5293 :
5294 1337 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5295 1337 : if (!new_expr)
5296 : return false;
5297 :
5298 113 : gfc_replace_expr (expr, new_expr);
5299 113 : return true;
5300 : }
5301 :
5302 :
5303 : static void
5304 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5305 : gfc_interface_mapping * mapping)
5306 : {
5307 24 : gfc_formal_arglist *f;
5308 24 : gfc_actual_arglist *actual;
5309 :
5310 24 : actual = expr->value.function.actual;
5311 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5312 :
5313 72 : for (; f && actual; f = f->next, actual = actual->next)
5314 : {
5315 24 : if (!actual->expr)
5316 0 : continue;
5317 :
5318 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5319 : }
5320 :
5321 24 : if (map_expr->symtree->n.sym->attr.dimension)
5322 : {
5323 6 : int d;
5324 6 : gfc_array_spec *as;
5325 :
5326 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5327 :
5328 18 : for (d = 0; d < as->rank; d++)
5329 : {
5330 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5331 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5332 : }
5333 :
5334 6 : expr->value.function.esym->as = as;
5335 : }
5336 :
5337 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5338 : {
5339 0 : expr->value.function.esym->ts.u.cl->length
5340 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5341 :
5342 0 : gfc_apply_interface_mapping_to_expr (mapping,
5343 0 : expr->value.function.esym->ts.u.cl->length);
5344 : }
5345 24 : }
5346 :
5347 :
5348 : /* EXPR is a copy of an expression that appeared in the interface
5349 : associated with MAPPING. Walk it recursively looking for references to
5350 : dummy arguments that MAPPING maps to actual arguments. Replace each such
5351 : reference with a reference to the associated actual argument. */
5352 :
5353 : static void
5354 21316 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5355 : gfc_expr * expr)
5356 : {
5357 22881 : gfc_interface_sym_mapping *sym;
5358 22881 : gfc_actual_arglist *actual;
5359 :
5360 22881 : if (!expr)
5361 : return;
5362 :
5363 : /* Copying an expression does not copy its length, so do that here. */
5364 12729 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5365 : {
5366 1802 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5367 1802 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5368 : }
5369 :
5370 : /* Apply the mapping to any references. */
5371 12729 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5372 :
5373 : /* ...and to the expression's symbol, if it has one. */
5374 : /* TODO Find out why the condition on expr->symtree had to be moved into
5375 : the loop rather than being outside it, as originally. */
5376 30170 : for (sym = mapping->syms; sym; sym = sym->next)
5377 17441 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5378 : {
5379 3406 : if (sym->new_sym->n.sym->backend_decl)
5380 3362 : expr->symtree = sym->new_sym;
5381 44 : else if (sym->expr)
5382 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5383 : }
5384 :
5385 : /* ...and to subexpressions in expr->value. */
5386 12729 : switch (expr->expr_type)
5387 : {
5388 : case EXPR_VARIABLE:
5389 : case EXPR_CONSTANT:
5390 : case EXPR_NULL:
5391 : case EXPR_SUBSTRING:
5392 : break;
5393 :
5394 1565 : case EXPR_OP:
5395 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5396 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5397 1565 : break;
5398 :
5399 0 : case EXPR_CONDITIONAL:
5400 0 : gfc_apply_interface_mapping_to_expr (mapping,
5401 0 : expr->value.conditional.true_expr);
5402 0 : gfc_apply_interface_mapping_to_expr (mapping,
5403 0 : expr->value.conditional.false_expr);
5404 0 : break;
5405 :
5406 2975 : case EXPR_FUNCTION:
5407 9556 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5408 6581 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5409 :
5410 2975 : if (expr->value.function.esym == NULL
5411 2662 : && expr->value.function.isym != NULL
5412 2650 : && expr->value.function.actual
5413 2649 : && expr->value.function.actual->expr
5414 2649 : && expr->value.function.actual->expr->symtree
5415 5207 : && gfc_map_intrinsic_function (expr, mapping))
5416 : break;
5417 :
5418 6190 : for (sym = mapping->syms; sym; sym = sym->next)
5419 3556 : if (sym->old == expr->value.function.esym)
5420 : {
5421 24 : expr->value.function.esym = sym->new_sym->n.sym;
5422 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5423 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5424 : }
5425 : break;
5426 :
5427 47 : case EXPR_ARRAY:
5428 47 : case EXPR_STRUCTURE:
5429 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5430 47 : break;
5431 :
5432 0 : case EXPR_COMPCALL:
5433 0 : case EXPR_PPC:
5434 0 : case EXPR_UNKNOWN:
5435 0 : gcc_unreachable ();
5436 : break;
5437 : }
5438 :
5439 : return;
5440 : }
5441 :
5442 :
5443 : /* Evaluate interface expression EXPR using MAPPING. Store the result
5444 : in SE. */
5445 :
5446 : void
5447 4130 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5448 : gfc_se * se, gfc_expr * expr)
5449 : {
5450 4130 : expr = gfc_copy_expr (expr);
5451 4130 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5452 4130 : gfc_conv_expr (se, expr);
5453 4130 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5454 4130 : gfc_free_expr (expr);
5455 4130 : }
5456 :
5457 :
5458 : /* Returns a reference to a temporary array into which a component of
5459 : an actual argument derived type array is copied and then returned
5460 : after the function call. */
5461 : void
5462 2801 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5463 : sym_intent intent, bool formal_ptr,
5464 : const gfc_symbol *fsym, const char *proc_name,
5465 : gfc_symbol *sym, bool check_contiguous,
5466 : bool deep_copy, bool span_only)
5467 : {
5468 2801 : gfc_se lse;
5469 2801 : gfc_se rse;
5470 2801 : gfc_ss *lss;
5471 2801 : gfc_ss *rss;
5472 2801 : gfc_loopinfo loop;
5473 2801 : gfc_loopinfo loop2;
5474 2801 : gfc_array_info *info;
5475 2801 : tree offset;
5476 2801 : tree tmp_index;
5477 2801 : tree tmp;
5478 2801 : tree base_type;
5479 2801 : tree size;
5480 2801 : stmtblock_t body;
5481 2801 : int n;
5482 2801 : int dimen;
5483 2801 : gfc_se work_se;
5484 2801 : gfc_se *parmse;
5485 2801 : bool pass_optional;
5486 2801 : bool readonly;
5487 :
5488 2801 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5489 :
5490 2760 : if (pass_optional || check_contiguous)
5491 : {
5492 1398 : gfc_init_se (&work_se, NULL);
5493 1398 : parmse = &work_se;
5494 : }
5495 : else
5496 : parmse = se;
5497 :
5498 2801 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5499 : {
5500 : /* We will create a temporary array, so let us warn. */
5501 868 : char * msg;
5502 :
5503 868 : if (fsym && proc_name)
5504 868 : msg = xasprintf ("An array temporary was created for argument "
5505 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5506 : else
5507 0 : msg = xasprintf ("An array temporary was created");
5508 :
5509 868 : tmp = build_int_cst (logical_type_node, 1);
5510 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5511 : &expr->where, msg);
5512 868 : free (msg);
5513 : }
5514 :
5515 2801 : gfc_init_se (&lse, NULL);
5516 2801 : gfc_init_se (&rse, NULL);
5517 :
5518 : /* Walk the argument expression. */
5519 2801 : rss = gfc_walk_expr (expr);
5520 :
5521 2801 : gcc_assert (rss != gfc_ss_terminator);
5522 :
5523 : /* Initialize the scalarizer. */
5524 2801 : gfc_init_loopinfo (&loop);
5525 2801 : gfc_add_ss_to_loop (&loop, rss);
5526 :
5527 : /* Calculate the bounds of the scalarization. */
5528 2801 : gfc_conv_ss_startstride (&loop);
5529 :
5530 : /* Build an ss for the temporary. */
5531 2801 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5532 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5533 :
5534 2801 : base_type = gfc_typenode_for_spec (&expr->ts);
5535 2801 : if (GFC_ARRAY_TYPE_P (base_type)
5536 2801 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5537 0 : base_type = gfc_get_element_type (base_type);
5538 :
5539 2801 : if (expr->ts.type == BT_CLASS)
5540 127 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5541 :
5542 3983 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5543 1182 : ? expr->ts.u.cl->backend_decl
5544 : : NULL),
5545 : loop.dimen);
5546 :
5547 2801 : parmse->string_length = loop.temp_ss->info->string_length;
5548 :
5549 : /* Associate the SS with the loop. */
5550 2801 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5551 :
5552 : /* Setup the scalarizing loops. */
5553 2801 : gfc_conv_loop_setup (&loop, &expr->where);
5554 :
5555 : /* Pass the temporary descriptor back to the caller. */
5556 2801 : info = &loop.temp_ss->info->data.array;
5557 2801 : parmse->expr = info->descriptor;
5558 :
5559 : /* Setup the gfc_se structures. */
5560 2801 : gfc_copy_loopinfo_to_se (&lse, &loop);
5561 2801 : gfc_copy_loopinfo_to_se (&rse, &loop);
5562 :
5563 2801 : rse.ss = rss;
5564 2801 : lse.ss = loop.temp_ss;
5565 2801 : gfc_mark_ss_chain_used (rss, 1);
5566 2801 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5567 :
5568 : /* Start the scalarized loop body. */
5569 2801 : gfc_start_scalarized_body (&loop, &body);
5570 :
5571 : /* Translate the expression. */
5572 2801 : gfc_conv_expr (&rse, expr);
5573 :
5574 2801 : gfc_conv_tmp_array_ref (&lse);
5575 :
5576 2801 : if (intent != INTENT_OUT)
5577 : {
5578 2763 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, deep_copy, false);
5579 2763 : gfc_add_expr_to_block (&body, tmp);
5580 2763 : gcc_assert (rse.ss == gfc_ss_terminator);
5581 2763 : gfc_trans_scalarizing_loops (&loop, &body);
5582 : }
5583 : else
5584 : {
5585 : /* Make sure that the temporary declaration survives by merging
5586 : all the loop declarations into the current context. */
5587 85 : for (n = 0; n < loop.dimen; n++)
5588 : {
5589 47 : gfc_merge_block_scope (&body);
5590 47 : body = loop.code[loop.order[n]];
5591 : }
5592 38 : gfc_merge_block_scope (&body);
5593 : }
5594 :
5595 : /* Add the post block after the second loop, so that any
5596 : freeing of allocated memory is done at the right time. */
5597 2801 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5598 :
5599 : /**********Copy the temporary back again.*********/
5600 :
5601 2801 : gfc_init_se (&lse, NULL);
5602 2801 : gfc_init_se (&rse, NULL);
5603 :
5604 : /* Walk the argument expression. */
5605 2801 : lss = gfc_walk_expr (expr);
5606 2801 : rse.ss = loop.temp_ss;
5607 2801 : lse.ss = lss;
5608 :
5609 : /* Initialize the scalarizer. */
5610 2801 : gfc_init_loopinfo (&loop2);
5611 2801 : gfc_add_ss_to_loop (&loop2, lss);
5612 :
5613 2801 : dimen = rse.ss->dimen;
5614 :
5615 : /* Skip the write-out loop for this case. */
5616 2801 : if (gfc_is_class_array_function (expr))
5617 13 : goto class_array_fcn;
5618 :
5619 : /* Calculate the bounds of the scalarization. */
5620 2788 : gfc_conv_ss_startstride (&loop2);
5621 :
5622 : /* Setup the scalarizing loops. */
5623 2788 : gfc_conv_loop_setup (&loop2, &expr->where);
5624 :
5625 2788 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5626 2788 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5627 :
5628 2788 : gfc_mark_ss_chain_used (lss, 1);
5629 2788 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5630 :
5631 : /* Declare the variable to hold the temporary offset and start the
5632 : scalarized loop body. */
5633 2788 : offset = gfc_create_var (gfc_array_index_type, NULL);
5634 2788 : gfc_start_scalarized_body (&loop2, &body);
5635 :
5636 : /* Build the offsets for the temporary from the loop variables. The
5637 : temporary array has lbounds of zero and strides of one in all
5638 : dimensions, so this is very simple. The offset is only computed
5639 : outside the innermost loop, so the overall transfer could be
5640 : optimized further. */
5641 2788 : info = &rse.ss->info->data.array;
5642 :
5643 2788 : tmp_index = gfc_index_zero_node;
5644 4171 : for (n = dimen - 1; n > 0; n--)
5645 : {
5646 1383 : tree tmp_str;
5647 1383 : tmp = rse.loop->loopvar[n];
5648 1383 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5649 : tmp, rse.loop->from[n]);
5650 1383 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5651 : tmp, tmp_index);
5652 :
5653 2766 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5654 : gfc_array_index_type,
5655 1383 : rse.loop->to[n-1], rse.loop->from[n-1]);
5656 1383 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5657 : gfc_array_index_type,
5658 : tmp_str, gfc_index_one_node);
5659 :
5660 1383 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5661 : gfc_array_index_type, tmp, tmp_str);
5662 : }
5663 :
5664 5576 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5665 : gfc_array_index_type,
5666 2788 : tmp_index, rse.loop->from[0]);
5667 2788 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5668 :
5669 5576 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5670 : gfc_array_index_type,
5671 2788 : rse.loop->loopvar[0], offset);
5672 :
5673 : /* Now use the offset for the reference. */
5674 2788 : tmp = build_fold_indirect_ref_loc (input_location,
5675 : info->data);
5676 2788 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5677 :
5678 2788 : if (expr->ts.type == BT_CHARACTER)
5679 1182 : rse.string_length = expr->ts.u.cl->backend_decl;
5680 :
5681 2788 : gfc_conv_expr (&lse, expr);
5682 :
5683 2788 : gcc_assert (lse.ss == gfc_ss_terminator);
5684 :
5685 : /* Do not do deallocations when we are looking at a g77-style argument. */
5686 :
5687 2788 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, !g77);
5688 2788 : gfc_add_expr_to_block (&body, tmp);
5689 :
5690 : /* Generate the copying loops. */
5691 2788 : gfc_trans_scalarizing_loops (&loop2, &body);
5692 :
5693 : /* Wrap the whole thing up by adding the second loop to the post-block
5694 : and following it by the post-block of the first loop. In this way,
5695 : if the temporary needs freeing, it is done after use!
5696 : If input expr is read-only, e.g. a PARAMETER array, copying back
5697 : modified values is undefined behavior. */
5698 5576 : readonly = (expr->expr_type == EXPR_VARIABLE
5699 2722 : && expr->symtree
5700 5510 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5701 :
5702 2788 : if ((intent != INTENT_IN) && !readonly)
5703 : {
5704 1181 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5705 1181 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5706 : }
5707 :
5708 1607 : class_array_fcn:
5709 :
5710 : /* A deep copy allocated fresh components for the temporary; free them
5711 : again once the call has returned, before the temporary itself goes.
5712 : Only INTENT_IN is supported, as writing the temporary back would leave
5713 : the actual argument holding the freed component pointers. */
5714 2801 : gcc_assert (!deep_copy || intent == INTENT_IN);
5715 2801 : if (deep_copy && expr->ts.type == BT_DERIVED
5716 24 : && expr->ts.u.derived->attr.alloc_comp)
5717 : {
5718 24 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, parmse->expr,
5719 : dimen);
5720 24 : gfc_add_expr_to_block (&parmse->post, tmp);
5721 : }
5722 :
5723 2801 : gfc_add_block_to_block (&parmse->post, &loop.post);
5724 :
5725 2801 : gfc_cleanup_loop (&loop);
5726 2801 : gfc_cleanup_loop (&loop2);
5727 :
5728 : /* Pass the string length to the argument expression. */
5729 2801 : if (expr->ts.type == BT_CHARACTER)
5730 1182 : parmse->string_length = expr->ts.u.cl->backend_decl;
5731 :
5732 : /* Determine the offset for pointer formal arguments and set the
5733 : lbounds to one. */
5734 2801 : if (formal_ptr)
5735 : {
5736 18 : size = gfc_index_one_node;
5737 18 : offset = gfc_index_zero_node;
5738 36 : for (n = 0; n < dimen; n++)
5739 : {
5740 18 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5741 : gfc_rank_cst[n]);
5742 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5743 : gfc_array_index_type, tmp,
5744 : gfc_index_one_node);
5745 18 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5746 : parmse->expr,
5747 : gfc_rank_cst[n],
5748 : tmp);
5749 18 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5750 : parmse->expr,
5751 : gfc_rank_cst[n],
5752 : gfc_index_one_node);
5753 18 : size = gfc_evaluate_now (size, &parmse->pre);
5754 18 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5755 : gfc_array_index_type,
5756 : offset, size);
5757 18 : offset = gfc_evaluate_now (offset, &parmse->pre);
5758 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5759 : gfc_array_index_type,
5760 18 : rse.loop->to[n], rse.loop->from[n]);
5761 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5762 : gfc_array_index_type,
5763 : tmp, gfc_index_one_node);
5764 18 : size = fold_build2_loc (input_location, MULT_EXPR,
5765 : gfc_array_index_type, size, tmp);
5766 : }
5767 :
5768 18 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5769 : offset);
5770 : }
5771 :
5772 : /* We want either the address for the data or the address of the descriptor,
5773 : depending on the mode of passing array arguments. */
5774 2801 : if (g77)
5775 458 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5776 : else
5777 2343 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5778 :
5779 : /* Basically make this into
5780 :
5781 : if (present)
5782 : {
5783 : if (contiguous)
5784 : {
5785 : pointer = a;
5786 : }
5787 : else
5788 : {
5789 : parmse->pre();
5790 : pointer = parmse->expr;
5791 : }
5792 : }
5793 : else
5794 : pointer = NULL;
5795 :
5796 : foo (pointer);
5797 : if (present && !contiguous)
5798 : se->post();
5799 :
5800 : */
5801 :
5802 2801 : if (pass_optional || check_contiguous)
5803 : {
5804 1398 : tree type;
5805 1398 : stmtblock_t else_block;
5806 1398 : tree pre_stmts, post_stmts;
5807 1398 : tree pointer;
5808 1398 : tree else_stmt;
5809 1398 : tree present_var = NULL_TREE;
5810 1398 : tree cont_var = NULL_TREE;
5811 1398 : tree post_cond;
5812 :
5813 1398 : type = TREE_TYPE (parmse->expr);
5814 1398 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5815 1063 : type = TREE_TYPE (type);
5816 1398 : pointer = gfc_create_var (type, "arg_ptr");
5817 :
5818 1398 : if (check_contiguous)
5819 : {
5820 1368 : gfc_se cont_se, array_se;
5821 1368 : stmtblock_t if_block, else_block;
5822 1368 : tree if_stmt, else_stmt;
5823 1368 : mpz_t size;
5824 1368 : bool size_set;
5825 :
5826 1368 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5827 :
5828 : /* If the size is known to be one at compile-time, set
5829 : cont_var to true unconditionally. This may look
5830 : inelegant, but we're only doing this during
5831 : optimization, so the statements will be optimized away,
5832 : and this saves complexity here. */
5833 :
5834 1368 : size_set = gfc_array_size (expr, &size);
5835 1368 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5836 : {
5837 6 : gfc_add_modify (&se->pre, cont_var,
5838 : build_one_cst (boolean_type_node));
5839 : }
5840 : else
5841 : {
5842 : /* cont_var = is_contiguous (expr), or just that the span is the
5843 : element length for a dummy that takes any stride. */
5844 1362 : gfc_init_se (&cont_se, parmse);
5845 1362 : if (span_only)
5846 12 : gfc_conv_span_is_elem_len (&cont_se, expr);
5847 : else
5848 1350 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5849 1362 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5850 1362 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5851 1362 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5852 : }
5853 :
5854 1368 : if (size_set)
5855 1155 : mpz_clear (size);
5856 :
5857 : /* arrayse->expr = descriptor of a. */
5858 1368 : gfc_init_se (&array_se, se);
5859 1368 : gfc_conv_expr_descriptor (&array_se, expr);
5860 1368 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5861 1368 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5862 :
5863 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5864 1368 : gfc_init_block (&if_block);
5865 1368 : if (GFC_DESCRIPTOR_TYPE_P (type))
5866 1039 : gfc_add_modify (&if_block, pointer, array_se.expr);
5867 : else
5868 : {
5869 329 : tmp = gfc_conv_array_data (array_se.expr);
5870 329 : tmp = fold_convert (type, tmp);
5871 329 : gfc_add_modify (&if_block, pointer, tmp);
5872 : }
5873 1368 : if_stmt = gfc_finish_block (&if_block);
5874 :
5875 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5876 1368 : gfc_init_block (&else_block);
5877 1368 : gfc_add_block_to_block (&else_block, &parmse->pre);
5878 1697 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5879 1368 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5880 : : parmse->expr);
5881 1368 : gfc_add_modify (&else_block, pointer, tmp);
5882 1368 : else_stmt = gfc_finish_block (&else_block);
5883 :
5884 : /* And put the above into an if statement. */
5885 1368 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5886 : gfc_likely (cont_var,
5887 : PRED_FORTRAN_CONTIGUOUS),
5888 : if_stmt, else_stmt);
5889 : }
5890 : else
5891 : {
5892 : /* pointer = parmse->expr; . */
5893 36 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5894 30 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5895 : : parmse->expr);
5896 30 : gfc_add_modify (&parmse->pre, pointer, tmp);
5897 30 : pre_stmts = gfc_finish_block (&parmse->pre);
5898 : }
5899 :
5900 1398 : if (pass_optional)
5901 : {
5902 41 : present_var = gfc_create_var (boolean_type_node, "present");
5903 :
5904 : /* present_var = present(sym); . */
5905 41 : tmp = gfc_conv_expr_present (sym);
5906 41 : tmp = fold_convert (boolean_type_node, tmp);
5907 41 : gfc_add_modify (&se->pre, present_var, tmp);
5908 :
5909 : /* else_stmt = { pointer = NULL; } . */
5910 41 : gfc_init_block (&else_block);
5911 41 : if (GFC_DESCRIPTOR_TYPE_P (type))
5912 24 : gfc_conv_descriptor_data_set (&else_block, pointer,
5913 : null_pointer_node);
5914 : else
5915 17 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5916 41 : else_stmt = gfc_finish_block (&else_block);
5917 :
5918 41 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5919 : gfc_likely (present_var,
5920 : PRED_FORTRAN_ABSENT_DUMMY),
5921 : pre_stmts, else_stmt);
5922 41 : gfc_add_expr_to_block (&se->pre, tmp);
5923 : }
5924 : else
5925 1357 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5926 :
5927 1398 : post_stmts = gfc_finish_block (&parmse->post);
5928 :
5929 : /* Put together the post stuff, plus the optional
5930 : deallocation. */
5931 1398 : if (check_contiguous)
5932 : {
5933 : /* !cont_var. */
5934 1368 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5935 : cont_var,
5936 : build_zero_cst (boolean_type_node));
5937 1368 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5938 :
5939 1368 : if (pass_optional)
5940 : {
5941 11 : tree present_likely = gfc_likely (present_var,
5942 : PRED_FORTRAN_ABSENT_DUMMY);
5943 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5944 : boolean_type_node, present_likely,
5945 : tmp);
5946 : }
5947 : else
5948 : post_cond = tmp;
5949 : }
5950 : else
5951 : {
5952 30 : gcc_assert (pass_optional);
5953 : post_cond = present_var;
5954 : }
5955 :
5956 1398 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5957 : post_stmts, build_empty_stmt (input_location));
5958 1398 : gfc_add_expr_to_block (&se->post, tmp);
5959 1398 : if (GFC_DESCRIPTOR_TYPE_P (type))
5960 : {
5961 1063 : type = TREE_TYPE (parmse->expr);
5962 1063 : if (POINTER_TYPE_P (type))
5963 : {
5964 1063 : pointer = gfc_build_addr_expr (type, pointer);
5965 1063 : if (pass_optional)
5966 : {
5967 24 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5968 24 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
5969 : tmp, pointer,
5970 : fold_convert (type,
5971 : null_pointer_node));
5972 : }
5973 : }
5974 : else
5975 0 : gcc_assert (!pass_optional);
5976 : }
5977 1398 : se->expr = pointer;
5978 1398 : se->string_length = parmse->string_length;
5979 : }
5980 :
5981 2801 : return;
5982 : }
5983 :
5984 :
5985 : /* Generate the code for argument list functions. */
5986 :
5987 : static void
5988 5826 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5989 : {
5990 : /* Pass by value for g77 %VAL(arg), pass the address
5991 : indirectly for %LOC, else by reference. Thus %REF
5992 : is a "do-nothing" and %LOC is the same as an F95
5993 : pointer. */
5994 5826 : if (strcmp (name, "%VAL") == 0)
5995 5814 : gfc_conv_expr (se, expr);
5996 12 : else if (strcmp (name, "%LOC") == 0)
5997 : {
5998 6 : gfc_conv_expr_reference (se, expr);
5999 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
6000 : }
6001 6 : else if (strcmp (name, "%REF") == 0)
6002 6 : gfc_conv_expr_reference (se, expr);
6003 : else
6004 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
6005 5826 : }
6006 :
6007 :
6008 : /* This function tells whether the middle-end representation of the expression
6009 : E given as input may point to data otherwise accessible through a variable
6010 : (sub-)reference.
6011 : It is assumed that the only expressions that may alias are variables,
6012 : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
6013 : may alias.
6014 : This function is used to decide whether freeing an expression's allocatable
6015 : components is safe or should be avoided.
6016 :
6017 : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
6018 : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
6019 : is necessary because for array constructors, aliasing depends on how
6020 : the array is used:
6021 : - If E is an array constructor used as argument to an elemental procedure,
6022 : the array, which is generated through shallow copy by the scalarizer,
6023 : is used directly and can alias the expressions it was copied from.
6024 : - If E is an array constructor used as argument to a non-elemental
6025 : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
6026 : the array as in the previous case, but then that array is used
6027 : to initialize a new descriptor through deep copy. There is no alias
6028 : possible in that case.
6029 : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
6030 : above. */
6031 :
6032 : static bool
6033 7746 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6034 : {
6035 7746 : gfc_constructor *c;
6036 :
6037 7746 : if (e->expr_type == EXPR_VARIABLE)
6038 : return true;
6039 562 : else if (e->expr_type == EXPR_FUNCTION)
6040 : {
6041 161 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
6042 :
6043 161 : if (proc_ifc->result != NULL
6044 161 : && ((proc_ifc->result->ts.type == BT_CLASS
6045 25 : && proc_ifc->result->ts.u.derived->attr.is_class
6046 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
6047 161 : || proc_ifc->result->attr.pointer))
6048 : return true;
6049 : else
6050 160 : return false;
6051 : }
6052 401 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6053 : return false;
6054 :
6055 79 : for (c = gfc_constructor_first (e->value.constructor);
6056 233 : c; c = gfc_constructor_next (c))
6057 189 : if (c->expr
6058 189 : && expr_may_alias_variables (c->expr, array_may_alias))
6059 : return true;
6060 :
6061 : return false;
6062 : }
6063 :
6064 :
6065 : /* A helper function to set the dtype for unallocated or unassociated
6066 : entities. */
6067 :
6068 : static void
6069 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6070 : {
6071 891 : tree tmp;
6072 891 : tree desc;
6073 891 : tree cond;
6074 891 : tree type;
6075 891 : stmtblock_t block;
6076 :
6077 : /* TODO Figure out how to handle optional dummies. */
6078 891 : if (e && e->expr_type == EXPR_VARIABLE
6079 807 : && e->symtree->n.sym->attr.optional)
6080 108 : return;
6081 :
6082 819 : desc = parmse->expr;
6083 819 : if (desc == NULL_TREE)
6084 : return;
6085 :
6086 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6087 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6088 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6089 192 : desc = gfc_class_data_get (desc);
6090 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6091 : return;
6092 :
6093 783 : gfc_init_block (&block);
6094 783 : tmp = gfc_conv_descriptor_data_get (desc);
6095 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6096 : logical_type_node, tmp,
6097 783 : build_int_cst (TREE_TYPE (tmp), 0));
6098 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6099 783 : gfc_conv_descriptor_dtype_set (&block, desc,
6100 : gfc_get_dtype_rank_type (e->rank, type));
6101 783 : cond = build3_v (COND_EXPR, cond,
6102 : gfc_finish_block (&block),
6103 : build_empty_stmt (input_location));
6104 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6105 : }
6106 :
6107 :
6108 :
6109 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6110 : ISO_Fortran_binding array descriptors. */
6111 :
6112 : static void
6113 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6114 : {
6115 6537 : stmtblock_t block, block2;
6116 6537 : tree cfi, gfc, tmp, tmp2;
6117 6537 : tree present = NULL;
6118 6537 : tree gfc_strlen = NULL;
6119 6537 : tree rank;
6120 6537 : gfc_se se;
6121 :
6122 6537 : if (fsym->attr.optional
6123 1094 : && e->expr_type == EXPR_VARIABLE
6124 1094 : && e->symtree->n.sym->attr.optional)
6125 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6126 :
6127 6537 : gfc_init_block (&block);
6128 :
6129 : /* Convert original argument to a tree. */
6130 6537 : gfc_init_se (&se, NULL);
6131 6537 : if (e->rank == 0)
6132 : {
6133 687 : se.want_pointer = 1;
6134 687 : gfc_conv_expr (&se, e);
6135 687 : gfc = se.expr;
6136 : }
6137 : else
6138 : {
6139 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6140 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6141 : length assumed-length/assumed-size CHARACTER array. This only
6142 : applies if the actual argument is a "variable"; if it's some
6143 : non-lvalue expression, we are going to evaluate it to a
6144 : temporary below anyway. */
6145 5850 : se.force_no_tmp = 1;
6146 5850 : if ((fsym->attr.contiguous
6147 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6148 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6149 937 : || fsym->as->type == AS_EXPLICIT)))
6150 2023 : && !gfc_is_simply_contiguous (e, false, true)
6151 6883 : && gfc_expr_is_variable (e))
6152 : {
6153 1027 : bool optional = fsym->attr.optional;
6154 1027 : fsym->attr.optional = 0;
6155 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6156 1027 : fsym->attr.pointer, fsym,
6157 1027 : fsym->ns->proc_name->name, NULL,
6158 : /* check_contiguous= */ true);
6159 1027 : fsym->attr.optional = optional;
6160 : }
6161 : else
6162 4823 : gfc_conv_expr_descriptor (&se, e);
6163 5850 : gfc = se.expr;
6164 : /* For dt(:)%var, the base_addr is that of the subobject and elem_len is
6165 : its size, see below. The descriptor built for a subreference of the
6166 : array provides both. While sm is fine as it uses span*stride and not
6167 : elem_len. */
6168 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6169 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6170 : }
6171 6537 : if (e->ts.type == BT_CHARACTER)
6172 : {
6173 3409 : if (se.string_length)
6174 : gfc_strlen = se.string_length;
6175 1 : else if (e->ts.u.cl->backend_decl)
6176 : gfc_strlen = e->ts.u.cl->backend_decl;
6177 : else
6178 0 : gcc_unreachable ();
6179 : }
6180 6537 : gfc_add_block_to_block (&block, &se.pre);
6181 :
6182 : /* Create array descriptor and set version, rank, attribute, type. */
6183 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6184 : ? GFC_MAX_DIMENSIONS : e->rank,
6185 : false), "cfi");
6186 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6187 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6188 : {
6189 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6190 2338 : tmp = build_pointer_type (tmp);
6191 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6192 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6193 : }
6194 : else
6195 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6196 :
6197 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6198 6537 : gfc_add_modify (&block, tmp,
6199 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6200 6537 : if (e->rank < 0)
6201 305 : rank = gfc_conv_descriptor_rank_get (gfc);
6202 : else
6203 6232 : rank = gfc_rank_cst[e->rank];
6204 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6205 6537 : gfc_add_modify (&block, tmp,
6206 6537 : fold_convert (TREE_TYPE (tmp), rank));
6207 6537 : int itype = CFI_type_other;
6208 6537 : if (e->ts.f90_type == BT_VOID)
6209 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6210 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6211 : else
6212 : {
6213 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6214 1 : e->ts = fsym->ts;
6215 6441 : switch (e->ts.type)
6216 : {
6217 2296 : case BT_INTEGER:
6218 2296 : case BT_LOGICAL:
6219 2296 : case BT_REAL:
6220 2296 : case BT_COMPLEX:
6221 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6222 2296 : break;
6223 3410 : case BT_CHARACTER:
6224 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6225 3410 : break;
6226 : case BT_DERIVED:
6227 6537 : itype = CFI_type_struct;
6228 : break;
6229 0 : case BT_VOID:
6230 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6231 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6232 : break;
6233 : case BT_ASSUMED:
6234 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6235 : break;
6236 1 : case BT_CLASS:
6237 1 : if (fsym->ts.type == BT_ASSUMED)
6238 : {
6239 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6240 : // type specifier is assumed-type and is an unlimited polymorphic
6241 : // entity." The actual argument _data component is passed.
6242 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6243 : break;
6244 : }
6245 : else
6246 0 : gcc_unreachable ();
6247 :
6248 0 : case BT_UNSIGNED:
6249 0 : gfc_internal_error ("Unsigned not yet implemented");
6250 :
6251 0 : case BT_PROCEDURE:
6252 0 : case BT_HOLLERITH:
6253 0 : case BT_UNION:
6254 0 : case BT_BOZ:
6255 0 : case BT_UNKNOWN:
6256 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6257 0 : gcc_unreachable ();
6258 : }
6259 : }
6260 :
6261 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6262 6537 : gfc_add_modify (&block, tmp,
6263 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6264 :
6265 6537 : int attr = CFI_attribute_other;
6266 6537 : if (fsym->attr.pointer)
6267 : attr = CFI_attribute_pointer;
6268 5774 : else if (fsym->attr.allocatable)
6269 433 : attr = CFI_attribute_allocatable;
6270 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6271 6537 : gfc_add_modify (&block, tmp,
6272 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6273 :
6274 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6275 : That is very sensible for undefined pointers, but the C code might assume
6276 : that the pointer retains the value, in particular, if it was NULL. */
6277 6537 : if (e->rank == 0)
6278 : {
6279 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6280 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6281 : }
6282 : else
6283 : {
6284 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6285 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6286 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6287 : }
6288 :
6289 : /* Set elem_len if known - must be before the next if block.
6290 : Note that allocatable implies 'len=:'. */
6291 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6292 : {
6293 : /* Length is known at compile time; use 'block' for it. */
6294 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6295 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6296 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6297 : }
6298 :
6299 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6300 91 : goto done;
6301 :
6302 : /* When allocatable + intent out, free the cfi descriptor. */
6303 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6304 : {
6305 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6306 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6307 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6308 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6309 90 : gfc_add_modify (&block, tmp,
6310 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6311 90 : goto done;
6312 : }
6313 :
6314 : /* If not unallocated/unassociated. */
6315 6356 : gfc_init_block (&block2);
6316 :
6317 : /* Set elem_len, which may be only known at run time. */
6318 6356 : if (e->ts.type == BT_CHARACTER
6319 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6320 : {
6321 3408 : gcc_assert (gfc_strlen);
6322 3409 : tmp = gfc_strlen;
6323 3409 : if (e->ts.kind != 1)
6324 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6325 : gfc_charlen_type_node, tmp,
6326 : build_int_cst (gfc_charlen_type_node,
6327 1117 : e->ts.kind));
6328 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6329 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6330 : }
6331 2947 : else if (e->ts.type == BT_ASSUMED)
6332 : {
6333 54 : tmp = gfc_conv_descriptor_elem_len_get (gfc);
6334 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6335 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6336 : }
6337 :
6338 6356 : if (e->ts.type == BT_ASSUMED)
6339 : {
6340 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6341 : an CFI descriptor. Use the type in the descriptor as it provide
6342 : mode information. (Quality of implementation feature.) */
6343 54 : tree cond;
6344 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6345 54 : tree type = fold_convert (TREE_TYPE (ctype),
6346 : gfc_conv_descriptor_type_get (gfc));
6347 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6348 : gfc_conv_descriptor_elem_len_get (gfc));
6349 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6350 54 : kind, build_int_cst (TREE_TYPE (type),
6351 : CFI_type_kind_shift));
6352 :
6353 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6354 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6355 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6356 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6357 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6358 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6359 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6360 : ctype,
6361 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6362 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6363 : tmp, tmp2);
6364 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6365 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6366 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6367 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6368 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6369 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6370 : tmp, tmp2);
6371 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6372 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6373 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6374 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6375 54 : tmp = build_int_cst (TREE_TYPE (type),
6376 : CFI_type_from_type_kind (CFI_type_Character, 1));
6377 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6378 : ctype, tmp);
6379 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6380 : tmp, tmp2);
6381 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6382 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6383 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6384 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6385 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6386 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6387 54 : build_int_cst (TREE_TYPE (type),
6388 : CFI_type_Complex));
6389 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6390 : ctype, tmp);
6391 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6392 : tmp, tmp2);
6393 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6394 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6395 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6396 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6397 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6398 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6399 : cond, tmp);
6400 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6401 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6402 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6403 : cond, tmp);
6404 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6405 : type, kind);
6406 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6407 : ctype, tmp);
6408 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6409 : tmp, tmp2);
6410 54 : gfc_add_expr_to_block (&block2, tmp2);
6411 : }
6412 :
6413 6356 : if (e->rank != 0)
6414 : {
6415 : /* Loop: for (i = 0; i < rank; ++i). */
6416 5735 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6417 : /* Loop body. */
6418 5735 : stmtblock_t loop_body;
6419 5735 : gfc_init_block (&loop_body);
6420 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6421 : ? gfc->dim[i].lbound : 0 */
6422 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6423 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6424 : else
6425 5087 : tmp = gfc_index_zero_node;
6426 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6427 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6428 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6429 : gfc_conv_descriptor_ubound_get (gfc, idx),
6430 : gfc_conv_descriptor_lbound_get (gfc, idx));
6431 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6432 : tmp, gfc_index_one_node);
6433 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6434 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6435 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6436 : gfc_conv_descriptor_stride_get (gfc, idx),
6437 : gfc_conv_descriptor_span_get (gfc));
6438 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6439 :
6440 : /* Generate loop. */
6441 5735 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6442 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6443 :
6444 5735 : if (e->expr_type == EXPR_VARIABLE
6445 5573 : && e->ref
6446 5573 : && e->ref->u.ar.type == AR_FULL
6447 2732 : && e->symtree->n.sym->attr.dummy
6448 988 : && e->symtree->n.sym->as
6449 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6450 : {
6451 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6452 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6453 : }
6454 : }
6455 :
6456 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6457 : {
6458 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6459 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6460 : tmp, null_pointer_node);
6461 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6462 : build_empty_stmt (input_location));
6463 1015 : gfc_add_expr_to_block (&block, tmp);
6464 : }
6465 : else
6466 5341 : gfc_add_block_to_block (&block, &block2);
6467 :
6468 :
6469 6537 : done:
6470 6537 : if (present)
6471 : {
6472 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6473 103 : TREE_TYPE (parmse->expr),
6474 : present, parmse->expr, null_pointer_node);
6475 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6476 : build_empty_stmt (input_location));
6477 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6478 : }
6479 : else
6480 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6481 :
6482 6537 : gfc_init_block (&block);
6483 :
6484 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6485 1196 : || fsym->attr.intent == INTENT_IN)
6486 5550 : goto post_call;
6487 :
6488 987 : gfc_init_block (&block2);
6489 987 : if (e->rank == 0)
6490 : {
6491 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6492 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6493 : }
6494 : else
6495 : {
6496 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6497 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6498 :
6499 559 : if (fsym->attr.allocatable)
6500 : {
6501 : /* gfc->span = cfi->elem_len. */
6502 252 : tmp = fold_convert (gfc_array_index_type,
6503 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6504 : }
6505 : else
6506 : {
6507 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6508 : ? cfi->dim[0].sm : cfi->elem_len). */
6509 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6510 307 : tmp2 = fold_convert (gfc_array_index_type,
6511 : gfc_get_cfi_desc_elem_len (cfi));
6512 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6513 : gfc_array_index_type, tmp, tmp2);
6514 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6515 : tmp, gfc_index_zero_node);
6516 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6517 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6518 : }
6519 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6520 :
6521 : /* Calculate offset + set lbound, ubound and stride. */
6522 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6523 : /* Loop: for (i = 0; i < rank; ++i). */
6524 559 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6525 : /* Loop body. */
6526 559 : stmtblock_t loop_body;
6527 559 : gfc_init_block (&loop_body);
6528 : /* gfc->dim[i].lbound = ... */
6529 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6530 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6531 :
6532 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6533 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6534 : gfc_conv_descriptor_lbound_get (gfc, idx),
6535 : gfc_index_one_node);
6536 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6537 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6538 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6539 :
6540 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6541 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6542 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6543 : gfc_array_index_type, tmp,
6544 : fold_convert (gfc_array_index_type,
6545 : gfc_get_cfi_desc_elem_len (cfi)));
6546 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6547 :
6548 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6549 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6550 : gfc_conv_descriptor_stride_get (gfc, idx),
6551 : gfc_conv_descriptor_lbound_get (gfc, idx));
6552 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6553 : gfc_conv_descriptor_offset_get (gfc), tmp);
6554 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6555 : /* Generate loop. */
6556 559 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6557 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6558 : }
6559 :
6560 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6561 : {
6562 60 : tmp = fold_convert (gfc_charlen_type_node,
6563 : gfc_get_cfi_desc_elem_len (cfi));
6564 60 : if (e->ts.kind != 1)
6565 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6566 : gfc_charlen_type_node, tmp,
6567 : build_int_cst (gfc_charlen_type_node,
6568 24 : e->ts.kind));
6569 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6570 : }
6571 :
6572 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6573 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6574 : tmp, null_pointer_node);
6575 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6576 : build_empty_stmt (input_location));
6577 987 : gfc_add_expr_to_block (&block, tmp);
6578 :
6579 6537 : post_call:
6580 6537 : gfc_add_block_to_block (&block, &se.post);
6581 6537 : if (present && block.head)
6582 : {
6583 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6584 : build_empty_stmt (input_location));
6585 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6586 : }
6587 6531 : else if (block.head)
6588 1564 : gfc_add_block_to_block (&parmse->post, &block);
6589 6537 : }
6590 :
6591 :
6592 : /* Create "conditional temporary" to handle scalar dummy variables with the
6593 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6594 : as fallback. Does not handle CLASS. */
6595 :
6596 : static void
6597 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6598 : {
6599 234 : tree temp;
6600 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6601 234 : gcc_assert (e->rank == 0);
6602 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6603 234 : TREE_STATIC (temp) = 1;
6604 234 : TREE_CONSTANT (temp) = 1;
6605 234 : TREE_READONLY (temp) = 1;
6606 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6607 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6608 234 : TREE_TYPE (parmse->expr),
6609 : cond, parmse->expr, temp);
6610 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6611 234 : }
6612 :
6613 :
6614 : /* Returns true if the type specified in TS is a character type whose length
6615 : is constant. Otherwise returns false. */
6616 :
6617 : static bool
6618 22204 : gfc_const_length_character_type_p (gfc_typespec *ts)
6619 : {
6620 22204 : return (ts->type == BT_CHARACTER
6621 515 : && ts->u.cl
6622 515 : && ts->u.cl->length
6623 479 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6624 22671 : && ts->u.cl->length->ts.type == BT_INTEGER);
6625 : }
6626 :
6627 :
6628 : /* Returns true if FORMAL contains an explicit-shape array dummy with the
6629 : VALUE attribute. The bounds of such a dummy may have to be evaluated
6630 : on the caller side, which needs an interface mapping. */
6631 :
6632 : static bool
6633 115464 : has_value_array_dummy (gfc_formal_arglist *formal)
6634 : {
6635 309213 : for (; formal; formal = formal->next)
6636 193815 : if (formal->sym && formal->sym->attr.value && formal->sym->attr.dimension
6637 174 : && formal->sym->as && formal->sym->as->type == AS_EXPLICIT)
6638 : return true;
6639 :
6640 : return false;
6641 : }
6642 :
6643 :
6644 : /* Sequence association (F2023, 15.5.2.12) of a scalar actual argument E with
6645 : an explicit-shape array dummy FSYM that has the VALUE attribute. Copy as
6646 : many elements as the dummy declares into a temporary and pass that.
6647 : MAPPING supplies the caller-side values of any dummy arguments appearing
6648 : in the bounds or the character length of FSYM. */
6649 :
6650 : static void
6651 36 : conv_seq_assoc_value_arg (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
6652 : gfc_interface_mapping *mapping)
6653 : {
6654 36 : tree nelems, elem_type, elem_size, tmpvar, src, tmp;
6655 36 : gfc_se se;
6656 36 : int n;
6657 :
6658 36 : gcc_assert (fsym->as && fsym->as->type == AS_EXPLICIT);
6659 :
6660 : /* Address of the first element of the actual argument's sequence. */
6661 36 : gfc_init_se (&se, NULL);
6662 36 : if (e->ts.type == BT_CHARACTER)
6663 : {
6664 12 : gfc_conv_expr (&se, e);
6665 12 : gfc_conv_string_parameter (&se);
6666 : /* The hidden length argument is that of the actual argument, as it
6667 : is for a dummy that does not have the VALUE attribute. */
6668 12 : parmse->string_length = se.string_length;
6669 : }
6670 : else
6671 24 : gfc_conv_expr_reference (&se, e);
6672 36 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6673 36 : gfc_add_block_to_block (&parmse->post, &se.post);
6674 36 : src = se.expr;
6675 :
6676 : /* Number of elements of the dummy. */
6677 36 : nelems = gfc_index_one_node;
6678 78 : for (n = 0; n < fsym->as->rank; n++)
6679 : {
6680 42 : tree lbound, ubound, extent;
6681 :
6682 42 : gfc_init_se (&se, NULL);
6683 42 : gfc_apply_interface_mapping (mapping, &se, fsym->as->upper[n]);
6684 42 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6685 42 : gfc_add_block_to_block (&parmse->post, &se.post);
6686 42 : ubound = fold_convert (gfc_array_index_type, se.expr);
6687 :
6688 42 : if (fsym->as->lower[n])
6689 : {
6690 42 : gfc_init_se (&se, NULL);
6691 42 : gfc_apply_interface_mapping (mapping, &se, fsym->as->lower[n]);
6692 42 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6693 42 : gfc_add_block_to_block (&parmse->post, &se.post);
6694 42 : lbound = fold_convert (gfc_array_index_type, se.expr);
6695 : }
6696 : else
6697 0 : lbound = gfc_index_one_node;
6698 :
6699 42 : extent = fold_build2_loc (input_location, MINUS_EXPR,
6700 : gfc_array_index_type, ubound, lbound);
6701 42 : extent = fold_build2_loc (input_location, PLUS_EXPR,
6702 : gfc_array_index_type, extent,
6703 : gfc_index_one_node);
6704 42 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6705 : extent, gfc_index_zero_node);
6706 42 : nelems = fold_build2_loc (input_location, MULT_EXPR,
6707 : gfc_array_index_type, nelems, extent);
6708 : }
6709 36 : nelems = gfc_evaluate_now (nelems, &parmse->pre);
6710 :
6711 : /* Element type and size of the dummy. For characters the element
6712 : sequence is grouped by the character length of the dummy. */
6713 36 : if (fsym->ts.type == BT_CHARACTER)
6714 : {
6715 12 : tree len;
6716 :
6717 12 : if (fsym->ts.u.cl->length)
6718 : {
6719 12 : gfc_init_se (&se, NULL);
6720 12 : gfc_apply_interface_mapping (mapping, &se, fsym->ts.u.cl->length);
6721 12 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6722 12 : gfc_add_block_to_block (&parmse->post, &se.post);
6723 12 : len = fold_convert (gfc_charlen_type_node, se.expr);
6724 : }
6725 : else
6726 0 : len = fold_convert (gfc_charlen_type_node, parmse->string_length);
6727 :
6728 12 : tree char_size = TYPE_SIZE_UNIT (gfc_get_char_type (fsym->ts.kind));
6729 :
6730 12 : elem_type = gfc_get_character_type_len (fsym->ts.kind, len);
6731 12 : elem_size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6732 : fold_convert (size_type_node, len),
6733 : fold_convert (size_type_node, char_size));
6734 : }
6735 : else
6736 : {
6737 24 : elem_type = gfc_typenode_for_spec (&fsym->ts);
6738 24 : elem_size = fold_convert (size_type_node, TYPE_SIZE_UNIT (elem_type));
6739 : }
6740 :
6741 : /* The temporary holding the copy. Allocate at least one element so that
6742 : a zero-sized dummy does not produce a degenerate array type. */
6743 36 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6744 : nelems, gfc_index_one_node);
6745 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6746 : tmp, gfc_index_one_node);
6747 36 : tmp = build_array_type (elem_type,
6748 : build_range_type (gfc_array_index_type,
6749 : gfc_index_zero_node, tmp));
6750 36 : tmpvar = gfc_create_var (tmp, "seq_copy");
6751 36 : gfc_add_expr_to_block (&parmse->pre,
6752 : fold_build1_loc (input_location, DECL_EXPR, tmp,
6753 : tmpvar));
6754 :
6755 36 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6756 : fold_convert (size_type_node, nelems), elem_size);
6757 36 : tmp = gfc_build_memcpy_call (fold_convert (pvoid_type_node,
6758 : gfc_build_addr_expr (NULL_TREE,
6759 : tmpvar)),
6760 : fold_convert (pvoid_type_node, src), tmp);
6761 36 : gfc_add_expr_to_block (&parmse->pre, tmp);
6762 :
6763 : /* The memcpy also copied the component pointers of a derived type, which
6764 : would leave the temporary sharing the actual argument's allocatable
6765 : components. Give the copy components of its own and free them again
6766 : once the call has returned. */
6767 36 : if (fsym->ts.type == BT_DERIVED && fsym->ts.u.derived->attr.alloc_comp)
6768 : {
6769 6 : tree src_ptr = fold_convert (build_pointer_type (elem_type), src);
6770 6 : tree elem_idx = gfc_create_var (gfc_array_index_type, "elem");
6771 6 : tree dest_elem = gfc_build_array_ref (tmpvar, elem_idx, NULL_TREE);
6772 6 : tree src_offset = fold_build2_loc (input_location, MULT_EXPR, sizetype,
6773 : fold_convert (sizetype, elem_idx),
6774 : elem_size);
6775 6 : tree src_elem
6776 6 : = build_fold_indirect_ref_loc (input_location,
6777 : fold_build_pointer_plus_loc
6778 : (input_location, src_ptr, src_offset));
6779 :
6780 6 : tmp = gfc_copy_alloc_comp (fsym->ts.u.derived, src_elem, dest_elem, 0, 0);
6781 6 : gfc_simple_for_loop (&parmse->pre, elem_idx, gfc_index_zero_node, nelems,
6782 : LT_EXPR, gfc_index_one_node, tmp);
6783 :
6784 6 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived, dest_elem, 0);
6785 6 : gfc_simple_for_loop (&parmse->post, elem_idx, gfc_index_zero_node, nelems,
6786 : LT_EXPR, gfc_index_one_node, tmp);
6787 : }
6788 :
6789 36 : if (fsym->ts.type == BT_CHARACTER)
6790 12 : parmse->expr
6791 12 : = gfc_build_addr_expr (build_pointer_type (gfc_get_char_type
6792 : (fsym->ts.kind)), tmpvar);
6793 : else
6794 24 : parmse->expr = gfc_build_addr_expr (build_pointer_type (elem_type), tmpvar);
6795 36 : }
6796 :
6797 :
6798 : /* Helper function for the handling of (currently) scalar dummy variables
6799 : with the VALUE attribute. Argument parmse should already be set up. */
6800 : static void
6801 22649 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6802 : vec<tree, va_gc> *& optionalargs)
6803 : {
6804 22649 : tree tmp;
6805 :
6806 22649 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6807 :
6808 22649 : if (IS_PDT (e))
6809 : {
6810 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6811 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6812 6 : gfc_add_expr_to_block (&parmse->pre,
6813 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6814 : parmse->expr, tmp,
6815 : e->rank, 0));
6816 6 : parmse->expr = tmp;
6817 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6818 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6819 6 : return;
6820 : }
6821 :
6822 : /* Absent actual argument for optional scalar dummy. */
6823 22643 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6824 : {
6825 : /* For scalar arguments with VALUE attribute which are passed by
6826 : value, pass "0" and a hidden argument for the optional status. */
6827 439 : if (fsym->ts.type == BT_CHARACTER)
6828 : {
6829 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6830 : zero. */
6831 102 : parmse->expr = null_pointer_node;
6832 102 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6833 : }
6834 337 : else if (gfc_bt_struct (fsym->ts.type)
6835 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6836 : {
6837 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6838 : are pointers and passed as such below. */
6839 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6840 24 : TREE_CONSTANT (temp) = 1;
6841 24 : TREE_READONLY (temp) = 1;
6842 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6843 24 : parmse->expr = temp;
6844 24 : }
6845 : else
6846 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6847 : integer_zero_node);
6848 439 : vec_safe_push (optionalargs, boolean_false_node);
6849 :
6850 439 : return;
6851 : }
6852 :
6853 : /* Assumed-length or non-constant-length CHARACTER VALUE dummy: copy
6854 : the actual argument and pass the copy. */
6855 22204 : if (fsym->ts.type == BT_CHARACTER
6856 515 : && (!fsym->ts.u.cl || !fsym->ts.u.cl->length
6857 479 : || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT))
6858 : {
6859 : /* An optional actual argument that is absent has nothing to copy
6860 : from; pass a null pointer and a length of zero instead. */
6861 48 : tree present = NULL_TREE;
6862 48 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
6863 24 : && e->symtree->n.sym->attr.optional)
6864 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
6865 :
6866 48 : gfc_conv_string_parameter (parmse);
6867 48 : tree len = fold_convert (gfc_charlen_type_node, parmse->string_length);
6868 48 : if (present)
6869 : {
6870 12 : len = fold_build3_loc (input_location, COND_EXPR,
6871 : gfc_charlen_type_node, present, len,
6872 : build_zero_cst (gfc_charlen_type_node));
6873 12 : len = gfc_evaluate_now (len, &parmse->pre);
6874 12 : parmse->string_length = len;
6875 : }
6876 48 : tree chartype = gfc_get_character_type_len (fsym->ts.kind, len);
6877 48 : tree val_copy = gfc_create_var (chartype, "val_copy");
6878 48 : tmp = fold_build1_loc (input_location, DECL_EXPR, chartype, val_copy);
6879 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
6880 : /* The copy size is in bytes, not in characters. */
6881 48 : tree bytes
6882 48 : = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6883 : fold_convert (size_type_node, len),
6884 48 : fold_convert (size_type_node,
6885 : TYPE_SIZE_UNIT (gfc_get_char_type
6886 : (fsym->ts.kind))));
6887 48 : tmp = gfc_build_memcpy_call (
6888 : fold_convert (pvoid_type_node,
6889 : gfc_build_addr_expr (NULL_TREE, val_copy)),
6890 : fold_convert (pvoid_type_node, parmse->expr), bytes);
6891 48 : if (present)
6892 12 : tmp = build3_v (COND_EXPR, present, tmp,
6893 : build_empty_stmt (input_location));
6894 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
6895 48 : parmse->expr = fold_convert (
6896 : build_pointer_type (gfc_get_char_type (fsym->ts.kind)),
6897 : gfc_build_addr_expr (NULL_TREE, val_copy));
6898 48 : if (present)
6899 24 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6900 12 : TREE_TYPE (parmse->expr), present,
6901 : parmse->expr,
6902 12 : fold_convert (TREE_TYPE (parmse->expr),
6903 : null_pointer_node));
6904 : }
6905 :
6906 : /* Truncate a too long constant character actual argument. */
6907 22204 : if (gfc_const_length_character_type_p (&fsym->ts)
6908 467 : && e->expr_type == EXPR_CONSTANT
6909 22287 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6910 : e->value.character.length) < 0)
6911 : {
6912 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6913 :
6914 : /* Truncate actual string argument. */
6915 17 : gfc_conv_expr (parmse, e);
6916 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6917 17 : e->value.character.string);
6918 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6919 :
6920 17 : if (flen == 1)
6921 : {
6922 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6923 14 : gfc_conv_string_parameter (parmse);
6924 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6925 : e->ts.kind);
6926 : }
6927 :
6928 : /* Indicate value,optional scalar dummy argument as present. */
6929 17 : if (fsym->attr.optional)
6930 1 : vec_safe_push (optionalargs, boolean_true_node);
6931 : return;
6932 : }
6933 :
6934 : /* gfortran argument passing conventions:
6935 : actual arguments to CHARACTER(len=1),VALUE
6936 : dummy arguments are actually passed by value.
6937 : Strings are truncated to length 1. */
6938 22187 : if (gfc_length_one_character_type_p (&fsym->ts))
6939 : {
6940 378 : if (e->expr_type == EXPR_CONSTANT
6941 54 : && e->value.character.length > 1)
6942 : {
6943 0 : e->value.character.length = 1;
6944 0 : gfc_conv_expr (parmse, e);
6945 : }
6946 :
6947 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6948 378 : gfc_conv_string_parameter (parmse);
6949 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6950 : e->ts.kind);
6951 : /* Truncate resulting string to length 1. */
6952 378 : parmse->string_length = slen1;
6953 : }
6954 :
6955 22187 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6956 : {
6957 : /* F2018:15.5.2.12 Argument presence and
6958 : restrictions on arguments not present. */
6959 847 : if (e->expr_type == EXPR_VARIABLE
6960 674 : && e->rank == 0
6961 1467 : && (gfc_expr_attr (e).allocatable
6962 620 : || gfc_expr_attr (e).pointer))
6963 : {
6964 198 : gfc_se argse;
6965 198 : tree cond;
6966 198 : gfc_init_se (&argse, NULL);
6967 198 : argse.want_pointer = 1;
6968 198 : gfc_conv_expr (&argse, e);
6969 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6970 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6971 : argse.expr, cond);
6972 198 : if (e->symtree->n.sym->attr.dummy)
6973 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6974 : logical_type_node,
6975 : gfc_conv_expr_present (e->symtree->n.sym),
6976 : cond);
6977 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
6978 : /* Create "conditional temporary". */
6979 198 : conv_cond_temp (parmse, e, cond);
6980 : }
6981 649 : else if (e->expr_type != EXPR_VARIABLE
6982 476 : || !e->symtree->n.sym->attr.optional
6983 272 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6984 377 : vec_safe_push (optionalargs, boolean_true_node);
6985 : else
6986 : {
6987 272 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6988 272 : if (gfc_bt_struct (fsym->ts.type)
6989 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6990 36 : conv_cond_temp (parmse, e, tmp);
6991 236 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6992 84 : parmse->expr
6993 168 : = fold_build3_loc (input_location, COND_EXPR,
6994 84 : TREE_TYPE (parmse->expr),
6995 : tmp, parmse->expr,
6996 84 : fold_convert (TREE_TYPE (parmse->expr),
6997 : integer_zero_node));
6998 :
6999 544 : vec_safe_push (optionalargs,
7000 272 : fold_convert (boolean_type_node, tmp));
7001 : }
7002 : }
7003 : }
7004 :
7005 :
7006 : /* Helper function for the handling of NULL() actual arguments associated with
7007 : non-optional dummy variables. Argument parmse should already be set up. */
7008 : static void
7009 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
7010 : {
7011 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
7012 :
7013 : /* Obtain the character length for a NULL() actual with a character
7014 : MOLD argument. Otherwise substitute a suitable dummy length.
7015 : Here we handle only non-optional dummies of non-bind(c) procedures. */
7016 426 : if (fsym->ts.type == BT_CHARACTER)
7017 : {
7018 216 : if (e->ts.type == BT_CHARACTER
7019 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
7020 : {
7021 : /* MOLD is present. Substitute a temporary character NULL pointer.
7022 : For an assumed-rank dummy we need a descriptor that passes the
7023 : correct rank. */
7024 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
7025 : {
7026 54 : tree tmp;
7027 54 : tmp = gfc_create_null_actual_descriptor (&parmse->pre, &e->ts,
7028 : fsym->attr, e->rank);
7029 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7030 54 : }
7031 : else
7032 : {
7033 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
7034 108 : gfc_add_modify (&parmse->pre, tmp,
7035 108 : build_zero_cst (TREE_TYPE (tmp)));
7036 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7037 : }
7038 :
7039 : /* Ensure that a usable length is available. */
7040 162 : if (parmse->string_length == NULL_TREE)
7041 : {
7042 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
7043 :
7044 162 : if (ts->u.cl->length != NULL
7045 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
7046 108 : gfc_conv_const_charlen (ts->u.cl);
7047 :
7048 162 : if (ts->u.cl->backend_decl)
7049 162 : parmse->string_length = ts->u.cl->backend_decl;
7050 : }
7051 : }
7052 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
7053 : {
7054 : /* MOLD is not present. Pass length of associated dummy character
7055 : argument if constant, or zero. */
7056 54 : if (fsym->ts.u.cl->length != NULL
7057 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7058 : {
7059 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
7060 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
7061 : }
7062 : else
7063 : {
7064 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
7065 : "slen");
7066 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
7067 : build_zero_cst (gfc_charlen_type_node));
7068 : }
7069 : }
7070 : }
7071 210 : else if (fsym->ts.type == BT_DERIVED)
7072 : {
7073 210 : if (e->ts.type != BT_UNKNOWN)
7074 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
7075 : For an assumed-rank dummy we provide a descriptor that passes
7076 : the correct rank. */
7077 : {
7078 138 : tree tmp = gfc_create_null_actual_descriptor (&parmse->pre, &e->ts,
7079 : fsym->attr, e->rank);
7080 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7081 : }
7082 : else
7083 : /* MOLD is not present. Use attributes from dummy argument, which is
7084 : not allowed to be assumed-rank. */
7085 : {
7086 72 : int dummy_rank = fsym->as ? fsym->as->rank : 0;
7087 72 : tree tmp = gfc_create_null_actual_descriptor (&parmse->pre, &fsym->ts,
7088 : fsym->attr, dummy_rank);
7089 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7090 : }
7091 : }
7092 426 : }
7093 :
7094 :
7095 : /* Return true if a subobject of the elements of an array is referenced. */
7096 :
7097 : static bool
7098 30 : is_subobject_ref (gfc_expr *e)
7099 : {
7100 30 : bool seen_array = false;
7101 :
7102 72 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
7103 : {
7104 60 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7105 : seen_array = true;
7106 30 : else if (seen_array)
7107 : return true;
7108 : }
7109 :
7110 : return false;
7111 : }
7112 :
7113 :
7114 : /* Return true if expr is a span addressed dummy that is passed on as a whole,
7115 : rather than a reference to a subobject of the elements of an array. */
7116 :
7117 : static bool
7118 781 : is_whole_span_addressed_dummy (gfc_expr *e)
7119 : {
7120 781 : return e->expr_type == EXPR_VARIABLE
7121 781 : && e->symtree && e->symtree->n.sym
7122 781 : && gfc_is_span_addressed_dummy (e->symtree->n.sym)
7123 811 : && !is_subobject_ref (e);
7124 : }
7125 :
7126 :
7127 : /* Return true if the dummy fsym has an array descriptor and so addresses its
7128 : elements by the strides held in it. Such a dummy accepts an actual
7129 : argument of any stride; only a dummy without a descriptor, or one declared
7130 : CONTIGUOUS, needs it packed into contiguous storage. */
7131 :
7132 : static bool
7133 12 : dummy_accepts_strided_arg (gfc_symbol *fsym, bool nodesc_arg)
7134 : {
7135 12 : return fsym && !nodesc_arg && !fsym->attr.contiguous && fsym->as
7136 24 : && (fsym->as->type == AS_ASSUMED_SHAPE
7137 0 : || fsym->as->type == AS_ASSUMED_RANK
7138 0 : || fsym->as->type == AS_DEFERRED);
7139 : }
7140 :
7141 :
7142 : /* Return true if the actual argument expr for the dummy fsym may be passed as
7143 : a copy-in/copy-out temporary. A pointer associated with a TARGET or POINTER
7144 : dummy must remain valid after the call, so the actual argument is passed
7145 : directly, with a descriptor whose span provides the element spacing. An
7146 : actual argument with a vector subscript is not definable and its pointer
7147 : association is undefined on return, so it is still copied. */
7148 :
7149 : static bool
7150 1148 : copy_in_out_allowed (gfc_symbol *fsym, gfc_expr *e, bool nodesc_arg)
7151 : {
7152 1148 : if (fsym == NULL || nodesc_arg || gfc_has_vector_subscript (e))
7153 : return true;
7154 :
7155 1043 : if (gfc_dummy_requires_direct_arg (fsym))
7156 : return false;
7157 :
7158 809 : return !(fsym->attr.pointer && !fsym->attr.contiguous && fsym->as
7159 6 : && (fsym->as->type == AS_ASSUMED_SHAPE
7160 : || fsym->as->type == AS_ASSUMED_RANK
7161 : || fsym->as->type == AS_DEFERRED));
7162 : }
7163 :
7164 :
7165 : /* Generate code for a procedure call. Note can return se->post != NULL.
7166 : If se->direct_byref is set then se->expr contains the return parameter.
7167 : Return nonzero, if the call has alternate specifiers.
7168 : 'expr' is only needed for procedure pointer components. */
7169 :
7170 : int
7171 138433 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
7172 : gfc_actual_arglist * args, gfc_expr * expr,
7173 : vec<tree, va_gc> *append_args)
7174 : {
7175 138433 : gfc_interface_mapping mapping;
7176 138433 : vec<tree, va_gc> *arglist;
7177 138433 : vec<tree, va_gc> *retargs;
7178 138433 : tree tmp;
7179 138433 : tree fntype;
7180 138433 : gfc_se parmse;
7181 138433 : gfc_array_info *info;
7182 138433 : int byref;
7183 138433 : int parm_kind;
7184 138433 : tree type;
7185 138433 : tree var;
7186 138433 : tree len;
7187 138433 : tree base_object;
7188 138433 : vec<tree, va_gc> *stringargs;
7189 138433 : vec<tree, va_gc> *optionalargs;
7190 138433 : tree result = NULL;
7191 138433 : gfc_formal_arglist *formal;
7192 138433 : gfc_actual_arglist *arg;
7193 138433 : int has_alternate_specifier = 0;
7194 138433 : bool need_interface_mapping;
7195 138433 : bool is_builtin;
7196 138433 : bool callee_alloc;
7197 138433 : bool ulim_copy;
7198 138433 : gfc_typespec ts;
7199 138433 : gfc_charlen cl;
7200 138433 : gfc_expr *e;
7201 138433 : gfc_symbol *fsym;
7202 138433 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
7203 138433 : gfc_component *comp = NULL;
7204 138433 : int arglen;
7205 138433 : unsigned int argc;
7206 138433 : tree arg1_cntnr = NULL_TREE;
7207 138433 : bool call_needed_for_length = true;
7208 138433 : arglist = NULL;
7209 138433 : retargs = NULL;
7210 138433 : stringargs = NULL;
7211 138433 : optionalargs = NULL;
7212 138433 : var = NULL_TREE;
7213 138433 : len = NULL_TREE;
7214 138433 : gfc_clear_ts (&ts);
7215 138433 : gfc_intrinsic_sym *isym = expr && expr->rank ?
7216 : expr->value.function.isym : NULL;
7217 :
7218 138433 : comp = gfc_get_proc_ptr_comp (expr);
7219 :
7220 276866 : bool elemental_proc = (comp
7221 2049 : && comp->ts.interface
7222 1995 : && comp->ts.interface->attr.elemental)
7223 1850 : || (comp && comp->attr.elemental)
7224 140283 : || sym->attr.elemental;
7225 :
7226 138433 : if (se->ss != NULL)
7227 : {
7228 25101 : if (!elemental_proc)
7229 : {
7230 21536 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
7231 21536 : if (se->ss->info->useflags)
7232 : {
7233 5802 : gcc_assert ((!comp && gfc_return_by_reference (sym)
7234 : && sym->result->attr.dimension)
7235 : || (comp && comp->attr.dimension)
7236 : || gfc_is_class_array_function (expr));
7237 5802 : gcc_assert (se->loop != NULL);
7238 : /* Access the previously obtained result. */
7239 5802 : gfc_conv_tmp_array_ref (se);
7240 5802 : return 0;
7241 : }
7242 : }
7243 19299 : info = &se->ss->info->data.array;
7244 : }
7245 : else
7246 : info = NULL;
7247 :
7248 132631 : stmtblock_t post, clobbers, dealloc_blk;
7249 132631 : gfc_init_block (&post);
7250 132631 : gfc_init_block (&clobbers);
7251 132631 : gfc_init_block (&dealloc_blk);
7252 132631 : gfc_init_interface_mapping (&mapping);
7253 132631 : if (!comp)
7254 : {
7255 130631 : formal = gfc_sym_get_dummy_args (sym);
7256 245780 : need_interface_mapping = sym->attr.dimension ||
7257 115149 : (sym->ts.type == BT_CHARACTER
7258 3204 : && sym->ts.u.cl->length
7259 2452 : && sym->ts.u.cl->length->expr_type
7260 : != EXPR_CONSTANT)
7261 244183 : || has_value_array_dummy (formal);
7262 : }
7263 : else
7264 : {
7265 2000 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
7266 3931 : need_interface_mapping = comp->attr.dimension ||
7267 1931 : (comp->ts.type == BT_CHARACTER
7268 229 : && comp->ts.u.cl->length
7269 220 : && comp->ts.u.cl->length->expr_type
7270 : != EXPR_CONSTANT)
7271 3912 : || has_value_array_dummy (formal);
7272 : }
7273 :
7274 132631 : base_object = NULL_TREE;
7275 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7276 : is the third and fourth argument to such a function call a value
7277 : denoting the number of elements to copy (i.e., most of the time the
7278 : length of a deferred length string). */
7279 265262 : ulim_copy = (formal == NULL)
7280 32334 : && UNLIMITED_POLY (sym)
7281 132711 : && comp && (strcmp ("_copy", comp->name) == 0);
7282 :
7283 : /* Scan for allocatable actual arguments passed to allocatable dummy
7284 : arguments with INTENT(OUT). As the corresponding actual arguments are
7285 : deallocated before execution of the procedure, we evaluate actual
7286 : argument expressions to avoid problems with possible dependencies. */
7287 132631 : bool force_eval_args = false;
7288 132631 : gfc_formal_arglist *tmp_formal;
7289 405945 : for (arg = args, tmp_formal = formal; arg != NULL;
7290 239961 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7291 : {
7292 273837 : e = arg->expr;
7293 273837 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7294 260243 : if (e && fsym
7295 228317 : && e->expr_type == EXPR_VARIABLE
7296 100696 : && fsym->attr.intent == INTENT_OUT
7297 6492 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7298 6492 : ? CLASS_DATA (fsym)->attr.allocatable
7299 4844 : : fsym->attr.allocatable)
7300 523 : && e->symtree
7301 523 : && e->symtree->n.sym
7302 534080 : && gfc_variable_attr (e).allocatable)
7303 : {
7304 : force_eval_args = true;
7305 : break;
7306 : }
7307 : }
7308 :
7309 : /* Evaluate the arguments. */
7310 406882 : for (arg = args, argc = 0; arg != NULL;
7311 274251 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7312 : {
7313 274251 : bool finalized = false;
7314 274251 : tree derived_array = NULL_TREE;
7315 274251 : symbol_attribute *attr;
7316 :
7317 274251 : e = arg->expr;
7318 274251 : fsym = formal ? formal->sym : NULL;
7319 515149 : parm_kind = MISSING;
7320 :
7321 240898 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7322 : : fsym->attr)
7323 : : nullptr;
7324 : /* If the procedure requires an explicit interface, the actual
7325 : argument is passed according to the corresponding formal
7326 : argument. If the corresponding formal argument is a POINTER,
7327 : ALLOCATABLE or assumed shape, we do not use g77's calling
7328 : convention, and pass the address of the array descriptor
7329 : instead. Otherwise we use g77's calling convention, in other words
7330 : pass the array data pointer without descriptor. */
7331 240845 : bool nodesc_arg = fsym != NULL
7332 240845 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7333 231731 : && fsym->as
7334 41589 : && fsym->as->type != AS_ASSUMED_SHAPE
7335 24958 : && fsym->as->type != AS_ASSUMED_RANK;
7336 274251 : if (comp)
7337 2755 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7338 : else
7339 271496 : nodesc_arg
7340 : = nodesc_arg
7341 271496 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7342 :
7343 : /* Class array expressions are sometimes coming completely unadorned
7344 : with either arrayspec or _data component. Correct that here.
7345 : OOP-TODO: Move this to the frontend. */
7346 274251 : if (e && e->expr_type == EXPR_VARIABLE
7347 114821 : && !e->ref
7348 52227 : && e->ts.type == BT_CLASS
7349 2645 : && (CLASS_DATA (e)->attr.codimension
7350 2645 : || CLASS_DATA (e)->attr.dimension))
7351 : {
7352 0 : gfc_typespec temp_ts = e->ts;
7353 0 : gfc_add_class_array_ref (e);
7354 0 : e->ts = temp_ts;
7355 : }
7356 :
7357 274251 : if (e == NULL
7358 260651 : || (e->expr_type == EXPR_NULL
7359 745 : && fsym
7360 745 : && fsym->attr.value
7361 72 : && fsym->attr.optional
7362 72 : && !fsym->attr.dimension
7363 72 : && fsym->ts.type != BT_CLASS))
7364 : {
7365 13672 : if (se->ignore_optional)
7366 : {
7367 : /* Some intrinsics have already been resolved to the correct
7368 : parameters. */
7369 434 : continue;
7370 : }
7371 13474 : else if (arg->label)
7372 : {
7373 224 : has_alternate_specifier = 1;
7374 224 : continue;
7375 : }
7376 : else
7377 : {
7378 13250 : gfc_init_se (&parmse, NULL);
7379 :
7380 : /* For scalar arguments with VALUE attribute which are passed by
7381 : value, pass "0" and a hidden argument gives the optional
7382 : status. */
7383 13250 : if (fsym && fsym->attr.optional && fsym->attr.value
7384 475 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7385 : {
7386 439 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7387 : }
7388 : else
7389 : {
7390 : /* Pass a NULL pointer for an absent arg. */
7391 12811 : parmse.expr = null_pointer_node;
7392 :
7393 : /* Is it an absent character dummy? */
7394 12811 : bool absent_char = false;
7395 12811 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7396 :
7397 : /* Fall back to inferred type only if no formal. */
7398 12811 : if (fsym)
7399 11753 : absent_char = (fsym->ts.type == BT_CHARACTER);
7400 1058 : else if (dummy_arg)
7401 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7402 : == BT_CHARACTER);
7403 12811 : if (absent_char)
7404 1133 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7405 : 0);
7406 : }
7407 : }
7408 : }
7409 260579 : else if (e->expr_type == EXPR_NULL
7410 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7411 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7412 293 : && fsym->ts.type == BT_DERIVED)
7413 : {
7414 210 : gfc_init_se (&parmse, NULL);
7415 210 : gfc_conv_expr_reference (&parmse, e);
7416 210 : conv_null_actual (&parmse, e, fsym);
7417 : }
7418 260369 : else if (arg->expr->expr_type == EXPR_NULL
7419 463 : && fsym && !fsym->attr.pointer
7420 163 : && (fsym->ts.type != BT_CLASS
7421 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7422 : {
7423 : /* Pass a NULL pointer to denote an absent arg. */
7424 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7425 : && (fsym->ts.type != BT_CLASS
7426 : || !CLASS_DATA (fsym)->attr.allocatable));
7427 163 : gfc_init_se (&parmse, NULL);
7428 163 : parmse.expr = null_pointer_node;
7429 163 : if (fsym->ts.type == BT_CHARACTER)
7430 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7431 : }
7432 260206 : else if (fsym && fsym->ts.type == BT_CLASS
7433 11465 : && e->ts.type == BT_DERIVED)
7434 : {
7435 : /* The derived type needs to be converted to a temporary
7436 : CLASS object. */
7437 4778 : gfc_init_se (&parmse, se);
7438 4778 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7439 4778 : fsym->attr.optional
7440 1008 : && e->expr_type == EXPR_VARIABLE
7441 1008 : && e->symtree->n.sym->attr.optional,
7442 4778 : CLASS_DATA (fsym)->attr.class_pointer
7443 4597 : || CLASS_DATA (fsym)->attr.allocatable,
7444 : sym->name, &derived_array);
7445 : }
7446 223502 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7447 954 : && e->ts.type != BT_PROCEDURE
7448 930 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7449 930 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7450 : {
7451 : /* The intrinsic type needs to be converted to a temporary
7452 : CLASS object for the unlimited polymorphic formal. */
7453 930 : gfc_find_vtab (&e->ts);
7454 930 : gfc_init_se (&parmse, se);
7455 930 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7456 :
7457 : }
7458 254498 : else if (se->ss && se->ss->info->useflags)
7459 : {
7460 5849 : gfc_ss *ss;
7461 :
7462 5849 : ss = se->ss;
7463 :
7464 : /* An elemental function inside a scalarized loop. */
7465 5849 : gfc_init_se (&parmse, se);
7466 5849 : parm_kind = ELEMENTAL;
7467 :
7468 : /* When no fsym is present, ulim_copy is set and this is a third or
7469 : fourth argument, use call-by-value instead of by reference to
7470 : hand the length properties to the copy routine (i.e., most of the
7471 : time this will be a call to a __copy_character_* routine where the
7472 : third and fourth arguments are the lengths of a deferred length
7473 : char array). */
7474 5849 : if ((fsym && fsym->attr.value)
7475 5615 : || (ulim_copy && (argc == 2 || argc == 3)))
7476 234 : gfc_conv_expr (&parmse, e);
7477 5615 : else if (e->expr_type == EXPR_ARRAY)
7478 : {
7479 306 : gfc_conv_expr (&parmse, e);
7480 306 : if (e->ts.type != BT_CHARACTER)
7481 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7482 : }
7483 : else
7484 5309 : gfc_conv_expr_reference (&parmse, e);
7485 :
7486 5849 : if (e->ts.type == BT_CHARACTER && !e->rank
7487 174 : && e->expr_type == EXPR_FUNCTION)
7488 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7489 : parmse.expr);
7490 :
7491 5799 : if (fsym && fsym->ts.type == BT_DERIVED
7492 7477 : && gfc_is_class_container_ref (e))
7493 : {
7494 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7495 :
7496 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7497 24 : && e->symtree->n.sym->attr.optional)
7498 : {
7499 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7500 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7501 0 : TREE_TYPE (parmse.expr),
7502 : cond, parmse.expr,
7503 0 : fold_convert (TREE_TYPE (parmse.expr),
7504 : null_pointer_node));
7505 : }
7506 : }
7507 :
7508 : /* Scalar dummy arguments of intrinsic type or derived type with
7509 : VALUE attribute. */
7510 5849 : if (fsym
7511 5799 : && fsym->attr.value
7512 234 : && fsym->ts.type != BT_CLASS)
7513 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7514 :
7515 : /* If we are passing an absent array as optional dummy to an
7516 : elemental procedure, make sure that we pass NULL when the data
7517 : pointer is NULL. We need this extra conditional because of
7518 : scalarization which passes arrays elements to the procedure,
7519 : ignoring the fact that the array can be absent/unallocated/... */
7520 5615 : else if (ss->info->can_be_null_ref
7521 421 : && ss->info->type != GFC_SS_REFERENCE)
7522 : {
7523 199 : tree descriptor_data;
7524 :
7525 199 : descriptor_data = ss->info->data.array.data;
7526 199 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7527 : descriptor_data,
7528 199 : fold_convert (TREE_TYPE (descriptor_data),
7529 : null_pointer_node));
7530 199 : parmse.expr
7531 398 : = fold_build3_loc (input_location, COND_EXPR,
7532 199 : TREE_TYPE (parmse.expr),
7533 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7534 199 : fold_convert (TREE_TYPE (parmse.expr),
7535 : null_pointer_node),
7536 : parmse.expr);
7537 : }
7538 :
7539 : /* The scalarizer does not repackage the reference to a class
7540 : array - instead it returns a pointer to the data element. */
7541 5849 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7542 210 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7543 186 : fsym->attr.intent != INTENT_IN
7544 : && (CLASS_DATA (fsym)->attr.class_pointer
7545 24 : || CLASS_DATA (fsym)->attr.allocatable),
7546 186 : fsym->attr.optional
7547 0 : && e->expr_type == EXPR_VARIABLE
7548 0 : && e->symtree->n.sym->attr.optional,
7549 186 : CLASS_DATA (fsym)->attr.class_pointer
7550 186 : || CLASS_DATA (fsym)->attr.allocatable);
7551 : }
7552 : else
7553 : {
7554 248649 : bool scalar;
7555 248649 : gfc_ss *argss;
7556 :
7557 248649 : gfc_init_se (&parmse, NULL);
7558 :
7559 : /* Check whether the expression is a scalar or not; we cannot use
7560 : e->rank as it can be nonzero for functions arguments. */
7561 248649 : argss = gfc_walk_expr (e);
7562 248649 : scalar = argss == gfc_ss_terminator;
7563 248649 : if (!scalar)
7564 61381 : gfc_free_ss_chain (argss);
7565 :
7566 : /* Special handling for passing scalar polymorphic coarrays;
7567 : otherwise one passes "class->_data.data" instead of "&class". */
7568 248649 : if (e->rank == 0 && e->ts.type == BT_CLASS
7569 3599 : && fsym && fsym->ts.type == BT_CLASS
7570 3177 : && CLASS_DATA (fsym)->attr.codimension
7571 55 : && !CLASS_DATA (fsym)->attr.dimension)
7572 : {
7573 55 : gfc_add_class_array_ref (e);
7574 55 : parmse.want_coarray = 1;
7575 55 : scalar = false;
7576 : }
7577 :
7578 : /* A scalar or transformational function. */
7579 248649 : if (scalar)
7580 : {
7581 187213 : if (e->expr_type == EXPR_VARIABLE
7582 55632 : && e->symtree->n.sym->attr.cray_pointee
7583 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7584 : {
7585 : /* The Cray pointer needs to be converted to a pointer to
7586 : a type given by the expression. */
7587 6 : gfc_conv_expr (&parmse, e);
7588 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7589 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7590 6 : parmse.expr = convert (type, tmp);
7591 : }
7592 :
7593 187207 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7594 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7595 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7596 :
7597 186520 : else if (fsym && fsym->attr.value && fsym->attr.dimension)
7598 : /* Scalar actual argument sequence associated with a VALUE
7599 : array dummy. */
7600 36 : conv_seq_assoc_value_arg (&parmse, e, fsym, &mapping);
7601 :
7602 158231 : else if (fsym && fsym->attr.value)
7603 : {
7604 22148 : if (fsym->ts.type == BT_CHARACTER
7605 591 : && fsym->ts.is_c_interop
7606 181 : && fsym->ns->proc_name != NULL
7607 181 : && fsym->ns->proc_name->attr.is_bind_c)
7608 : {
7609 172 : parmse.expr = NULL;
7610 172 : conv_scalar_char_value (fsym, &parmse, &e);
7611 172 : if (parmse.expr == NULL)
7612 166 : gfc_conv_expr (&parmse, e);
7613 : }
7614 : else
7615 : {
7616 21976 : gfc_conv_expr (&parmse, e);
7617 21976 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7618 : }
7619 : }
7620 :
7621 164336 : else if (arg->name && arg->name[0] == '%')
7622 : /* Argument list functions %VAL, %LOC and %REF are signalled
7623 : through arg->name. */
7624 5826 : conv_arglist_function (&parmse, arg->expr, arg->name);
7625 158510 : else if ((e->expr_type == EXPR_FUNCTION)
7626 8305 : && ((e->value.function.esym
7627 2154 : && e->value.function.esym->result->attr.pointer)
7628 8210 : || (!e->value.function.esym
7629 6151 : && e->symtree->n.sym->attr.pointer))
7630 95 : && fsym && fsym->attr.target)
7631 : /* Make sure the function only gets called once. */
7632 8 : gfc_conv_expr_reference (&parmse, e);
7633 158502 : else if (e->expr_type == EXPR_FUNCTION
7634 8297 : && e->symtree->n.sym->result
7635 7262 : && e->symtree->n.sym->result != e->symtree->n.sym
7636 138 : && e->symtree->n.sym->result->attr.proc_pointer)
7637 : {
7638 : /* Functions returning procedure pointers. */
7639 18 : gfc_conv_expr (&parmse, e);
7640 18 : if (fsym && fsym->attr.proc_pointer)
7641 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7642 : }
7643 :
7644 : else
7645 : {
7646 158484 : bool defer_to_dealloc_blk = false;
7647 158484 : if (e->ts.type == BT_CLASS && fsym
7648 3532 : && fsym->ts.type == BT_CLASS
7649 3110 : && (!CLASS_DATA (fsym)->as
7650 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7651 2754 : && CLASS_DATA (e)->attr.codimension)
7652 : {
7653 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7654 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7655 48 : gfc_add_class_array_ref (e);
7656 48 : parmse.want_coarray = 1;
7657 48 : gfc_conv_expr_reference (&parmse, e);
7658 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7659 48 : fsym->attr.optional
7660 48 : && e->expr_type == EXPR_VARIABLE);
7661 : }
7662 158436 : else if (e->ts.type == BT_CLASS && fsym
7663 3484 : && fsym->ts.type == BT_CLASS
7664 3062 : && !CLASS_DATA (fsym)->as
7665 2706 : && !CLASS_DATA (e)->as
7666 2596 : && strcmp (fsym->ts.u.derived->name,
7667 : e->ts.u.derived->name))
7668 : {
7669 1649 : type = gfc_typenode_for_spec (&fsym->ts);
7670 1649 : var = gfc_create_var (type, fsym->name);
7671 1649 : gfc_conv_expr (&parmse, e);
7672 1649 : if (fsym->attr.optional
7673 153 : && e->expr_type == EXPR_VARIABLE
7674 153 : && e->symtree->n.sym->attr.optional)
7675 : {
7676 66 : stmtblock_t block;
7677 66 : tree cond;
7678 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7679 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7680 : logical_type_node, tmp,
7681 66 : fold_convert (TREE_TYPE (tmp),
7682 : null_pointer_node));
7683 66 : gfc_start_block (&block);
7684 66 : gfc_add_modify (&block, var,
7685 : fold_build1_loc (input_location,
7686 : VIEW_CONVERT_EXPR,
7687 : type, parmse.expr));
7688 66 : gfc_add_expr_to_block (&parmse.pre,
7689 : fold_build3_loc (input_location,
7690 : COND_EXPR, void_type_node,
7691 : cond, gfc_finish_block (&block),
7692 : build_empty_stmt (input_location)));
7693 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7694 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7695 66 : TREE_TYPE (parmse.expr),
7696 : cond, parmse.expr,
7697 66 : fold_convert (TREE_TYPE (parmse.expr),
7698 : null_pointer_node));
7699 66 : }
7700 : else
7701 : {
7702 : /* Since the internal representation of unlimited
7703 : polymorphic expressions includes an extra field
7704 : that other class objects do not, a cast to the
7705 : formal type does not work. */
7706 1583 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7707 : {
7708 91 : tree efield;
7709 :
7710 : /* Evaluate arguments just once, when they have
7711 : side effects. */
7712 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7713 : {
7714 25 : tree cldata, zero;
7715 :
7716 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7717 : &parmse.pre);
7718 :
7719 : /* Prevent memory leak, when old component
7720 : was allocated already. */
7721 25 : cldata = gfc_class_data_get (parmse.expr);
7722 25 : zero = build_int_cst (TREE_TYPE (cldata),
7723 : 0);
7724 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7725 : logical_type_node,
7726 : cldata, zero);
7727 25 : tmp = build3_v (COND_EXPR, tmp,
7728 : gfc_call_free (cldata),
7729 : build_empty_stmt (
7730 : input_location));
7731 25 : gfc_add_expr_to_block (&parmse.finalblock,
7732 : tmp);
7733 25 : gfc_add_modify (&parmse.finalblock,
7734 : cldata, zero);
7735 : }
7736 :
7737 : /* Set the _data field. */
7738 91 : tmp = gfc_class_data_get (var);
7739 91 : efield = fold_convert (TREE_TYPE (tmp),
7740 : gfc_class_data_get (parmse.expr));
7741 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7742 :
7743 : /* Set the _vptr field. */
7744 91 : tmp = gfc_class_vptr_get (var);
7745 91 : efield = fold_convert (TREE_TYPE (tmp),
7746 : gfc_class_vptr_get (parmse.expr));
7747 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7748 :
7749 : /* Set the _len field. */
7750 91 : tmp = gfc_class_len_get (var);
7751 91 : gfc_add_modify (&parmse.pre, tmp,
7752 91 : build_int_cst (TREE_TYPE (tmp), 0));
7753 91 : }
7754 : else
7755 : {
7756 1492 : tmp = fold_build1_loc (input_location,
7757 : VIEW_CONVERT_EXPR,
7758 : type, parmse.expr);
7759 1492 : gfc_add_modify (&parmse.pre, var, tmp);
7760 1583 : ;
7761 : }
7762 1583 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7763 : }
7764 : }
7765 : else
7766 : {
7767 156787 : gfc_conv_expr_reference (&parmse, e);
7768 :
7769 156787 : gfc_symbol *dsym = fsym;
7770 156787 : gfc_dummy_arg *dummy;
7771 :
7772 : /* Use associated dummy as fallback for formal
7773 : argument if there is no explicit interface. */
7774 156787 : if (dsym == NULL
7775 27441 : && (dummy = arg->associated_dummy)
7776 24901 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7777 180281 : && dummy->u.non_intrinsic->sym)
7778 156787 : dsym = dummy->u.non_intrinsic->sym;
7779 :
7780 156787 : if (dsym
7781 152840 : && dsym->attr.intent == INTENT_OUT
7782 3303 : && !dsym->attr.allocatable
7783 3160 : && !dsym->attr.pointer
7784 3142 : && e->expr_type == EXPR_VARIABLE
7785 3141 : && e->ref == NULL
7786 3026 : && e->symtree
7787 3026 : && e->symtree->n.sym
7788 3026 : && !e->symtree->n.sym->attr.dimension
7789 3026 : && e->ts.type != BT_CHARACTER
7790 2924 : && e->ts.type != BT_CLASS
7791 2688 : && (e->ts.type != BT_DERIVED
7792 492 : || (dsym->ts.type == BT_DERIVED
7793 492 : && e->ts.u.derived == dsym->ts.u.derived
7794 : /* Types with allocatable components are
7795 : excluded from clobbering because we need
7796 : the unclobbered pointers to free the
7797 : allocatable components in the callee.
7798 : Same goes for finalizable types or types
7799 : with finalizable components, we need to
7800 : pass the unclobbered values to the
7801 : finalization routines.
7802 : For parameterized types, it's less clear
7803 : but they may not have a constant size
7804 : so better exclude them in any case. */
7805 477 : && !e->ts.u.derived->attr.alloc_comp
7806 351 : && !e->ts.u.derived->attr.pdt_type
7807 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7808 2505 : && e->ts.type != BT_PROCEDURE
7809 159256 : && !sym->attr.elemental)
7810 : {
7811 1136 : tree var;
7812 1136 : var = build_fold_indirect_ref_loc (input_location,
7813 : parmse.expr);
7814 1136 : tree clobber = build_clobber (TREE_TYPE (var));
7815 1136 : gfc_add_modify (&clobbers, var, clobber);
7816 : }
7817 : }
7818 : /* Catch base objects that are not variables. */
7819 158484 : if (e->ts.type == BT_CLASS
7820 3532 : && e->expr_type != EXPR_VARIABLE
7821 306 : && expr && e == expr->base_expr)
7822 80 : base_object = build_fold_indirect_ref_loc (input_location,
7823 : parmse.expr);
7824 :
7825 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7826 : allocated on entry, it must be deallocated. */
7827 131043 : if (fsym && fsym->attr.intent == INTENT_OUT
7828 3232 : && (fsym->attr.allocatable
7829 3089 : || (fsym->ts.type == BT_CLASS
7830 265 : && CLASS_DATA (fsym)->attr.allocatable))
7831 158782 : && !is_CFI_desc (fsym, NULL))
7832 : {
7833 298 : stmtblock_t block;
7834 298 : tree ptr;
7835 :
7836 298 : defer_to_dealloc_blk = true;
7837 :
7838 298 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7839 : &parmse.pre);
7840 :
7841 298 : if (parmse.class_container != NULL_TREE)
7842 162 : parmse.class_container
7843 162 : = gfc_evaluate_data_ref_now (parmse.class_container,
7844 : &parmse.pre);
7845 :
7846 298 : gfc_init_block (&block);
7847 298 : ptr = parmse.expr;
7848 298 : if (e->ts.type == BT_CLASS)
7849 162 : ptr = gfc_class_data_get (ptr);
7850 :
7851 298 : tree cls = parmse.class_container;
7852 298 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7853 : NULL_TREE, true,
7854 : e, e->ts, cls);
7855 298 : gfc_add_expr_to_block (&block, tmp);
7856 298 : gfc_add_modify (&block, ptr,
7857 298 : fold_convert (TREE_TYPE (ptr),
7858 : null_pointer_node));
7859 :
7860 298 : if (fsym->ts.type == BT_CLASS)
7861 155 : gfc_reset_vptr (&block, nullptr,
7862 : build_fold_indirect_ref (parmse.expr),
7863 155 : fsym->ts.u.derived);
7864 :
7865 298 : if (fsym->attr.optional
7866 42 : && e->expr_type == EXPR_VARIABLE
7867 42 : && e->symtree->n.sym->attr.optional)
7868 : {
7869 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7870 : void_type_node,
7871 18 : gfc_conv_expr_present (e->symtree->n.sym),
7872 : gfc_finish_block (&block),
7873 : build_empty_stmt (input_location));
7874 : }
7875 : else
7876 280 : tmp = gfc_finish_block (&block);
7877 :
7878 298 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7879 : }
7880 :
7881 : /* A class array element needs converting back to be a
7882 : class object, if the formal argument is a class object. */
7883 158484 : if (fsym && fsym->ts.type == BT_CLASS
7884 3134 : && e->ts.type == BT_CLASS
7885 3110 : && ((CLASS_DATA (fsym)->as
7886 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7887 2754 : || CLASS_DATA (e)->attr.dimension))
7888 : {
7889 466 : gfc_se class_se = parmse;
7890 466 : gfc_init_block (&class_se.pre);
7891 466 : gfc_init_block (&class_se.post);
7892 :
7893 733 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7894 466 : fsym->attr.intent != INTENT_IN
7895 : && (CLASS_DATA (fsym)->attr.class_pointer
7896 267 : || CLASS_DATA (fsym)->attr.allocatable),
7897 466 : fsym->attr.optional
7898 198 : && e->expr_type == EXPR_VARIABLE
7899 198 : && e->symtree->n.sym->attr.optional,
7900 466 : CLASS_DATA (fsym)->attr.class_pointer
7901 430 : || CLASS_DATA (fsym)->attr.allocatable);
7902 :
7903 466 : parmse.expr = class_se.expr;
7904 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7905 466 : ? &dealloc_blk
7906 : : &parmse.pre;
7907 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7908 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7909 : }
7910 :
7911 131043 : if (fsym && (fsym->ts.type == BT_DERIVED
7912 119097 : || fsym->ts.type == BT_ASSUMED)
7913 12813 : && e->ts.type == BT_CLASS
7914 410 : && !CLASS_DATA (e)->attr.dimension
7915 374 : && !CLASS_DATA (e)->attr.codimension)
7916 : {
7917 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7918 : /* The result is a class temporary, whose _data component
7919 : must be freed to avoid a memory leak. */
7920 374 : if (e->expr_type == EXPR_FUNCTION
7921 23 : && CLASS_DATA (e)->attr.allocatable)
7922 : {
7923 19 : tree zero;
7924 :
7925 : /* Finalize the expression. */
7926 19 : gfc_finalize_tree_expr (&parmse, NULL,
7927 19 : gfc_expr_attr (e), e->rank);
7928 19 : gfc_add_block_to_block (&parmse.post,
7929 : &parmse.finalblock);
7930 :
7931 : /* Then free the class _data. */
7932 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7933 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7934 : logical_type_node,
7935 : parmse.expr, zero);
7936 19 : tmp = build3_v (COND_EXPR, tmp,
7937 : gfc_call_free (parmse.expr),
7938 : build_empty_stmt (input_location));
7939 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7940 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7941 : }
7942 : }
7943 :
7944 : /* Wrap scalar variable in a descriptor. We need to convert
7945 : the address of a pointer back to the pointer itself before,
7946 : we can assign it to the data field. */
7947 :
7948 131043 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7949 1344 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7950 : {
7951 1272 : tmp = parmse.expr;
7952 1272 : if (TREE_CODE (tmp) == ADDR_EXPR)
7953 754 : tmp = TREE_OPERAND (tmp, 0);
7954 1272 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7955 : fsym->attr);
7956 1272 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
7957 : parmse.expr);
7958 : }
7959 129771 : else if (fsym && e->expr_type != EXPR_NULL
7960 129473 : && ((fsym->attr.pointer
7961 1740 : && fsym->attr.flavor != FL_PROCEDURE)
7962 127739 : || (fsym->attr.proc_pointer
7963 199 : && !(e->expr_type == EXPR_VARIABLE
7964 199 : && e->symtree->n.sym->attr.dummy))
7965 127552 : || (fsym->attr.proc_pointer
7966 12 : && e->expr_type == EXPR_VARIABLE
7967 12 : && gfc_is_proc_ptr_comp (e))
7968 127546 : || (fsym->attr.allocatable
7969 1041 : && fsym->attr.flavor != FL_PROCEDURE)))
7970 : {
7971 : /* Scalar pointer dummy args require an extra level of
7972 : indirection. The null pointer already contains
7973 : this level of indirection. */
7974 2962 : parm_kind = SCALAR_POINTER;
7975 2962 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7976 : }
7977 : }
7978 : }
7979 61436 : else if (e->ts.type == BT_CLASS
7980 2843 : && fsym && fsym->ts.type == BT_CLASS
7981 2425 : && (CLASS_DATA (fsym)->attr.dimension
7982 55 : || CLASS_DATA (fsym)->attr.codimension))
7983 : {
7984 : /* Pass a class array. */
7985 2425 : gfc_conv_expr_descriptor (&parmse, e);
7986 2425 : bool defer_to_dealloc_blk = false;
7987 :
7988 2425 : if (fsym->attr.optional
7989 798 : && e->expr_type == EXPR_VARIABLE
7990 798 : && e->symtree->n.sym->attr.optional)
7991 : {
7992 438 : stmtblock_t block;
7993 :
7994 438 : gfc_init_block (&block);
7995 438 : gfc_add_block_to_block (&block, &parmse.pre);
7996 :
7997 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
7998 : void_type_node,
7999 438 : gfc_conv_expr_present (e->symtree->n.sym),
8000 : gfc_finish_block (&block),
8001 : build_empty_stmt (input_location));
8002 :
8003 438 : gfc_add_expr_to_block (&parmse.pre, t);
8004 : }
8005 :
8006 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8007 : allocated on entry, it must be deallocated. */
8008 2425 : if (fsym->attr.intent == INTENT_OUT
8009 153 : && CLASS_DATA (fsym)->attr.allocatable)
8010 : {
8011 122 : stmtblock_t block;
8012 122 : tree ptr;
8013 :
8014 : /* In case the data reference to deallocate is dependent on
8015 : its own content, save the resulting pointer to a variable
8016 : and only use that variable from now on, before the
8017 : expression becomes invalid. */
8018 122 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
8019 : &parmse.pre);
8020 :
8021 122 : if (parmse.class_container != NULL_TREE)
8022 122 : parmse.class_container
8023 122 : = gfc_evaluate_data_ref_now (parmse.class_container,
8024 : &parmse.pre);
8025 :
8026 122 : gfc_init_block (&block);
8027 122 : ptr = parmse.expr;
8028 122 : ptr = gfc_class_data_get (ptr);
8029 :
8030 122 : tree cls = parmse.class_container;
8031 122 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
8032 : NULL_TREE, NULL_TREE,
8033 : NULL_TREE, true, e,
8034 : GFC_CAF_COARRAY_NOCOARRAY,
8035 : cls);
8036 122 : gfc_add_expr_to_block (&block, tmp);
8037 122 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8038 : void_type_node, ptr,
8039 : null_pointer_node);
8040 122 : gfc_add_expr_to_block (&block, tmp);
8041 122 : gfc_reset_vptr (&block, e, parmse.class_container);
8042 :
8043 122 : if (fsym->attr.optional
8044 30 : && e->expr_type == EXPR_VARIABLE
8045 30 : && (!e->ref
8046 30 : || (e->ref->type == REF_ARRAY
8047 0 : && e->ref->u.ar.type != AR_FULL))
8048 0 : && e->symtree->n.sym->attr.optional)
8049 : {
8050 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
8051 : void_type_node,
8052 0 : gfc_conv_expr_present (e->symtree->n.sym),
8053 : gfc_finish_block (&block),
8054 : build_empty_stmt (input_location));
8055 : }
8056 : else
8057 122 : tmp = gfc_finish_block (&block);
8058 :
8059 122 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8060 122 : defer_to_dealloc_blk = true;
8061 : }
8062 :
8063 2425 : gfc_se class_se = parmse;
8064 2425 : gfc_init_block (&class_se.pre);
8065 2425 : gfc_init_block (&class_se.post);
8066 :
8067 2425 : if (e->expr_type != EXPR_VARIABLE)
8068 : {
8069 : int n;
8070 : /* Set the bounds and offset correctly. */
8071 60 : for (n = 0; n < e->rank; n++)
8072 30 : gfc_conv_shift_descriptor_lbound (&class_se.pre,
8073 : class_se.expr,
8074 : n, gfc_index_one_node);
8075 : }
8076 :
8077 : /* The conversion does not repackage the reference to a class
8078 : array - _data descriptor. */
8079 3852 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
8080 2425 : fsym->attr.intent != INTENT_IN
8081 : && (CLASS_DATA (fsym)->attr.class_pointer
8082 1241 : || CLASS_DATA (fsym)->attr.allocatable),
8083 2425 : fsym->attr.optional
8084 798 : && e->expr_type == EXPR_VARIABLE
8085 798 : && e->symtree->n.sym->attr.optional,
8086 2425 : CLASS_DATA (fsym)->attr.class_pointer
8087 1999 : || CLASS_DATA (fsym)->attr.allocatable);
8088 :
8089 2425 : parmse.expr = class_se.expr;
8090 2303 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
8091 2425 : ? &dealloc_blk
8092 : : &parmse.pre;
8093 2425 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
8094 2425 : gfc_add_block_to_block (&parmse.post, &class_se.post);
8095 :
8096 2425 : if (e->expr_type == EXPR_OP
8097 12 : && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
8098 2437 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
8099 : {
8100 12 : tree cond;
8101 12 : tree dealloc_expr = gfc_finish_block (&parmse.post);
8102 12 : tmp = TREE_OPERAND (parmse.expr, 0);
8103 12 : gfc_init_block (&parmse.post);
8104 12 : cond = gfc_class_data_get (tmp);
8105 12 : tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
8106 : tmp, e->rank, true);
8107 12 : gfc_add_expr_to_block (&parmse.post, tmp);
8108 12 : cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
8109 12 : cond = gfc_conv_descriptor_data_get (cond);
8110 12 : cond = fold_build2_loc (input_location, NE_EXPR,
8111 : logical_type_node, cond,
8112 12 : build_int_cst (TREE_TYPE (cond), 0));
8113 12 : tmp = build3_v (COND_EXPR, cond, dealloc_expr,
8114 : build_empty_stmt (input_location));
8115 :
8116 : /* This specific case should not be processed further and so
8117 : bundle everything up and proceed to the next argument. */
8118 12 : if (fsym && need_interface_mapping && e)
8119 12 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8120 12 : gfc_add_expr_to_block (&parmse.post, tmp);
8121 12 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8122 12 : gfc_add_block_to_block (&post, &parmse.post);
8123 12 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8124 12 : vec_safe_push (arglist, parmse.expr);
8125 12 : continue;
8126 12 : }
8127 2413 : }
8128 : else
8129 : {
8130 : /* If the argument is a function call that may not create
8131 : a temporary for the result, we have to check that we
8132 : can do it, i.e. that there is no alias between this
8133 : argument and another one. */
8134 59011 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
8135 : {
8136 406 : gfc_expr *iarg;
8137 406 : sym_intent intent;
8138 :
8139 406 : if (fsym != NULL)
8140 397 : intent = fsym->attr.intent;
8141 : else
8142 : intent = INTENT_UNKNOWN;
8143 :
8144 406 : if (gfc_check_fncall_dependency (e, intent, sym, args,
8145 : NOT_ELEMENTAL))
8146 21 : parmse.force_tmp = 1;
8147 :
8148 406 : iarg = e->value.function.actual->expr;
8149 :
8150 : /* Temporary needed if aliasing due to host association. */
8151 406 : if (sym->attr.contained
8152 168 : && !sym->attr.pure
8153 168 : && !sym->attr.implicit_pure
8154 84 : && !sym->attr.use_assoc
8155 84 : && iarg->expr_type == EXPR_VARIABLE
8156 84 : && sym->ns == iarg->symtree->n.sym->ns)
8157 36 : parmse.force_tmp = 1;
8158 :
8159 : /* Ditto within module. */
8160 406 : if (sym->attr.use_assoc
8161 6 : && !sym->attr.pure
8162 6 : && !sym->attr.implicit_pure
8163 0 : && iarg->expr_type == EXPR_VARIABLE
8164 0 : && sym->module == iarg->symtree->n.sym->module)
8165 0 : parmse.force_tmp = 1;
8166 : }
8167 :
8168 : /* Special case for assumed-rank arrays: when passing an
8169 : argument to a nonallocatable/nonpointer dummy, the bounds have
8170 : to be reset as otherwise a last-dim ubound of -1 is
8171 : indistinguishable from an assumed-size array in the callee. */
8172 59011 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
8173 35920 : && fsym->as->type == AS_ASSUMED_RANK
8174 11978 : && e->rank != -1
8175 11664 : && e->expr_type == EXPR_VARIABLE
8176 11199 : && ((fsym->ts.type == BT_CLASS
8177 0 : && !CLASS_DATA (fsym)->attr.class_pointer
8178 0 : && !CLASS_DATA (fsym)->attr.allocatable)
8179 11199 : || (fsym->ts.type != BT_CLASS
8180 11199 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
8181 : {
8182 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
8183 10656 : gfc_ref *ref;
8184 10920 : for (ref = e->ref; ref->next; ref = ref->next)
8185 : {
8186 342 : if (ref->next->type == REF_INQUIRY)
8187 : break;
8188 294 : if (ref->type == REF_ARRAY
8189 30 : && ref->u.ar.type != AR_ELEMENT)
8190 : break;
8191 10656 : };
8192 10656 : if (ref->u.ar.type == AR_FULL
8193 9906 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
8194 9786 : ref->u.ar.type = AR_SECTION;
8195 : }
8196 :
8197 59011 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
8198 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
8199 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
8200 :
8201 53161 : else if (fsym && fsym->attr.value && fsym->attr.dimension
8202 102 : && e->rank != -1)
8203 : /* VALUE array dummy: pass a private copy of the actual
8204 : argument. Allocatable components are copied deeply, so
8205 : that the callee cannot reach the actual argument's data.
8206 : The symbol passed is that of the actual argument, so that
8207 : the copy is suppressed and a null pointer passed when an
8208 : optional actual argument is absent. */
8209 102 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, INTENT_IN,
8210 : false, fsym, sym->name,
8211 102 : e->expr_type == EXPR_VARIABLE
8212 102 : ? e->symtree->n.sym : NULL,
8213 : false, true);
8214 :
8215 53059 : else if (e->expr_type == EXPR_VARIABLE
8216 41457 : && is_subref_array (e)
8217 1214 : && !(fsym && fsym->attr.pointer)
8218 54008 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8219 : /* The actual argument is a component reference to an
8220 : array of derived types. In this case, the argument
8221 : is converted to a temporary, which is passed and then
8222 : written back after the procedure call. The elements of
8223 : a span addressed dummy passed on as a whole are usually
8224 : contiguous, so the copy is made conditional. A dummy that
8225 : has a descriptor takes any stride, so for it the condition
8226 : is only that the span be the element length. */
8227 : {
8228 781 : bool whole_span = is_whole_span_addressed_dummy (e);
8229 1532 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8230 739 : fsym ? fsym->attr.intent : INTENT_INOUT,
8231 739 : fsym && fsym->attr.pointer, fsym, sym->name,
8232 : NULL, whole_span, false,
8233 : whole_span
8234 12 : && dummy_accepts_strided_arg (fsym,
8235 : nodesc_arg));
8236 : }
8237 :
8238 52278 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
8239 417 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
8240 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
8241 : /* An assumed size class actual argument being passed to
8242 : a 'no descriptor' formal argument just requires the
8243 : data pointer to be passed. For class dummy arguments
8244 : this is stored in the symbol backend decl.. */
8245 6 : parmse.expr = e->symtree->n.sym->backend_decl;
8246 :
8247 52272 : else if (gfc_is_class_array_ref (e, NULL)
8248 410 : && fsym && fsym->ts.type == BT_DERIVED
8249 52458 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8250 : /* The actual argument is a component reference to an
8251 : array of derived types. In this case, the argument
8252 : is converted to a temporary, which is passed and then
8253 : written back after the procedure call. */
8254 114 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8255 114 : fsym->attr.intent,
8256 114 : fsym->attr.pointer);
8257 :
8258 52158 : else if (gfc_is_class_array_function (e)
8259 13 : && fsym && fsym->ts.type == BT_DERIVED
8260 52171 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8261 : /* See previous comment. For function actual argument,
8262 : the write out is not needed so the intent is set as
8263 : intent in. */
8264 : {
8265 13 : e->must_finalize = 1;
8266 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8267 13 : INTENT_IN, fsym->attr.pointer);
8268 : }
8269 48564 : else if (fsym && fsym->attr.contiguous
8270 90 : && (fsym->attr.target
8271 1762 : ? gfc_is_not_contiguous (e)
8272 1672 : : !gfc_is_simply_contiguous (e, false, true))
8273 357 : && gfc_expr_is_variable (e)
8274 54252 : && e->rank != -1)
8275 : {
8276 333 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8277 333 : fsym->attr.intent,
8278 333 : fsym->attr.pointer);
8279 : }
8280 : else
8281 : {
8282 : /* Having declined copy-in/copy-out above, a subobject of an
8283 : array is described by a spanned descriptor. */
8284 51812 : if (e->expr_type == EXPR_VARIABLE && is_subref_array (e))
8285 433 : parmse.force_no_tmp = 1;
8286 :
8287 : /* This is where we introduce a temporary to store the
8288 : result of a non-lvalue array expression. */
8289 51812 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
8290 : sym->name, NULL);
8291 : }
8292 :
8293 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8294 : allocated on entry, it must be deallocated.
8295 : CFI descriptors are handled elsewhere. */
8296 55388 : if (fsym && fsym->attr.allocatable
8297 1787 : && fsym->attr.intent == INTENT_OUT
8298 58754 : && !is_CFI_desc (fsym, NULL))
8299 : {
8300 161 : if (fsym->ts.type == BT_DERIVED
8301 47 : && fsym->ts.u.derived->attr.alloc_comp)
8302 : {
8303 : // deallocate the components first
8304 11 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
8305 : parmse.expr, e->rank);
8306 : /* But check whether dummy argument is optional. */
8307 11 : if (tmp != NULL_TREE
8308 11 : && fsym->attr.optional
8309 6 : && e->expr_type == EXPR_VARIABLE
8310 6 : && e->symtree->n.sym->attr.optional)
8311 : {
8312 6 : tree present;
8313 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
8314 6 : tmp = build3_v (COND_EXPR, present, tmp,
8315 : build_empty_stmt (input_location));
8316 : }
8317 11 : if (tmp != NULL_TREE)
8318 11 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8319 : }
8320 :
8321 161 : tmp = parmse.expr;
8322 : /* With bind(C), the actual argument is replaced by a bind-C
8323 : descriptor; in this case, the data component arrives here,
8324 : which shall not be dereferenced, but still freed and
8325 : nullified. */
8326 161 : if (TREE_TYPE(tmp) != pvoid_type_node)
8327 161 : tmp = build_fold_indirect_ref_loc (input_location,
8328 : parmse.expr);
8329 161 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8330 : NULL_TREE, NULL_TREE, true,
8331 : e,
8332 : GFC_CAF_COARRAY_NOCOARRAY);
8333 161 : if (fsym->attr.optional
8334 48 : && e->expr_type == EXPR_VARIABLE
8335 48 : && e->symtree->n.sym->attr.optional)
8336 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
8337 : void_type_node,
8338 24 : gfc_conv_expr_present (e->symtree->n.sym),
8339 : tmp, build_empty_stmt (input_location));
8340 161 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8341 : }
8342 : }
8343 : }
8344 : /* Special case for an assumed-rank dummy argument. */
8345 273817 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
8346 57798 : && (fsym->ts.type == BT_CLASS
8347 57798 : ? (CLASS_DATA (fsym)->as
8348 4696 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
8349 53102 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8350 : {
8351 12815 : if (fsym->ts.type == BT_CLASS
8352 12815 : ? (CLASS_DATA (fsym)->attr.class_pointer
8353 1067 : || CLASS_DATA (fsym)->attr.allocatable)
8354 11748 : : (fsym->attr.pointer || fsym->attr.allocatable))
8355 : {
8356 : /* Unallocated allocatable arrays and unassociated pointer
8357 : arrays need their dtype setting if they are argument
8358 : associated with assumed rank dummies to set the rank. */
8359 891 : set_dtype_for_unallocated (&parmse, e);
8360 : }
8361 11924 : else if (e->expr_type == EXPR_VARIABLE
8362 11421 : && e->symtree->n.sym->attr.dummy
8363 722 : && (e->ts.type == BT_CLASS
8364 915 : ? (e->ref && e->ref->next
8365 193 : && e->ref->next->type == REF_ARRAY
8366 193 : && e->ref->next->u.ar.type == AR_FULL
8367 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8368 529 : : (e->ref && e->ref->type == REF_ARRAY
8369 529 : && e->ref->u.ar.type == AR_FULL
8370 757 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8371 : {
8372 : /* Assumed-size actual to assumed-rank dummy requires
8373 : dim[rank-1].ubound = -1. */
8374 180 : tree minus_one;
8375 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8376 180 : if (fsym->ts.type == BT_CLASS)
8377 60 : tmp = gfc_class_data_get (tmp);
8378 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8379 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8380 180 : gfc_rank_cst[e->rank - 1],
8381 : minus_one);
8382 : }
8383 : }
8384 :
8385 : /* The case with fsym->attr.optional is that of a user subroutine
8386 : with an interface indicating an optional argument. When we call
8387 : an intrinsic subroutine, however, fsym is NULL, but we might still
8388 : have an optional argument, so we proceed to the substitution
8389 : just in case. Arguments passed to bind(c) procedures via CFI
8390 : descriptors are handled elsewhere. */
8391 260639 : if (e && (fsym == NULL || fsym->attr.optional)
8392 334450 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8393 : {
8394 : /* If an optional argument is itself an optional dummy argument,
8395 : check its presence and substitute a null if absent. This is
8396 : only needed when passing an array to an elemental procedure
8397 : as then array elements are accessed - or no NULL pointer is
8398 : allowed and a "1" or "0" should be passed if not present.
8399 : When passing a non-array-descriptor full array to a
8400 : non-array-descriptor dummy, no check is needed. For
8401 : array-descriptor actual to array-descriptor dummy, see
8402 : PR 41911 for why a check has to be inserted.
8403 : fsym == NULL is checked as intrinsics required the descriptor
8404 : but do not always set fsym.
8405 : Also, it is necessary to pass a NULL pointer to library routines
8406 : which usually ignore optional arguments, so they can handle
8407 : these themselves. */
8408 59539 : if (e->expr_type == EXPR_VARIABLE
8409 26590 : && e->symtree->n.sym->attr.optional
8410 2469 : && (((e->rank != 0 && elemental_proc)
8411 2288 : || e->representation.length || e->ts.type == BT_CHARACTER
8412 2044 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8413 1934 : || (e->rank != 0
8414 1094 : && (fsym == NULL
8415 1058 : || (fsym->as
8416 296 : && (fsym->as->type == AS_ASSUMED_SHAPE
8417 241 : || fsym->as->type == AS_ASSUMED_RANK
8418 123 : || fsym->as->type == AS_DEFERRED)))))
8419 1691 : || se->ignore_optional))
8420 806 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8421 806 : e->representation.length);
8422 : }
8423 :
8424 : /* Make the class container for the first argument available with class
8425 : valued transformational functions. */
8426 273817 : if (argc == 0 && e && e->ts.type == BT_CLASS
8427 5129 : && isym && isym->transformational
8428 84 : && se->ss && se->ss->info)
8429 : {
8430 84 : arg1_cntnr = parmse.expr;
8431 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8432 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8433 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8434 84 : se->ss->info->class_container = arg1_cntnr;
8435 : }
8436 :
8437 : /* Obtain the character length of an assumed character length procedure
8438 : from the typespec of the actual argument. */
8439 273817 : if (e
8440 260639 : && parmse.string_length == NULL_TREE
8441 224915 : && e->ts.type == BT_PROCEDURE
8442 1941 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8443 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8444 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8445 : {
8446 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8447 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8448 : }
8449 :
8450 273817 : if (fsym && e)
8451 : {
8452 : /* Obtain the character length for a NULL() actual with a character
8453 : MOLD argument. Otherwise substitute a suitable dummy length.
8454 : Here we handle non-optional dummies of non-bind(c) procedures. */
8455 228713 : if (e->expr_type == EXPR_NULL
8456 745 : && fsym->ts.type == BT_CHARACTER
8457 296 : && !fsym->attr.optional
8458 228931 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8459 216 : conv_null_actual (&parmse, e, fsym);
8460 : }
8461 :
8462 : /* If any actual argument of the procedure is allocatable and passed
8463 : to an allocatable dummy with INTENT(OUT), we conservatively
8464 : evaluate actual argument expressions before deallocations are
8465 : performed and the procedure is executed. May create temporaries.
8466 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8467 260639 : if (e && fsym && force_eval_args
8468 1144 : && fsym->attr.intent != INTENT_OUT
8469 274244 : && !gfc_is_constant_expr (e))
8470 274 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8471 :
8472 273817 : if (fsym && need_interface_mapping && e)
8473 40672 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8474 :
8475 273817 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8476 273817 : gfc_add_block_to_block (&post, &parmse.post);
8477 273817 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8478 :
8479 : /* Allocated allocatable components of derived types must be
8480 : deallocated for non-variable scalars, array arguments to elemental
8481 : procedures, and array arguments with descriptor to non-elemental
8482 : procedures. As bounds information for descriptorless arrays is no
8483 : longer available here, they are dealt with in trans-array.cc
8484 : (gfc_conv_array_parameter). */
8485 260639 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8486 28823 : && e->ts.u.derived->attr.alloc_comp
8487 7701 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8488 281374 : && !expr_may_alias_variables (e, elemental_proc))
8489 : {
8490 372 : int parm_rank;
8491 : /* It is known the e returns a structure type with at least one
8492 : allocatable component. When e is a function, ensure that the
8493 : function is called once only by using a temporary variable. */
8494 372 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8495 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8496 : parmse.expr, &se->pre);
8497 :
8498 372 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8499 152 : tmp = parmse.expr;
8500 : else
8501 220 : tmp = build_fold_indirect_ref_loc (input_location,
8502 : parmse.expr);
8503 :
8504 372 : parm_rank = e->rank;
8505 372 : switch (parm_kind)
8506 : {
8507 : case (ELEMENTAL):
8508 : case (SCALAR):
8509 372 : parm_rank = 0;
8510 : break;
8511 :
8512 0 : case (SCALAR_POINTER):
8513 0 : tmp = build_fold_indirect_ref_loc (input_location,
8514 : tmp);
8515 0 : break;
8516 : }
8517 :
8518 372 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8519 : {
8520 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8521 : Therefore, class actuals can be handled correctly but derived
8522 : types passed to class formals need the _data component. */
8523 82 : tmp = gfc_class_data_get (tmp);
8524 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8525 : {
8526 56 : if (UNLIMITED_POLY (fsym))
8527 : {
8528 12 : tree type = gfc_typenode_for_spec (&e->ts);
8529 12 : type = build_pointer_type (type);
8530 12 : tmp = fold_convert (type, tmp);
8531 : }
8532 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8533 : }
8534 : }
8535 :
8536 372 : if (e->expr_type == EXPR_OP
8537 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8538 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8539 : {
8540 24 : tree local_tmp;
8541 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8542 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8543 : parm_rank, 0);
8544 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8545 : }
8546 :
8547 : /* Items of array expressions passed to a polymorphic formal arguments
8548 : create their own clean up, so prevent double free. */
8549 372 : if (!finalized && !e->must_finalize
8550 371 : && !(e->expr_type == EXPR_ARRAY && fsym
8551 86 : && fsym->ts.type == BT_CLASS))
8552 : {
8553 351 : bool scalar_res_outside_loop;
8554 1041 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8555 151 : && parm_rank == 0
8556 490 : && parmse.loop;
8557 :
8558 : /* Scalars passed to an assumed rank argument are converted to
8559 : a descriptor. Obtain the data field before deallocating any
8560 : allocatable components. */
8561 298 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8562 612 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8563 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8564 :
8565 351 : if (scalar_res_outside_loop)
8566 : {
8567 : /* Go through the ss chain to find the argument and use
8568 : the stored value. */
8569 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8570 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8571 60 : if (tmp_ss->info
8572 48 : && tmp_ss->info->expr == e
8573 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8574 : {
8575 18 : tmp = tmp_ss->info->data.scalar.value;
8576 18 : break;
8577 : }
8578 : }
8579 :
8580 351 : STRIP_NOPS (tmp);
8581 :
8582 351 : if (derived_array != NULL_TREE)
8583 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8584 : derived_array,
8585 : parm_rank);
8586 351 : else if ((e->ts.type == BT_CLASS
8587 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8588 351 : || e->ts.type == BT_DERIVED)
8589 351 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8590 : parm_rank, 0, true);
8591 0 : else if (e->ts.type == BT_CLASS)
8592 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8593 : tmp, parm_rank);
8594 :
8595 351 : if (scalar_res_outside_loop)
8596 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8597 : else
8598 321 : gfc_prepend_expr_to_block (&post, tmp);
8599 : }
8600 : }
8601 :
8602 : /* Add argument checking of passing an unallocated/NULL actual to
8603 : a nonallocatable/nonpointer dummy. */
8604 :
8605 273817 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8606 : {
8607 6546 : symbol_attribute attr;
8608 6546 : char *msg;
8609 6546 : tree cond;
8610 6546 : tree tmp;
8611 6546 : symbol_attribute fsym_attr;
8612 :
8613 6546 : if (fsym)
8614 : {
8615 6385 : if (fsym->ts.type == BT_CLASS)
8616 : {
8617 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8618 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8619 : }
8620 : else
8621 6064 : fsym_attr = fsym->attr;
8622 : }
8623 :
8624 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8625 4094 : attr = gfc_expr_attr (e);
8626 : else
8627 6081 : goto end_pointer_check;
8628 :
8629 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8630 : allocatable to an optional dummy, cf. 12.5.2.12. */
8631 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8632 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8633 1032 : goto end_pointer_check;
8634 :
8635 3062 : if (attr.optional)
8636 : {
8637 : /* If the actual argument is an optional pointer/allocatable and
8638 : the formal argument takes an nonpointer optional value,
8639 : it is invalid to pass a non-present argument on, even
8640 : though there is no technical reason for this in gfortran.
8641 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8642 96 : tree present, null_ptr, type;
8643 :
8644 96 : if (attr.allocatable
8645 12 : && (fsym == NULL || !fsym_attr.allocatable))
8646 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8647 : "allocated or not present",
8648 0 : e->symtree->n.sym->name);
8649 96 : else if (attr.pointer
8650 24 : && (fsym == NULL || !fsym_attr.pointer))
8651 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8652 : "associated or not present",
8653 12 : e->symtree->n.sym->name);
8654 84 : else if (attr.proc_pointer && !e->value.function.actual
8655 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8656 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8657 : "associated or not present",
8658 0 : e->symtree->n.sym->name);
8659 : else
8660 84 : goto end_pointer_check;
8661 :
8662 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8663 12 : type = TREE_TYPE (present);
8664 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8665 : logical_type_node, present,
8666 : fold_convert (type,
8667 : null_pointer_node));
8668 12 : type = TREE_TYPE (parmse.expr);
8669 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8670 : logical_type_node, parmse.expr,
8671 : fold_convert (type,
8672 : null_pointer_node));
8673 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8674 : logical_type_node, present, null_ptr);
8675 : }
8676 : else
8677 : {
8678 2966 : if (attr.allocatable
8679 244 : && (fsym == NULL || !fsym_attr.allocatable))
8680 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8681 190 : "allocated", e->symtree->n.sym->name);
8682 2776 : else if (attr.pointer
8683 260 : && (fsym == NULL || !fsym_attr.pointer))
8684 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8685 184 : "associated", e->symtree->n.sym->name);
8686 2592 : else if (attr.proc_pointer && !e->value.function.actual
8687 80 : && (fsym == NULL
8688 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8689 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8690 79 : "associated", e->symtree->n.sym->name);
8691 : else
8692 2513 : goto end_pointer_check;
8693 :
8694 453 : tmp = parmse.expr;
8695 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8696 : {
8697 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8698 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8699 76 : tmp = gfc_class_data_get (tmp);
8700 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8701 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8702 : }
8703 :
8704 : /* If the argument is passed by value, we need to strip the
8705 : INDIRECT_REF. */
8706 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8707 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8708 :
8709 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8710 : logical_type_node, tmp,
8711 453 : fold_convert (TREE_TYPE (tmp),
8712 : null_pointer_node));
8713 : }
8714 :
8715 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8716 : msg);
8717 465 : free (msg);
8718 : }
8719 267271 : end_pointer_check:
8720 :
8721 : /* Deferred length dummies pass the character length by reference
8722 : so that the value can be returned. */
8723 273817 : if (parmse.string_length && fsym && fsym->ts.deferred)
8724 : {
8725 795 : if (INDIRECT_REF_P (parmse.string_length))
8726 : {
8727 : /* In chains of functions/procedure calls the string_length already
8728 : is a pointer to the variable holding the length. Therefore
8729 : remove the deref on call. */
8730 90 : tmp = parmse.string_length;
8731 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8732 : }
8733 : else
8734 : {
8735 705 : tmp = parmse.string_length;
8736 705 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8737 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8738 705 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8739 : }
8740 :
8741 795 : if (e && e->expr_type == EXPR_VARIABLE
8742 638 : && fsym->attr.allocatable
8743 368 : && e->ts.u.cl->backend_decl
8744 368 : && VAR_P (e->ts.u.cl->backend_decl))
8745 : {
8746 284 : if (INDIRECT_REF_P (tmp))
8747 0 : tmp = TREE_OPERAND (tmp, 0);
8748 284 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8749 : fold_convert (gfc_charlen_type_node, tmp));
8750 : }
8751 : }
8752 :
8753 : /* Character strings are passed as two parameters, a length and a
8754 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8755 : An unlimited polymorphic formal argument likewise does not
8756 : need the length. */
8757 273817 : if (parmse.string_length != NULL_TREE
8758 37152 : && !sym->attr.is_bind_c
8759 36456 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8760 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8761 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8762 30571 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8763 30462 : && !(fsym && UNLIMITED_POLY (fsym)))
8764 36166 : vec_safe_push (stringargs, parmse.string_length);
8765 :
8766 : /* When calling __copy for character expressions to unlimited
8767 : polymorphic entities, the dst argument needs a string length. */
8768 52056 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8769 5326 : && startswith (sym->name, "__vtab_CHARACTER")
8770 0 : && arg->next && arg->next->expr
8771 0 : && (arg->next->expr->ts.type == BT_DERIVED
8772 0 : || arg->next->expr->ts.type == BT_CLASS)
8773 273817 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8774 0 : vec_safe_push (stringargs, parmse.string_length);
8775 :
8776 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8777 : pass the token and the offset as additional arguments. */
8778 273817 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8779 144 : && attr->codimension && !attr->allocatable)
8780 : {
8781 : /* Token and offset. */
8782 5 : vec_safe_push (stringargs, null_pointer_node);
8783 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8784 5 : gcc_assert (fsym->attr.optional);
8785 : }
8786 240828 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8787 145 : && !attr->allocatable)
8788 : {
8789 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8790 123 : tree offset, tmp2;
8791 :
8792 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8793 123 : caf_type = TREE_TYPE (caf_decl);
8794 123 : if (POINTER_TYPE_P (caf_type)
8795 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8796 3 : caf_desc = TREE_TYPE (caf_type);
8797 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8798 : caf_desc = caf_type;
8799 :
8800 51 : if (caf_desc
8801 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8802 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8803 : {
8804 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8805 54 : ? build_fold_indirect_ref (caf_decl)
8806 : : caf_decl;
8807 51 : tmp = gfc_conv_descriptor_token (tmp);
8808 : }
8809 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8810 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8811 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8812 : else
8813 : {
8814 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8815 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8816 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8817 : }
8818 :
8819 123 : vec_safe_push (stringargs, tmp);
8820 :
8821 123 : if (caf_desc
8822 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8823 51 : offset = build_int_cst (gfc_array_index_type, 0);
8824 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8825 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8826 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8827 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8828 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8829 : else
8830 60 : offset = build_int_cst (gfc_array_index_type, 0);
8831 :
8832 123 : if (caf_desc)
8833 : {
8834 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8835 54 : ? build_fold_indirect_ref (caf_decl)
8836 : : caf_decl;
8837 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8838 : }
8839 : else
8840 : {
8841 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8842 72 : tmp = caf_decl;
8843 : }
8844 :
8845 108 : tmp2 = fsym->ts.type == BT_CLASS
8846 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8847 123 : if ((fsym->ts.type != BT_CLASS
8848 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8849 59 : || fsym->as->type == AS_ASSUMED_RANK))
8850 74 : || (fsym->ts.type == BT_CLASS
8851 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8852 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8853 : {
8854 54 : if (fsym->ts.type == BT_CLASS)
8855 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8856 : else
8857 : {
8858 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8859 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8860 : }
8861 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8862 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8863 : }
8864 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8865 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8866 : else
8867 : {
8868 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8869 : }
8870 :
8871 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8872 : gfc_array_index_type,
8873 : fold_convert (gfc_array_index_type, tmp2),
8874 : fold_convert (gfc_array_index_type, tmp));
8875 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8876 : gfc_array_index_type, offset, tmp);
8877 :
8878 123 : vec_safe_push (stringargs, offset);
8879 : }
8880 :
8881 273817 : vec_safe_push (arglist, parmse.expr);
8882 : }
8883 :
8884 132631 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8885 132631 : gfc_add_block_to_block (&se->pre, &clobbers);
8886 132631 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8887 :
8888 132631 : if (comp)
8889 2000 : ts = comp->ts;
8890 130631 : else if (sym->ts.type == BT_CLASS)
8891 863 : ts = CLASS_DATA (sym)->ts;
8892 : else
8893 129768 : ts = sym->ts;
8894 :
8895 132631 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8896 210 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8897 132421 : else if (ts.type == BT_CHARACTER)
8898 : {
8899 5046 : if (ts.u.cl->length == NULL)
8900 : {
8901 : /* Assumed character length results are not allowed by C418 of the 2003
8902 : standard and are trapped in resolve.cc; except in the case of SPREAD
8903 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8904 : we take the character length of the first argument for the result.
8905 : For dummies, we have to look through the formal argument list for
8906 : this function and use the character length found there.
8907 : Likewise, we handle the case of deferred-length character dummy
8908 : arguments to intrinsics that determine the characteristics of
8909 : the result, which cannot be deferred-length. */
8910 2315 : if (expr->value.function.isym)
8911 1703 : ts.deferred = false;
8912 2315 : if (ts.deferred)
8913 605 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8914 1710 : else if (!sym->attr.dummy)
8915 1703 : cl.backend_decl = (*stringargs)[0];
8916 : else
8917 : {
8918 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8919 26 : for (; formal; formal = formal->next)
8920 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8921 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8922 : }
8923 : len = cl.backend_decl;
8924 : }
8925 : else
8926 : {
8927 2731 : tree tmp;
8928 :
8929 : /* Calculate the length of the returned string. */
8930 2731 : gfc_init_se (&parmse, NULL);
8931 2731 : if (need_interface_mapping)
8932 1885 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8933 : else
8934 846 : gfc_conv_expr (&parmse, ts.u.cl->length);
8935 2731 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8936 2731 : gfc_add_block_to_block (&se->post, &parmse.post);
8937 2731 : tmp = parmse.expr;
8938 : /* TODO: It would be better to have the charlens as
8939 : gfc_charlen_type_node already when the interface is
8940 : created instead of converting it here (see PR 84615). */
8941 2731 : tmp = fold_build2_loc (input_location, MAX_EXPR,
8942 : gfc_charlen_type_node,
8943 : fold_convert (gfc_charlen_type_node, tmp),
8944 : build_zero_cst (gfc_charlen_type_node));
8945 2731 : cl.backend_decl = tmp;
8946 :
8947 : /* The length was fully computed above from the specification
8948 : expression, without needing the callee to actually run. */
8949 2731 : call_needed_for_length = false;
8950 : }
8951 :
8952 : /* Set up a charlen structure for it. */
8953 5046 : cl.next = NULL;
8954 5046 : cl.length = NULL;
8955 5046 : ts.u.cl = &cl;
8956 :
8957 5046 : len = cl.backend_decl;
8958 : }
8959 :
8960 2000 : byref = (comp && (comp->attr.dimension
8961 1931 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
8962 132631 : || (!comp && gfc_return_by_reference (sym));
8963 :
8964 : if (byref)
8965 : {
8966 18835 : if (se->direct_byref)
8967 : {
8968 : /* Sometimes, too much indirection can be applied; e.g. for
8969 : function_result = array_valued_recursive_function. */
8970 6993 : if (TREE_TYPE (TREE_TYPE (se->expr))
8971 6993 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
8972 7011 : && GFC_DESCRIPTOR_TYPE_P
8973 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
8974 18 : se->expr = build_fold_indirect_ref_loc (input_location,
8975 : se->expr);
8976 :
8977 : /* If the lhs of an assignment x = f(..) is allocatable and
8978 : f2003 is allowed, we must do the automatic reallocation.
8979 : TODO - deal with intrinsics, without using a temporary. */
8980 6993 : if (flag_realloc_lhs
8981 6918 : && se->ss && se->ss->loop_chain
8982 203 : && se->ss->loop_chain->is_alloc_lhs
8983 203 : && !expr->value.function.isym
8984 203 : && sym->result->as != NULL)
8985 : {
8986 : /* Evaluate the bounds of the result, if known. */
8987 203 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
8988 : sym->result->as);
8989 :
8990 : /* Perform the automatic reallocation. */
8991 203 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
8992 : expr, NULL);
8993 203 : gfc_add_expr_to_block (&se->pre, tmp);
8994 :
8995 : /* Pass the temporary as the first argument. */
8996 203 : result = info->descriptor;
8997 : }
8998 : else
8999 6790 : result = build_fold_indirect_ref_loc (input_location,
9000 : se->expr);
9001 6993 : vec_safe_push (retargs, se->expr);
9002 : }
9003 11842 : else if (comp && comp->attr.dimension)
9004 : {
9005 66 : gcc_assert (se->loop && info);
9006 :
9007 : /* Set the type of the array. vtable charlens are not always reliable.
9008 : Use the interface, if possible. */
9009 66 : if (comp->ts.type == BT_CHARACTER
9010 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
9011 1 : && comp->ts.interface && comp->ts.interface->result)
9012 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
9013 : else
9014 65 : tmp = gfc_typenode_for_spec (&comp->ts);
9015 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
9016 :
9017 : /* Evaluate the bounds of the result, if known. */
9018 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
9019 :
9020 : /* If the lhs of an assignment x = f(..) is allocatable and
9021 : f2003 is allowed, we must not generate the function call
9022 : here but should just send back the results of the mapping.
9023 : This is signalled by the function ss being flagged. */
9024 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
9025 : {
9026 0 : gfc_free_interface_mapping (&mapping);
9027 0 : return has_alternate_specifier;
9028 : }
9029 :
9030 : /* Create a temporary to store the result. In case the function
9031 : returns a pointer, the temporary will be a shallow copy and
9032 : mustn't be deallocated. */
9033 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
9034 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
9035 : tmp, NULL_TREE, false,
9036 : !comp->attr.pointer, callee_alloc,
9037 66 : &se->ss->info->expr->where);
9038 :
9039 : /* Pass the temporary as the first argument. */
9040 66 : result = info->descriptor;
9041 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
9042 66 : vec_safe_push (retargs, tmp);
9043 : }
9044 11547 : else if (!comp && sym->result->attr.dimension)
9045 : {
9046 8492 : gcc_assert (se->loop && info);
9047 :
9048 : /* Set the type of the array. */
9049 8492 : tmp = gfc_typenode_for_spec (&ts);
9050 8492 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
9051 8492 : gcc_assert (se->ss->dimen == se->loop->dimen);
9052 :
9053 : /* Evaluate the bounds of the result, if known. */
9054 8492 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
9055 :
9056 : /* If the lhs of an assignment x = f(..) is allocatable and
9057 : f2003 is allowed, we must not generate the function call
9058 : here but should just send back the results of the mapping.
9059 : This is signalled by the function ss being flagged. */
9060 8492 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
9061 : {
9062 0 : gfc_free_interface_mapping (&mapping);
9063 0 : return has_alternate_specifier;
9064 : }
9065 :
9066 : /* Create a temporary to store the result. In case the function
9067 : returns a pointer, the temporary will be a shallow copy and
9068 : mustn't be deallocated. */
9069 8492 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
9070 8492 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
9071 : tmp, NULL_TREE, false,
9072 : !sym->attr.pointer, callee_alloc,
9073 8492 : &se->ss->info->expr->where);
9074 :
9075 : /* Pass the temporary as the first argument. */
9076 8492 : result = info->descriptor;
9077 8492 : tmp = gfc_build_addr_expr (NULL_TREE, result);
9078 8492 : vec_safe_push (retargs, tmp);
9079 : }
9080 3284 : else if (ts.type == BT_CHARACTER)
9081 : {
9082 : /* Pass the string length. */
9083 3223 : type = gfc_get_character_type (ts.kind, ts.u.cl);
9084 3223 : type = build_pointer_type (type);
9085 :
9086 : /* Emit a DECL_EXPR for the VLA type. */
9087 3223 : tmp = TREE_TYPE (type);
9088 3223 : if (TYPE_SIZE (tmp)
9089 3223 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
9090 : {
9091 1935 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
9092 1935 : DECL_ARTIFICIAL (tmp) = 1;
9093 1935 : DECL_IGNORED_P (tmp) = 1;
9094 1935 : tmp = fold_build1_loc (input_location, DECL_EXPR,
9095 1935 : TREE_TYPE (tmp), tmp);
9096 1935 : gfc_add_expr_to_block (&se->pre, tmp);
9097 : }
9098 :
9099 : /* Return an address to a char[0:len-1]* temporary for
9100 : character pointers. */
9101 3223 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9102 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9103 : {
9104 648 : var = gfc_create_var (type, "pstr");
9105 :
9106 648 : if ((!comp && sym->attr.allocatable)
9107 21 : || (comp && comp->attr.allocatable))
9108 : {
9109 361 : gfc_add_modify (&se->pre, var,
9110 361 : fold_convert (TREE_TYPE (var),
9111 : null_pointer_node));
9112 361 : tmp = gfc_call_free (var);
9113 361 : gfc_add_expr_to_block (&se->post, tmp);
9114 : }
9115 :
9116 : /* Provide an address expression for the function arguments. */
9117 648 : var = gfc_build_addr_expr (NULL_TREE, var);
9118 : }
9119 : else
9120 2575 : var = gfc_conv_string_tmp (se, type, len);
9121 :
9122 3223 : vec_safe_push (retargs, var);
9123 : }
9124 : else
9125 : {
9126 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
9127 :
9128 61 : type = gfc_get_complex_type (ts.kind);
9129 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
9130 61 : vec_safe_push (retargs, var);
9131 : }
9132 :
9133 : /* Add the string length to the argument list. */
9134 18835 : if (ts.type == BT_CHARACTER && ts.deferred)
9135 : {
9136 605 : tmp = len;
9137 605 : if (!VAR_P (tmp))
9138 0 : tmp = gfc_evaluate_now (len, &se->pre);
9139 605 : TREE_STATIC (tmp) = 1;
9140 605 : gfc_add_modify (&se->pre, tmp,
9141 605 : build_int_cst (TREE_TYPE (tmp), 0));
9142 605 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
9143 605 : vec_safe_push (retargs, tmp);
9144 : }
9145 18230 : else if (ts.type == BT_CHARACTER)
9146 4441 : vec_safe_push (retargs, len);
9147 : }
9148 :
9149 132631 : gfc_free_interface_mapping (&mapping);
9150 :
9151 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
9152 246819 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
9153 158204 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
9154 132631 : vec_safe_reserve (retargs, arglen);
9155 :
9156 : /* Add the return arguments. */
9157 132631 : vec_safe_splice (retargs, arglist);
9158 :
9159 : /* Add the hidden present status for optional+value to the arguments. */
9160 132631 : vec_safe_splice (retargs, optionalargs);
9161 :
9162 : /* Add the hidden string length parameters to the arguments. */
9163 132631 : vec_safe_splice (retargs, stringargs);
9164 :
9165 : /* We may want to append extra arguments here. This is used e.g. for
9166 : calls to libgfortran_matmul_??, which need extra information. */
9167 132631 : vec_safe_splice (retargs, append_args);
9168 :
9169 132631 : arglist = retargs;
9170 :
9171 : /* Generate the actual call. */
9172 132631 : is_builtin = false;
9173 132631 : if (base_object == NULL_TREE)
9174 132551 : conv_function_val (se, &is_builtin, sym, expr, args);
9175 : else
9176 80 : conv_base_obj_fcn_val (se, base_object, expr);
9177 :
9178 : /* If there are alternate return labels, function type should be
9179 : integer. Can't modify the type in place though, since it can be shared
9180 : with other functions. For dummy arguments, the typing is done to
9181 : this result, even if it has to be repeated for each call. */
9182 132631 : if (has_alternate_specifier
9183 132631 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
9184 : {
9185 7 : if (!sym->attr.dummy)
9186 : {
9187 0 : TREE_TYPE (sym->backend_decl)
9188 0 : = build_function_type (integer_type_node,
9189 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
9190 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
9191 : }
9192 : else
9193 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
9194 : }
9195 :
9196 132631 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
9197 132631 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
9198 :
9199 132631 : if (is_builtin)
9200 567 : se->expr = update_builtin_function (se->expr, sym);
9201 :
9202 : /* Allocatable scalar function results must be freed and nullified
9203 : after use. This necessitates the creation of a temporary to
9204 : hold the result to prevent duplicate calls. */
9205 132631 : symbol_attribute attr = comp ? comp->attr : sym->attr;
9206 132631 : bool allocatable = attr.allocatable && !attr.dimension;
9207 136007 : gfc_symbol *der = comp ?
9208 2000 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
9209 : :
9210 130631 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
9211 3376 : bool finalizable = der != NULL && der->ns->proc_name
9212 6749 : && gfc_is_finalizable (der, NULL);
9213 :
9214 132631 : if (!byref && finalizable)
9215 188 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9216 :
9217 132631 : if (!byref && sym->ts.type != BT_CHARACTER
9218 113586 : && allocatable && !finalizable)
9219 : {
9220 236 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
9221 236 : gfc_add_modify (&se->pre, tmp, se->expr);
9222 236 : se->expr = tmp;
9223 236 : tmp = gfc_call_free (tmp);
9224 236 : gfc_add_expr_to_block (&post, tmp);
9225 236 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
9226 : }
9227 :
9228 : /* If we have a pointer function, but we don't want a pointer, e.g.
9229 : something like
9230 : x = f()
9231 : where f is pointer valued, we have to dereference the result. */
9232 132631 : if (!se->want_pointer && !byref
9233 113194 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9234 1658 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
9235 462 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9236 :
9237 : /* f2c calling conventions require a scalar default real function to
9238 : return a double precision result. Convert this back to default
9239 : real. We only care about the cases that can happen in Fortran 77.
9240 : */
9241 132631 : if (flag_f2c && sym->ts.type == BT_REAL
9242 98 : && sym->ts.kind == gfc_default_real_kind
9243 74 : && !sym->attr.pointer
9244 55 : && !sym->attr.allocatable
9245 43 : && !sym->attr.always_explicit)
9246 43 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
9247 :
9248 : /* A pure function may still have side-effects - it may modify its
9249 : parameters. */
9250 132631 : TREE_SIDE_EFFECTS (se->expr) = 1;
9251 : #if 0
9252 : if (!sym->attr.pure)
9253 : TREE_SIDE_EFFECTS (se->expr) = 1;
9254 : #endif
9255 :
9256 132631 : if (byref)
9257 : {
9258 : /* Add the function call to the pre chain. There is no expression. */
9259 18835 : if (!se->no_function_call || call_needed_for_length)
9260 18803 : gfc_add_expr_to_block (&se->pre, se->expr);
9261 :
9262 18835 : se->expr = NULL_TREE;
9263 :
9264 18835 : if (!se->direct_byref)
9265 : {
9266 11842 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
9267 : {
9268 8558 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
9269 : {
9270 : /* Check the data pointer hasn't been modified. This would
9271 : happen in a function returning a pointer. */
9272 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9273 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
9274 : logical_type_node,
9275 : tmp, info->data);
9276 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
9277 : gfc_msg_fault);
9278 : }
9279 8558 : se->expr = info->descriptor;
9280 : /* Bundle in the string length. */
9281 8558 : se->string_length = len;
9282 :
9283 8558 : if (finalizable)
9284 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9285 : }
9286 3284 : else if (ts.type == BT_CHARACTER)
9287 : {
9288 : /* Dereference for character pointer results. */
9289 3223 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9290 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9291 648 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9292 : else
9293 2575 : se->expr = var;
9294 :
9295 3223 : se->string_length = len;
9296 : }
9297 : else
9298 : {
9299 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
9300 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9301 : }
9302 : }
9303 : }
9304 :
9305 : /* Associate the rhs class object's meta-data with the result, when the
9306 : result is a temporary. */
9307 114193 : if (args && args->expr && args->expr->ts.type == BT_CLASS
9308 5141 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
9309 132663 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
9310 : {
9311 32 : gfc_se parmse;
9312 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
9313 :
9314 32 : gfc_init_se (&parmse, NULL);
9315 32 : parmse.data_not_needed = 1;
9316 32 : gfc_conv_expr (&parmse, class_expr);
9317 32 : if (!DECL_LANG_SPECIFIC (result))
9318 32 : gfc_allocate_lang_decl (result);
9319 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
9320 32 : gfc_free_expr (class_expr);
9321 : /* -fcheck= can add diagnostic code, which has to be placed before
9322 : the call. */
9323 32 : if (parmse.pre.head != NULL)
9324 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
9325 32 : gcc_assert (parmse.post.head == NULL_TREE);
9326 : }
9327 :
9328 : /* Follow the function call with the argument post block. */
9329 132631 : if (byref)
9330 : {
9331 : /* Transformational functions of derived types with allocatable
9332 : components must have the result allocatable components copied
9333 : BEFORE the argument post block is appended. Copying the result
9334 : first, then freeing the argument, gives the correct order. */
9335 18835 : arg = expr->value.function.actual;
9336 18835 : if (result && arg && expr->rank
9337 14704 : && isym && isym->transformational
9338 13123 : && isym->id != GFC_ISYM_REDUCE
9339 12997 : && arg->expr
9340 12937 : && arg->expr->ts.type == BT_DERIVED
9341 241 : && arg->expr->ts.u.derived->attr.alloc_comp)
9342 : {
9343 48 : tree tmp2;
9344 : /* Copy the allocatable components. We have to use a
9345 : temporary here to prevent source allocatable components
9346 : from being corrupted. */
9347 48 : tmp2 = gfc_evaluate_now (result, &se->pre);
9348 48 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
9349 : result, tmp2, expr->rank, 0);
9350 48 : gfc_add_expr_to_block (&se->pre, tmp);
9351 48 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
9352 : expr->rank);
9353 48 : gfc_add_expr_to_block (&se->pre, tmp);
9354 :
9355 : /* Finally free the temporary's data field. */
9356 48 : tmp = gfc_conv_descriptor_data_get (tmp2);
9357 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9358 : NULL_TREE, NULL_TREE, true,
9359 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9360 48 : gfc_add_expr_to_block (&se->pre, tmp);
9361 : }
9362 :
9363 18835 : gfc_add_block_to_block (&se->pre, &post);
9364 : }
9365 : else
9366 : {
9367 : /* For a function with a class array result, save the result as
9368 : a temporary, set the info fields needed by the scalarizer and
9369 : call the finalization function of the temporary. Note that the
9370 : nullification of allocatable components needed by the result
9371 : is done in gfc_trans_assignment_1. */
9372 35527 : if (expr && (gfc_is_class_array_function (expr)
9373 35205 : || gfc_is_alloc_class_scalar_function (expr))
9374 853 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9375 114637 : && expr->must_finalize)
9376 : {
9377 : /* TODO Eliminate the doubling of temporaries. This
9378 : one is necessary to ensure no memory leakage. */
9379 333 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9380 :
9381 : /* Finalize the result, if necessary. */
9382 666 : attr = expr->value.function.esym
9383 333 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9384 14 : : CLASS_DATA (expr)->attr;
9385 333 : if (!((gfc_is_class_array_function (expr)
9386 120 : || gfc_is_alloc_class_scalar_function (expr))
9387 333 : && attr.pointer))
9388 288 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9389 : }
9390 113796 : gfc_add_block_to_block (&se->post, &post);
9391 : }
9392 :
9393 : return has_alternate_specifier;
9394 : }
9395 :
9396 :
9397 : /* Fill a character string with spaces. */
9398 :
9399 : static tree
9400 31164 : fill_with_spaces (tree start, tree type, tree size)
9401 : {
9402 31164 : stmtblock_t block, loop;
9403 31164 : tree i, el, exit_label, cond, tmp;
9404 :
9405 : /* For a simple char type, we can call memset(). */
9406 31164 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9407 51680 : return build_call_expr_loc (input_location,
9408 : builtin_decl_explicit (BUILT_IN_MEMSET),
9409 : 3, start,
9410 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9411 25840 : lang_hooks.to_target_charset (' ')),
9412 : fold_convert (size_type_node, size));
9413 :
9414 : /* Otherwise, we use a loop:
9415 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9416 : *el = (type) ' ';
9417 : */
9418 :
9419 : /* Initialize variables. */
9420 5324 : gfc_init_block (&block);
9421 5324 : i = gfc_create_var (sizetype, "i");
9422 5324 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9423 5324 : el = gfc_create_var (build_pointer_type (type), "el");
9424 5324 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9425 5324 : exit_label = gfc_build_label_decl (NULL_TREE);
9426 5324 : TREE_USED (exit_label) = 1;
9427 :
9428 :
9429 : /* Loop body. */
9430 5324 : gfc_init_block (&loop);
9431 :
9432 : /* Exit condition. */
9433 5324 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9434 : build_zero_cst (sizetype));
9435 5324 : tmp = build1_v (GOTO_EXPR, exit_label);
9436 5324 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9437 : build_empty_stmt (input_location));
9438 5324 : gfc_add_expr_to_block (&loop, tmp);
9439 :
9440 : /* Assignment. */
9441 5324 : gfc_add_modify (&loop,
9442 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9443 5324 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9444 :
9445 : /* Increment loop variables. */
9446 5324 : gfc_add_modify (&loop, i,
9447 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9448 5324 : TYPE_SIZE_UNIT (type)));
9449 5324 : gfc_add_modify (&loop, el,
9450 : fold_build_pointer_plus_loc (input_location,
9451 5324 : el, TYPE_SIZE_UNIT (type)));
9452 :
9453 : /* Making the loop... actually loop! */
9454 5324 : tmp = gfc_finish_block (&loop);
9455 5324 : tmp = build1_v (LOOP_EXPR, tmp);
9456 5324 : gfc_add_expr_to_block (&block, tmp);
9457 :
9458 : /* The exit label. */
9459 5324 : tmp = build1_v (LABEL_EXPR, exit_label);
9460 5324 : gfc_add_expr_to_block (&block, tmp);
9461 :
9462 :
9463 5324 : return gfc_finish_block (&block);
9464 : }
9465 :
9466 :
9467 : /* Generate code to copy a string. */
9468 :
9469 : void
9470 36399 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9471 : int dkind, tree slength, tree src, int skind)
9472 : {
9473 36399 : tree tmp, dlen, slen;
9474 36399 : tree dsc;
9475 36399 : tree ssc;
9476 36399 : tree cond;
9477 36399 : tree cond2;
9478 36399 : tree tmp2;
9479 36399 : tree tmp3;
9480 36399 : tree tmp4;
9481 36399 : tree chartype;
9482 36399 : stmtblock_t tempblock;
9483 :
9484 36399 : gcc_assert (dkind == skind);
9485 :
9486 36399 : if (slength != NULL_TREE)
9487 : {
9488 36399 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9489 36399 : ssc = gfc_string_to_single_character (slen, src, skind);
9490 : }
9491 : else
9492 : {
9493 0 : slen = build_one_cst (gfc_charlen_type_node);
9494 0 : ssc = src;
9495 : }
9496 :
9497 36399 : if (dlength != NULL_TREE)
9498 : {
9499 36399 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9500 36399 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9501 : }
9502 : else
9503 : {
9504 0 : dlen = build_one_cst (gfc_charlen_type_node);
9505 0 : dsc = dest;
9506 : }
9507 :
9508 : /* Assign directly if the types are compatible. */
9509 36399 : if (dsc != NULL_TREE && ssc != NULL_TREE
9510 36399 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9511 : {
9512 5235 : gfc_add_modify (block, dsc, ssc);
9513 5235 : return;
9514 : }
9515 :
9516 : /* The string copy algorithm below generates code like
9517 :
9518 : if (destlen > 0)
9519 : {
9520 : if (srclen < destlen)
9521 : {
9522 : memmove (dest, src, srclen);
9523 : // Pad with spaces.
9524 : memset (&dest[srclen], ' ', destlen - srclen);
9525 : }
9526 : else
9527 : {
9528 : // Truncate if too long.
9529 : memmove (dest, src, destlen);
9530 : }
9531 : }
9532 : */
9533 :
9534 : /* Do nothing if the destination length is zero. */
9535 31164 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9536 31164 : build_zero_cst (TREE_TYPE (dlen)));
9537 :
9538 : /* For non-default character kinds, we have to multiply the string
9539 : length by the base type size. */
9540 31164 : chartype = gfc_get_char_type (dkind);
9541 31164 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9542 : slen,
9543 31164 : fold_convert (TREE_TYPE (slen),
9544 : TYPE_SIZE_UNIT (chartype)));
9545 31164 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9546 : dlen,
9547 31164 : fold_convert (TREE_TYPE (dlen),
9548 : TYPE_SIZE_UNIT (chartype)));
9549 :
9550 31164 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9551 31116 : dest = fold_convert (pvoid_type_node, dest);
9552 : else
9553 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9554 :
9555 31164 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9556 31160 : src = fold_convert (pvoid_type_node, src);
9557 : else
9558 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9559 :
9560 : /* Truncate string if source is too long. */
9561 31164 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9562 : dlen);
9563 :
9564 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9565 31164 : if (!CONSTANT_CLASS_P (cond2))
9566 : {
9567 9640 : dest = gfc_evaluate_now (dest, block);
9568 9640 : src = gfc_evaluate_now (src, block);
9569 : }
9570 :
9571 : /* Copy and pad with spaces. */
9572 31164 : tmp3 = build_call_expr_loc (input_location,
9573 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9574 : 3, dest, src,
9575 : fold_convert (size_type_node, slen));
9576 :
9577 : /* Wstringop-overflow appears at -O3 even though this warning is not
9578 : explicitly available in fortran nor can it be switched off. If the
9579 : source length is a constant, its negative appears as a very large
9580 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9581 : the result of the MINUS_EXPR suppresses this spurious warning. */
9582 31164 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9583 31164 : TREE_TYPE(dlen), dlen, slen);
9584 31164 : if (slength && TREE_CONSTANT (slength))
9585 27590 : tmp = gfc_evaluate_now (tmp, block);
9586 :
9587 31164 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9588 31164 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9589 :
9590 31164 : gfc_init_block (&tempblock);
9591 31164 : gfc_add_expr_to_block (&tempblock, tmp3);
9592 31164 : gfc_add_expr_to_block (&tempblock, tmp4);
9593 31164 : tmp3 = gfc_finish_block (&tempblock);
9594 :
9595 : /* The truncated memmove if the slen >= dlen. */
9596 31164 : tmp2 = build_call_expr_loc (input_location,
9597 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9598 : 3, dest, src,
9599 : fold_convert (size_type_node, dlen));
9600 :
9601 : /* The whole copy_string function is there. */
9602 31164 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9603 : tmp3, tmp2);
9604 31164 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9605 : build_empty_stmt (input_location));
9606 31164 : gfc_add_expr_to_block (block, tmp);
9607 : }
9608 :
9609 :
9610 : /* Translate a statement function.
9611 : The value of a statement function reference is obtained by evaluating the
9612 : expression using the values of the actual arguments for the values of the
9613 : corresponding dummy arguments. */
9614 :
9615 : static void
9616 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9617 : {
9618 269 : gfc_symbol *sym;
9619 269 : gfc_symbol *fsym;
9620 269 : gfc_formal_arglist *fargs;
9621 269 : gfc_actual_arglist *args;
9622 269 : gfc_se lse;
9623 269 : gfc_se rse;
9624 269 : gfc_saved_var *saved_vars;
9625 269 : tree *temp_vars;
9626 269 : tree type;
9627 269 : tree tmp;
9628 269 : int n;
9629 :
9630 269 : sym = expr->symtree->n.sym;
9631 269 : args = expr->value.function.actual;
9632 269 : gfc_init_se (&lse, NULL);
9633 269 : gfc_init_se (&rse, NULL);
9634 :
9635 269 : n = 0;
9636 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9637 458 : n++;
9638 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9639 269 : temp_vars = XCNEWVEC (tree, n);
9640 :
9641 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9642 458 : fargs = fargs->next, n++)
9643 : {
9644 : /* Each dummy shall be specified, explicitly or implicitly, to be
9645 : scalar. */
9646 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9647 458 : fsym = fargs->sym;
9648 :
9649 458 : if (fsym->ts.type == BT_CHARACTER)
9650 : {
9651 : /* Copy string arguments. */
9652 48 : tree arglen;
9653 :
9654 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9655 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9656 :
9657 : /* Create a temporary to hold the value. */
9658 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9659 1 : fsym->ts.u.cl->backend_decl
9660 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9661 :
9662 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9663 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9664 :
9665 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9666 :
9667 48 : gfc_conv_expr (&rse, args->expr);
9668 48 : gfc_conv_string_parameter (&rse);
9669 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9670 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9671 :
9672 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9673 : rse.string_length, rse.expr, fsym->ts.kind);
9674 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9675 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9676 : }
9677 : else
9678 : {
9679 : /* For everything else, just evaluate the expression. */
9680 :
9681 : /* Create a temporary to hold the value. */
9682 410 : type = gfc_typenode_for_spec (&fsym->ts);
9683 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9684 :
9685 410 : gfc_conv_expr (&lse, args->expr);
9686 :
9687 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9688 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9689 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9690 : }
9691 :
9692 458 : args = args->next;
9693 : }
9694 :
9695 : /* Use the temporary variables in place of the real ones. */
9696 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9697 458 : fargs = fargs->next, n++)
9698 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9699 :
9700 269 : gfc_conv_expr (se, sym->value);
9701 :
9702 269 : if (sym->ts.type == BT_CHARACTER)
9703 : {
9704 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9705 :
9706 : /* Force the expression to the correct length. */
9707 55 : if (!INTEGER_CST_P (se->string_length)
9708 101 : || tree_int_cst_lt (se->string_length,
9709 46 : sym->ts.u.cl->backend_decl))
9710 : {
9711 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9712 31 : tmp = gfc_create_var (type, sym->name);
9713 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9714 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9715 : sym->ts.kind, se->string_length, se->expr,
9716 : sym->ts.kind);
9717 31 : se->expr = tmp;
9718 : }
9719 55 : se->string_length = sym->ts.u.cl->backend_decl;
9720 : }
9721 :
9722 : /* Restore the original variables. */
9723 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9724 458 : fargs = fargs->next, n++)
9725 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9726 269 : free (temp_vars);
9727 269 : free (saved_vars);
9728 269 : }
9729 :
9730 :
9731 : /* Translate a function expression. */
9732 :
9733 : static void
9734 317850 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9735 : {
9736 317850 : gfc_symbol *sym;
9737 :
9738 317850 : if (expr->value.function.isym)
9739 : {
9740 266553 : gfc_conv_intrinsic_function (se, expr);
9741 266553 : return;
9742 : }
9743 :
9744 : /* expr.value.function.esym is the resolved (specific) function symbol for
9745 : most functions. However this isn't set for dummy procedures. */
9746 51297 : sym = expr->value.function.esym;
9747 51297 : if (!sym)
9748 1640 : sym = expr->symtree->n.sym;
9749 :
9750 : /* The IEEE_ARITHMETIC functions are caught here. */
9751 51297 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9752 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9753 : return;
9754 :
9755 : /* We distinguish statement functions from general functions to improve
9756 : runtime performance. */
9757 38840 : if (sym->attr.proc == PROC_ST_FUNCTION)
9758 : {
9759 269 : gfc_conv_statement_function (se, expr);
9760 269 : return;
9761 : }
9762 :
9763 38571 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9764 : NULL);
9765 : }
9766 :
9767 :
9768 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9769 :
9770 : static bool
9771 40258 : is_zero_initializer_p (gfc_expr * expr)
9772 : {
9773 40258 : if (expr->expr_type != EXPR_CONSTANT)
9774 : return false;
9775 :
9776 : /* We ignore constants with prescribed memory representations for now. */
9777 11580 : if (expr->representation.string)
9778 : return false;
9779 :
9780 11562 : switch (expr->ts.type)
9781 : {
9782 5405 : case BT_INTEGER:
9783 5405 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9784 :
9785 4849 : case BT_REAL:
9786 4849 : return mpfr_zero_p (expr->value.real)
9787 4849 : && MPFR_SIGN (expr->value.real) >= 0;
9788 :
9789 931 : case BT_LOGICAL:
9790 931 : return expr->value.logical == 0;
9791 :
9792 243 : case BT_COMPLEX:
9793 243 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9794 155 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9795 155 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9796 386 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9797 :
9798 : default:
9799 : break;
9800 : }
9801 : return false;
9802 : }
9803 :
9804 :
9805 : static void
9806 36598 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9807 : {
9808 36598 : gfc_ss *ss;
9809 :
9810 36598 : ss = se->ss;
9811 36598 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9812 36598 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9813 :
9814 36598 : gfc_conv_tmp_array_ref (se);
9815 36598 : }
9816 :
9817 :
9818 : /* Build a static initializer. EXPR is the expression for the initial value.
9819 : The other parameters describe the variable of the component being
9820 : initialized. EXPR may be null. */
9821 :
9822 : tree
9823 137752 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9824 : bool array, bool pointer, bool procptr)
9825 : {
9826 137752 : gfc_se se;
9827 :
9828 137752 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9829 43136 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9830 171 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9831 59 : return build_constructor (type, NULL);
9832 :
9833 137693 : if (!(expr || pointer || procptr))
9834 : return NULL_TREE;
9835 :
9836 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9837 : (these are the only two iso_c_binding derived types that can be
9838 : used as initialization expressions). If so, we need to modify
9839 : the 'expr' to be that for a (void *). */
9840 129249 : if (expr != NULL && expr->ts.type == BT_DERIVED
9841 38872 : && expr->ts.is_iso_c && expr->ts.u.derived)
9842 : {
9843 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9844 4 : return build_constructor (type, NULL);
9845 182 : else if (POINTER_TYPE_P (type))
9846 182 : return build_int_cst (type, 0);
9847 : else
9848 0 : gcc_unreachable ();
9849 : }
9850 :
9851 129063 : if (array && !procptr)
9852 : {
9853 8886 : tree ctor;
9854 : /* Arrays need special handling. */
9855 8886 : if (pointer)
9856 815 : ctor = gfc_build_null_descriptor (type);
9857 : /* Special case assigning an array to zero. */
9858 8071 : else if (is_zero_initializer_p (expr))
9859 226 : ctor = build_constructor (type, NULL);
9860 : else
9861 7845 : ctor = gfc_conv_array_initializer (type, expr);
9862 8886 : TREE_STATIC (ctor) = 1;
9863 8886 : return ctor;
9864 : }
9865 120177 : else if (pointer || procptr)
9866 : {
9867 56267 : if (ts->type == BT_CLASS && !procptr)
9868 : {
9869 1792 : gfc_init_se (&se, NULL);
9870 1792 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9871 1792 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9872 1792 : TREE_STATIC (se.expr) = 1;
9873 1792 : return se.expr;
9874 : }
9875 54475 : else if (!expr || expr->expr_type == EXPR_NULL)
9876 28974 : return fold_convert (type, null_pointer_node);
9877 : else
9878 : {
9879 25501 : gfc_init_se (&se, NULL);
9880 25501 : se.want_pointer = 1;
9881 25501 : gfc_conv_expr (&se, expr);
9882 25501 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9883 : return se.expr;
9884 : }
9885 : }
9886 : else
9887 : {
9888 63910 : switch (ts->type)
9889 : {
9890 18695 : case_bt_struct:
9891 18695 : case BT_CLASS:
9892 18695 : gfc_init_se (&se, NULL);
9893 18695 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9894 809 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9895 : else
9896 17886 : gfc_conv_structure (&se, expr, 1);
9897 18695 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9898 18695 : TREE_STATIC (se.expr) = 1;
9899 18695 : return se.expr;
9900 :
9901 2717 : case BT_CHARACTER:
9902 2717 : if (expr->expr_type == EXPR_CONSTANT)
9903 : {
9904 2716 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9905 2716 : TREE_STATIC (ctor) = 1;
9906 2716 : return ctor;
9907 : }
9908 :
9909 : /* Fallthrough. */
9910 42499 : default:
9911 42499 : gfc_init_se (&se, NULL);
9912 42499 : gfc_conv_constant (&se, expr);
9913 42499 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9914 : return se.expr;
9915 : }
9916 : }
9917 : }
9918 :
9919 : static tree
9920 956 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9921 : {
9922 956 : gfc_se rse;
9923 956 : gfc_se lse;
9924 956 : gfc_ss *rss;
9925 956 : gfc_ss *lss;
9926 956 : gfc_array_info *lss_array;
9927 956 : stmtblock_t body;
9928 956 : stmtblock_t block;
9929 956 : gfc_loopinfo loop;
9930 956 : int n;
9931 956 : tree tmp;
9932 :
9933 956 : gfc_start_block (&block);
9934 :
9935 : /* Initialize the scalarizer. */
9936 956 : gfc_init_loopinfo (&loop);
9937 :
9938 956 : gfc_init_se (&lse, NULL);
9939 956 : gfc_init_se (&rse, NULL);
9940 :
9941 : /* Walk the rhs. */
9942 956 : rss = gfc_walk_expr (expr);
9943 956 : if (rss == gfc_ss_terminator)
9944 : /* The rhs is scalar. Add a ss for the expression. */
9945 208 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
9946 :
9947 : /* Create a SS for the destination. */
9948 956 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
9949 : GFC_SS_COMPONENT);
9950 956 : lss_array = &lss->info->data.array;
9951 956 : lss_array->shape = gfc_get_shape (cm->as->rank);
9952 956 : lss_array->descriptor = dest;
9953 956 : lss_array->data = gfc_conv_array_data (dest);
9954 956 : lss_array->offset = gfc_conv_array_offset (dest);
9955 1969 : for (n = 0; n < cm->as->rank; n++)
9956 : {
9957 1013 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
9958 1013 : lss_array->stride[n] = gfc_index_one_node;
9959 :
9960 1013 : mpz_init (lss_array->shape[n]);
9961 1013 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
9962 1013 : cm->as->lower[n]->value.integer);
9963 1013 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
9964 : }
9965 :
9966 : /* Associate the SS with the loop. */
9967 956 : gfc_add_ss_to_loop (&loop, lss);
9968 956 : gfc_add_ss_to_loop (&loop, rss);
9969 :
9970 : /* Calculate the bounds of the scalarization. */
9971 956 : gfc_conv_ss_startstride (&loop);
9972 :
9973 : /* Setup the scalarizing loops. */
9974 956 : gfc_conv_loop_setup (&loop, &expr->where);
9975 :
9976 : /* Setup the gfc_se structures. */
9977 956 : gfc_copy_loopinfo_to_se (&lse, &loop);
9978 956 : gfc_copy_loopinfo_to_se (&rse, &loop);
9979 :
9980 956 : rse.ss = rss;
9981 956 : gfc_mark_ss_chain_used (rss, 1);
9982 956 : lse.ss = lss;
9983 956 : gfc_mark_ss_chain_used (lss, 1);
9984 :
9985 : /* Start the scalarized loop body. */
9986 956 : gfc_start_scalarized_body (&loop, &body);
9987 :
9988 956 : gfc_conv_tmp_array_ref (&lse);
9989 956 : if (cm->ts.type == BT_CHARACTER)
9990 176 : lse.string_length = cm->ts.u.cl->backend_decl;
9991 :
9992 956 : gfc_conv_expr (&rse, expr);
9993 :
9994 956 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
9995 956 : gfc_add_expr_to_block (&body, tmp);
9996 :
9997 956 : gcc_assert (rse.ss == gfc_ss_terminator);
9998 :
9999 : /* Generate the copying loops. */
10000 956 : gfc_trans_scalarizing_loops (&loop, &body);
10001 :
10002 : /* Wrap the whole thing up. */
10003 956 : gfc_add_block_to_block (&block, &loop.pre);
10004 956 : gfc_add_block_to_block (&block, &loop.post);
10005 :
10006 956 : gcc_assert (lss_array->shape != NULL);
10007 956 : gfc_free_shape (&lss_array->shape, cm->as->rank);
10008 956 : gfc_cleanup_loop (&loop);
10009 :
10010 956 : return gfc_finish_block (&block);
10011 : }
10012 :
10013 :
10014 : static stmtblock_t *final_block;
10015 :
10016 :
10017 : /* Get the address of element index of contiguous character array data whose elements
10018 : are len characters of ksize bytes each. */
10019 :
10020 : static tree
10021 196 : gfc_char_elem_addr (tree char_ptr, tree data, tree idx, tree len, tree ksize)
10022 : {
10023 196 : tree offset = fold_build2_loc (input_location, MULT_EXPR,
10024 : gfc_array_index_type, len, ksize);
10025 196 : offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10026 : idx, offset);
10027 196 : return fold_build_pointer_plus_loc (input_location,
10028 196 : fold_convert (char_ptr, data), offset);
10029 : }
10030 :
10031 :
10032 : /* Copy a deferred-shape allocatable character array component in a structure
10033 : constructor when the source element length (SRC_LEN) may differ from the
10034 : component's declared length. Like gfc_duplicate_allocatable, a
10035 : contiguous source layout is assumed. DEST and SRC are array descriptors;
10036 : DEST already carries the source's bounds. */
10037 :
10038 : static tree
10039 98 : gfc_trans_alloc_char_subarray_assign (tree dest, gfc_component *cm, tree src,
10040 : tree src_len, int rank)
10041 : {
10042 98 : stmtblock_t block, body;
10043 98 : tree dlen, slen, ksize, nelems, idx, size, tmp, pchar, cond;
10044 :
10045 98 : gfc_init_block (&block);
10046 :
10047 98 : pchar = gfc_get_pchar_type (cm->ts.kind);
10048 98 : ksize = fold_convert (gfc_array_index_type,
10049 : TYPE_SIZE_UNIT (gfc_get_char_type (cm->ts.kind)));
10050 98 : dlen = fold_convert (gfc_array_index_type, cm->ts.u.cl->backend_decl);
10051 98 : slen = fold_convert (gfc_array_index_type, src_len);
10052 98 : nelems = gfc_full_array_size (&block, src, rank);
10053 98 : nelems = gfc_evaluate_now (nelems, &block);
10054 :
10055 : /* Allocate the destination data: nelems elements of the component length. */
10056 98 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10057 : nelems, dlen);
10058 98 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10059 : size, ksize);
10060 98 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (dest));
10061 98 : gfc_conv_descriptor_data_set (&block, dest,
10062 : gfc_call_malloc (&block, tmp, size));
10063 :
10064 : /* Copy element IDX, padding or truncating to the component length. */
10065 98 : idx = gfc_create_var (gfc_array_index_type, "idx");
10066 98 : gfc_init_block (&body);
10067 98 : gfc_trans_string_copy (&body, cm->ts.u.cl->backend_decl,
10068 : gfc_char_elem_addr (pchar,
10069 : gfc_conv_descriptor_data_get (dest),
10070 : idx, dlen, ksize),
10071 : cm->ts.kind, src_len,
10072 : gfc_char_elem_addr (pchar,
10073 : gfc_conv_descriptor_data_get (src),
10074 : idx, slen, ksize),
10075 : cm->ts.kind);
10076 98 : gfc_simple_for_loop (&block, idx, gfc_index_zero_node, nelems, LT_EXPR,
10077 : gfc_index_one_node, gfc_finish_block (&body));
10078 :
10079 98 : tmp = gfc_finish_block (&block);
10080 :
10081 : /* Null the destination if the source is unallocated. */
10082 98 : gfc_init_block (&body);
10083 98 : gfc_conv_descriptor_data_set (&body, dest, null_pointer_node);
10084 98 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10085 : fold_convert (pvoid_type_node,
10086 : gfc_conv_descriptor_data_get (src)),
10087 : null_pointer_node);
10088 98 : return build3_v (COND_EXPR, cond, tmp, gfc_finish_block (&body));
10089 : }
10090 :
10091 :
10092 : static tree
10093 1330 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
10094 : gfc_expr * expr)
10095 : {
10096 1330 : gfc_se se;
10097 1330 : stmtblock_t block;
10098 1330 : tree offset;
10099 1330 : int n;
10100 1330 : tree tmp;
10101 1330 : tree tmp2;
10102 1330 : gfc_array_spec *as;
10103 1330 : gfc_expr *arg = NULL;
10104 :
10105 1330 : gfc_start_block (&block);
10106 1330 : gfc_init_se (&se, NULL);
10107 :
10108 : /* Get the descriptor for the expressions. */
10109 1330 : se.want_pointer = 0;
10110 1330 : gfc_conv_expr_descriptor (&se, expr);
10111 1330 : gfc_add_block_to_block (&block, &se.pre);
10112 1330 : gfc_add_modify (&block, dest, se.expr);
10113 1330 : if (cm->ts.type == BT_CHARACTER
10114 1330 : && gfc_deferred_strlen (cm, &tmp))
10115 : {
10116 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10117 30 : TREE_TYPE (tmp),
10118 30 : TREE_OPERAND (dest, 0),
10119 : tmp, NULL_TREE);
10120 30 : gfc_add_modify (&block, tmp,
10121 30 : fold_convert (TREE_TYPE (tmp),
10122 : se.string_length));
10123 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
10124 : "slen");
10125 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
10126 : }
10127 :
10128 : /* Deal with arrays of derived types with allocatable components. */
10129 1330 : if (gfc_bt_struct (cm->ts.type)
10130 199 : && cm->ts.u.derived->attr.alloc_comp)
10131 : // TODO: Fix caf_mode
10132 113 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
10133 : se.expr, dest,
10134 113 : cm->as->rank, 0);
10135 1217 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
10136 36 : && CLASS_DATA(cm)->attr.allocatable)
10137 : {
10138 36 : if (cm->ts.u.derived->attr.alloc_comp)
10139 : // TODO: Fix caf_mode
10140 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
10141 : se.expr, dest,
10142 : expr->rank, 0);
10143 : else
10144 : {
10145 36 : tmp = TREE_TYPE (dest);
10146 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10147 : tmp, expr->rank, NULL_TREE);
10148 : }
10149 : }
10150 1181 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10151 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10152 : gfc_typenode_for_spec (&cm->ts),
10153 30 : cm->as->rank, NULL_TREE);
10154 1151 : else if (cm->ts.type == BT_CHARACTER)
10155 : /* Explicit-length character: the source element length may differ from
10156 : the component length, so a bitwise duplicate would copy the wrong
10157 : bytes. Copy element by element with padding/truncation. */
10158 98 : tmp = gfc_trans_alloc_char_subarray_assign (dest, cm, se.expr,
10159 : se.string_length,
10160 98 : cm->as->rank);
10161 : else
10162 1053 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10163 1053 : TREE_TYPE(cm->backend_decl),
10164 1053 : cm->as->rank, NULL_TREE);
10165 :
10166 :
10167 1330 : gfc_add_expr_to_block (&block, tmp);
10168 1330 : gfc_add_block_to_block (&block, &se.post);
10169 :
10170 1330 : if (final_block && !cm->attr.allocatable
10171 96 : && expr->expr_type == EXPR_ARRAY)
10172 : {
10173 96 : tree data_ptr;
10174 96 : data_ptr = gfc_conv_descriptor_data_get (dest);
10175 96 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
10176 96 : }
10177 1234 : else if (final_block && cm->attr.allocatable)
10178 162 : gfc_add_block_to_block (final_block, &se.finalblock);
10179 :
10180 1330 : if (expr->expr_type != EXPR_VARIABLE)
10181 : {
10182 1191 : if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp)
10183 : {
10184 214 : tmp = gfc_deallocate_alloc_comp_no_caf (cm->ts.u.derived,
10185 107 : se.expr, cm->as->rank, true);
10186 107 : gfc_add_expr_to_block (&block, tmp);
10187 : }
10188 1191 : gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
10189 : }
10190 :
10191 : /* We need to know if the argument of a conversion function is a
10192 : variable, so that the correct lower bound can be used. */
10193 1330 : if (expr->expr_type == EXPR_FUNCTION
10194 68 : && expr->value.function.isym
10195 56 : && expr->value.function.isym->conversion
10196 56 : && expr->value.function.actual->expr
10197 56 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
10198 56 : arg = expr->value.function.actual->expr;
10199 :
10200 : /* Obtain the array spec of full array references. */
10201 56 : if (arg)
10202 56 : as = gfc_get_full_arrayspec_from_expr (arg);
10203 : else
10204 1274 : as = gfc_get_full_arrayspec_from_expr (expr);
10205 :
10206 : /* Shift the lbound and ubound of temporaries to being unity,
10207 : rather than zero, based. Always calculate the offset. */
10208 1330 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
10209 1330 : offset = gfc_conv_descriptor_offset_get (dest);
10210 1330 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
10211 :
10212 4046 : for (n = 0; n < expr->rank; n++)
10213 : {
10214 1386 : tree span;
10215 1386 : tree lbound;
10216 :
10217 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
10218 : TODO It looks as if gfc_conv_expr_descriptor should return
10219 : the correct bounds and that the following should not be
10220 : necessary. This would simplify gfc_conv_intrinsic_bound
10221 : as well. */
10222 1386 : if (as && as->lower[n])
10223 : {
10224 92 : gfc_se lbse;
10225 92 : gfc_init_se (&lbse, NULL);
10226 92 : gfc_conv_expr (&lbse, as->lower[n]);
10227 92 : gfc_add_block_to_block (&block, &lbse.pre);
10228 92 : lbound = gfc_evaluate_now (lbse.expr, &block);
10229 92 : }
10230 1294 : else if (as && arg)
10231 : {
10232 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
10233 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
10234 : gfc_rank_cst[n]);
10235 : }
10236 1260 : else if (as)
10237 82 : lbound = gfc_conv_descriptor_lbound_get (dest,
10238 : gfc_rank_cst[n]);
10239 : else
10240 1178 : lbound = gfc_index_one_node;
10241 :
10242 1386 : lbound = fold_convert (gfc_array_index_type, lbound);
10243 :
10244 : /* Shift the bounds and set the offset accordingly. */
10245 1386 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
10246 1386 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10247 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
10248 1386 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
10249 : span, lbound);
10250 1386 : gfc_conv_descriptor_ubound_set (&block, dest,
10251 : gfc_rank_cst[n], tmp);
10252 1386 : gfc_conv_descriptor_lbound_set (&block, dest,
10253 : gfc_rank_cst[n], lbound);
10254 :
10255 1386 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10256 : gfc_conv_descriptor_lbound_get (dest,
10257 : gfc_rank_cst[n]),
10258 : gfc_conv_descriptor_stride_get (dest,
10259 : gfc_rank_cst[n]));
10260 1386 : gfc_add_modify (&block, tmp2, tmp);
10261 1386 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10262 : offset, tmp2);
10263 1386 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
10264 : }
10265 :
10266 1330 : if (arg)
10267 : {
10268 : /* If a conversion expression has a null data pointer
10269 : argument, nullify the allocatable component. */
10270 56 : tree non_null_expr;
10271 56 : tree null_expr;
10272 :
10273 56 : if (arg->symtree->n.sym->attr.allocatable
10274 24 : || arg->symtree->n.sym->attr.pointer)
10275 : {
10276 32 : non_null_expr = gfc_finish_block (&block);
10277 32 : gfc_start_block (&block);
10278 32 : gfc_conv_descriptor_data_set (&block, dest,
10279 : null_pointer_node);
10280 32 : null_expr = gfc_finish_block (&block);
10281 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
10282 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
10283 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
10284 32 : return build3_v (COND_EXPR, tmp,
10285 : null_expr, non_null_expr);
10286 : }
10287 : }
10288 :
10289 1298 : return gfc_finish_block (&block);
10290 : }
10291 :
10292 :
10293 : /* Allocate or reallocate scalar component, as necessary. */
10294 :
10295 : static void
10296 428 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
10297 : gfc_component *cm, gfc_expr *expr2,
10298 : tree slen)
10299 : {
10300 428 : tree tmp;
10301 428 : tree ptr;
10302 428 : tree size;
10303 428 : tree size_in_bytes;
10304 428 : tree lhs_cl_size = NULL_TREE;
10305 428 : gfc_se se;
10306 :
10307 428 : if (!comp)
10308 0 : return;
10309 :
10310 428 : if (!expr2 || expr2->rank)
10311 : return;
10312 :
10313 428 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10314 :
10315 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10316 : {
10317 145 : gcc_assert (expr2->ts.type == BT_CHARACTER);
10318 145 : size = expr2->ts.u.cl->backend_decl;
10319 145 : if (!size || !VAR_P (size))
10320 145 : size = gfc_create_var (TREE_TYPE (slen), "slen");
10321 145 : gfc_add_modify (block, size, slen);
10322 :
10323 145 : gfc_deferred_strlen (cm, &tmp);
10324 145 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
10325 : gfc_charlen_type_node,
10326 145 : TREE_OPERAND (comp, 0),
10327 : tmp, NULL_TREE);
10328 :
10329 145 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
10330 145 : tmp = TYPE_SIZE_UNIT (tmp);
10331 290 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10332 145 : TREE_TYPE (tmp), tmp,
10333 145 : fold_convert (TREE_TYPE (tmp), size));
10334 : }
10335 283 : else if (cm->ts.type == BT_CLASS)
10336 : {
10337 109 : if (expr2->ts.type != BT_CLASS)
10338 : {
10339 109 : if (expr2->ts.type == BT_CHARACTER)
10340 : {
10341 24 : gfc_init_se (&se, NULL);
10342 24 : gfc_conv_expr (&se, expr2);
10343 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
10344 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10345 : gfc_charlen_type_node,
10346 : se.string_length, size);
10347 24 : size = fold_convert (size_type_node, size);
10348 : }
10349 : else
10350 : {
10351 85 : if (expr2->ts.type == BT_DERIVED)
10352 54 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
10353 : else
10354 31 : tmp = gfc_typenode_for_spec (&expr2->ts);
10355 85 : size = TYPE_SIZE_UNIT (tmp);
10356 : }
10357 : }
10358 : else
10359 : {
10360 0 : gfc_expr *e2vtab;
10361 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
10362 0 : gfc_add_vptr_component (e2vtab);
10363 0 : gfc_add_size_component (e2vtab);
10364 0 : gfc_init_se (&se, NULL);
10365 0 : gfc_conv_expr (&se, e2vtab);
10366 0 : gfc_add_block_to_block (block, &se.pre);
10367 0 : size = fold_convert (size_type_node, se.expr);
10368 0 : gfc_free_expr (e2vtab);
10369 : }
10370 : size_in_bytes = size;
10371 : }
10372 : else
10373 : {
10374 : /* Otherwise use the length in bytes of the rhs. */
10375 174 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
10376 174 : size_in_bytes = size;
10377 : }
10378 :
10379 428 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10380 : size_in_bytes, size_one_node);
10381 :
10382 428 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
10383 : {
10384 6 : tmp = build_call_expr_loc (input_location,
10385 : builtin_decl_explicit (BUILT_IN_CALLOC),
10386 : 2, build_one_cst (size_type_node),
10387 : size_in_bytes);
10388 6 : tmp = fold_convert (TREE_TYPE (comp), tmp);
10389 6 : gfc_add_modify (block, comp, tmp);
10390 : }
10391 : else
10392 : {
10393 422 : tmp = build_call_expr_loc (input_location,
10394 : builtin_decl_explicit (BUILT_IN_MALLOC),
10395 : 1, size_in_bytes);
10396 422 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
10397 109 : ptr = gfc_class_data_get (comp);
10398 : else
10399 : ptr = comp;
10400 422 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
10401 422 : gfc_add_modify (block, ptr, tmp);
10402 : }
10403 :
10404 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10405 : /* Update the lhs character length. */
10406 145 : gfc_add_modify (block, lhs_cl_size,
10407 145 : fold_convert (TREE_TYPE (lhs_cl_size), size));
10408 : }
10409 :
10410 :
10411 : /* Assign a single component of a derived type constructor. */
10412 :
10413 : static tree
10414 31072 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
10415 : gfc_expr * expr, bool init)
10416 : {
10417 31072 : gfc_se se;
10418 31072 : gfc_se lse;
10419 31072 : stmtblock_t block;
10420 31072 : tree tmp;
10421 31072 : tree vtab;
10422 :
10423 31072 : gfc_start_block (&block);
10424 :
10425 31072 : if (cm->attr.pointer || cm->attr.proc_pointer)
10426 : {
10427 : /* Only care about pointers here, not about allocatables. */
10428 2704 : gfc_init_se (&se, NULL);
10429 : /* Pointer component. */
10430 2704 : if ((cm->attr.dimension || cm->attr.codimension)
10431 682 : && !cm->attr.proc_pointer)
10432 : {
10433 : /* Array pointer. */
10434 666 : if (expr->expr_type == EXPR_NULL)
10435 660 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10436 : else
10437 : {
10438 6 : se.direct_byref = 1;
10439 6 : se.expr = dest;
10440 6 : gfc_conv_expr_descriptor (&se, expr);
10441 6 : gfc_add_block_to_block (&block, &se.pre);
10442 6 : gfc_add_block_to_block (&block, &se.post);
10443 : }
10444 : }
10445 : else
10446 : {
10447 : /* Scalar pointers. */
10448 2038 : se.want_pointer = 1;
10449 2038 : gfc_conv_expr (&se, expr);
10450 2038 : gfc_add_block_to_block (&block, &se.pre);
10451 :
10452 2038 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10453 12 : && expr->symtree->n.sym->attr.dummy)
10454 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10455 :
10456 2038 : gfc_add_modify (&block, dest,
10457 2038 : fold_convert (TREE_TYPE (dest), se.expr));
10458 2038 : gfc_add_block_to_block (&block, &se.post);
10459 : }
10460 : }
10461 28368 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10462 : {
10463 : /* NULL initialization for CLASS components. */
10464 976 : tmp = gfc_trans_structure_assign (dest,
10465 : gfc_class_initializer (&cm->ts, expr),
10466 : false);
10467 976 : gfc_add_expr_to_block (&block, tmp);
10468 : }
10469 27392 : else if ((cm->attr.dimension || cm->attr.codimension)
10470 : && !cm->attr.proc_pointer)
10471 : {
10472 5099 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10473 : {
10474 2849 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10475 2849 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10476 2 : gfc_conv_descriptor_token_set (&block, dest, null_pointer_node);
10477 : }
10478 2250 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10479 : {
10480 1294 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10481 1294 : gfc_add_expr_to_block (&block, tmp);
10482 : }
10483 : else
10484 : {
10485 956 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10486 956 : gfc_add_expr_to_block (&block, tmp);
10487 : }
10488 : }
10489 22293 : else if (cm->ts.type == BT_CLASS
10490 157 : && CLASS_DATA (cm)->attr.dimension
10491 36 : && CLASS_DATA (cm)->attr.allocatable
10492 36 : && expr->ts.type == BT_DERIVED)
10493 : {
10494 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10495 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10496 36 : tmp = gfc_class_vptr_get (dest);
10497 36 : gfc_add_modify (&block, tmp,
10498 36 : fold_convert (TREE_TYPE (tmp), vtab));
10499 36 : tmp = gfc_class_data_get (dest);
10500 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10501 36 : gfc_add_expr_to_block (&block, tmp);
10502 : }
10503 22257 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10504 1844 : && (init
10505 1717 : || (cm->ts.type == BT_CHARACTER
10506 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10507 : {
10508 : /* NULL initialization for allocatable components.
10509 : Deferred-length character is dealt with later. */
10510 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10511 : null_pointer_node));
10512 : }
10513 22106 : else if (init && (cm->attr.allocatable
10514 14039 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10515 121 : && expr->ts.type != BT_CLASS)))
10516 : {
10517 428 : tree size;
10518 428 : tree tmp2;
10519 :
10520 428 : gfc_init_se (&se, NULL);
10521 428 : gfc_conv_expr (&se, expr);
10522 :
10523 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10524 : if (!cm->attr.dimension) part above. */
10525 428 : gfc_add_block_to_block (&block, &se.pre);
10526 : /* Take care about non-array allocatable components here. The alloc_*
10527 : routine below is motivated by the alloc_scalar_allocatable_for_
10528 : assignment() routine, but with the realloc portions removed and
10529 : different input. */
10530 428 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10531 : se.string_length);
10532 :
10533 428 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10534 0 : && expr->symtree->n.sym->attr.dummy)
10535 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10536 :
10537 428 : if (cm->ts.type == BT_CLASS)
10538 : {
10539 109 : tmp = gfc_class_data_get (dest);
10540 109 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10541 109 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10542 109 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10543 109 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10544 109 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10545 : }
10546 : else
10547 319 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10548 :
10549 : /* For deferred strings insert a memcpy. */
10550 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10551 : {
10552 145 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10553 145 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10554 : ? se.string_length
10555 0 : : expr->ts.u.cl->backend_decl);
10556 145 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10557 145 : gfc_add_expr_to_block (&block, tmp);
10558 : }
10559 283 : else if (cm->ts.type == BT_CLASS)
10560 : {
10561 : /* Fix the expression for memcpy. */
10562 109 : if (expr->expr_type != EXPR_VARIABLE)
10563 73 : se.expr = gfc_evaluate_now (se.expr, &block);
10564 :
10565 109 : if (expr->ts.type == BT_CHARACTER)
10566 : {
10567 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10568 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10569 : gfc_charlen_type_node,
10570 : se.string_length, size);
10571 24 : size = fold_convert (size_type_node, size);
10572 : }
10573 : else
10574 85 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10575 :
10576 : /* Now copy the expression to the constructor component _data. */
10577 109 : gfc_add_expr_to_block (&block,
10578 : gfc_build_memcpy_call (tmp, se.expr, size));
10579 :
10580 109 : if (expr->ts.type == BT_DERIVED
10581 54 : && expr->ts.u.derived->attr.alloc_comp
10582 6 : && expr->expr_type != EXPR_NULL)
10583 : {
10584 6 : tmp2 = gfc_class_data_get (dest);
10585 6 : tmp2 = gfc_copy_alloc_comp (expr->ts.u.derived, tmp2,
10586 : gfc_class_data_get (dest),
10587 : expr->rank, 0);
10588 6 : gfc_add_expr_to_block (&block, tmp2);
10589 : }
10590 :
10591 : /* Fill the unlimited polymorphic _len field. */
10592 109 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10593 : {
10594 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10595 24 : gfc_add_modify (&block, tmp,
10596 24 : fold_convert (TREE_TYPE (tmp),
10597 : se.string_length));
10598 : }
10599 : }
10600 : else
10601 : {
10602 174 : gfc_add_modify (&block, tmp,
10603 174 : fold_convert (TREE_TYPE (tmp), se.expr));
10604 174 : if (expr->ts.type == BT_DERIVED
10605 32 : && expr->ts.u.derived->attr.alloc_comp
10606 6 : && expr->expr_type != EXPR_NULL)
10607 : {
10608 6 : tmp2 = build_fold_indirect_ref_loc (input_location, dest);
10609 6 : tmp2 = gfc_copy_alloc_comp (cm->ts.u.derived, tmp2,
10610 : se.expr, expr->rank, 0);
10611 6 : gfc_add_expr_to_block (&block, tmp2);
10612 : }
10613 : }
10614 :
10615 428 : gfc_add_block_to_block (&block, &se.post);
10616 428 : }
10617 21678 : else if (expr->ts.type == BT_UNION)
10618 : {
10619 13 : tree tmp;
10620 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10621 : /* We mark that the entire union should be initialized with a contrived
10622 : EXPR_NULL expression at the beginning. */
10623 13 : if (c != NULL && c->n.component == NULL
10624 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10625 : {
10626 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10627 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10628 6 : gfc_add_expr_to_block (&block, tmp);
10629 6 : c = gfc_constructor_next (c);
10630 : }
10631 : /* The following constructor expression, if any, represents a specific
10632 : map initializer, as given by the user. */
10633 13 : if (c != NULL && c->expr != NULL)
10634 : {
10635 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10636 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10637 6 : gfc_add_expr_to_block (&block, tmp);
10638 : }
10639 : }
10640 21665 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10641 : {
10642 3585 : if (expr->expr_type != EXPR_STRUCTURE)
10643 : {
10644 494 : tree dealloc = NULL_TREE;
10645 494 : gfc_init_se (&se, NULL);
10646 494 : gfc_conv_expr (&se, expr);
10647 494 : gfc_add_block_to_block (&block, &se.pre);
10648 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10649 : expression in a temporary variable and deallocate the allocatable
10650 : components. Then we can the copy the expression to the result. */
10651 494 : if (cm->ts.u.derived->attr.alloc_comp
10652 372 : && expr->expr_type != EXPR_VARIABLE)
10653 : {
10654 336 : se.expr = gfc_evaluate_now (se.expr, &block);
10655 336 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10656 : expr->rank);
10657 : }
10658 494 : gfc_add_modify (&block, dest,
10659 494 : fold_convert (TREE_TYPE (dest), se.expr));
10660 494 : if (cm->ts.u.derived->attr.alloc_comp
10661 372 : && expr->expr_type != EXPR_NULL)
10662 : {
10663 : // TODO: Fix caf_mode
10664 54 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10665 : dest, expr->rank, 0);
10666 54 : gfc_add_expr_to_block (&block, tmp);
10667 54 : if (dealloc != NULL_TREE)
10668 18 : gfc_add_expr_to_block (&block, dealloc);
10669 : }
10670 494 : gfc_add_block_to_block (&block, &se.post);
10671 : }
10672 : else
10673 : {
10674 : /* Nested constructors. */
10675 3091 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10676 3091 : gfc_add_expr_to_block (&block, tmp);
10677 : }
10678 : }
10679 18080 : else if (gfc_deferred_strlen (cm, &tmp))
10680 : {
10681 125 : tree strlen;
10682 125 : strlen = tmp;
10683 125 : gcc_assert (strlen);
10684 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10685 125 : TREE_TYPE (strlen),
10686 125 : TREE_OPERAND (dest, 0),
10687 : strlen, NULL_TREE);
10688 :
10689 125 : if (expr->expr_type == EXPR_NULL)
10690 : {
10691 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10692 107 : gfc_add_modify (&block, dest, tmp);
10693 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10694 107 : gfc_add_modify (&block, strlen, tmp);
10695 : }
10696 : else
10697 : {
10698 18 : tree size;
10699 18 : gfc_init_se (&se, NULL);
10700 18 : gfc_conv_expr (&se, expr);
10701 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10702 18 : size = fold_convert (size_type_node, size);
10703 18 : tmp = build_call_expr_loc (input_location,
10704 : builtin_decl_explicit (BUILT_IN_MALLOC),
10705 : 1, size);
10706 18 : gfc_add_modify (&block, dest,
10707 18 : fold_convert (TREE_TYPE (dest), tmp));
10708 18 : gfc_add_modify (&block, strlen,
10709 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10710 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10711 18 : gfc_add_expr_to_block (&block, tmp);
10712 : }
10713 : }
10714 17955 : else if (cm->ts.type == BT_CLASS
10715 12 : && !CLASS_DATA (cm)->as
10716 12 : && expr->ts.type == BT_CLASS)
10717 : {
10718 12 : tree vptr1, vptr2;
10719 12 : tree data1, data2;
10720 12 : tree size, fcn;
10721 :
10722 12 : gfc_init_se (&se, NULL);
10723 :
10724 12 : gfc_conv_expr (&se, expr);
10725 :
10726 : /* Copy the _vptr to the destination.... */
10727 12 : vptr1 = gfc_class_vptr_get (dest);
10728 12 : vptr2 = gfc_class_vptr_get (se.expr);
10729 12 : gfc_add_modify (&block, vptr1,
10730 12 : fold_convert (TREE_TYPE (vptr1), vptr2));
10731 :
10732 : /* ....and the _len field if necessary. */
10733 12 : size = gfc_vptr_size_get (vptr2);
10734 12 : if (UNLIMITED_POLY (cm) && UNLIMITED_POLY (expr))
10735 : {
10736 0 : gfc_add_modify (&block, gfc_class_len_get (dest),
10737 : gfc_class_len_get (se.expr));
10738 0 : size = gfc_resize_class_size_with_len (&block, se.expr, size);
10739 : }
10740 :
10741 : /* Allocate the destination data. */
10742 12 : data1 = gfc_class_data_get (dest);
10743 12 : data2 = gfc_class_data_get (se.expr);
10744 12 : tmp = gfc_call_malloc (&block, TREE_TYPE (data1), size);
10745 12 : gfc_add_modify (&block, data1, tmp);
10746 :
10747 : /* Now call the copy function. */
10748 12 : fcn = gfc_vptr_copy_get (vptr2);
10749 12 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10750 12 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
10751 12 : tmp = build_call_expr_loc (input_location, fcn, 2,
10752 : data2, data1);
10753 12 : gfc_add_expr_to_block (&block, tmp);
10754 12 : }
10755 17943 : else if (!cm->attr.artificial)
10756 : {
10757 : /* Scalar component (excluding deferred parameters). */
10758 17822 : gfc_init_se (&se, NULL);
10759 17822 : gfc_init_se (&lse, NULL);
10760 :
10761 17822 : gfc_conv_expr (&se, expr);
10762 17822 : if (cm->ts.type == BT_CHARACTER)
10763 1081 : lse.string_length = cm->ts.u.cl->backend_decl;
10764 17822 : lse.expr = dest;
10765 17822 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10766 17822 : gfc_add_expr_to_block (&block, tmp);
10767 : }
10768 31072 : return gfc_finish_block (&block);
10769 : }
10770 :
10771 : /* Assign a derived type constructor to a variable. */
10772 :
10773 : tree
10774 21418 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10775 : {
10776 21418 : gfc_constructor *c;
10777 21418 : gfc_component *cm;
10778 21418 : stmtblock_t block;
10779 21418 : tree field;
10780 21418 : tree tmp;
10781 21418 : gfc_se se;
10782 :
10783 21418 : gfc_start_block (&block);
10784 :
10785 21418 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10786 179 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10787 13 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10788 : {
10789 179 : gfc_se lse;
10790 :
10791 179 : gfc_init_se (&se, NULL);
10792 179 : gfc_init_se (&lse, NULL);
10793 179 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10794 179 : lse.expr = dest;
10795 179 : gfc_add_modify (&block, lse.expr,
10796 179 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10797 :
10798 179 : return gfc_finish_block (&block);
10799 : }
10800 :
10801 : /* Make sure that the derived type has been completely built. */
10802 21239 : if (!expr->ts.u.derived->backend_decl
10803 21239 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10804 : {
10805 230 : tmp = gfc_typenode_for_spec (&expr->ts);
10806 230 : gcc_assert (tmp);
10807 : }
10808 :
10809 21239 : cm = expr->ts.u.derived->components;
10810 :
10811 :
10812 21239 : if (coarray)
10813 225 : gfc_init_se (&se, NULL);
10814 :
10815 21239 : for (c = gfc_constructor_first (expr->value.constructor);
10816 55533 : c; c = gfc_constructor_next (c), cm = cm->next)
10817 : {
10818 : /* Skip absent members in default initializers. */
10819 34294 : if (!c->expr && !cm->attr.allocatable)
10820 3222 : continue;
10821 :
10822 : /* Register the component with the caf-lib before it is initialized.
10823 : Register only allocatable components, that are not coarray'ed
10824 : components (%comp[*]). Only register when the constructor is the
10825 : null-expression. */
10826 31072 : if (coarray && !cm->attr.codimension
10827 515 : && (cm->attr.allocatable || cm->attr.pointer)
10828 179 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10829 : {
10830 177 : tree token, desc, size;
10831 354 : bool is_array = cm->ts.type == BT_CLASS
10832 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10833 :
10834 177 : field = cm->backend_decl;
10835 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
10836 177 : TREE_TYPE (field), dest, field, NULL_TREE);
10837 177 : if (cm->ts.type == BT_CLASS)
10838 0 : field = gfc_class_data_get (field);
10839 :
10840 177 : token
10841 : = is_array
10842 177 : ? gfc_conv_descriptor_token (field)
10843 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10844 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10845 52 : gfc_comp_caf_token (cm), NULL_TREE);
10846 :
10847 177 : if (is_array)
10848 : {
10849 : /* The _caf_register routine looks at the rank of the array
10850 : descriptor to decide whether the data registered is an array
10851 : or not. */
10852 125 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10853 125 : : cm->as->rank;
10854 : /* When the rank is not known just set a positive rank, which
10855 : suffices to recognize the data as array. */
10856 125 : if (rank < 0)
10857 0 : rank = 1;
10858 125 : size = build_zero_cst (size_type_node);
10859 125 : desc = field;
10860 125 : gfc_conv_descriptor_rank_set (&block, desc, rank);
10861 : }
10862 : else
10863 : {
10864 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10865 52 : cm->ts.type == BT_CLASS
10866 52 : ? CLASS_DATA (cm)->attr
10867 : : cm->attr);
10868 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10869 : }
10870 177 : gfc_add_block_to_block (&block, &se.pre);
10871 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10872 : 7, size, build_int_cst (
10873 : integer_type_node,
10874 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10875 : gfc_build_addr_expr (pvoid_type_node,
10876 : token),
10877 : gfc_build_addr_expr (NULL_TREE, desc),
10878 : null_pointer_node, null_pointer_node,
10879 : integer_zero_node);
10880 177 : gfc_add_expr_to_block (&block, tmp);
10881 : }
10882 31072 : field = cm->backend_decl;
10883 31072 : gcc_assert(field);
10884 31072 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10885 : dest, field, NULL_TREE);
10886 31072 : if (!c->expr)
10887 : {
10888 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10889 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10890 0 : gfc_free_expr (e);
10891 : }
10892 : else
10893 31072 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10894 31072 : gfc_add_expr_to_block (&block, tmp);
10895 : }
10896 21239 : return gfc_finish_block (&block);
10897 : }
10898 :
10899 : static void
10900 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10901 : gfc_component *un, gfc_expr *init)
10902 : {
10903 21 : gfc_constructor *ctor;
10904 :
10905 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
10906 : return;
10907 :
10908 21 : ctor = gfc_constructor_first (init->value.constructor);
10909 :
10910 21 : if (ctor == NULL || ctor->expr == NULL)
10911 : return;
10912 :
10913 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
10914 :
10915 : /* If we have an 'initialize all' constructor, do it first. */
10916 21 : if (ctor->expr->expr_type == EXPR_NULL)
10917 : {
10918 9 : tree union_type = TREE_TYPE (un->backend_decl);
10919 9 : tree val = build_constructor (union_type, NULL);
10920 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10921 9 : ctor = gfc_constructor_next (ctor);
10922 : }
10923 :
10924 : /* Add the map initializer on top. */
10925 21 : if (ctor != NULL && ctor->expr != NULL)
10926 : {
10927 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
10928 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
10929 12 : TREE_TYPE (un->backend_decl),
10930 12 : un->attr.dimension, un->attr.pointer,
10931 12 : un->attr.proc_pointer);
10932 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10933 : }
10934 : }
10935 :
10936 : /* Build an expression for a constructor. If init is nonzero then
10937 : this is part of a static variable initializer. */
10938 :
10939 : void
10940 39296 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
10941 : {
10942 39296 : gfc_constructor *c;
10943 39296 : gfc_component *cm;
10944 39296 : tree val;
10945 39296 : tree type;
10946 39296 : tree tmp;
10947 39296 : vec<constructor_elt, va_gc> *v = NULL;
10948 :
10949 39296 : gcc_assert (se->ss == NULL);
10950 39296 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10951 39296 : type = gfc_typenode_for_spec (&expr->ts);
10952 :
10953 39296 : if (!init)
10954 : {
10955 16536 : if (IS_PDT (expr) && expr->must_finalize)
10956 276 : final_block = &se->finalblock;
10957 :
10958 : /* Create a temporary variable and fill it in. */
10959 16536 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
10960 : /* The symtree in expr is NULL, if the code to generate is for
10961 : initializing the static members only. */
10962 33072 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
10963 16536 : se->want_coarray);
10964 16536 : gfc_add_expr_to_block (&se->pre, tmp);
10965 16536 : final_block = NULL;
10966 16536 : return;
10967 : }
10968 :
10969 22760 : cm = expr->ts.u.derived->components;
10970 :
10971 22760 : for (c = gfc_constructor_first (expr->value.constructor);
10972 116439 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
10973 : {
10974 : /* Skip absent members in default initializers and allocatable
10975 : components. Although the latter have a default initializer
10976 : of EXPR_NULL,... by default, the static nullify is not needed
10977 : since this is done every time we come into scope. */
10978 102550 : if (!c->expr
10979 91231 : || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)
10980 178577 : || (IS_PDT (cm) && has_parameterized_comps (cm->ts.u.derived)))
10981 8871 : continue;
10982 :
10983 84808 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
10984 49359 : && strcmp (cm->name, "_extends") == 0
10985 1374 : && cm->initializer->symtree)
10986 : {
10987 1374 : tree vtab;
10988 1374 : gfc_symbol *vtabs;
10989 1374 : vtabs = cm->initializer->symtree->n.sym;
10990 1374 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
10991 1374 : vtab = unshare_expr_without_location (vtab);
10992 1374 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
10993 1374 : }
10994 83434 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
10995 : {
10996 9033 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
10997 9033 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10998 : fold_convert (TREE_TYPE (cm->backend_decl),
10999 : val));
11000 9033 : }
11001 74401 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
11002 425 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
11003 : fold_convert (TREE_TYPE (cm->backend_decl),
11004 425 : integer_zero_node));
11005 73976 : else if (cm->ts.type == BT_UNION)
11006 21 : gfc_conv_union_initializer (v, cm, c->expr);
11007 : else
11008 : {
11009 73955 : val = gfc_conv_initializer (c->expr, &cm->ts,
11010 73955 : TREE_TYPE (cm->backend_decl),
11011 73955 : cm->attr.dimension, cm->attr.pointer,
11012 73955 : cm->attr.proc_pointer);
11013 73955 : val = unshare_expr_without_location (val);
11014 :
11015 : /* Append it to the constructor list. */
11016 167634 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
11017 : }
11018 : }
11019 :
11020 22760 : se->expr = build_constructor (type, v);
11021 22760 : if (init)
11022 22760 : TREE_CONSTANT (se->expr) = 1;
11023 : }
11024 :
11025 :
11026 : /* Translate a substring expression. */
11027 :
11028 : static void
11029 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
11030 : {
11031 258 : gfc_ref *ref;
11032 :
11033 258 : ref = expr->ref;
11034 :
11035 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
11036 :
11037 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
11038 258 : expr->value.character.length,
11039 258 : expr->value.character.string);
11040 :
11041 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
11042 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
11043 :
11044 258 : if (ref)
11045 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
11046 258 : }
11047 :
11048 :
11049 : /* Entry point for expression translation. Evaluates a scalar quantity.
11050 : EXPR is the expression to be translated, and SE is the state structure if
11051 : called from within the scalarized. */
11052 :
11053 : void
11054 3706694 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
11055 : {
11056 3706694 : gfc_ss *ss;
11057 :
11058 3706694 : ss = se->ss;
11059 3706694 : if (ss && ss->info->expr == expr
11060 242082 : && (ss->info->type == GFC_SS_SCALAR
11061 : || ss->info->type == GFC_SS_REFERENCE))
11062 : {
11063 40936 : gfc_ss_info *ss_info;
11064 :
11065 40936 : ss_info = ss->info;
11066 : /* Substitute a scalar expression evaluated outside the scalarization
11067 : loop. */
11068 40936 : se->expr = ss_info->data.scalar.value;
11069 40936 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
11070 844 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
11071 :
11072 40936 : se->string_length = ss_info->string_length;
11073 40936 : gfc_advance_se_ss_chain (se);
11074 40936 : return;
11075 : }
11076 :
11077 : /* We need to convert the expressions for the iso_c_binding derived types.
11078 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
11079 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
11080 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
11081 : updated to be an integer with a kind equal to the size of a (void *). */
11082 3665758 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
11083 14938 : && expr->ts.u.derived->attr.is_bind_c)
11084 : {
11085 14029 : if (expr->expr_type == EXPR_VARIABLE
11086 9572 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
11087 9572 : || expr->symtree->n.sym->intmod_sym_id
11088 : == ISOCBINDING_NULL_FUNPTR))
11089 : {
11090 : /* Set expr_type to EXPR_NULL, which will result in
11091 : null_pointer_node being used below. */
11092 0 : expr->expr_type = EXPR_NULL;
11093 : }
11094 : else
11095 : {
11096 : /* Update the type/kind of the expression to be what the new
11097 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
11098 14029 : expr->ts.type = BT_INTEGER;
11099 14029 : expr->ts.f90_type = BT_VOID;
11100 14029 : expr->ts.kind = gfc_index_integer_kind;
11101 : }
11102 : }
11103 :
11104 3665758 : gfc_fix_class_refs (expr);
11105 :
11106 3665758 : switch (expr->expr_type)
11107 : {
11108 512811 : case EXPR_OP:
11109 512811 : gfc_conv_expr_op (se, expr);
11110 512811 : break;
11111 :
11112 159 : case EXPR_CONDITIONAL:
11113 159 : gfc_conv_conditional_expr (se, expr);
11114 159 : break;
11115 :
11116 310940 : case EXPR_FUNCTION:
11117 310940 : gfc_conv_function_expr (se, expr);
11118 310940 : break;
11119 :
11120 1154937 : case EXPR_CONSTANT:
11121 1154937 : gfc_conv_constant (se, expr);
11122 1154937 : break;
11123 :
11124 1629229 : case EXPR_VARIABLE:
11125 1629229 : gfc_conv_variable (se, expr);
11126 1629229 : break;
11127 :
11128 4290 : case EXPR_NULL:
11129 4290 : se->expr = null_pointer_node;
11130 4290 : break;
11131 :
11132 258 : case EXPR_SUBSTRING:
11133 258 : gfc_conv_substring_expr (se, expr);
11134 258 : break;
11135 :
11136 16536 : case EXPR_STRUCTURE:
11137 16536 : gfc_conv_structure (se, expr, 0);
11138 : /* F2008 4.5.6.3 para 5: If an executable construct references a
11139 : structure constructor or array constructor, the entity created by
11140 : the constructor is finalized after execution of the innermost
11141 : executable construct containing the reference. This, in fact,
11142 : was later deleted by the Combined Technical Corrigenda 1 TO 4 for
11143 : fortran 2008 (f08/0011). */
11144 16536 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
11145 16536 : && !(gfc_option.allow_std & GFC_STD_GNU)
11146 139 : && expr->must_finalize
11147 16548 : && gfc_may_be_finalized (expr->ts))
11148 : {
11149 12 : locus loc;
11150 12 : gfc_locus_from_location (&loc, input_location);
11151 12 : gfc_warning (0, "The structure constructor at %L has been"
11152 : " finalized. This feature was removed by f08/0011."
11153 : " Use -std=f2018 or -std=gnu to eliminate the"
11154 : " finalization.", &loc);
11155 12 : symbol_attribute attr;
11156 12 : attr.allocatable = attr.pointer = 0;
11157 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
11158 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
11159 : }
11160 : break;
11161 :
11162 36598 : case EXPR_ARRAY:
11163 36598 : gfc_conv_array_constructor_expr (se, expr);
11164 36598 : gfc_add_block_to_block (&se->post, &se->finalblock);
11165 36598 : break;
11166 :
11167 0 : default:
11168 0 : gcc_unreachable ();
11169 3706694 : break;
11170 : }
11171 : }
11172 :
11173 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
11174 : of an assignment. */
11175 : void
11176 379709 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
11177 : {
11178 379709 : gfc_conv_expr (se, expr);
11179 : /* All numeric lvalues should have empty post chains. If not we need to
11180 : figure out a way of rewriting an lvalue so that it has no post chain. */
11181 379709 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
11182 379709 : }
11183 :
11184 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
11185 : numeric expressions. Used for scalar values where inserting cleanup code
11186 : is inconvenient. */
11187 : void
11188 1049475 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
11189 : {
11190 1049475 : tree val;
11191 :
11192 1049475 : gcc_assert (expr->ts.type != BT_CHARACTER);
11193 1049475 : gfc_conv_expr (se, expr);
11194 1049475 : if (se->post.head)
11195 : {
11196 2565 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
11197 2565 : gfc_add_modify (&se->pre, val, se->expr);
11198 2565 : se->expr = val;
11199 2565 : gfc_add_block_to_block (&se->pre, &se->post);
11200 : }
11201 1049475 : }
11202 :
11203 : /* Helper to translate an expression and convert it to a particular type. */
11204 : void
11205 298054 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
11206 : {
11207 298054 : gfc_conv_expr_val (se, expr);
11208 298054 : se->expr = convert (type, se->expr);
11209 298054 : }
11210 :
11211 :
11212 : /* Converts an expression so that it can be passed by reference. Scalar
11213 : values only. */
11214 :
11215 : void
11216 230384 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
11217 : {
11218 230384 : gfc_ss *ss;
11219 230384 : tree var;
11220 :
11221 230384 : ss = se->ss;
11222 230384 : if (ss && ss->info->expr == expr
11223 8053 : && ss->info->type == GFC_SS_REFERENCE)
11224 : {
11225 : /* Returns a reference to the scalar evaluated outside the loop
11226 : for this case. */
11227 907 : gfc_conv_expr (se, expr);
11228 :
11229 907 : if (expr->ts.type == BT_CHARACTER
11230 114 : && expr->expr_type != EXPR_FUNCTION)
11231 102 : gfc_conv_string_parameter (se);
11232 : else
11233 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11234 :
11235 : return;
11236 : }
11237 :
11238 229477 : if (expr->ts.type == BT_CHARACTER)
11239 : {
11240 49959 : gfc_conv_expr (se, expr);
11241 49959 : gfc_conv_string_parameter (se);
11242 49959 : return;
11243 : }
11244 :
11245 179518 : if (expr->expr_type == EXPR_VARIABLE)
11246 : {
11247 71636 : se->want_pointer = 1;
11248 71636 : gfc_conv_expr (se, expr);
11249 71636 : if (se->post.head)
11250 : {
11251 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11252 0 : gfc_add_modify (&se->pre, var, se->expr);
11253 0 : gfc_add_block_to_block (&se->pre, &se->post);
11254 0 : se->expr = var;
11255 : }
11256 : return;
11257 : }
11258 :
11259 107882 : if (expr->expr_type == EXPR_CONDITIONAL)
11260 : {
11261 18 : se->want_pointer = 1;
11262 18 : gfc_conv_expr (se, expr);
11263 18 : return;
11264 : }
11265 :
11266 107864 : if (expr->expr_type == EXPR_FUNCTION
11267 13858 : && ((expr->value.function.esym
11268 2107 : && expr->value.function.esym->result
11269 2106 : && expr->value.function.esym->result->attr.pointer
11270 83 : && !expr->value.function.esym->result->attr.dimension)
11271 13781 : || (!expr->value.function.esym && !expr->ref
11272 11645 : && expr->symtree->n.sym->attr.pointer
11273 0 : && !expr->symtree->n.sym->attr.dimension)))
11274 : {
11275 77 : se->want_pointer = 1;
11276 77 : gfc_conv_expr (se, expr);
11277 77 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11278 77 : gfc_add_modify (&se->pre, var, se->expr);
11279 77 : se->expr = var;
11280 77 : return;
11281 : }
11282 :
11283 107787 : gfc_conv_expr (se, expr);
11284 :
11285 : /* Create a temporary var to hold the value. */
11286 107787 : if (TREE_CONSTANT (se->expr))
11287 : {
11288 : tree tmp = se->expr;
11289 85328 : STRIP_TYPE_NOPS (tmp);
11290 85328 : var = build_decl (input_location,
11291 85328 : CONST_DECL, NULL, TREE_TYPE (tmp));
11292 85328 : DECL_INITIAL (var) = tmp;
11293 85328 : TREE_STATIC (var) = 1;
11294 85328 : pushdecl (var);
11295 : }
11296 : else
11297 : {
11298 22459 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11299 22459 : gfc_add_modify (&se->pre, var, se->expr);
11300 : }
11301 :
11302 107787 : if (!expr->must_finalize)
11303 107691 : gfc_add_block_to_block (&se->pre, &se->post);
11304 :
11305 : /* Take the address of that value. */
11306 107787 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
11307 : }
11308 :
11309 :
11310 : /* Get the _len component for an unlimited polymorphic expression. */
11311 :
11312 : static tree
11313 1902 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
11314 : {
11315 1902 : gfc_se se;
11316 1902 : gfc_ref *ref = expr->ref;
11317 :
11318 1902 : gfc_init_se (&se, NULL);
11319 3918 : while (ref && ref->next)
11320 : ref = ref->next;
11321 1902 : gfc_add_len_component (expr);
11322 1902 : gfc_conv_expr (&se, expr);
11323 1902 : gfc_add_block_to_block (block, &se.pre);
11324 1902 : gcc_assert (se.post.head == NULL_TREE);
11325 1902 : if (ref)
11326 : {
11327 292 : gfc_free_ref_list (ref->next);
11328 292 : ref->next = NULL;
11329 : }
11330 : else
11331 : {
11332 1610 : gfc_free_ref_list (expr->ref);
11333 1610 : expr->ref = NULL;
11334 : }
11335 1902 : return se.expr;
11336 : }
11337 :
11338 :
11339 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
11340 : statement-list outside of the scalarizer-loop. When code is generated, that
11341 : depends on the scalarized expression, it is added to RSE.PRE.
11342 : Returns le's _vptr tree and when set the len expressions in to_lenp and
11343 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
11344 : expression. */
11345 :
11346 : static tree
11347 4734 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
11348 : gfc_expr * re, gfc_se *rse,
11349 : tree * to_lenp, tree * from_lenp,
11350 : tree * from_vptrp)
11351 : {
11352 4734 : gfc_se se;
11353 4734 : gfc_expr * vptr_expr;
11354 4734 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
11355 4734 : bool set_vptr = false, temp_rhs = false;
11356 4734 : stmtblock_t *pre = block;
11357 4734 : tree class_expr = NULL_TREE;
11358 4734 : tree from_vptr = NULL_TREE;
11359 :
11360 : /* Create a temporary for complicated expressions. */
11361 4734 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
11362 1323 : && rse->expr != NULL_TREE)
11363 : {
11364 1323 : if (!DECL_P (rse->expr))
11365 : {
11366 404 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11367 37 : class_expr = gfc_get_class_from_expr (rse->expr);
11368 :
11369 404 : if (rse->loop)
11370 159 : pre = &rse->loop->pre;
11371 : else
11372 245 : pre = &rse->pre;
11373 :
11374 404 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
11375 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
11376 : else
11377 367 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
11378 :
11379 404 : rse->expr = tmp;
11380 : }
11381 : else
11382 919 : pre = &rse->pre;
11383 :
11384 : temp_rhs = true;
11385 : }
11386 :
11387 : /* Get the _vptr for the left-hand side expression. */
11388 4734 : gfc_init_se (&se, NULL);
11389 4734 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
11390 4734 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
11391 : {
11392 : /* Care about _len for unlimited polymorphic entities. */
11393 4734 : if (UNLIMITED_POLY (vptr_expr)
11394 3666 : || (vptr_expr->ts.type == BT_DERIVED
11395 2539 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11396 1570 : to_len = trans_get_upoly_len (block, vptr_expr);
11397 4734 : gfc_add_vptr_component (vptr_expr);
11398 4734 : set_vptr = true;
11399 : }
11400 : else
11401 0 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11402 4734 : se.want_pointer = 1;
11403 4734 : gfc_conv_expr (&se, vptr_expr);
11404 4734 : gfc_free_expr (vptr_expr);
11405 4734 : gfc_add_block_to_block (block, &se.pre);
11406 4734 : gcc_assert (se.post.head == NULL_TREE);
11407 4734 : lhs_vptr = se.expr;
11408 4734 : STRIP_NOPS (lhs_vptr);
11409 :
11410 : /* Set the _vptr only when the left-hand side of the assignment is a
11411 : class-object. */
11412 4734 : if (set_vptr)
11413 : {
11414 : /* Get the vptr from the rhs expression only, when it is variable.
11415 : Functions are expected to be assigned to a temporary beforehand. */
11416 3282 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
11417 5624 : ? gfc_find_and_cut_at_last_class_ref (re)
11418 : : NULL;
11419 890 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
11420 : {
11421 890 : if (to_len != NULL_TREE)
11422 : {
11423 : /* Get the _len information from the rhs. */
11424 347 : if (UNLIMITED_POLY (vptr_expr)
11425 : || (vptr_expr->ts.type == BT_DERIVED
11426 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11427 320 : from_len = trans_get_upoly_len (block, vptr_expr);
11428 : }
11429 890 : gfc_add_vptr_component (vptr_expr);
11430 : }
11431 : else
11432 : {
11433 3844 : if (re->expr_type == EXPR_VARIABLE
11434 2392 : && DECL_P (re->symtree->n.sym->backend_decl)
11435 2392 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
11436 834 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
11437 3911 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
11438 : re->symtree->n.sym->backend_decl))))
11439 : {
11440 43 : vptr_expr = NULL;
11441 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
11442 : re->symtree->n.sym->backend_decl));
11443 43 : if (to_len && UNLIMITED_POLY (re))
11444 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
11445 : re->symtree->n.sym->backend_decl));
11446 : }
11447 3801 : else if (temp_rhs && re->ts.type == BT_CLASS)
11448 : {
11449 239 : vptr_expr = NULL;
11450 239 : if (class_expr)
11451 : tmp = class_expr;
11452 202 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11453 0 : tmp = gfc_get_class_from_expr (rse->expr);
11454 : else
11455 : tmp = rse->expr;
11456 :
11457 239 : se.expr = gfc_class_vptr_get (tmp);
11458 239 : from_vptr = se.expr;
11459 239 : if (UNLIMITED_POLY (re))
11460 80 : from_len = gfc_class_len_get (tmp);
11461 :
11462 : }
11463 3562 : else if (re->expr_type != EXPR_NULL)
11464 : /* Only when rhs is non-NULL use its declared type for vptr
11465 : initialisation. */
11466 3433 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
11467 : else
11468 : /* When the rhs is NULL use the vtab of lhs' declared type. */
11469 129 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11470 : }
11471 :
11472 4532 : if (vptr_expr)
11473 : {
11474 4452 : gfc_init_se (&se, NULL);
11475 4452 : se.want_pointer = 1;
11476 4452 : gfc_conv_expr (&se, vptr_expr);
11477 4452 : gfc_free_expr (vptr_expr);
11478 4452 : gfc_add_block_to_block (block, &se.pre);
11479 4452 : gcc_assert (se.post.head == NULL_TREE);
11480 4452 : from_vptr = se.expr;
11481 : }
11482 4734 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
11483 : se.expr));
11484 :
11485 4734 : if (to_len != NULL_TREE)
11486 : {
11487 : /* The _len component needs to be set. Figure how to get the
11488 : value of the right-hand side. */
11489 1570 : if (from_len == NULL_TREE)
11490 : {
11491 1170 : if (rse->string_length != NULL_TREE)
11492 : from_len = rse->string_length;
11493 712 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
11494 : {
11495 0 : gfc_init_se (&se, NULL);
11496 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
11497 0 : gfc_add_block_to_block (block, &se.pre);
11498 0 : gcc_assert (se.post.head == NULL_TREE);
11499 0 : from_len = gfc_evaluate_now (se.expr, block);
11500 : }
11501 : else
11502 712 : from_len = build_zero_cst (gfc_charlen_type_node);
11503 : }
11504 1570 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
11505 : from_len));
11506 : }
11507 : }
11508 :
11509 : /* Return the _len and _vptr trees only, when requested. */
11510 4734 : if (to_lenp)
11511 3476 : *to_lenp = to_len;
11512 4734 : if (from_lenp)
11513 3476 : *from_lenp = from_len;
11514 4734 : if (from_vptrp)
11515 3476 : *from_vptrp = from_vptr;
11516 4734 : return lhs_vptr;
11517 : }
11518 :
11519 :
11520 : /* Assign tokens for pointer components. */
11521 :
11522 : static void
11523 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11524 : gfc_expr *expr2)
11525 : {
11526 12 : symbol_attribute lhs_attr, rhs_attr;
11527 12 : tree tmp, lhs_tok, rhs_tok;
11528 : /* Flag to indicated component refs on the rhs. */
11529 12 : bool rhs_cr;
11530 :
11531 12 : lhs_attr = gfc_caf_attr (expr1);
11532 12 : if (expr2->expr_type != EXPR_NULL)
11533 : {
11534 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11535 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11536 : {
11537 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11538 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11539 :
11540 4 : if (rhs_cr)
11541 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11542 : else
11543 : {
11544 4 : tree caf_decl;
11545 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11546 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11547 : NULL_TREE, NULL);
11548 : }
11549 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11550 : lhs_tok,
11551 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11552 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11553 : }
11554 : }
11555 4 : else if (lhs_attr.codimension)
11556 : {
11557 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11558 4 : if (!lhs_tok)
11559 : {
11560 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11561 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11562 : }
11563 : else
11564 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11565 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11566 : lhs_tok, null_pointer_node);
11567 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11568 : }
11569 12 : }
11570 :
11571 :
11572 : /* Do everything that is needed for a CLASS function expr2. */
11573 :
11574 : static tree
11575 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11576 : gfc_expr *expr1, gfc_expr *expr2)
11577 : {
11578 18 : tree expr1_vptr = NULL_TREE;
11579 18 : tree tmp;
11580 :
11581 18 : gfc_conv_function_expr (rse, expr2);
11582 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11583 :
11584 18 : if (expr1->ts.type != BT_CLASS)
11585 12 : rse->expr = gfc_class_data_get (rse->expr);
11586 : else
11587 : {
11588 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11589 : expr2, rse,
11590 : NULL, NULL, NULL);
11591 6 : gfc_add_block_to_block (block, &rse->pre);
11592 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11593 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11594 :
11595 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11596 6 : fold_convert (TREE_TYPE (expr1_vptr),
11597 : gfc_class_vptr_get (tmp)));
11598 6 : rse->expr = gfc_class_data_get (tmp);
11599 : }
11600 :
11601 18 : return expr1_vptr;
11602 : }
11603 :
11604 :
11605 : tree
11606 10307 : gfc_trans_pointer_assign (gfc_code * code)
11607 : {
11608 10307 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11609 : }
11610 :
11611 :
11612 : /* Generate code for a pointer assignment. */
11613 :
11614 : tree
11615 10362 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11616 : {
11617 10362 : gfc_se lse;
11618 10362 : gfc_se rse;
11619 10362 : stmtblock_t block;
11620 10362 : tree desc;
11621 10362 : tree tmp;
11622 10362 : tree expr1_vptr = NULL_TREE;
11623 10362 : bool scalar, non_proc_ptr_assign;
11624 10362 : gfc_ss *ss;
11625 :
11626 10362 : gfc_start_block (&block);
11627 :
11628 10362 : gfc_init_se (&lse, NULL);
11629 :
11630 : /* Usually testing whether this is not a proc pointer assignment. */
11631 10362 : non_proc_ptr_assign
11632 10362 : = !(gfc_expr_attr (expr1).proc_pointer
11633 1213 : && ((expr2->expr_type == EXPR_VARIABLE
11634 981 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11635 282 : || expr2->expr_type == EXPR_NULL));
11636 :
11637 : /* Check whether the expression is a scalar or not; we cannot use
11638 : expr1->rank as it can be nonzero for proc pointers. */
11639 10362 : ss = gfc_walk_expr (expr1);
11640 10362 : scalar = ss == gfc_ss_terminator;
11641 10362 : if (!scalar)
11642 4492 : gfc_free_ss_chain (ss);
11643 :
11644 10362 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11645 96 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11646 : {
11647 72 : gfc_add_data_component (expr2);
11648 : /* The following is required as gfc_add_data_component doesn't
11649 : update ts.type if there is a trailing REF_ARRAY. */
11650 72 : expr2->ts.type = BT_DERIVED;
11651 : }
11652 :
11653 10362 : if (scalar)
11654 : {
11655 : /* Scalar pointers. */
11656 5870 : lse.want_pointer = 1;
11657 5870 : gfc_conv_expr (&lse, expr1);
11658 5870 : gfc_init_se (&rse, NULL);
11659 5870 : rse.want_pointer = 1;
11660 5870 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11661 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11662 : else
11663 5864 : gfc_conv_expr (&rse, expr2);
11664 :
11665 5870 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11666 : {
11667 769 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11668 : NULL, NULL);
11669 769 : lse.expr = gfc_class_data_get (lse.expr);
11670 : }
11671 :
11672 5870 : if (expr1->symtree->n.sym->attr.proc_pointer
11673 863 : && expr1->symtree->n.sym->attr.dummy)
11674 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11675 : lse.expr);
11676 :
11677 5870 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11678 47 : && expr2->symtree->n.sym->attr.dummy)
11679 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11680 : rse.expr);
11681 :
11682 5870 : gfc_add_block_to_block (&block, &lse.pre);
11683 5870 : gfc_add_block_to_block (&block, &rse.pre);
11684 :
11685 : /* Check character lengths if character expression. The test is only
11686 : really added if -fbounds-check is enabled. Exclude deferred
11687 : character length lefthand sides. */
11688 960 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11689 786 : && !expr1->ts.deferred
11690 371 : && !expr1->symtree->n.sym->attr.proc_pointer
11691 6234 : && !gfc_is_proc_ptr_comp (expr1))
11692 : {
11693 345 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11694 345 : gcc_assert (lse.string_length && rse.string_length);
11695 345 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11696 : lse.string_length, rse.string_length,
11697 : &block);
11698 : }
11699 :
11700 : /* The assignment to an deferred character length sets the string
11701 : length to that of the rhs. */
11702 5870 : if (expr1->ts.deferred)
11703 : {
11704 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11705 413 : gfc_add_modify (&block, lse.string_length,
11706 413 : fold_convert (TREE_TYPE (lse.string_length),
11707 : rse.string_length));
11708 117 : else if (lse.string_length != NULL)
11709 115 : gfc_add_modify (&block, lse.string_length,
11710 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11711 : }
11712 :
11713 5870 : gfc_add_modify (&block, lse.expr,
11714 5870 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11715 :
11716 5870 : if (flag_coarray == GFC_FCOARRAY_LIB)
11717 : {
11718 342 : if (expr1->ref)
11719 : /* Also set the tokens for pointer components in derived typed
11720 : coarrays. */
11721 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11722 330 : else if (gfc_caf_attr (expr1).codimension)
11723 : {
11724 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11725 :
11726 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11727 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11728 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11729 : NULL_TREE, expr1);
11730 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11731 : NULL_TREE, expr2);
11732 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11733 : }
11734 : }
11735 :
11736 5870 : gfc_add_block_to_block (&block, &rse.post);
11737 5870 : gfc_add_block_to_block (&block, &lse.post);
11738 : }
11739 : else
11740 : {
11741 4492 : gfc_ref* remap;
11742 4492 : bool rank_remap;
11743 4492 : tree strlen_lhs;
11744 4492 : tree strlen_rhs = NULL_TREE;
11745 :
11746 : /* Array pointer. Find the last reference on the LHS and if it is an
11747 : array section ref, we're dealing with bounds remapping. In this case,
11748 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11749 : not see it and process the bounds remapping afterwards explicitly. */
11750 10004 : for (remap = expr1->ref; remap; remap = remap->next)
11751 5891 : if (!remap->next && remap->type == REF_ARRAY
11752 4492 : && remap->u.ar.type == AR_SECTION)
11753 : break;
11754 4492 : rank_remap = (remap && remap->u.ar.end[0]);
11755 :
11756 379 : if (remap && expr2->expr_type == EXPR_NULL)
11757 : {
11758 2 : gfc_error ("If bounds remapping is specified at %L, "
11759 : "the pointer target shall not be NULL", &expr1->where);
11760 2 : return NULL_TREE;
11761 : }
11762 :
11763 4490 : gfc_init_se (&lse, NULL);
11764 4490 : if (remap)
11765 377 : lse.descriptor_only = 1;
11766 4490 : gfc_conv_expr_descriptor (&lse, expr1);
11767 4490 : strlen_lhs = lse.string_length;
11768 4490 : desc = lse.expr;
11769 :
11770 4490 : if (expr2->expr_type == EXPR_NULL)
11771 : {
11772 : /* Just set the data pointer to null. */
11773 692 : gfc_nullify_descriptor (&lse.pre, lse.expr);
11774 : }
11775 3798 : else if (rank_remap)
11776 : {
11777 : /* If we are rank-remapping, just get the RHS's descriptor and
11778 : process this later on. */
11779 254 : gfc_init_se (&rse, NULL);
11780 254 : rse.direct_byref = 1;
11781 254 : rse.byref_noassign = 1;
11782 :
11783 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11784 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11785 : expr1, expr2);
11786 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11787 : {
11788 : tree bound[GFC_MAX_DIMENSIONS];
11789 : int i;
11790 :
11791 26 : for (i = 0; i < expr2->rank; i++)
11792 13 : bound[i] = NULL_TREE;
11793 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11794 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11795 : bound, bound, 0,
11796 : GFC_ARRAY_POINTER_CONT, false);
11797 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11798 13 : rse.descriptor_only = 0;
11799 13 : rse.expr = tmp;
11800 13 : rse.direct_byref = 1;
11801 13 : gfc_conv_expr_descriptor (&rse, expr2);
11802 13 : strlen_rhs = rse.string_length;
11803 13 : rse.expr = tmp;
11804 : }
11805 : else
11806 : {
11807 229 : gfc_conv_expr_descriptor (&rse, expr2);
11808 229 : strlen_rhs = rse.string_length;
11809 229 : if (expr1->ts.type == BT_CLASS)
11810 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11811 : expr2, &rse,
11812 : NULL, NULL,
11813 : NULL);
11814 : }
11815 : }
11816 3544 : else if (expr2->expr_type == EXPR_VARIABLE)
11817 : {
11818 : /* Assign directly to the LHS's descriptor. */
11819 3412 : lse.descriptor_only = 0;
11820 3412 : lse.direct_byref = 1;
11821 3412 : gfc_conv_expr_descriptor (&lse, expr2);
11822 3412 : strlen_rhs = lse.string_length;
11823 3412 : gfc_init_se (&rse, NULL);
11824 :
11825 3412 : if (expr1->ts.type == BT_CLASS)
11826 : {
11827 410 : rse.expr = NULL_TREE;
11828 410 : rse.string_length = strlen_rhs;
11829 410 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11830 : NULL, NULL, NULL);
11831 : }
11832 :
11833 3412 : if (remap == NULL)
11834 : {
11835 : /* If the target is not a whole array, use the target array
11836 : reference for remap. */
11837 7003 : for (remap = expr2->ref; remap; remap = remap->next)
11838 3894 : if (remap->type == REF_ARRAY
11839 3349 : && remap->u.ar.type == AR_FULL
11840 2650 : && remap->next)
11841 : break;
11842 : }
11843 : }
11844 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11845 : {
11846 25 : gfc_init_se (&rse, NULL);
11847 25 : rse.want_pointer = 1;
11848 25 : gfc_conv_function_expr (&rse, expr2);
11849 25 : if (expr1->ts.type != BT_CLASS)
11850 : {
11851 12 : rse.expr = gfc_class_data_get (rse.expr);
11852 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11853 : }
11854 : else
11855 : {
11856 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11857 : expr2, &rse, NULL,
11858 : NULL, NULL);
11859 13 : gfc_add_block_to_block (&block, &rse.pre);
11860 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11861 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11862 :
11863 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11864 13 : fold_convert (TREE_TYPE (expr1_vptr),
11865 : gfc_class_vptr_get (tmp)));
11866 13 : rse.expr = gfc_class_data_get (tmp);
11867 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11868 : }
11869 : }
11870 : else
11871 : {
11872 : /* Assign to a temporary descriptor and then copy that
11873 : temporary to the pointer. */
11874 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11875 107 : lse.descriptor_only = 0;
11876 107 : lse.expr = tmp;
11877 107 : lse.direct_byref = 1;
11878 107 : gfc_conv_expr_descriptor (&lse, expr2);
11879 107 : strlen_rhs = lse.string_length;
11880 107 : gfc_add_modify (&lse.pre, desc, tmp);
11881 : }
11882 :
11883 4490 : if (expr1->ts.type == BT_CHARACTER
11884 596 : && expr1->ts.deferred)
11885 : {
11886 338 : gfc_symbol *psym = expr1->symtree->n.sym;
11887 338 : tmp = NULL_TREE;
11888 338 : if (psym->ts.type == BT_CHARACTER
11889 337 : && psym->ts.u.cl->backend_decl)
11890 337 : tmp = psym->ts.u.cl->backend_decl;
11891 1 : else if (expr1->ts.u.cl->backend_decl
11892 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11893 0 : tmp = expr1->ts.u.cl->backend_decl;
11894 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11895 : {
11896 1 : gfc_ref *ref = expr1->ref;
11897 3 : for (;ref; ref = ref->next)
11898 : {
11899 2 : if (ref->type == REF_COMPONENT
11900 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11901 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11902 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11903 1 : TREE_TYPE (tmp),
11904 1 : TREE_OPERAND (lse.expr, 0),
11905 : tmp, NULL_TREE);
11906 : }
11907 : }
11908 :
11909 338 : gcc_assert (tmp);
11910 :
11911 338 : if (expr2->expr_type != EXPR_NULL)
11912 326 : gfc_add_modify (&block, tmp,
11913 326 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
11914 : else
11915 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
11916 : }
11917 :
11918 4490 : gfc_add_block_to_block (&block, &lse.pre);
11919 4490 : if (rank_remap)
11920 254 : gfc_add_block_to_block (&block, &rse.pre);
11921 :
11922 : /* If we do bounds remapping, update LHS descriptor accordingly. */
11923 4490 : if (remap)
11924 : {
11925 557 : int dim;
11926 557 : gcc_assert (remap->u.ar.dimen == expr1->rank);
11927 :
11928 : /* Always set dtype. */
11929 557 : gfc_conv_descriptor_dtype_set (&block, desc,
11930 557 : gfc_get_dtype (TREE_TYPE (desc)));
11931 :
11932 : /* For unlimited polymorphic LHS use elem_len from RHS. */
11933 557 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11934 : {
11935 60 : tree elem_len;
11936 60 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11937 60 : elem_len = fold_convert (gfc_array_index_type, tmp);
11938 60 : elem_len = gfc_evaluate_now (elem_len, &block);
11939 60 : gfc_conv_descriptor_elem_len_set (&block, desc, elem_len);
11940 : }
11941 :
11942 557 : if (rank_remap)
11943 : {
11944 : /* Do rank remapping. We already have the RHS's descriptor
11945 : converted in rse and now have to build the correct LHS
11946 : descriptor for it. */
11947 :
11948 254 : tree data, span;
11949 254 : tree offs, stride;
11950 254 : tree lbound, ubound;
11951 :
11952 : /* Copy data pointer. */
11953 254 : data = gfc_conv_descriptor_data_get (rse.expr);
11954 254 : gfc_conv_descriptor_data_set (&block, desc, data);
11955 :
11956 : /* Copy the span. */
11957 254 : if (VAR_P (rse.expr)
11958 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
11959 12 : span = gfc_conv_descriptor_span_get (rse.expr);
11960 : else
11961 : {
11962 242 : tmp = TREE_TYPE (rse.expr);
11963 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
11964 242 : span = fold_convert (gfc_array_index_type, tmp);
11965 : }
11966 254 : gfc_conv_descriptor_span_set (&block, desc, span);
11967 :
11968 : /* Copy offset but adjust it such that it would correspond
11969 : to a lbound of zero. */
11970 254 : if (expr2->rank == -1)
11971 42 : gfc_conv_descriptor_offset_set (&block, desc,
11972 : gfc_index_zero_node);
11973 : else
11974 : {
11975 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
11976 654 : for (dim = 0; dim < expr2->rank; ++dim)
11977 : {
11978 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11979 : gfc_rank_cst[dim]);
11980 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
11981 : gfc_rank_cst[dim]);
11982 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11983 : gfc_array_index_type, stride,
11984 : lbound);
11985 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
11986 : gfc_array_index_type, offs, tmp);
11987 : }
11988 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11989 : }
11990 : /* Set the bounds as declared for the LHS and calculate strides as
11991 : well as another offset update accordingly. */
11992 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11993 : gfc_rank_cst[0]);
11994 895 : for (dim = 0; dim < expr1->rank; ++dim)
11995 : {
11996 387 : gfc_se lower_se;
11997 387 : gfc_se upper_se;
11998 :
11999 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
12000 :
12001 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
12002 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
12003 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
12004 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
12005 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
12006 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
12007 :
12008 : /* Convert declared bounds. */
12009 387 : gfc_init_se (&lower_se, NULL);
12010 387 : gfc_init_se (&upper_se, NULL);
12011 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
12012 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
12013 :
12014 387 : gfc_add_block_to_block (&block, &lower_se.pre);
12015 387 : gfc_add_block_to_block (&block, &upper_se.pre);
12016 :
12017 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
12018 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
12019 :
12020 387 : lbound = gfc_evaluate_now (lbound, &block);
12021 387 : ubound = gfc_evaluate_now (ubound, &block);
12022 :
12023 387 : gfc_add_block_to_block (&block, &lower_se.post);
12024 387 : gfc_add_block_to_block (&block, &upper_se.post);
12025 :
12026 : /* Set bounds in descriptor. */
12027 387 : gfc_conv_descriptor_lbound_set (&block, desc,
12028 : gfc_rank_cst[dim], lbound);
12029 387 : gfc_conv_descriptor_ubound_set (&block, desc,
12030 : gfc_rank_cst[dim], ubound);
12031 :
12032 : /* Set stride. */
12033 387 : stride = gfc_evaluate_now (stride, &block);
12034 387 : gfc_conv_descriptor_stride_set (&block, desc,
12035 : gfc_rank_cst[dim], stride);
12036 :
12037 : /* Update offset. */
12038 387 : offs = gfc_conv_descriptor_offset_get (desc);
12039 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12040 : gfc_array_index_type, lbound, stride);
12041 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
12042 : gfc_array_index_type, offs, tmp);
12043 387 : offs = gfc_evaluate_now (offs, &block);
12044 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
12045 :
12046 : /* Update stride. */
12047 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
12048 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
12049 : gfc_array_index_type, stride, tmp);
12050 : }
12051 : }
12052 : else
12053 : {
12054 : /* Bounds remapping. Just shift the lower bounds. */
12055 :
12056 303 : gcc_assert (expr1->rank == expr2->rank);
12057 :
12058 714 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
12059 : {
12060 411 : gfc_se lbound_se;
12061 :
12062 411 : gcc_assert (!remap->u.ar.end[dim]);
12063 411 : gfc_init_se (&lbound_se, NULL);
12064 411 : if (remap->u.ar.start[dim])
12065 : {
12066 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
12067 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
12068 : }
12069 : else
12070 : /* This remap arises from a target that is not a whole
12071 : array. The start expressions will be NULL but we need
12072 : the lbounds to be one. */
12073 186 : lbound_se.expr = gfc_index_one_node;
12074 411 : gfc_conv_shift_descriptor_lbound (&block, desc,
12075 : dim, lbound_se.expr);
12076 411 : gfc_add_block_to_block (&block, &lbound_se.post);
12077 : }
12078 : }
12079 : }
12080 :
12081 : /* If rank remapping was done, check with -fcheck=bounds that
12082 : the target is at least as large as the pointer. */
12083 4490 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
12084 72 : && expr2->rank != -1)
12085 : {
12086 54 : tree lsize, rsize;
12087 54 : tree fault;
12088 54 : const char* msg;
12089 :
12090 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
12091 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
12092 :
12093 54 : lsize = gfc_evaluate_now (lsize, &block);
12094 54 : rsize = gfc_evaluate_now (rsize, &block);
12095 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
12096 : rsize, lsize);
12097 :
12098 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
12099 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
12100 : msg, rsize, lsize);
12101 : }
12102 :
12103 : /* Check string lengths if applicable. The check is only really added
12104 : to the output code if -fbounds-check is enabled. */
12105 4490 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
12106 : {
12107 530 : gcc_assert (expr2->ts.type == BT_CHARACTER);
12108 530 : gcc_assert (strlen_lhs && strlen_rhs);
12109 530 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
12110 : strlen_lhs, strlen_rhs, &block);
12111 : }
12112 :
12113 4490 : gfc_add_block_to_block (&block, &lse.post);
12114 4490 : if (rank_remap)
12115 254 : gfc_add_block_to_block (&block, &rse.post);
12116 : }
12117 :
12118 10360 : return gfc_finish_block (&block);
12119 : }
12120 :
12121 :
12122 : /* Makes sure se is suitable for passing as a function string parameter. */
12123 : /* TODO: Need to check all callers of this function. It may be abused. */
12124 :
12125 : void
12126 249162 : gfc_conv_string_parameter (gfc_se * se)
12127 : {
12128 249162 : tree type;
12129 :
12130 249162 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
12131 249162 : && integer_onep (se->string_length))
12132 : {
12133 691 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
12134 691 : return;
12135 : }
12136 :
12137 248471 : if (TREE_CODE (se->expr) == STRING_CST)
12138 : {
12139 103734 : type = TREE_TYPE (TREE_TYPE (se->expr));
12140 103734 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
12141 103734 : return;
12142 : }
12143 :
12144 144737 : if (TREE_CODE (se->expr) == COND_EXPR)
12145 : {
12146 478 : tree cond = TREE_OPERAND (se->expr, 0);
12147 478 : tree lhs = TREE_OPERAND (se->expr, 1);
12148 478 : tree rhs = TREE_OPERAND (se->expr, 2);
12149 :
12150 478 : gfc_se lse, rse;
12151 478 : gfc_init_se (&lse, NULL);
12152 478 : gfc_init_se (&rse, NULL);
12153 :
12154 478 : lse.expr = lhs;
12155 478 : lse.string_length = se->string_length;
12156 478 : gfc_conv_string_parameter (&lse);
12157 :
12158 478 : rse.expr = rhs;
12159 478 : rse.string_length = se->string_length;
12160 478 : gfc_conv_string_parameter (&rse);
12161 :
12162 478 : se->expr
12163 478 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
12164 : cond, lse.expr, rse.expr);
12165 : }
12166 :
12167 144737 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
12168 47030 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
12169 145112 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
12170 : {
12171 98082 : type = TREE_TYPE (se->expr);
12172 98082 : if (TREE_CODE (se->expr) != INDIRECT_REF)
12173 83271 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
12174 : else
12175 : {
12176 14811 : if (TREE_CODE (type) == ARRAY_TYPE)
12177 14532 : type = TREE_TYPE (type);
12178 14811 : type = gfc_get_character_type_len_for_eltype (type,
12179 : se->string_length);
12180 14811 : type = build_pointer_type (type);
12181 14811 : se->expr = gfc_build_addr_expr (type, se->expr);
12182 : }
12183 : }
12184 :
12185 144737 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
12186 : }
12187 :
12188 :
12189 : /* Generate code for assignment of scalar variables. Includes character
12190 : strings and derived types with allocatable components.
12191 : If you know that the LHS has no allocations, set dealloc to false.
12192 :
12193 : DEEP_COPY has no effect if the typespec TS is not a derived type with
12194 : allocatable components. Otherwise, if it is set, an explicit copy of each
12195 : allocatable component is made. This is necessary as a simple copy of the
12196 : whole object would copy array descriptors as is, so that the lhs's
12197 : allocatable components would point to the rhs's after the assignment.
12198 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
12199 : necessary if the rhs is a non-pointer function, as the allocatable components
12200 : are not accessible by other means than the function's result after the
12201 : function has returned. It is even more subtle when temporaries are involved,
12202 : as the two following examples show:
12203 : 1. When we evaluate an array constructor, a temporary is created. Thus
12204 : there is theoretically no alias possible. However, no deep copy is
12205 : made for this temporary, so that if the constructor is made of one or
12206 : more variable with allocatable components, those components still point
12207 : to the variable's: DEEP_COPY should be set for the assignment from the
12208 : temporary to the lhs in that case.
12209 : 2. When assigning a scalar to an array, we evaluate the scalar value out
12210 : of the loop, store it into a temporary variable, and assign from that.
12211 : In that case, deep copying when assigning to the temporary would be a
12212 : waste of resources; however deep copies should happen when assigning from
12213 : the temporary to each array element: again DEEP_COPY should be set for
12214 : the assignment from the temporary to the lhs. */
12215 :
12216 : tree
12217 344136 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
12218 : bool deep_copy, bool dealloc, bool in_coarray,
12219 : bool assoc_assign)
12220 : {
12221 344136 : stmtblock_t block;
12222 344136 : tree tmp;
12223 344136 : tree cond;
12224 344136 : int caf_mode;
12225 :
12226 344136 : gfc_init_block (&block);
12227 :
12228 344136 : if (ts.type == BT_CHARACTER)
12229 : {
12230 33879 : tree rlen = NULL;
12231 33879 : tree llen = NULL;
12232 :
12233 33879 : if (lse->string_length != NULL_TREE)
12234 : {
12235 33879 : gfc_conv_string_parameter (lse);
12236 33879 : gfc_add_block_to_block (&block, &lse->pre);
12237 33879 : llen = lse->string_length;
12238 : }
12239 :
12240 33879 : if (rse->string_length != NULL_TREE)
12241 : {
12242 33879 : gfc_conv_string_parameter (rse);
12243 33879 : gfc_add_block_to_block (&block, &rse->pre);
12244 33879 : rlen = rse->string_length;
12245 : }
12246 :
12247 33879 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
12248 : rse->expr, ts.kind);
12249 : }
12250 290436 : else if (gfc_bt_struct (ts.type)
12251 310257 : && (ts.u.derived->attr.alloc_comp
12252 12895 : || (deep_copy && has_parameterized_comps (ts.u.derived))))
12253 : {
12254 7088 : tree tmp_var = NULL_TREE;
12255 7088 : cond = NULL_TREE;
12256 :
12257 : /* Are the rhs and the lhs the same? */
12258 7088 : if (deep_copy)
12259 : {
12260 4248 : if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
12261 3095 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
12262 4248 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12263 : gfc_build_addr_expr (NULL_TREE, lse->expr),
12264 : gfc_build_addr_expr (NULL_TREE, rse->expr));
12265 4248 : cond = gfc_evaluate_now (cond, &lse->pre);
12266 : }
12267 :
12268 : /* Deallocate the lhs allocated components as long as it is not
12269 : the same as the rhs. This must be done following the assignment
12270 : to prevent deallocating data that could be used in the rhs
12271 : expression. */
12272 7088 : if (dealloc)
12273 : {
12274 2013 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
12275 2013 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
12276 : 0, gfc_may_be_finalized (ts));
12277 2013 : if (deep_copy)
12278 845 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12279 : tmp);
12280 2013 : gfc_add_expr_to_block (&lse->post, tmp);
12281 : }
12282 :
12283 7088 : gfc_add_block_to_block (&block, &rse->pre);
12284 :
12285 : /* Skip finalization for self-assignment. */
12286 7088 : if (deep_copy && lse->finalblock.head)
12287 : {
12288 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12289 : gfc_finish_block (&lse->finalblock));
12290 24 : gfc_add_expr_to_block (&block, tmp);
12291 : }
12292 : else
12293 7064 : gfc_add_block_to_block (&block, &lse->finalblock);
12294 :
12295 7088 : gfc_add_block_to_block (&block, &lse->pre);
12296 :
12297 7088 : if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
12298 7088 : == TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)))
12299 6746 : gfc_add_modify (&block, lse->expr,
12300 6746 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12301 : else
12302 : {
12303 342 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12304 342 : TREE_TYPE (lse->expr), rse->expr);
12305 342 : gfc_add_modify (&block, lse->expr, tmp);
12306 : }
12307 :
12308 : /* Restore pointer address of coarray components. */
12309 7088 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
12310 : {
12311 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
12312 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12313 : tmp);
12314 5 : gfc_add_expr_to_block (&block, tmp);
12315 : }
12316 :
12317 : /* Do a deep copy if the rhs is a variable, if it is not the
12318 : same as the lhs. */
12319 7088 : if (deep_copy)
12320 : {
12321 4248 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
12322 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
12323 4248 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
12324 : caf_mode);
12325 4248 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12326 : tmp);
12327 4248 : gfc_add_expr_to_block (&block, tmp);
12328 : }
12329 : }
12330 303169 : else if (gfc_bt_struct (ts.type))
12331 : {
12332 12733 : gfc_add_block_to_block (&block, &rse->pre);
12333 12733 : gfc_add_block_to_block (&block, &lse->finalblock);
12334 12733 : gfc_add_block_to_block (&block, &lse->pre);
12335 12733 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12336 12733 : TREE_TYPE (lse->expr), rse->expr);
12337 12733 : gfc_add_modify (&block, lse->expr, tmp);
12338 : }
12339 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
12340 290436 : else if (ts.type == BT_CLASS)
12341 : {
12342 745 : gfc_add_block_to_block (&block, &lse->pre);
12343 745 : gfc_add_block_to_block (&block, &rse->pre);
12344 745 : gfc_add_block_to_block (&block, &lse->finalblock);
12345 :
12346 745 : if (!trans_scalar_class_assign (&block, lse, rse))
12347 : {
12348 : /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
12349 : for the lhs which ensures that class data rhs cast as a string
12350 : assigns correctly. */
12351 599 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12352 599 : TREE_TYPE (rse->expr), lse->expr);
12353 599 : gfc_add_modify (&block, tmp, rse->expr);
12354 :
12355 : /* Copy allocatable components but guard against class pointer
12356 : assign, which arrives here. */
12357 : #define DATA_DT ts.u.derived->components->ts.u.derived
12358 599 : if (deep_copy
12359 158 : && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
12360 0 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
12361 158 : && ts.u.derived->components
12362 757 : && DATA_DT && DATA_DT->attr.alloc_comp)
12363 : {
12364 6 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
12365 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
12366 : : 0;
12367 6 : tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
12368 : caf_mode);
12369 6 : gfc_add_expr_to_block (&block, tmp);
12370 : }
12371 : #undef DATA_DT
12372 : }
12373 : }
12374 289691 : else if (ts.type != BT_CLASS)
12375 : {
12376 289691 : gfc_add_block_to_block (&block, &lse->pre);
12377 289691 : gfc_add_block_to_block (&block, &rse->pre);
12378 :
12379 289691 : if (in_coarray)
12380 : {
12381 868 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
12382 : {
12383 0 : tree rtype = TREE_TYPE (TREE_TYPE (rse->expr));
12384 0 : tree rtoken = TYPE_LANG_SPECIFIC (rtype)->caf_token;
12385 0 : gfc_conv_descriptor_token_set (&block, lse->expr, rtoken);
12386 : }
12387 868 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
12388 0 : lse->expr = gfc_conv_array_data (lse->expr);
12389 277 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
12390 868 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
12391 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
12392 : }
12393 289691 : gfc_add_modify (&block, lse->expr,
12394 289691 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12395 : }
12396 :
12397 344136 : gfc_add_block_to_block (&block, &lse->post);
12398 344136 : gfc_add_block_to_block (&block, &rse->post);
12399 :
12400 344136 : return gfc_finish_block (&block);
12401 : }
12402 :
12403 :
12404 : /* There are quite a lot of restrictions on the optimisation in using an
12405 : array function assign without a temporary. */
12406 :
12407 : static bool
12408 14478 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
12409 : {
12410 14478 : gfc_ref * ref;
12411 14478 : bool seen_array_ref;
12412 14478 : bool c = false;
12413 14478 : gfc_symbol *sym = expr1->symtree->n.sym;
12414 :
12415 : /* Play it safe with class functions assigned to a derived type. */
12416 14478 : if (gfc_is_class_array_function (expr2)
12417 14478 : && expr1->ts.type == BT_DERIVED)
12418 : return true;
12419 :
12420 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
12421 14454 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
12422 : return true;
12423 :
12424 : /* Elemental functions are scalarized so that they don't need a
12425 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
12426 : they would need special treatment in gfc_trans_arrayfunc_assign. */
12427 8531 : if (expr2->value.function.esym != NULL
12428 1595 : && expr2->value.function.esym->attr.elemental)
12429 : return true;
12430 :
12431 : /* Need a temporary if rhs is not FULL or a contiguous section. */
12432 8166 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
12433 : return true;
12434 :
12435 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
12436 7916 : if (gfc_ref_needs_temporary_p (expr1->ref))
12437 : return true;
12438 :
12439 : /* Functions returning pointers or allocatables need temporaries. */
12440 7904 : if (gfc_expr_attr (expr2).pointer
12441 7904 : || gfc_expr_attr (expr2).allocatable)
12442 : return true;
12443 :
12444 : /* Character array functions need temporaries unless the
12445 : character lengths are the same. */
12446 7528 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
12447 : {
12448 562 : if (UNLIMITED_POLY (expr1))
12449 : return true;
12450 :
12451 556 : if (expr1->ts.u.cl->length == NULL
12452 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12453 : return true;
12454 :
12455 493 : if (expr2->ts.u.cl->length == NULL
12456 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12457 : return true;
12458 :
12459 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
12460 475 : expr2->ts.u.cl->length->value.integer) != 0)
12461 : return true;
12462 : }
12463 :
12464 : /* Check that no LHS component references appear during an array
12465 : reference. This is needed because we do not have the means to
12466 : span any arbitrary stride with an array descriptor. This check
12467 : is not needed for the rhs because the function result has to be
12468 : a complete type. */
12469 7435 : seen_array_ref = false;
12470 14870 : for (ref = expr1->ref; ref; ref = ref->next)
12471 : {
12472 7448 : if (ref->type == REF_ARRAY)
12473 : seen_array_ref= true;
12474 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
12475 : return true;
12476 : }
12477 :
12478 : /* Check for a dependency. */
12479 7422 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
12480 : expr2->value.function.esym,
12481 : expr2->value.function.actual,
12482 : NOT_ELEMENTAL))
12483 : return true;
12484 :
12485 : /* If we have reached here with an intrinsic function, we do not
12486 : need a temporary except in the particular case that reallocation
12487 : on assignment is active and the lhs is allocatable and a target,
12488 : or a pointer which may be a subref pointer. FIXME: The last
12489 : condition can go away when we use span in the intrinsics
12490 : directly.*/
12491 6985 : if (expr2->value.function.isym)
12492 6107 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
12493 12268 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
12494 :
12495 : /* If the LHS is a dummy, we need a temporary if it is not
12496 : INTENT(OUT). */
12497 803 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
12498 : return true;
12499 :
12500 : /* If the lhs has been host_associated, is in common, a pointer or is
12501 : a target and the function is not using a RESULT variable, aliasing
12502 : can occur and a temporary is needed. */
12503 797 : if ((sym->attr.host_assoc
12504 743 : || sym->attr.in_common
12505 737 : || sym->attr.pointer
12506 731 : || sym->attr.cray_pointee
12507 731 : || sym->attr.target)
12508 66 : && expr2->symtree != NULL
12509 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
12510 : return true;
12511 :
12512 : /* A PURE function can unconditionally be called without a temporary. */
12513 755 : if (expr2->value.function.esym != NULL
12514 730 : && expr2->value.function.esym->attr.pure)
12515 : return false;
12516 :
12517 : /* Implicit_pure functions are those which could legally be declared
12518 : to be PURE. */
12519 727 : if (expr2->value.function.esym != NULL
12520 702 : && expr2->value.function.esym->attr.implicit_pure)
12521 : return false;
12522 :
12523 444 : if (!sym->attr.use_assoc
12524 444 : && !sym->attr.in_common
12525 444 : && !sym->attr.pointer
12526 438 : && !sym->attr.target
12527 438 : && !sym->attr.cray_pointee
12528 438 : && expr2->value.function.esym)
12529 : {
12530 : /* A temporary is not needed if the function is not contained and
12531 : the variable is local or host associated and not a pointer or
12532 : a target. */
12533 413 : if (!expr2->value.function.esym->attr.contained)
12534 : return false;
12535 :
12536 : /* A temporary is not needed if the lhs has never been host
12537 : associated and the procedure is contained. */
12538 164 : else if (!sym->attr.host_assoc)
12539 : return false;
12540 :
12541 : /* A temporary is not needed if the variable is local and not
12542 : a pointer, a target or a result. */
12543 6 : if (sym->ns->parent
12544 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12545 0 : return false;
12546 : }
12547 :
12548 : /* Default to temporary use. */
12549 : return true;
12550 : }
12551 :
12552 :
12553 : /* Provide the loop info so that the lhs descriptor can be built for
12554 : reallocatable assignments from extrinsic function calls. */
12555 :
12556 : static void
12557 203 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12558 : gfc_loopinfo *loop)
12559 : {
12560 : /* Signal that the function call should not be made by
12561 : gfc_conv_loop_setup. */
12562 203 : se->ss->is_alloc_lhs = 1;
12563 203 : gfc_init_loopinfo (loop);
12564 203 : gfc_add_ss_to_loop (loop, *ss);
12565 203 : gfc_add_ss_to_loop (loop, se->ss);
12566 203 : gfc_conv_ss_startstride (loop);
12567 203 : gfc_conv_loop_setup (loop, where);
12568 203 : gfc_copy_loopinfo_to_se (se, loop);
12569 203 : gfc_add_block_to_block (&se->pre, &loop->pre);
12570 203 : gfc_add_block_to_block (&se->pre, &loop->post);
12571 203 : se->ss->is_alloc_lhs = 0;
12572 203 : }
12573 :
12574 :
12575 : /* For assignment to a reallocatable lhs from intrinsic functions,
12576 : replace the se.expr (ie. the result) with a temporary descriptor.
12577 : Null the data field so that the library allocates space for the
12578 : result. Free the data of the original descriptor after the function,
12579 : in case it appears in an argument expression and transfer the
12580 : result to the original descriptor. */
12581 :
12582 : static void
12583 2137 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12584 : {
12585 2137 : tree desc;
12586 2137 : tree res_desc;
12587 2137 : tree tmp;
12588 2137 : tree offset;
12589 2137 : tree zero_cond;
12590 2137 : tree not_same_shape;
12591 2137 : stmtblock_t shape_block;
12592 2137 : int n;
12593 :
12594 : /* Use the allocation done by the library. Substitute the lhs
12595 : descriptor with a copy, whose data field is nulled.*/
12596 2137 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12597 2137 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12598 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12599 :
12600 2137 : res_desc = gfc_create_unallocated_library_result_descriptor (&se->pre, desc,
12601 : dtype);
12602 2137 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12603 :
12604 : /* Free the lhs after the function call and copy the result data to
12605 : the lhs descriptor. */
12606 2137 : tmp = gfc_conv_descriptor_data_get (desc);
12607 2137 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12608 : logical_type_node, tmp,
12609 2137 : build_int_cst (TREE_TYPE (tmp), 0));
12610 2137 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12611 2137 : tmp = gfc_call_free (tmp);
12612 2137 : gfc_add_expr_to_block (&se->post, tmp);
12613 :
12614 2137 : tmp = gfc_conv_descriptor_data_get (res_desc);
12615 2137 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12616 :
12617 : /* Check that the shapes are the same between lhs and expression.
12618 : The evaluation of the shape is done in 'shape_block' to avoid
12619 : uninitialized warnings from the lhs bounds. */
12620 2137 : not_same_shape = boolean_false_node;
12621 2137 : gfc_start_block (&shape_block);
12622 9015 : for (n = 0 ; n < rank; n++)
12623 : {
12624 4741 : tree tmp1;
12625 4741 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12626 4741 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12627 4741 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12628 : gfc_array_index_type, tmp, tmp1);
12629 4741 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12630 4741 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12631 : gfc_array_index_type, tmp, tmp1);
12632 4741 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12633 4741 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12634 : gfc_array_index_type, tmp, tmp1);
12635 4741 : tmp = fold_build2_loc (input_location, NE_EXPR,
12636 : logical_type_node, tmp,
12637 : gfc_index_zero_node);
12638 4741 : tmp = gfc_evaluate_now (tmp, &shape_block);
12639 4741 : if (n == 0)
12640 : not_same_shape = tmp;
12641 : else
12642 2604 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12643 : logical_type_node, tmp,
12644 : not_same_shape);
12645 : }
12646 :
12647 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12648 : shapes being different. */
12649 2137 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12650 : zero_cond, not_same_shape);
12651 2137 : gfc_add_modify (&shape_block, zero_cond, tmp);
12652 2137 : tmp = gfc_finish_block (&shape_block);
12653 2137 : tmp = build3_v (COND_EXPR, zero_cond,
12654 : build_empty_stmt (input_location), tmp);
12655 2137 : gfc_add_expr_to_block (&se->post, tmp);
12656 :
12657 : /* Now reset the bounds returned from the function call to bounds based
12658 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12659 : of 'variable and 'expr' are different. Set the offset accordingly. */
12660 2137 : offset = gfc_index_zero_node;
12661 6878 : for (n = 0 ; n < rank; n++)
12662 : {
12663 4741 : tree lbound;
12664 :
12665 4741 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12666 4741 : lbound = fold_build3_loc (input_location, COND_EXPR,
12667 : gfc_array_index_type, zero_cond,
12668 : gfc_index_one_node, lbound);
12669 4741 : lbound = gfc_evaluate_now (lbound, &se->post);
12670 :
12671 4741 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12672 4741 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12673 : gfc_array_index_type, tmp, lbound);
12674 4741 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12675 : gfc_rank_cst[n], lbound);
12676 4741 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12677 : gfc_rank_cst[n], tmp);
12678 :
12679 : /* Set stride and accumulate the offset. */
12680 4741 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12681 4741 : gfc_conv_descriptor_stride_set (&se->post, desc,
12682 : gfc_rank_cst[n], tmp);
12683 4741 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12684 : gfc_array_index_type, lbound, tmp);
12685 4741 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12686 : gfc_array_index_type, offset, tmp);
12687 4741 : offset = gfc_evaluate_now (offset, &se->post);
12688 : }
12689 :
12690 2137 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12691 2137 : }
12692 :
12693 :
12694 :
12695 : /* Try to translate array(:) = func (...), where func is a transformational
12696 : array function, without using a temporary. Returns NULL if this isn't the
12697 : case. */
12698 :
12699 : static tree
12700 14518 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12701 : {
12702 14518 : gfc_se se;
12703 14518 : gfc_ss *ss = NULL;
12704 14518 : gfc_component *comp = NULL;
12705 14518 : gfc_loopinfo loop;
12706 14518 : tree tmp;
12707 14518 : tree lhs;
12708 14518 : gfc_se final_se;
12709 14518 : gfc_symbol *sym = expr1->symtree->n.sym;
12710 14518 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12711 :
12712 : /* If the symbol is host associated and has not been referenced in its name
12713 : space, it might be lacking a backend_decl and vtable. */
12714 14518 : if (sym->backend_decl == NULL_TREE)
12715 : return NULL_TREE;
12716 :
12717 14478 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12718 : return NULL_TREE;
12719 :
12720 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12721 : functions. */
12722 6867 : comp = gfc_get_proc_ptr_comp (expr2);
12723 :
12724 6867 : if (!(expr2->value.function.isym
12725 718 : || (comp && comp->attr.dimension)
12726 718 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12727 718 : && expr2->value.function.esym->result->attr.dimension)))
12728 : return NULL_TREE;
12729 :
12730 6867 : gfc_init_se (&se, NULL);
12731 6867 : gfc_start_block (&se.pre);
12732 6867 : se.want_pointer = 1;
12733 :
12734 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12735 : backend decl, stash the original away for the finalization so that the
12736 : value used is that before the assignment. This is necessary because
12737 : evaluation of the rhs expression using direct by reference can change
12738 : the value. However, the standard mandates that the finalization must occur
12739 : after evaluation of the rhs. */
12740 6867 : gfc_init_se (&final_se, NULL);
12741 :
12742 6867 : if (finalizable)
12743 : {
12744 45 : tmp = sym->backend_decl;
12745 45 : lhs = sym->backend_decl;
12746 45 : if (INDIRECT_REF_P (tmp))
12747 0 : tmp = TREE_OPERAND (tmp, 0);
12748 45 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12749 45 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12750 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12751 : {
12752 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12753 : expr1->rank, 0);
12754 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12755 : }
12756 : }
12757 :
12758 45 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12759 : {
12760 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12761 45 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12762 : }
12763 :
12764 6867 : if (finalizable)
12765 45 : sym->backend_decl = lhs;
12766 :
12767 6867 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12768 :
12769 6867 : if (expr1->ts.type == BT_DERIVED
12770 264 : && expr1->ts.u.derived->attr.alloc_comp)
12771 : {
12772 110 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12773 110 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12774 : expr1->rank);
12775 110 : gfc_add_expr_to_block (&se.pre, tmp);
12776 : }
12777 :
12778 6867 : se.direct_byref = 1;
12779 6867 : se.ss = gfc_walk_expr (expr2);
12780 6867 : gcc_assert (se.ss != gfc_ss_terminator);
12781 :
12782 : /* Since this is a direct by reference call, references to the lhs can be
12783 : used for finalization of the function result just as long as the blocks
12784 : from final_se are added at the right time. */
12785 6867 : gfc_init_se (&final_se, NULL);
12786 6867 : if (finalizable && expr2->value.function.esym)
12787 : {
12788 32 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12789 32 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12790 32 : expr2->value.function.esym->attr,
12791 : expr2->rank);
12792 : }
12793 :
12794 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12795 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12796 : Clearly, this cannot be done for an allocatable function result, since
12797 : the shape of the result is unknown and, in any case, the function must
12798 : correctly take care of the reallocation internally. For intrinsic
12799 : calls, the array data is freed and the library takes care of allocation.
12800 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12801 : to the library. */
12802 6867 : if (flag_realloc_lhs
12803 6792 : && gfc_is_reallocatable_lhs (expr1)
12804 9207 : && !gfc_expr_attr (expr1).codimension
12805 2340 : && !gfc_is_coindexed (expr1)
12806 9207 : && !(expr2->value.function.esym
12807 203 : && expr2->value.function.esym->result->attr.allocatable))
12808 : {
12809 2340 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12810 :
12811 2340 : if (!expr2->value.function.isym)
12812 : {
12813 203 : ss = gfc_walk_expr (expr1);
12814 203 : gcc_assert (ss != gfc_ss_terminator);
12815 :
12816 203 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12817 203 : ss->is_alloc_lhs = 1;
12818 : }
12819 : else
12820 : {
12821 2137 : tree dtype = NULL_TREE;
12822 2137 : tree type = gfc_typenode_for_spec (&expr2->ts);
12823 2137 : if (expr1->ts.type == BT_CLASS)
12824 : {
12825 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12826 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12827 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12828 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12829 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12830 : }
12831 2137 : fcncall_realloc_result (&se, expr1->rank, dtype);
12832 : }
12833 : }
12834 :
12835 6867 : gfc_conv_function_expr (&se, expr2);
12836 :
12837 : /* Fix the result. */
12838 6867 : gfc_add_block_to_block (&se.pre, &se.post);
12839 6867 : if (finalizable)
12840 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12841 :
12842 : /* Do the finalization, including final calls from function arguments. */
12843 45 : if (finalizable)
12844 : {
12845 45 : gfc_add_block_to_block (&se.pre, &final_se.post);
12846 45 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12847 45 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12848 : }
12849 :
12850 6867 : if (ss)
12851 203 : gfc_cleanup_loop (&loop);
12852 : else
12853 6664 : gfc_free_ss_chain (se.ss);
12854 :
12855 6867 : return gfc_finish_block (&se.pre);
12856 : }
12857 :
12858 :
12859 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12860 : can't be done. */
12861 :
12862 : static tree
12863 4060 : gfc_trans_zero_assign (gfc_expr * expr)
12864 : {
12865 4060 : tree dest, len, type;
12866 4060 : tree tmp;
12867 4060 : gfc_symbol *sym;
12868 :
12869 4060 : sym = expr->symtree->n.sym;
12870 4060 : dest = gfc_get_symbol_decl (sym);
12871 :
12872 4060 : type = TREE_TYPE (dest);
12873 4060 : if (POINTER_TYPE_P (type))
12874 255 : type = TREE_TYPE (type);
12875 4060 : if (GFC_ARRAY_TYPE_P (type))
12876 : {
12877 : /* Determine the length of the array. */
12878 2850 : len = GFC_TYPE_ARRAY_SIZE (type);
12879 2850 : if (!len || TREE_CODE (len) != INTEGER_CST)
12880 : return NULL_TREE;
12881 : }
12882 1210 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12883 1210 : && gfc_is_simply_contiguous (expr, false, false))
12884 : {
12885 1098 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12886 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12887 1098 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12888 1098 : dest = gfc_conv_descriptor_data_get (dest);
12889 : }
12890 : else
12891 : return NULL_TREE;
12892 :
12893 : /* If we are zeroing a local array avoid taking its address by emitting
12894 : a = {} instead. */
12895 3763 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12896 2622 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12897 2622 : dest, build_constructor (TREE_TYPE (dest),
12898 2622 : NULL));
12899 :
12900 : /* Multiply len by element size. */
12901 1141 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12902 1141 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12903 : len, fold_convert (gfc_array_index_type, tmp));
12904 :
12905 : /* Convert arguments to the correct types. */
12906 1141 : dest = fold_convert (pvoid_type_node, dest);
12907 1141 : len = fold_convert (size_type_node, len);
12908 :
12909 : /* Construct call to __builtin_memset. */
12910 1141 : tmp = build_call_expr_loc (input_location,
12911 : builtin_decl_explicit (BUILT_IN_MEMSET),
12912 : 3, dest, integer_zero_node, len);
12913 1141 : return fold_convert (void_type_node, tmp);
12914 : }
12915 :
12916 :
12917 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
12918 : that constructs the call to __builtin_memcpy. */
12919 :
12920 : tree
12921 8148 : gfc_build_memcpy_call (tree dst, tree src, tree len)
12922 : {
12923 8148 : tree tmp;
12924 :
12925 : /* Convert arguments to the correct types. */
12926 8148 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
12927 7763 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
12928 : else
12929 385 : dst = fold_convert (pvoid_type_node, dst);
12930 :
12931 8148 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
12932 7650 : src = gfc_build_addr_expr (pvoid_type_node, src);
12933 : else
12934 498 : src = fold_convert (pvoid_type_node, src);
12935 :
12936 8148 : len = fold_convert (size_type_node, len);
12937 :
12938 : /* Construct call to __builtin_memcpy. */
12939 8148 : tmp = build_call_expr_loc (input_location,
12940 : builtin_decl_explicit (BUILT_IN_MEMCPY),
12941 : 3, dst, src, len);
12942 8148 : return fold_convert (void_type_node, tmp);
12943 : }
12944 :
12945 :
12946 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
12947 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
12948 : source/rhs, both are gfc_full_array_ref_p which have been checked for
12949 : dependencies. */
12950 :
12951 : static tree
12952 2603 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
12953 : {
12954 2603 : tree dst, dlen, dtype;
12955 2603 : tree src, slen, stype;
12956 2603 : tree tmp;
12957 :
12958 2603 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12959 2603 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
12960 :
12961 2603 : dtype = TREE_TYPE (dst);
12962 2603 : if (POINTER_TYPE_P (dtype))
12963 265 : dtype = TREE_TYPE (dtype);
12964 2603 : stype = TREE_TYPE (src);
12965 2603 : if (POINTER_TYPE_P (stype))
12966 293 : stype = TREE_TYPE (stype);
12967 :
12968 2603 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
12969 : return NULL_TREE;
12970 :
12971 : /* Determine the lengths of the arrays. */
12972 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
12973 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
12974 : return NULL_TREE;
12975 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12976 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12977 : dlen, fold_convert (gfc_array_index_type, tmp));
12978 :
12979 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
12980 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
12981 : return NULL_TREE;
12982 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
12983 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12984 : slen, fold_convert (gfc_array_index_type, tmp));
12985 :
12986 : /* Sanity check that they are the same. This should always be
12987 : the case, as we should already have checked for conformance. */
12988 1486 : if (!tree_int_cst_equal (slen, dlen))
12989 : return NULL_TREE;
12990 :
12991 1486 : return gfc_build_memcpy_call (dst, src, dlen);
12992 : }
12993 :
12994 :
12995 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
12996 : this can't be done. EXPR1 is the destination/lhs for which
12997 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
12998 :
12999 : static tree
13000 8319 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
13001 : {
13002 8319 : unsigned HOST_WIDE_INT nelem;
13003 8319 : tree dst, dtype;
13004 8319 : tree src, stype;
13005 8319 : tree len;
13006 8319 : tree tmp;
13007 :
13008 8319 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
13009 8319 : if (nelem == 0)
13010 : return NULL_TREE;
13011 :
13012 6887 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
13013 6887 : dtype = TREE_TYPE (dst);
13014 6887 : if (POINTER_TYPE_P (dtype))
13015 265 : dtype = TREE_TYPE (dtype);
13016 6887 : if (!GFC_ARRAY_TYPE_P (dtype))
13017 : return NULL_TREE;
13018 :
13019 : /* Determine the lengths of the array. */
13020 6039 : len = GFC_TYPE_ARRAY_SIZE (dtype);
13021 6039 : if (!len || TREE_CODE (len) != INTEGER_CST)
13022 : return NULL_TREE;
13023 :
13024 : /* Confirm that the constructor is the same size. */
13025 5935 : if (compare_tree_int (len, nelem) != 0)
13026 : return NULL_TREE;
13027 :
13028 5935 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
13029 5935 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
13030 : fold_convert (gfc_array_index_type, tmp));
13031 :
13032 5935 : stype = gfc_typenode_for_spec (&expr2->ts);
13033 5935 : src = gfc_build_constant_array_constructor (expr2, stype);
13034 :
13035 5935 : return gfc_build_memcpy_call (dst, src, len);
13036 : }
13037 :
13038 :
13039 : /* Tells whether the expression is to be treated as a variable reference. */
13040 :
13041 : bool
13042 319235 : gfc_expr_is_variable (gfc_expr *expr)
13043 : {
13044 319513 : gfc_expr *arg;
13045 319513 : gfc_component *comp;
13046 319513 : gfc_symbol *func_ifc;
13047 :
13048 319513 : if (expr->expr_type == EXPR_VARIABLE)
13049 : return true;
13050 :
13051 283451 : arg = gfc_get_noncopying_intrinsic_argument (expr);
13052 283451 : if (arg)
13053 : {
13054 278 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
13055 : return gfc_expr_is_variable (arg);
13056 : }
13057 :
13058 : /* A data-pointer-returning function should be considered as a variable
13059 : too. */
13060 283173 : if (expr->expr_type == EXPR_FUNCTION
13061 37695 : && expr->ref == NULL)
13062 : {
13063 37306 : if (expr->value.function.isym != NULL)
13064 : return false;
13065 :
13066 9757 : if (expr->value.function.esym != NULL)
13067 : {
13068 9748 : func_ifc = expr->value.function.esym;
13069 9748 : goto found_ifc;
13070 : }
13071 9 : gcc_assert (expr->symtree);
13072 9 : func_ifc = expr->symtree->n.sym;
13073 9 : goto found_ifc;
13074 : }
13075 :
13076 245867 : comp = gfc_get_proc_ptr_comp (expr);
13077 245867 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
13078 389 : && comp)
13079 : {
13080 275 : func_ifc = comp->ts.interface;
13081 275 : goto found_ifc;
13082 : }
13083 :
13084 245592 : if (expr->expr_type == EXPR_COMPCALL)
13085 : {
13086 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
13087 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
13088 0 : goto found_ifc;
13089 : }
13090 :
13091 : return false;
13092 :
13093 10032 : found_ifc:
13094 10032 : gcc_assert (func_ifc->attr.function
13095 : && func_ifc->result != NULL);
13096 10032 : return func_ifc->result->attr.pointer;
13097 : }
13098 :
13099 :
13100 : /* Is the lhs OK for automatic reallocation? */
13101 :
13102 : static bool
13103 269960 : is_scalar_reallocatable_lhs (gfc_expr *expr)
13104 : {
13105 269960 : gfc_ref * ref;
13106 :
13107 : /* An allocatable variable with no reference. */
13108 269960 : if (expr->symtree->n.sym->attr.allocatable
13109 6872 : && !expr->ref)
13110 : return true;
13111 :
13112 : /* All that can be left are allocatable components. However, we do
13113 : not check for allocatable components here because the expression
13114 : could be an allocatable component of a pointer component. */
13115 267127 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
13116 243706 : && expr->symtree->n.sym->ts.type != BT_CLASS)
13117 : return false;
13118 :
13119 : /* Find an allocatable component ref last. */
13120 41710 : for (ref = expr->ref; ref; ref = ref->next)
13121 17249 : if (ref->type == REF_COMPONENT
13122 12719 : && !ref->next
13123 9755 : && ref->u.c.component->attr.allocatable)
13124 : return true;
13125 :
13126 : return false;
13127 : }
13128 :
13129 :
13130 : /* Allocate or reallocate scalar lhs, as necessary. */
13131 :
13132 : static void
13133 3715 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
13134 : tree string_length,
13135 : gfc_expr *expr1,
13136 : gfc_expr *expr2)
13137 :
13138 : {
13139 3715 : tree cond;
13140 3715 : tree tmp;
13141 3715 : tree size;
13142 3715 : tree size_in_bytes;
13143 3715 : tree jump_label1;
13144 3715 : tree jump_label2;
13145 3715 : gfc_se lse;
13146 3715 : gfc_ref *ref;
13147 :
13148 3715 : if (!expr1 || expr1->rank)
13149 0 : return;
13150 :
13151 3715 : if (!expr2 || expr2->rank)
13152 : return;
13153 :
13154 5223 : for (ref = expr1->ref; ref; ref = ref->next)
13155 1508 : if (ref->type == REF_SUBSTRING)
13156 : return;
13157 :
13158 3715 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
13159 :
13160 : /* Since this is a scalar lhs, we can afford to do this. That is,
13161 : there is no risk of side effects being repeated. */
13162 3715 : gfc_init_se (&lse, NULL);
13163 3715 : lse.want_pointer = 1;
13164 3715 : gfc_conv_expr (&lse, expr1);
13165 :
13166 3715 : jump_label1 = gfc_build_label_decl (NULL_TREE);
13167 3715 : jump_label2 = gfc_build_label_decl (NULL_TREE);
13168 :
13169 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
13170 3715 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
13171 3715 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
13172 : lse.expr, tmp);
13173 3715 : tmp = build3_v (COND_EXPR, cond,
13174 : build1_v (GOTO_EXPR, jump_label1),
13175 : build_empty_stmt (input_location));
13176 3715 : gfc_add_expr_to_block (block, tmp);
13177 :
13178 3715 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13179 : {
13180 : /* Use the rhs string length and the lhs element size. Note that 'size' is
13181 : used below for the string-length comparison, only. */
13182 1566 : size = string_length;
13183 1566 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
13184 3132 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
13185 1566 : TREE_TYPE (tmp), tmp,
13186 1566 : fold_convert (TREE_TYPE (tmp), size));
13187 : }
13188 : else
13189 : {
13190 : /* Otherwise use the length in bytes of the rhs. */
13191 2149 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
13192 2149 : size_in_bytes = size;
13193 : }
13194 :
13195 3715 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13196 : size_in_bytes, size_one_node);
13197 :
13198 3715 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
13199 : {
13200 32 : tree caf_decl, token;
13201 32 : gfc_se caf_se;
13202 32 : symbol_attribute attr;
13203 :
13204 32 : gfc_clear_attr (&attr);
13205 32 : gfc_init_se (&caf_se, NULL);
13206 :
13207 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
13208 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
13209 : NULL);
13210 32 : gfc_add_block_to_block (block, &caf_se.pre);
13211 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
13212 : gfc_build_addr_expr (NULL_TREE, token),
13213 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
13214 : expr1, 1);
13215 : }
13216 3683 : else if (expr1->ts.type == BT_DERIVED
13217 3683 : && (expr1->ts.u.derived->attr.alloc_comp
13218 220 : || has_parameterized_comps (expr1->ts.u.derived)))
13219 : {
13220 128 : tmp = build_call_expr_loc (input_location,
13221 : builtin_decl_explicit (BUILT_IN_CALLOC),
13222 : 2, build_one_cst (size_type_node),
13223 : size_in_bytes);
13224 128 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13225 128 : gfc_add_modify (block, lse.expr, tmp);
13226 : }
13227 : else
13228 : {
13229 3555 : tmp = build_call_expr_loc (input_location,
13230 : builtin_decl_explicit (BUILT_IN_MALLOC),
13231 : 1, size_in_bytes);
13232 3555 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13233 3555 : gfc_add_modify (block, lse.expr, tmp);
13234 : }
13235 :
13236 3715 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13237 : {
13238 : /* Deferred characters need checking for lhs and rhs string
13239 : length. Other deferred parameter variables will have to
13240 : come here too. */
13241 1566 : tmp = build1_v (GOTO_EXPR, jump_label2);
13242 1566 : gfc_add_expr_to_block (block, tmp);
13243 : }
13244 3715 : tmp = build1_v (LABEL_EXPR, jump_label1);
13245 3715 : gfc_add_expr_to_block (block, tmp);
13246 :
13247 : /* For a deferred length character, reallocate if lengths of lhs and
13248 : rhs are different. */
13249 3715 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13250 : {
13251 1566 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13252 : lse.string_length,
13253 1566 : fold_convert (TREE_TYPE (lse.string_length),
13254 : size));
13255 : /* Jump past the realloc if the lengths are the same. */
13256 1566 : tmp = build3_v (COND_EXPR, cond,
13257 : build1_v (GOTO_EXPR, jump_label2),
13258 : build_empty_stmt (input_location));
13259 1566 : gfc_add_expr_to_block (block, tmp);
13260 1566 : tmp = build_call_expr_loc (input_location,
13261 : builtin_decl_explicit (BUILT_IN_REALLOC),
13262 : 2, fold_convert (pvoid_type_node, lse.expr),
13263 : size_in_bytes);
13264 1566 : tree omp_cond = NULL_TREE;
13265 1566 : if (flag_openmp_allocators)
13266 : {
13267 1 : tree omp_tmp;
13268 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
13269 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
13270 :
13271 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
13272 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
13273 : fold_convert (pvoid_type_node,
13274 : lse.expr), size_in_bytes,
13275 : build_zero_cst (ptr_type_node),
13276 : build_zero_cst (ptr_type_node));
13277 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
13278 : omp_cond, omp_tmp, tmp);
13279 : }
13280 1566 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13281 1566 : gfc_add_modify (block, lse.expr, tmp);
13282 1566 : if (omp_cond)
13283 1 : gfc_add_expr_to_block (block,
13284 : build3_loc (input_location, COND_EXPR,
13285 : void_type_node, omp_cond,
13286 : gfc_omp_call_add_alloc (lse.expr),
13287 : build_empty_stmt (input_location)));
13288 1566 : tmp = build1_v (LABEL_EXPR, jump_label2);
13289 1566 : gfc_add_expr_to_block (block, tmp);
13290 :
13291 : /* Update the lhs character length. */
13292 1566 : size = string_length;
13293 1566 : gfc_add_modify (block, lse.string_length,
13294 1566 : fold_convert (TREE_TYPE (lse.string_length), size));
13295 : }
13296 : }
13297 :
13298 : /* Check for assignments of the type
13299 :
13300 : a = a + 4
13301 :
13302 : to make sure we do not check for reallocation unnecessarily. */
13303 :
13304 :
13305 : /* Strip parentheses from an expression to get the underlying variable.
13306 : This is needed for self-assignment detection since (a) creates a
13307 : parentheses operator node. */
13308 :
13309 : static gfc_expr *
13310 8099 : strip_parentheses (gfc_expr *expr)
13311 : {
13312 0 : while (expr->expr_type == EXPR_OP
13313 320790 : && expr->value.op.op == INTRINSIC_PARENTHESES)
13314 602 : expr = expr->value.op.op1;
13315 319517 : return expr;
13316 : }
13317 :
13318 :
13319 : static bool
13320 7622 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
13321 : {
13322 8099 : gfc_actual_arglist *a;
13323 8099 : gfc_expr *e1, *e2;
13324 :
13325 : /* Strip parentheses to handle cases like a = (a). */
13326 16249 : expr1 = strip_parentheses (expr1);
13327 8099 : expr2 = strip_parentheses (expr2);
13328 :
13329 8099 : switch (expr2->expr_type)
13330 : {
13331 2218 : case EXPR_VARIABLE:
13332 2218 : return gfc_dep_compare_expr (expr1, expr2) == 0;
13333 :
13334 2839 : case EXPR_FUNCTION:
13335 2839 : if (expr2->value.function.esym
13336 305 : && expr2->value.function.esym->attr.elemental)
13337 : {
13338 75 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
13339 : {
13340 74 : e1 = a->expr;
13341 74 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
13342 : return false;
13343 : }
13344 : return true;
13345 : }
13346 2777 : else if (expr2->value.function.isym
13347 2520 : && expr2->value.function.isym->elemental)
13348 : {
13349 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
13350 : {
13351 322 : e1 = a->expr;
13352 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
13353 : return false;
13354 : }
13355 : return true;
13356 : }
13357 :
13358 : break;
13359 :
13360 671 : case EXPR_OP:
13361 671 : switch (expr2->value.op.op)
13362 : {
13363 19 : case INTRINSIC_NOT:
13364 19 : case INTRINSIC_UPLUS:
13365 19 : case INTRINSIC_UMINUS:
13366 19 : case INTRINSIC_PARENTHESES:
13367 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
13368 :
13369 627 : case INTRINSIC_PLUS:
13370 627 : case INTRINSIC_MINUS:
13371 627 : case INTRINSIC_TIMES:
13372 627 : case INTRINSIC_DIVIDE:
13373 627 : case INTRINSIC_POWER:
13374 627 : case INTRINSIC_AND:
13375 627 : case INTRINSIC_OR:
13376 627 : case INTRINSIC_EQV:
13377 627 : case INTRINSIC_NEQV:
13378 627 : case INTRINSIC_EQ:
13379 627 : case INTRINSIC_NE:
13380 627 : case INTRINSIC_GT:
13381 627 : case INTRINSIC_GE:
13382 627 : case INTRINSIC_LT:
13383 627 : case INTRINSIC_LE:
13384 627 : case INTRINSIC_EQ_OS:
13385 627 : case INTRINSIC_NE_OS:
13386 627 : case INTRINSIC_GT_OS:
13387 627 : case INTRINSIC_GE_OS:
13388 627 : case INTRINSIC_LT_OS:
13389 627 : case INTRINSIC_LE_OS:
13390 :
13391 627 : e1 = expr2->value.op.op1;
13392 627 : e2 = expr2->value.op.op2;
13393 :
13394 627 : if (e1->rank == 0 && e2->rank > 0)
13395 : return is_runtime_conformable (expr1, e2);
13396 569 : else if (e1->rank > 0 && e2->rank == 0)
13397 : return is_runtime_conformable (expr1, e1);
13398 169 : else if (e1->rank > 0 && e2->rank > 0)
13399 169 : return is_runtime_conformable (expr1, e1)
13400 169 : && is_runtime_conformable (expr1, e2);
13401 : break;
13402 :
13403 : default:
13404 : break;
13405 :
13406 : }
13407 :
13408 : break;
13409 :
13410 : default:
13411 : break;
13412 : }
13413 : return false;
13414 : }
13415 :
13416 :
13417 : static tree
13418 3476 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
13419 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
13420 : bool class_realloc)
13421 : {
13422 3476 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
13423 3476 : vec<tree, va_gc> *args = NULL;
13424 3476 : bool final_expr;
13425 :
13426 3476 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
13427 3476 : if (final_expr)
13428 : {
13429 515 : if (rse->loop)
13430 244 : gfc_prepend_expr_to_block (&rse->loop->pre,
13431 : gfc_finish_block (&lse->finalblock));
13432 : else
13433 271 : gfc_add_block_to_block (block, &lse->finalblock);
13434 : }
13435 :
13436 : /* Store the old vptr so that dynamic types can be compared for
13437 : reallocation to occur or not. */
13438 3476 : if (class_realloc)
13439 : {
13440 307 : tmp = lse->expr;
13441 307 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13442 0 : tmp = gfc_get_class_from_expr (tmp);
13443 : }
13444 :
13445 3476 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
13446 : &from_len, &rhs_vptr);
13447 3476 : if (rhs_vptr == NULL_TREE)
13448 43 : rhs_vptr = vptr;
13449 :
13450 : /* Generate (re)allocation of the lhs. */
13451 3476 : if (class_realloc)
13452 : {
13453 307 : stmtblock_t alloc, re_alloc;
13454 307 : tree class_han, re, size;
13455 :
13456 307 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13457 307 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
13458 : else
13459 0 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
13460 :
13461 307 : size = gfc_vptr_size_get (rhs_vptr);
13462 :
13463 : /* Take into account _len of unlimited polymorphic entities.
13464 : TODO: handle class(*) allocatable function results on rhs. */
13465 307 : if (UNLIMITED_POLY (rhs))
13466 : {
13467 18 : tree len;
13468 18 : if (rhs->expr_type == EXPR_VARIABLE)
13469 12 : len = trans_get_upoly_len (block, rhs);
13470 : else
13471 6 : len = gfc_class_len_get (tmp);
13472 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13473 : fold_convert (size_type_node, len),
13474 : size_one_node);
13475 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
13476 18 : size, fold_convert (TREE_TYPE (size), len));
13477 18 : }
13478 289 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
13479 27 : size = fold_build2_loc (input_location, MULT_EXPR,
13480 : gfc_charlen_type_node, size,
13481 : rse->string_length);
13482 :
13483 :
13484 307 : tmp = lse->expr;
13485 307 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
13486 307 : ? gfc_class_data_get (tmp) : tmp;
13487 :
13488 307 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
13489 0 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
13490 :
13491 : /* Allocate block. */
13492 307 : gfc_init_block (&alloc);
13493 307 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
13494 :
13495 : /* Reallocate if dynamic types are different. */
13496 307 : gfc_init_block (&re_alloc);
13497 307 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
13498 : {
13499 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
13500 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
13501 : }
13502 : else
13503 : {
13504 280 : tmp = fold_convert (pvoid_type_node, class_han);
13505 280 : re = build_call_expr_loc (input_location,
13506 : builtin_decl_explicit (BUILT_IN_REALLOC),
13507 : 2, tmp, size);
13508 280 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
13509 : tmp, re);
13510 280 : tmp = fold_build2_loc (input_location, NE_EXPR,
13511 : logical_type_node, rhs_vptr, old_vptr);
13512 280 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13513 : tmp, re, build_empty_stmt (input_location));
13514 280 : gfc_add_expr_to_block (&re_alloc, re);
13515 : }
13516 307 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
13517 307 : gfc_finish_block (&re_alloc) :
13518 0 : build_empty_stmt (input_location);
13519 :
13520 : /* Allocate if _data is NULL, reallocate otherwise. */
13521 307 : tmp = fold_build2_loc (input_location, EQ_EXPR,
13522 : logical_type_node, class_han,
13523 : build_int_cst (prvoid_type_node, 0));
13524 307 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13525 : gfc_unlikely (tmp,
13526 : PRED_FORTRAN_FAIL_ALLOC),
13527 : gfc_finish_block (&alloc),
13528 : realloc_expr);
13529 307 : gfc_add_expr_to_block (&lse->pre, tmp);
13530 : }
13531 :
13532 3476 : fcn = gfc_vptr_copy_get (vptr);
13533 :
13534 3476 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
13535 3476 : ? gfc_class_data_get (rse->expr) : rse->expr;
13536 3476 : if (use_vptr_copy)
13537 : {
13538 5734 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13539 578 : || INDIRECT_REF_P (tmp)
13540 421 : || (rhs->ts.type == BT_DERIVED
13541 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13542 0 : && !rhs->ts.u.derived->attr.pointer
13543 0 : && !rhs->ts.u.derived->attr.allocatable)
13544 3574 : || (UNLIMITED_POLY (rhs)
13545 134 : && !CLASS_DATA (rhs)->attr.pointer
13546 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13547 2732 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13548 : else
13549 421 : vec_safe_push (args, tmp);
13550 3153 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13551 3153 : ? gfc_class_data_get (lse->expr) : lse->expr;
13552 5466 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13553 840 : || INDIRECT_REF_P (tmp)
13554 307 : || (lhs->ts.type == BT_DERIVED
13555 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13556 0 : && !lhs->ts.u.derived->attr.pointer
13557 0 : && !lhs->ts.u.derived->attr.allocatable)
13558 3460 : || (UNLIMITED_POLY (lhs)
13559 119 : && !CLASS_DATA (lhs)->attr.pointer
13560 119 : && !CLASS_DATA (lhs)->attr.allocatable))
13561 2846 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13562 : else
13563 307 : vec_safe_push (args, tmp);
13564 :
13565 3153 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13566 :
13567 3153 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13568 : {
13569 442 : tree extcopy;
13570 442 : vec_safe_push (args, from_len);
13571 442 : vec_safe_push (args, to_len);
13572 442 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13573 :
13574 442 : tmp = fold_build2_loc (input_location, GT_EXPR,
13575 : logical_type_node, from_len,
13576 442 : build_zero_cst (TREE_TYPE (from_len)));
13577 442 : return fold_build3_loc (input_location, COND_EXPR,
13578 : void_type_node, tmp,
13579 442 : extcopy, stdcopy);
13580 : }
13581 : else
13582 : return stdcopy;
13583 : }
13584 : else
13585 : {
13586 323 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13587 323 : ? gfc_class_data_get (lse->expr) : lse->expr;
13588 323 : stmtblock_t tblock;
13589 323 : gfc_init_block (&tblock);
13590 323 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13591 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13592 323 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13593 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13594 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13595 323 : gfc_add_modify_loc (input_location, &tblock, rhst,
13596 323 : fold_convert (TREE_TYPE (rhst), tmp));
13597 323 : return gfc_finish_block (&tblock);
13598 : }
13599 : }
13600 :
13601 : bool
13602 313477 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13603 : {
13604 313477 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13605 : return false;
13606 :
13607 32576 : return lhs->symtree->n.sym->assoc
13608 32576 : && lhs->symtree->n.sym->assoc->target == rhs;
13609 : }
13610 :
13611 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13612 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13613 : init_flag indicates initialization expressions and dealloc that no
13614 : deallocate prior assignment is needed (if in doubt, set true).
13615 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13616 : routine instead of a pointer assignment. Alias resolution is only done,
13617 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13618 : where it is known, that newly allocated memory on the lhs can never be
13619 : an alias of the rhs. */
13620 :
13621 : static tree
13622 313477 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13623 : bool dealloc, bool use_vptr_copy, bool may_alias)
13624 : {
13625 313477 : gfc_se lse;
13626 313477 : gfc_se rse;
13627 313477 : gfc_ss *lss;
13628 313477 : gfc_ss *lss_section;
13629 313477 : gfc_ss *rss;
13630 313477 : gfc_loopinfo loop;
13631 313477 : tree tmp;
13632 313477 : stmtblock_t block;
13633 313477 : stmtblock_t body;
13634 313477 : bool final_expr;
13635 313477 : bool l_is_temp;
13636 313477 : bool scalar_to_array;
13637 313477 : tree string_length;
13638 313477 : int n;
13639 313477 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13640 313477 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr, rhs_attr;
13641 313477 : bool is_poly_assign;
13642 313477 : bool realloc_flag;
13643 313477 : bool assoc_assign = false;
13644 313477 : bool dummy_class_array_copy;
13645 :
13646 : /* Assignment of the form lhs = rhs. */
13647 313477 : gfc_start_block (&block);
13648 :
13649 313477 : gfc_init_se (&lse, NULL);
13650 313477 : gfc_init_se (&rse, NULL);
13651 :
13652 313477 : gfc_fix_class_refs (expr1);
13653 :
13654 626954 : realloc_flag = flag_realloc_lhs
13655 307245 : && gfc_is_reallocatable_lhs (expr1)
13656 8437 : && expr2->rank
13657 320439 : && !is_runtime_conformable (expr1, expr2);
13658 :
13659 : /* Walk the lhs. */
13660 313477 : lss = gfc_walk_expr (expr1);
13661 313477 : if (realloc_flag)
13662 : {
13663 6579 : lss->no_bounds_check = 1;
13664 6579 : lss->is_alloc_lhs = 1;
13665 : }
13666 : else
13667 306898 : lss->no_bounds_check = expr1->no_bounds_check;
13668 :
13669 313477 : rss = NULL;
13670 :
13671 313477 : if (expr2->expr_type != EXPR_VARIABLE
13672 313477 : && expr2->expr_type != EXPR_CONSTANT
13673 313477 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13674 : {
13675 906 : expr2->must_finalize = 1;
13676 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13677 : function, the result is finalized after execution of the innermost
13678 : executable construct containing the reference. */
13679 906 : if (expr2->expr_type == EXPR_FUNCTION
13680 906 : && (gfc_expr_attr (expr2).pointer
13681 310 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13682 147 : expr2->must_finalize = 0;
13683 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13684 : structure constructor or array constructor, the entity created by
13685 : the constructor is finalized after execution of the innermost
13686 : executable construct containing the reference.
13687 : These finalizations were later deleted by the Combined Technical
13688 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13689 759 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13690 759 : && (expr2->expr_type == EXPR_STRUCTURE
13691 716 : || expr2->expr_type == EXPR_ARRAY))
13692 387 : expr2->must_finalize = 0;
13693 : }
13694 :
13695 :
13696 : /* Checking whether a class assignment is desired is quite complicated and
13697 : needed at two locations, so do it once only before the information is
13698 : needed. */
13699 313477 : lhs_attr = gfc_expr_attr (expr1);
13700 313477 : rhs_attr = gfc_expr_attr (expr2);
13701 313477 : dummy_class_array_copy
13702 626954 : = (expr2->expr_type == EXPR_VARIABLE
13703 32576 : && expr2->rank > 0
13704 8486 : && expr2->symtree != NULL
13705 8486 : && expr2->symtree->n.sym->attr.dummy
13706 1507 : && expr2->ts.type == BT_CLASS
13707 163 : && !rhs_attr.pointer
13708 163 : && !rhs_attr.allocatable
13709 150 : && !CLASS_DATA (expr2)->attr.class_pointer
13710 313627 : && !CLASS_DATA (expr2)->attr.allocatable);
13711 :
13712 : /* What can be sent to trans_class_assignment includes all the obvious
13713 : candidates but scalar assignment of a class expression to a derived type
13714 : must be done using gfc_trans_scalar_assign; partly because it is simpler
13715 : and partly because some cases fail, eg. class assignment to derived_type
13716 : select type temporaries. */
13717 313477 : is_poly_assign
13718 313477 : = (use_vptr_copy
13719 296019 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13720 23477 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13721 21342 : || gfc_is_class_scalar_expr (expr1)
13722 19989 : || gfc_is_class_array_ref (expr2, NULL)
13723 19989 : || (gfc_is_class_scalar_expr (expr2)
13724 42 : && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
13725 316965 : && lhs_attr.flavor != FL_PROCEDURE;
13726 :
13727 313477 : assoc_assign = is_assoc_assign (expr1, expr2);
13728 :
13729 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13730 : mode. Avoid false-positive uninitialized diagnostics with initializing
13731 : the codimension flag unconditionally. */
13732 313477 : lhs_caf_attr.codimension = false;
13733 313477 : rhs_caf_attr.codimension = false;
13734 313477 : if (flag_coarray == GFC_FCOARRAY_LIB)
13735 : {
13736 6887 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13737 6887 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13738 : }
13739 :
13740 313477 : tree reallocation = NULL_TREE;
13741 313477 : if (lss != gfc_ss_terminator)
13742 : {
13743 : /* The assignment needs scalarization. */
13744 : lss_section = lss;
13745 :
13746 : /* Find a non-scalar SS from the lhs. */
13747 : while (lss_section != gfc_ss_terminator
13748 40676 : && lss_section->info->type != GFC_SS_SECTION)
13749 0 : lss_section = lss_section->next;
13750 :
13751 40676 : gcc_assert (lss_section != gfc_ss_terminator);
13752 :
13753 : /* Initialize the scalarizer. */
13754 40676 : gfc_init_loopinfo (&loop);
13755 :
13756 : /* Walk the rhs. */
13757 40676 : rss = gfc_walk_expr (expr2);
13758 40676 : if (rss == gfc_ss_terminator)
13759 : {
13760 : /* The rhs is scalar. Add a ss for the expression. */
13761 15221 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13762 15221 : lss->is_alloc_lhs = 0;
13763 : }
13764 :
13765 : /* When doing a class assign, then the handle to the rhs needs to be a
13766 : pointer to allow for polymorphism. */
13767 40676 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13768 509 : rss->info->type = GFC_SS_REFERENCE;
13769 :
13770 40676 : rss->no_bounds_check = expr2->no_bounds_check;
13771 : /* Associate the SS with the loop. */
13772 40676 : gfc_add_ss_to_loop (&loop, lss);
13773 40676 : gfc_add_ss_to_loop (&loop, rss);
13774 :
13775 : /* Calculate the bounds of the scalarization. */
13776 40676 : gfc_conv_ss_startstride (&loop);
13777 : /* Enable loop reversal. */
13778 691492 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13779 610140 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13780 : /* Resolve any data dependencies in the statement. */
13781 40676 : if (may_alias)
13782 38349 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13783 : /* Setup the scalarizing loops. */
13784 40676 : gfc_conv_loop_setup (&loop, &expr2->where);
13785 :
13786 : /* Setup the gfc_se structures. */
13787 40676 : gfc_copy_loopinfo_to_se (&lse, &loop);
13788 40676 : gfc_copy_loopinfo_to_se (&rse, &loop);
13789 :
13790 40676 : rse.ss = rss;
13791 40676 : gfc_mark_ss_chain_used (rss, 1);
13792 40676 : if (loop.temp_ss == NULL)
13793 : {
13794 39562 : lse.ss = lss;
13795 39562 : gfc_mark_ss_chain_used (lss, 1);
13796 : }
13797 : else
13798 : {
13799 1114 : lse.ss = loop.temp_ss;
13800 1114 : gfc_mark_ss_chain_used (lss, 3);
13801 1114 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13802 : }
13803 :
13804 : /* Allow the scalarizer to workshare array assignments. */
13805 40676 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13806 : == OMPWS_WORKSHARE_FLAG
13807 85 : && loop.temp_ss == NULL)
13808 : {
13809 73 : maybe_workshare = true;
13810 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13811 : }
13812 :
13813 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13814 40676 : if (realloc_flag)
13815 : {
13816 6579 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13817 6579 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13818 6579 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13819 : expr2);
13820 : }
13821 :
13822 : /* Start the scalarized loop body. */
13823 40676 : gfc_start_scalarized_body (&loop, &body);
13824 : }
13825 : else
13826 272801 : gfc_init_block (&body);
13827 :
13828 313477 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13829 :
13830 : /* Translate the expression. */
13831 626954 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13832 313477 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13833 313477 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13834 313477 : gfc_conv_expr (&rse, expr2);
13835 :
13836 : /* Deal with the case of a scalar class function assigned to a derived type.
13837 : */
13838 313477 : if (gfc_is_alloc_class_scalar_function (expr2)
13839 313477 : && expr1->ts.type == BT_DERIVED)
13840 : {
13841 60 : rse.expr = gfc_class_data_get (rse.expr);
13842 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13843 : }
13844 :
13845 : /* Stabilize a string length for temporaries. */
13846 313477 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13847 24952 : && !(VAR_P (rse.string_length)
13848 : || TREE_CODE (rse.string_length) == PARM_DECL
13849 : || INDIRECT_REF_P (rse.string_length)))
13850 24076 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13851 289401 : else if (expr2->ts.type == BT_CHARACTER)
13852 : {
13853 4484 : if (expr1->ts.deferred
13854 6977 : && gfc_expr_attr (expr1).allocatable
13855 7097 : && gfc_check_dependency (expr1, expr2, true))
13856 120 : rse.string_length =
13857 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13858 4484 : string_length = rse.string_length;
13859 : }
13860 : else
13861 : string_length = NULL_TREE;
13862 :
13863 313477 : if (l_is_temp)
13864 : {
13865 1114 : gfc_conv_tmp_array_ref (&lse);
13866 1114 : if (expr2->ts.type == BT_CHARACTER)
13867 123 : lse.string_length = string_length;
13868 : }
13869 : else
13870 : {
13871 312363 : gfc_conv_expr (&lse, expr1);
13872 : /* For some expression (e.g. complex numbers) fold_convert uses a
13873 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13874 : not updated when assigned to. */
13875 312363 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13876 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13877 :
13878 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13879 318516 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13880 : {
13881 36 : tree cond;
13882 36 : const char* msg;
13883 :
13884 36 : tmp = INDIRECT_REF_P (lse.expr)
13885 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13886 36 : STRIP_NOPS (tmp);
13887 :
13888 : /* We should only get array references here. */
13889 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13890 : || TREE_CODE (tmp) == ARRAY_REF);
13891 :
13892 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13893 : or the array itself(ARRAY_REF). */
13894 36 : tmp = TREE_OPERAND (tmp, 0);
13895 :
13896 : /* Provide the address of the array. */
13897 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13898 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13899 :
13900 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13901 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13902 36 : msg = _("Assignment of scalar to unallocated array");
13903 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13904 : &expr1->where, msg);
13905 : }
13906 :
13907 : /* Deallocate the lhs parameterized components if required. */
13908 312363 : if (dealloc
13909 293333 : && !expr1->symtree->n.sym->attr.associate_var
13910 291279 : && expr2->expr_type != EXPR_ARRAY
13911 285075 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
13912 : {
13913 403 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
13914 :
13915 403 : tmp = lse.expr;
13916 403 : if (pdt_dep)
13917 : {
13918 : /* Create a temporary for deallocation after assignment. */
13919 204 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
13920 204 : gfc_add_modify (&lse.pre, tmp, lse.expr);
13921 : }
13922 :
13923 403 : if (expr1->ts.type == BT_DERIVED)
13924 403 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
13925 : expr1->rank);
13926 0 : else if (expr1->ts.type == BT_CLASS)
13927 : {
13928 0 : tmp = gfc_class_data_get (tmp);
13929 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
13930 : tmp, expr1->rank);
13931 : }
13932 :
13933 403 : if (tmp && pdt_dep)
13934 92 : gfc_add_expr_to_block (&rse.post, tmp);
13935 311 : else if (tmp)
13936 67 : gfc_add_expr_to_block (&lse.pre, tmp);
13937 : }
13938 : }
13939 :
13940 : /* Assignments of scalar derived types with allocatable components
13941 : to arrays must be done with a deep copy and the rhs temporary
13942 : must have its components deallocated afterwards. */
13943 626954 : scalar_to_array = (expr2->ts.type == BT_DERIVED
13944 20088 : && expr2->ts.u.derived->attr.alloc_comp
13945 6964 : && !gfc_expr_is_variable (expr2)
13946 317258 : && expr1->rank && !expr2->rank);
13947 626954 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
13948 20383 : && expr1->rank
13949 3909 : && expr1->ts.u.derived->attr.alloc_comp
13950 314912 : && gfc_is_alloc_class_scalar_function (expr2));
13951 313477 : if (scalar_to_array && dealloc)
13952 : {
13953 59 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
13954 59 : gfc_prepend_expr_to_block (&loop.post, tmp);
13955 : }
13956 :
13957 : /* When assigning a character function result to a deferred-length variable,
13958 : the function call must happen before the (re)allocation of the lhs -
13959 : otherwise the character length of the result is not known.
13960 : NOTE 1: This relies on having the exact dependence of the length type
13961 : parameter available to the caller; gfortran saves it in the .mod files.
13962 : NOTE 2: Vector array references generate an index temporary that must
13963 : not go outside the loop. Otherwise, variables should not generate
13964 : a pre block.
13965 : NOTE 3: The concatenation operation generates a temporary pointer,
13966 : whose allocation must go to the innermost loop.
13967 : NOTE 4: Elemental functions may generate a temporary, too. */
13968 313477 : if (flag_realloc_lhs
13969 307245 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
13970 3074 : && !(lss != gfc_ss_terminator
13971 952 : && rss != gfc_ss_terminator
13972 952 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
13973 759 : || (expr2->expr_type == EXPR_FUNCTION
13974 160 : && expr2->value.function.esym != NULL
13975 26 : && expr2->value.function.esym->attr.elemental)
13976 746 : || (expr2->expr_type == EXPR_FUNCTION
13977 147 : && expr2->value.function.isym != NULL
13978 134 : && expr2->value.function.isym->elemental)
13979 690 : || (expr2->expr_type == EXPR_OP
13980 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
13981 2787 : gfc_add_block_to_block (&block, &rse.pre);
13982 :
13983 : /* Nullify the allocatable components corresponding to those of the lhs
13984 : derived type, so that the finalization of the function result does not
13985 : affect the lhs of the assignment. Prepend is used to ensure that the
13986 : nullification occurs before the call to the finalizer. In the case of
13987 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
13988 : as part of the deep copy. */
13989 312643 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
13990 333026 : && (gfc_is_class_array_function (expr2)
13991 19525 : || gfc_is_alloc_class_scalar_function (expr2)))
13992 : {
13993 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
13994 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
13995 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
13996 0 : gfc_add_block_to_block (&loop.post, &rse.post);
13997 : }
13998 :
13999 313477 : tmp = NULL_TREE;
14000 :
14001 313477 : if (is_poly_assign)
14002 : {
14003 10428 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
14004 630 : use_vptr_copy || (lhs_attr.allocatable
14005 307 : && !lhs_attr.dimension),
14006 3202 : !realloc_flag && flag_realloc_lhs
14007 630 : && !lhs_attr.pointer);
14008 3476 : if (expr2->expr_type == EXPR_FUNCTION
14009 244 : && expr2->ts.type == BT_DERIVED
14010 18 : && expr2->ts.u.derived->attr.alloc_comp)
14011 : {
14012 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
14013 : rse.expr, expr2->rank);
14014 18 : if (lss == gfc_ss_terminator)
14015 18 : gfc_add_expr_to_block (&rse.post, tmp2);
14016 : else
14017 0 : gfc_add_expr_to_block (&loop.post, tmp2);
14018 : }
14019 :
14020 3476 : expr1->must_finalize = 0;
14021 : }
14022 310001 : else if (!is_poly_assign
14023 310001 : && expr1->ts.type == BT_CLASS
14024 393 : && expr2->ts.type == BT_CLASS
14025 200 : && (expr2->must_finalize || dummy_class_array_copy))
14026 : {
14027 : /* This case comes about when the scalarizer provides array element
14028 : references to class temporaries or nonpointer dummy arrays. Use the
14029 : vptr copy function, since this does a deep copy of allocatable
14030 : components. */
14031 132 : tmp = gfc_get_vptr_from_expr (rse.expr);
14032 132 : if (tmp == NULL_TREE && dummy_class_array_copy)
14033 12 : tmp = gfc_get_vptr_from_expr (gfc_get_class_from_gfc_expr (expr2));
14034 132 : if (tmp != NULL_TREE)
14035 : {
14036 132 : tree fcn = gfc_vptr_copy_get (tmp);
14037 132 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
14038 132 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
14039 132 : tmp = build_call_expr_loc (input_location,
14040 : fcn, 2,
14041 : gfc_build_addr_expr (NULL, rse.expr),
14042 : gfc_build_addr_expr (NULL, lse.expr));
14043 : }
14044 : }
14045 :
14046 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
14047 : after evaluation of the rhs and before reallocation.
14048 : Skip finalization for self-assignment to avoid use-after-free.
14049 : Strip parentheses from both sides to handle cases like a = (a). */
14050 313477 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
14051 313477 : if (final_expr
14052 684 : && gfc_dep_compare_expr (strip_parentheses (expr1),
14053 : strip_parentheses (expr2)) != 0
14054 314137 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
14055 229 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
14056 : {
14057 660 : if (lss == gfc_ss_terminator)
14058 : {
14059 189 : gfc_add_block_to_block (&block, &rse.pre);
14060 189 : gfc_add_block_to_block (&block, &lse.finalblock);
14061 : }
14062 : else
14063 : {
14064 471 : gfc_add_block_to_block (&body, &rse.pre);
14065 471 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
14066 : &lse.finalblock);
14067 : }
14068 : }
14069 : else
14070 312817 : gfc_add_block_to_block (&body, &rse.pre);
14071 :
14072 313477 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
14073 2994 : && assoc_assign)
14074 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
14075 :
14076 : /* The finalization above is all that is wanted: the structure copy is done
14077 : component by component in generate_component_assignments. */
14078 313477 : if (expr1->finalize_only)
14079 24 : tmp = build_empty_stmt (input_location);
14080 :
14081 : /* If nothing else works, do it the old fashioned way! */
14082 313477 : if (tmp == NULL_TREE)
14083 : {
14084 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
14085 309845 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
14086 309845 : tmp
14087 619690 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
14088 309845 : gfc_expr_is_variable (expr2_stripped)
14089 279119 : || scalar_to_array
14090 278375 : || expr2->expr_type == EXPR_ARRAY,
14091 : !(l_is_temp || init_flag) && dealloc,
14092 309845 : expr1->symtree->n.sym->attr.codimension,
14093 : assoc_assign);
14094 : }
14095 :
14096 : /* Add the lse pre block to the body */
14097 313477 : gfc_add_block_to_block (&body, &lse.pre);
14098 313477 : gfc_add_expr_to_block (&body, tmp);
14099 :
14100 : /* Add the post blocks to the body. Scalar finalization must appear before
14101 : the post block in case any dellocations are done. */
14102 313477 : if (rse.finalblock.head
14103 313477 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
14104 154 : && gfc_expr_attr (expr2).elemental)))
14105 : {
14106 154 : gfc_add_block_to_block (&body, &rse.finalblock);
14107 154 : gfc_add_block_to_block (&body, &rse.post);
14108 : }
14109 : else
14110 313323 : gfc_add_block_to_block (&body, &rse.post);
14111 :
14112 313477 : gfc_add_block_to_block (&body, &lse.post);
14113 :
14114 313477 : if (lss == gfc_ss_terminator)
14115 : {
14116 : /* F2003: Add the code for reallocation on assignment. */
14117 269960 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
14118 276516 : && !is_poly_assign)
14119 3715 : alloc_scalar_allocatable_for_assignment (&block, string_length,
14120 : expr1, expr2);
14121 :
14122 : /* Use the scalar assignment as is. */
14123 272801 : gfc_add_block_to_block (&block, &body);
14124 : }
14125 : else
14126 : {
14127 40676 : gcc_assert (lse.ss == gfc_ss_terminator
14128 : && rse.ss == gfc_ss_terminator);
14129 :
14130 40676 : if (l_is_temp)
14131 : {
14132 1114 : gfc_trans_scalarized_loop_boundary (&loop, &body);
14133 :
14134 : /* We need to copy the temporary to the actual lhs. */
14135 1114 : gfc_init_se (&lse, NULL);
14136 1114 : gfc_init_se (&rse, NULL);
14137 1114 : gfc_copy_loopinfo_to_se (&lse, &loop);
14138 1114 : gfc_copy_loopinfo_to_se (&rse, &loop);
14139 :
14140 1114 : rse.ss = loop.temp_ss;
14141 1114 : lse.ss = lss;
14142 :
14143 1114 : gfc_conv_tmp_array_ref (&rse);
14144 1114 : gfc_conv_expr (&lse, expr1);
14145 :
14146 1114 : gcc_assert (lse.ss == gfc_ss_terminator
14147 : && rse.ss == gfc_ss_terminator);
14148 :
14149 1114 : if (expr2->ts.type == BT_CHARACTER)
14150 123 : rse.string_length = string_length;
14151 :
14152 1114 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
14153 : false, dealloc);
14154 1114 : gfc_add_expr_to_block (&body, tmp);
14155 : }
14156 :
14157 40676 : if (reallocation != NULL_TREE)
14158 6579 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
14159 :
14160 40676 : if (maybe_workshare)
14161 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
14162 :
14163 : /* Generate the copying loops. */
14164 40676 : gfc_trans_scalarizing_loops (&loop, &body);
14165 :
14166 : /* Wrap the whole thing up. */
14167 40676 : gfc_add_block_to_block (&block, &loop.pre);
14168 40676 : gfc_add_block_to_block (&block, &loop.post);
14169 :
14170 40676 : gfc_cleanup_loop (&loop);
14171 : }
14172 :
14173 : /* Since parameterized components cannot have default initializers,
14174 : the default PDT constructor leaves them unallocated. Do the
14175 : allocation now. */
14176 313477 : if (init_flag && IS_PDT (expr1)
14177 395 : && !expr1->symtree->n.sym->attr.allocatable
14178 395 : && !expr1->symtree->n.sym->attr.dummy)
14179 : {
14180 79 : gfc_symbol *sym = expr1->symtree->n.sym;
14181 79 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
14182 : sym->backend_decl,
14183 79 : sym->as ? sym->as->rank : 0,
14184 79 : sym->param_list);
14185 79 : gfc_add_expr_to_block (&block, tmp);
14186 : }
14187 :
14188 313477 : return gfc_finish_block (&block);
14189 : }
14190 :
14191 :
14192 : /* Check whether EXPR is a copyable array. */
14193 :
14194 : static bool
14195 993395 : copyable_array_p (gfc_expr * expr)
14196 : {
14197 993395 : if (expr->expr_type != EXPR_VARIABLE)
14198 : return false;
14199 :
14200 : /* First check it's an array. */
14201 969334 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
14202 : return false;
14203 :
14204 149863 : if (!gfc_full_array_ref_p (expr->ref, NULL))
14205 : return false;
14206 :
14207 : /* Next check that it's of a simple enough type. */
14208 117563 : switch (expr->ts.type)
14209 : {
14210 : case BT_INTEGER:
14211 : case BT_REAL:
14212 : case BT_COMPLEX:
14213 : case BT_LOGICAL:
14214 : return true;
14215 :
14216 : case BT_CHARACTER:
14217 : return false;
14218 :
14219 6839 : case_bt_struct:
14220 6839 : return (!expr->ts.u.derived->attr.alloc_comp
14221 6839 : && !expr->ts.u.derived->attr.pdt_type);
14222 :
14223 : default:
14224 : break;
14225 : }
14226 :
14227 : return false;
14228 : }
14229 :
14230 : /* Translate an assignment. */
14231 :
14232 : tree
14233 331528 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
14234 : bool dealloc, bool use_vptr_copy, bool may_alias)
14235 : {
14236 331528 : tree tmp;
14237 :
14238 : /* Special case a single function returning an array. */
14239 331528 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
14240 : {
14241 14518 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
14242 14518 : if (tmp)
14243 : return tmp;
14244 : }
14245 :
14246 : /* Special case assigning an array to zero. */
14247 324661 : if (copyable_array_p (expr1)
14248 324661 : && is_zero_initializer_p (expr2))
14249 : {
14250 4060 : tmp = gfc_trans_zero_assign (expr1);
14251 4060 : if (tmp)
14252 : return tmp;
14253 : }
14254 :
14255 : /* Special case copying one array to another. */
14256 320898 : if (copyable_array_p (expr1)
14257 28424 : && copyable_array_p (expr2)
14258 2699 : && gfc_compare_types (&expr1->ts, &expr2->ts)
14259 323597 : && !gfc_check_dependency (expr1, expr2, 0))
14260 : {
14261 2603 : tmp = gfc_trans_array_copy (expr1, expr2);
14262 2603 : if (tmp)
14263 : return tmp;
14264 : }
14265 :
14266 : /* Special case initializing an array from a constant array constructor. */
14267 319412 : if (copyable_array_p (expr1)
14268 26938 : && expr2->expr_type == EXPR_ARRAY
14269 327731 : && gfc_compare_types (&expr1->ts, &expr2->ts))
14270 : {
14271 8319 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
14272 8319 : if (tmp)
14273 : return tmp;
14274 : }
14275 :
14276 313477 : if (UNLIMITED_POLY (expr1) && expr1->rank)
14277 313477 : use_vptr_copy = true;
14278 :
14279 : /* Fallback to the scalarizer to generate explicit loops. */
14280 313477 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
14281 313477 : use_vptr_copy, may_alias);
14282 : }
14283 :
14284 : tree
14285 13521 : gfc_trans_init_assign (gfc_code * code)
14286 : {
14287 13521 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
14288 : }
14289 :
14290 : tree
14291 309412 : gfc_trans_assign (gfc_code * code)
14292 : {
14293 309412 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
14294 : }
14295 :
14296 : /* Generate a simple loop for internal use of the form
14297 : for (var = begin; var <cond> end; var += step)
14298 : body; */
14299 : void
14300 12281 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
14301 : enum tree_code cond, tree step, tree body)
14302 : {
14303 12281 : tree tmp;
14304 :
14305 : /* var = begin. */
14306 12281 : gfc_add_modify (block, var, begin);
14307 :
14308 : /* Loop: for (var = begin; var <cond> end; var += step). */
14309 12281 : tree label_loop = gfc_build_label_decl (NULL_TREE);
14310 12281 : tree label_cond = gfc_build_label_decl (NULL_TREE);
14311 12281 : TREE_USED (label_loop) = 1;
14312 12281 : TREE_USED (label_cond) = 1;
14313 :
14314 12281 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
14315 12281 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
14316 :
14317 : /* Loop body. */
14318 12281 : gfc_add_expr_to_block (block, body);
14319 :
14320 : /* End of loop body. */
14321 12281 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
14322 12281 : gfc_add_modify (block, var, tmp);
14323 12281 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
14324 12281 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
14325 12281 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
14326 : build_empty_stmt (input_location));
14327 12281 : gfc_add_expr_to_block (block, tmp);
14328 12281 : }
|
