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 : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 : #include "trans-stmt.h"
43 : #include "dependency.h"
44 : #include "gimplify.h"
45 : #include "tm.h" /* For CHAR_TYPE_SIZE. */
46 :
47 :
48 : /* Calculate the number of characters in a string. */
49 :
50 : static tree
51 36136 : gfc_get_character_len (tree type)
52 : {
53 36136 : tree len;
54 :
55 36136 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
56 : && TYPE_STRING_FLAG (type));
57 :
58 36136 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
59 36136 : len = (len) ? (len) : (integer_zero_node);
60 36136 : return fold_convert (gfc_charlen_type_node, len);
61 : }
62 :
63 :
64 :
65 : /* Calculate the number of bytes in a string. */
66 :
67 : tree
68 36136 : gfc_get_character_len_in_bytes (tree type)
69 : {
70 36136 : tree tmp, len;
71 :
72 36136 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
73 : && TYPE_STRING_FLAG (type));
74 :
75 36136 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
76 72272 : tmp = (tmp && !integer_zerop (tmp))
77 72272 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
78 36136 : len = gfc_get_character_len (type);
79 36136 : if (tmp && len && !integer_zerop (len))
80 35364 : len = fold_build2_loc (input_location, MULT_EXPR,
81 : gfc_charlen_type_node, len, tmp);
82 36136 : return len;
83 : }
84 :
85 :
86 : /* Convert a scalar to an array descriptor. To be used for assumed-rank
87 : arrays. */
88 :
89 : static tree
90 6276 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
91 : {
92 6276 : enum gfc_array_kind akind;
93 6276 : tree *lbound = NULL, *ubound = NULL;
94 6276 : int codim = 0;
95 :
96 6276 : if (attr.pointer)
97 : akind = GFC_ARRAY_POINTER_CONT;
98 5924 : else if (attr.allocatable)
99 : akind = GFC_ARRAY_ALLOCATABLE;
100 : else
101 5155 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
102 :
103 6276 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
104 5329 : scalar = TREE_TYPE (scalar);
105 6276 : if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
106 : {
107 4734 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
108 4734 : codim = lang_specific->corank;
109 4734 : lbound = lang_specific->lbound;
110 4734 : ubound = lang_specific->ubound;
111 : }
112 6276 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
113 : ubound, 1, akind,
114 6276 : !(attr.pointer || attr.target));
115 : }
116 :
117 : tree
118 5598 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
119 : {
120 5598 : tree desc, type, etype;
121 :
122 5598 : type = get_scalar_to_descriptor_type (scalar, attr);
123 5598 : etype = TREE_TYPE (scalar);
124 5598 : desc = gfc_create_var (type, "desc");
125 5598 : DECL_ARTIFICIAL (desc) = 1;
126 :
127 5598 : if (CONSTANT_CLASS_P (scalar))
128 : {
129 54 : tree tmp;
130 54 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
131 54 : gfc_add_modify (&se->pre, tmp, scalar);
132 54 : scalar = tmp;
133 : }
134 5598 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
135 947 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
136 4651 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
137 158 : etype = TREE_TYPE (etype);
138 5598 : gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
139 : gfc_get_dtype_rank_type (0, etype));
140 5598 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
141 5598 : gfc_conv_descriptor_span_set (&se->pre, desc,
142 : gfc_conv_descriptor_elem_len (desc));
143 :
144 : /* Copy pointer address back - but only if it could have changed and
145 : if the actual argument is a pointer and not, e.g., NULL(). */
146 5598 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
147 846 : gfc_add_modify (&se->post, scalar,
148 423 : fold_convert (TREE_TYPE (scalar),
149 : gfc_conv_descriptor_data_get (desc)));
150 5598 : return desc;
151 : }
152 :
153 :
154 : /* Get the coarray token from the ultimate array or component ref.
155 : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
156 :
157 : tree
158 512 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
159 : {
160 512 : gfc_symbol *sym = expr->symtree->n.sym;
161 1024 : bool is_coarray = sym->ts.type == BT_CLASS
162 512 : ? CLASS_DATA (sym)->attr.codimension
163 467 : : sym->attr.codimension;
164 512 : gfc_expr *caf_expr = gfc_copy_expr (expr);
165 512 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
166 :
167 1622 : while (ref)
168 : {
169 1110 : if (ref->type == REF_COMPONENT
170 417 : && (ref->u.c.component->attr.allocatable
171 104 : || ref->u.c.component->attr.pointer)
172 415 : && (is_coarray || ref->u.c.component->attr.codimension))
173 1110 : last_caf_ref = ref;
174 1110 : ref = ref->next;
175 : }
176 :
177 512 : if (last_caf_ref == NULL)
178 : {
179 180 : gfc_free_expr (caf_expr);
180 180 : return NULL_TREE;
181 : }
182 :
183 143 : tree comp = last_caf_ref->u.c.component->caf_token
184 332 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
185 : : NULL_TREE,
186 : caf;
187 332 : gfc_se se;
188 332 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
189 332 : if (comp == NULL_TREE && comp_ref)
190 : {
191 46 : gfc_free_expr (caf_expr);
192 46 : return NULL_TREE;
193 : }
194 286 : gfc_init_se (&se, outerse);
195 286 : gfc_free_ref_list (last_caf_ref->next);
196 286 : last_caf_ref->next = NULL;
197 286 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
198 572 : caf_expr->corank = last_caf_ref->u.c.component->as
199 286 : ? last_caf_ref->u.c.component->as->corank
200 : : expr->corank;
201 286 : se.want_pointer = comp_ref;
202 286 : gfc_conv_expr (&se, caf_expr);
203 286 : gfc_add_block_to_block (&outerse->pre, &se.pre);
204 :
205 286 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
206 143 : se.expr = TREE_OPERAND (se.expr, 0);
207 286 : gfc_free_expr (caf_expr);
208 :
209 286 : if (comp_ref)
210 143 : caf = fold_build3_loc (input_location, COMPONENT_REF,
211 143 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
212 : else
213 143 : caf = gfc_conv_descriptor_token (se.expr);
214 286 : return gfc_build_addr_expr (NULL_TREE, caf);
215 : }
216 :
217 :
218 : /* This is the seed for an eventual trans-class.c
219 :
220 : The following parameters should not be used directly since they might
221 : in future implementations. Use the corresponding APIs. */
222 : #define CLASS_DATA_FIELD 0
223 : #define CLASS_VPTR_FIELD 1
224 : #define CLASS_LEN_FIELD 2
225 : #define VTABLE_HASH_FIELD 0
226 : #define VTABLE_SIZE_FIELD 1
227 : #define VTABLE_EXTENDS_FIELD 2
228 : #define VTABLE_DEF_INIT_FIELD 3
229 : #define VTABLE_COPY_FIELD 4
230 : #define VTABLE_FINAL_FIELD 5
231 : #define VTABLE_DEALLOCATE_FIELD 6
232 :
233 :
234 : tree
235 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
236 : {
237 40 : tree tmp;
238 40 : tree field;
239 40 : vec<constructor_elt, va_gc> *init = NULL;
240 :
241 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
242 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
243 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
244 :
245 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
246 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
247 :
248 40 : return build_constructor (TREE_TYPE (decl), init);
249 : }
250 :
251 :
252 : tree
253 32324 : gfc_class_data_get (tree decl)
254 : {
255 32324 : tree data;
256 32324 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
257 5423 : decl = build_fold_indirect_ref_loc (input_location, decl);
258 32324 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
259 : CLASS_DATA_FIELD);
260 32324 : return fold_build3_loc (input_location, COMPONENT_REF,
261 32324 : TREE_TYPE (data), decl, data,
262 32324 : NULL_TREE);
263 : }
264 :
265 :
266 : tree
267 45755 : gfc_class_vptr_get (tree decl)
268 : {
269 45755 : tree vptr;
270 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
271 : then available through the saved descriptor. */
272 28346 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
273 47555 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
274 1297 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
275 45755 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
276 2363 : decl = build_fold_indirect_ref_loc (input_location, decl);
277 45755 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
278 : CLASS_VPTR_FIELD);
279 45755 : return fold_build3_loc (input_location, COMPONENT_REF,
280 45755 : TREE_TYPE (vptr), decl, vptr,
281 45755 : NULL_TREE);
282 : }
283 :
284 :
285 : tree
286 6685 : gfc_class_len_get (tree decl)
287 : {
288 6685 : tree len;
289 : /* For class arrays decl may be a temporary descriptor handle, the len is
290 : then available through the saved descriptor. */
291 4793 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
292 6934 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
293 85 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
294 6685 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
295 662 : decl = build_fold_indirect_ref_loc (input_location, decl);
296 6685 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
297 : CLASS_LEN_FIELD);
298 6685 : return fold_build3_loc (input_location, COMPONENT_REF,
299 6685 : TREE_TYPE (len), decl, len,
300 6685 : NULL_TREE);
301 : }
302 :
303 :
304 : /* Try to get the _len component of a class. When the class is not unlimited
305 : poly, i.e. no _len field exists, then return a zero node. */
306 :
307 : static tree
308 4999 : gfc_class_len_or_zero_get (tree decl)
309 : {
310 4999 : tree len;
311 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
312 : then available through the saved descriptor. */
313 2975 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
314 5047 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
315 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
316 4999 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
317 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
318 4999 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
319 : CLASS_LEN_FIELD);
320 6866 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
321 1867 : TREE_TYPE (len), decl, len,
322 : NULL_TREE)
323 3132 : : build_zero_cst (gfc_charlen_type_node);
324 : }
325 :
326 :
327 : tree
328 4835 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
329 : {
330 4835 : tree tmp;
331 4835 : tree tmp2;
332 4835 : tree type;
333 :
334 4835 : tmp = gfc_class_len_or_zero_get (class_expr);
335 :
336 : /* Include the len value in the element size if present. */
337 4835 : if (!integer_zerop (tmp))
338 : {
339 1703 : type = TREE_TYPE (size);
340 1703 : if (block)
341 : {
342 990 : size = gfc_evaluate_now (size, block);
343 990 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
344 : }
345 : else
346 713 : tmp = fold_convert (type , tmp);
347 1703 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
348 : type, size, tmp);
349 1703 : tmp = fold_build2_loc (input_location, GT_EXPR,
350 : logical_type_node, tmp,
351 : build_zero_cst (type));
352 1703 : size = fold_build3_loc (input_location, COND_EXPR,
353 : type, tmp, tmp2, size);
354 : }
355 : else
356 : return size;
357 :
358 1703 : if (block)
359 990 : size = gfc_evaluate_now (size, block);
360 :
361 : return size;
362 : }
363 :
364 :
365 : /* Get the specified FIELD from the VPTR. */
366 :
367 : static tree
368 21268 : vptr_field_get (tree vptr, int fieldno)
369 : {
370 21268 : tree field;
371 21268 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
372 21268 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
373 : fieldno);
374 21268 : field = fold_build3_loc (input_location, COMPONENT_REF,
375 21268 : TREE_TYPE (field), vptr, field,
376 : NULL_TREE);
377 21268 : gcc_assert (field);
378 21268 : return field;
379 : }
380 :
381 :
382 : /* Get the field from the class' vptr. */
383 :
384 : static tree
385 9888 : class_vtab_field_get (tree decl, int fieldno)
386 : {
387 9888 : tree vptr;
388 9888 : vptr = gfc_class_vptr_get (decl);
389 9888 : return vptr_field_get (vptr, fieldno);
390 : }
391 :
392 :
393 : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
394 : unison. */
395 : #define VTAB_GET_FIELD_GEN(name, field) tree \
396 : gfc_class_vtab_## name ##_get (tree cl) \
397 : { \
398 : return class_vtab_field_get (cl, field); \
399 : } \
400 : \
401 : tree \
402 : gfc_vptr_## name ##_get (tree vptr) \
403 : { \
404 : return vptr_field_get (vptr, field); \
405 : }
406 :
407 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
408 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
409 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
410 4359 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
411 1812 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
412 1023 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
413 : #undef VTAB_GET_FIELD_GEN
414 :
415 : /* The size field is returned as an array index type. Therefore treat
416 : it and only it specially. */
417 :
418 : tree
419 7910 : gfc_class_vtab_size_get (tree cl)
420 : {
421 7910 : tree size;
422 7910 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
423 : /* Always return size as an array index type. */
424 7910 : size = fold_convert (gfc_array_index_type, size);
425 7910 : gcc_assert (size);
426 7910 : return size;
427 : }
428 :
429 : tree
430 5981 : gfc_vptr_size_get (tree vptr)
431 : {
432 5981 : tree size;
433 5981 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
434 : /* Always return size as an array index type. */
435 5981 : size = fold_convert (gfc_array_index_type, size);
436 5981 : gcc_assert (size);
437 5981 : return size;
438 : }
439 :
440 :
441 : #undef CLASS_DATA_FIELD
442 : #undef CLASS_VPTR_FIELD
443 : #undef CLASS_LEN_FIELD
444 : #undef VTABLE_HASH_FIELD
445 : #undef VTABLE_SIZE_FIELD
446 : #undef VTABLE_EXTENDS_FIELD
447 : #undef VTABLE_DEF_INIT_FIELD
448 : #undef VTABLE_COPY_FIELD
449 : #undef VTABLE_FINAL_FIELD
450 :
451 :
452 : /* IF ts is null (default), search for the last _class ref in the chain
453 : of references of the expression and cut the chain there. Although
454 : this routine is similar to class.cc:gfc_add_component_ref (), there
455 : is a significant difference: gfc_add_component_ref () concentrates
456 : on an array ref that is the last ref in the chain and is oblivious
457 : to the kind of refs following.
458 : ELSE IF ts is non-null the cut is at the class entity or component
459 : that is followed by an array reference, which is not an element.
460 : These calls come from trans-array.cc:build_class_array_ref, which
461 : handles scalarized class array references.*/
462 :
463 : gfc_expr *
464 9451 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
465 : gfc_typespec **ts)
466 : {
467 9451 : gfc_expr *base_expr;
468 9451 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
469 :
470 : /* Find the last class reference. */
471 9451 : class_ref = NULL;
472 9451 : array_ref = NULL;
473 :
474 9451 : if (ts)
475 : {
476 435 : if (e->symtree
477 410 : && e->symtree->n.sym->ts.type == BT_CLASS)
478 410 : *ts = &e->symtree->n.sym->ts;
479 : else
480 25 : *ts = NULL;
481 : }
482 :
483 23761 : for (ref = e->ref; ref; ref = ref->next)
484 : {
485 14730 : if (ts)
486 : {
487 1038 : if (ref->type == REF_COMPONENT
488 490 : && ref->u.c.component->ts.type == BT_CLASS
489 0 : && ref->next && ref->next->type == REF_COMPONENT
490 0 : && !strcmp (ref->next->u.c.component->name, "_data")
491 0 : && ref->next->next
492 0 : && ref->next->next->type == REF_ARRAY
493 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
494 : {
495 0 : *ts = &ref->u.c.component->ts;
496 0 : class_ref = ref;
497 0 : break;
498 : }
499 :
500 1038 : if (ref->next == NULL)
501 : break;
502 : }
503 : else
504 : {
505 13692 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
506 13692 : array_ref = ref;
507 :
508 13692 : if (ref->type == REF_COMPONENT
509 8241 : && ref->u.c.component->ts.type == BT_CLASS)
510 : {
511 : /* Component to the right of a part reference with nonzero
512 : rank must not have the ALLOCATABLE attribute. If attempts
513 : are made to reference such a component reference, an error
514 : results followed by an ICE. */
515 1612 : if (array_ref
516 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
517 : return NULL;
518 : class_ref = ref;
519 : }
520 : }
521 : }
522 :
523 9441 : if (ts && *ts == NULL)
524 : return NULL;
525 :
526 : /* Remove and store all subsequent references after the
527 : CLASS reference. */
528 9416 : if (class_ref)
529 : {
530 1410 : tail = class_ref->next;
531 1410 : class_ref->next = NULL;
532 : }
533 8006 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
534 : {
535 8006 : tail = e->ref;
536 8006 : e->ref = NULL;
537 : }
538 :
539 9416 : if (is_mold)
540 61 : base_expr = gfc_expr_to_initialize (e);
541 : else
542 9355 : base_expr = gfc_copy_expr (e);
543 :
544 : /* Restore the original tail expression. */
545 9416 : if (class_ref)
546 : {
547 1410 : gfc_free_ref_list (class_ref->next);
548 1410 : class_ref->next = tail;
549 : }
550 8006 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
551 : {
552 8006 : gfc_free_ref_list (e->ref);
553 8006 : e->ref = tail;
554 : }
555 : return base_expr;
556 : }
557 :
558 : /* Reset the vptr to the declared type, e.g. after deallocation.
559 : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
560 : one with e or class_type. At least one of the two has to be set. The
561 : generated assignment code is added at the end of BLOCK. */
562 :
563 : void
564 11242 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
565 : gfc_symbol *class_type)
566 : {
567 11242 : tree vptr = NULL_TREE;
568 :
569 11242 : if (class_container != NULL_TREE)
570 6746 : vptr = gfc_get_vptr_from_expr (class_container);
571 :
572 6746 : if (vptr == NULL_TREE)
573 : {
574 4503 : gfc_se se;
575 4503 : gcc_assert (e);
576 :
577 : /* Evaluate the expression and obtain the vptr from it. */
578 4503 : gfc_init_se (&se, NULL);
579 4503 : if (e->rank)
580 2249 : gfc_conv_expr_descriptor (&se, e);
581 : else
582 2254 : gfc_conv_expr (&se, e);
583 4503 : gfc_add_block_to_block (block, &se.pre);
584 :
585 4503 : vptr = gfc_get_vptr_from_expr (se.expr);
586 : }
587 :
588 : /* If a vptr is not found, we can do nothing more. */
589 4503 : if (vptr == NULL_TREE)
590 : return;
591 :
592 11232 : if (UNLIMITED_POLY (e)
593 10202 : || UNLIMITED_POLY (class_type)
594 : /* When the class_type's source is not a symbol (e.g. a component's ts),
595 : then look at the _data-components type. */
596 1517 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
597 1517 : && class_type->components && class_type->components->ts.u.derived
598 1511 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
599 1198 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
600 : else
601 : {
602 10034 : gfc_symbol *vtab, *type = nullptr;
603 10034 : tree vtable;
604 :
605 10034 : if (e)
606 8685 : type = e->ts.u.derived;
607 1349 : else if (class_type)
608 : {
609 1349 : if (class_type->ts.type == BT_CLASS)
610 0 : type = CLASS_DATA (class_type)->ts.u.derived;
611 : else
612 : type = class_type;
613 : }
614 8685 : gcc_assert (type);
615 : /* Return the vptr to the address of the declared type. */
616 10034 : vtab = gfc_find_derived_vtab (type);
617 10034 : vtable = vtab->backend_decl;
618 10034 : if (vtable == NULL_TREE)
619 88 : vtable = gfc_get_symbol_decl (vtab);
620 10034 : vtable = gfc_build_addr_expr (NULL, vtable);
621 10034 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
622 10034 : gfc_add_modify (block, vptr, vtable);
623 : }
624 : }
625 :
626 : /* Set the vptr of a class in to from the type given in from. If from is NULL,
627 : then reset the vptr to the default or to. */
628 :
629 : void
630 228 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
631 : {
632 228 : tree tmp, vptr_ref;
633 228 : gfc_symbol *type;
634 :
635 228 : vptr_ref = gfc_get_vptr_from_expr (to);
636 264 : if (POINTER_TYPE_P (TREE_TYPE (from))
637 228 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
638 : {
639 44 : gfc_add_modify (block, vptr_ref,
640 22 : fold_convert (TREE_TYPE (vptr_ref),
641 : gfc_get_vptr_from_expr (from)));
642 250 : return;
643 : }
644 206 : tmp = gfc_get_vptr_from_expr (from);
645 206 : if (tmp)
646 : {
647 170 : gfc_add_modify (block, vptr_ref,
648 170 : fold_convert (TREE_TYPE (vptr_ref), tmp));
649 170 : return;
650 : }
651 36 : if (VAR_P (from)
652 36 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
653 : {
654 36 : gfc_add_modify (block, vptr_ref,
655 36 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
656 36 : return;
657 : }
658 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
659 0 : && GFC_CLASS_TYPE_P (
660 : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
661 : {
662 0 : gfc_add_modify (block, vptr_ref,
663 0 : fold_convert (TREE_TYPE (vptr_ref),
664 : gfc_get_vptr_from_expr (TREE_OPERAND (
665 : TREE_OPERAND (from, 0), 0))));
666 0 : return;
667 : }
668 :
669 : /* If nothing of the above matches, set the vtype according to the type. */
670 0 : tmp = TREE_TYPE (from);
671 0 : if (POINTER_TYPE_P (tmp))
672 0 : tmp = TREE_TYPE (tmp);
673 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
674 : &type);
675 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
676 0 : gcc_assert (tmp);
677 0 : gfc_add_modify (block, vptr_ref,
678 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
679 : }
680 :
681 : /* Reset the len for unlimited polymorphic objects. */
682 :
683 : void
684 633 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
685 : {
686 633 : gfc_expr *e;
687 633 : gfc_se se_len;
688 633 : e = gfc_find_and_cut_at_last_class_ref (expr);
689 633 : if (e == NULL)
690 0 : return;
691 633 : gfc_add_len_component (e);
692 633 : gfc_init_se (&se_len, NULL);
693 633 : gfc_conv_expr (&se_len, e);
694 633 : gfc_add_modify (block, se_len.expr,
695 633 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
696 633 : gfc_free_expr (e);
697 : }
698 :
699 :
700 : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
701 : reference is found. Note that it is up to the caller to avoid using this
702 : for expressions other than variables. */
703 :
704 : tree
705 1451 : gfc_get_class_from_gfc_expr (gfc_expr *e)
706 : {
707 1451 : gfc_expr *class_expr;
708 1451 : gfc_se cse;
709 1451 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
710 1451 : if (class_expr == NULL)
711 : return NULL_TREE;
712 1451 : gfc_init_se (&cse, NULL);
713 1451 : gfc_conv_expr (&cse, class_expr);
714 1451 : gfc_free_expr (class_expr);
715 1451 : return cse.expr;
716 : }
717 :
718 :
719 : /* Obtain the last class reference in an expression.
720 : Return NULL_TREE if no class reference is found. */
721 :
722 : tree
723 108189 : gfc_get_class_from_expr (tree expr)
724 : {
725 108189 : tree tmp;
726 108189 : tree type;
727 108189 : bool array_descr_found = false;
728 108189 : bool comp_after_descr_found = false;
729 :
730 278731 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
731 : {
732 278731 : if (CONSTANT_CLASS_P (tmp))
733 : return NULL_TREE;
734 :
735 278694 : type = TREE_TYPE (tmp);
736 323106 : while (type)
737 : {
738 315228 : if (GFC_CLASS_TYPE_P (type))
739 : return tmp;
740 295244 : if (GFC_DESCRIPTOR_TYPE_P (type))
741 35273 : array_descr_found = true;
742 295244 : if (type != TYPE_CANONICAL (type))
743 44412 : type = TYPE_CANONICAL (type);
744 : else
745 : type = NULL_TREE;
746 : }
747 258710 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
748 : break;
749 :
750 : /* Avoid walking up the reference chain too far. For class arrays, the
751 : array descriptor is a direct component (through a pointer) of the class
752 : container. So there is exactly one COMPONENT_REF between a class
753 : container and its child array descriptor. After seeing an array
754 : descriptor, we can give up on the second COMPONENT_REF we see, if no
755 : class container was found until that point. */
756 170542 : if (array_descr_found)
757 : {
758 7455 : if (comp_after_descr_found)
759 : {
760 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
761 : return NULL_TREE;
762 : }
763 7443 : else if (TREE_CODE (tmp) == COMPONENT_REF)
764 7455 : comp_after_descr_found = true;
765 : }
766 : }
767 :
768 88168 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
769 59195 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
770 :
771 88168 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
772 : return tmp;
773 :
774 : return NULL_TREE;
775 : }
776 :
777 :
778 : /* Obtain the vptr of the last class reference in an expression.
779 : Return NULL_TREE if no class reference is found. */
780 :
781 : tree
782 11897 : gfc_get_vptr_from_expr (tree expr)
783 : {
784 11897 : tree tmp;
785 :
786 11897 : tmp = gfc_get_class_from_expr (expr);
787 :
788 11897 : if (tmp != NULL_TREE)
789 11832 : return gfc_class_vptr_get (tmp);
790 :
791 : return NULL_TREE;
792 : }
793 :
794 : static void
795 2275 : copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
796 : {
797 2275 : tree src_type = TREE_TYPE (src);
798 2275 : if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
799 : {
800 135 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
801 270 : for (int c = 0; c < lang_specific->corank; ++c)
802 : {
803 135 : int dim = lang_specific->rank + c;
804 135 : tree codim = gfc_rank_cst[dim];
805 :
806 135 : if (lang_specific->lbound[dim])
807 54 : gfc_conv_descriptor_lbound_set (block, dest, codim,
808 : lang_specific->lbound[dim]);
809 : else
810 81 : gfc_conv_descriptor_lbound_set (
811 : block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
812 135 : if (dim + 1 < lang_specific->corank)
813 : {
814 0 : if (lang_specific->ubound[dim])
815 0 : gfc_conv_descriptor_ubound_set (block, dest, codim,
816 : lang_specific->ubound[dim]);
817 : else
818 0 : gfc_conv_descriptor_ubound_set (
819 : block, dest, codim,
820 : gfc_conv_descriptor_ubound_get (src, codim));
821 : }
822 : }
823 : }
824 2275 : }
825 :
826 : void
827 1953 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
828 : bool lhs_type)
829 : {
830 1953 : tree lhs_dim, rhs_dim, type;
831 :
832 1953 : gfc_conv_descriptor_data_set (block, lhs_desc,
833 : gfc_conv_descriptor_data_get (rhs_desc));
834 1953 : gfc_conv_descriptor_offset_set (block, lhs_desc,
835 : gfc_conv_descriptor_offset_get (rhs_desc));
836 :
837 1953 : gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
838 : gfc_conv_descriptor_dtype (rhs_desc));
839 :
840 : /* Assign the dimension as range-ref. */
841 1953 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
842 1953 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
843 :
844 1953 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
845 1953 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
846 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
847 1953 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
848 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
849 1953 : gfc_add_modify (block, lhs_dim, rhs_dim);
850 :
851 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
852 1953 : copy_coarray_desc_part (block, lhs_desc, rhs_desc);
853 1953 : }
854 :
855 : /* Takes a derived type expression and returns the address of a temporary
856 : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
857 : used for the temporary class object.
858 : optional_alloc_ptr is false when the dummy is neither allocatable
859 : nor a pointer; that's only relevant for the optional handling.
860 : The optional argument 'derived_array' is used to preserve the parmse
861 : expression for deallocation of allocatable components. Assumed rank
862 : formal arguments made this necessary. */
863 : void
864 5247 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
865 : tree opt_vptr_src, bool optional,
866 : bool optional_alloc_ptr, const char *proc_name,
867 : tree *derived_array)
868 : {
869 5247 : tree cond_optional = NULL_TREE;
870 5247 : gfc_ss *ss;
871 5247 : tree ctree;
872 5247 : tree var;
873 5247 : tree tmp;
874 5247 : tree packed = NULL_TREE;
875 :
876 : /* The derived type needs to be converted to a temporary CLASS object. */
877 5247 : tmp = gfc_typenode_for_spec (&fsym->ts);
878 5247 : var = gfc_create_var (tmp, "class");
879 :
880 : /* Set the vptr. */
881 5247 : if (opt_vptr_src)
882 128 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
883 : else
884 5119 : gfc_reset_vptr (&parmse->pre, e, var);
885 :
886 : /* Now set the data field. */
887 5247 : ctree = gfc_class_data_get (var);
888 :
889 5247 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
890 : {
891 4 : tree token;
892 4 : tmp = gfc_get_tree_for_caf_expr (e);
893 4 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
894 2 : tmp = build_fold_indirect_ref (tmp);
895 4 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
896 4 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), token);
897 : }
898 :
899 5247 : if (optional)
900 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
901 :
902 : /* Set the _len as early as possible. */
903 5247 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
904 5247 : && fsym->ts.u.derived->components->ts.u.derived->attr
905 5247 : .unlimited_polymorphic)
906 : {
907 : /* Take care about initializing the _len component correctly. */
908 386 : tree len_tree = gfc_class_len_get (var);
909 386 : if (UNLIMITED_POLY (e))
910 : {
911 12 : gfc_expr *len;
912 12 : gfc_se se;
913 :
914 12 : len = gfc_find_and_cut_at_last_class_ref (e);
915 12 : gfc_add_len_component (len);
916 12 : gfc_init_se (&se, NULL);
917 12 : gfc_conv_expr (&se, len);
918 12 : if (optional)
919 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
920 : cond_optional, se.expr,
921 0 : fold_convert (TREE_TYPE (se.expr),
922 : integer_zero_node));
923 : else
924 12 : tmp = se.expr;
925 12 : gfc_free_expr (len);
926 12 : }
927 : else
928 374 : tmp = integer_zero_node;
929 386 : gfc_add_modify (&parmse->pre, len_tree,
930 386 : fold_convert (TREE_TYPE (len_tree), tmp));
931 : }
932 :
933 5247 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
934 : {
935 : /* If there is a ready made pointer to a derived type, use it
936 : rather than evaluating the expression again. */
937 535 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
938 535 : gfc_add_modify (&parmse->pre, ctree, tmp);
939 : }
940 4712 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
941 : {
942 : /* For an array reference in an elemental procedure call we need
943 : to retain the ss to provide the scalarized array reference. */
944 445 : gfc_conv_expr_reference (parmse, e);
945 445 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
946 445 : if (optional)
947 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
948 : cond_optional, tmp,
949 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
950 445 : gfc_add_modify (&parmse->pre, ctree, tmp);
951 : }
952 : else
953 : {
954 4267 : ss = gfc_walk_expr (e);
955 4267 : if (ss == gfc_ss_terminator)
956 : {
957 3013 : parmse->ss = NULL;
958 3013 : gfc_conv_expr_reference (parmse, e);
959 :
960 : /* Scalar to an assumed-rank array. */
961 3013 : if (fsym->ts.u.derived->components->as)
962 : {
963 322 : tree type;
964 322 : type = get_scalar_to_descriptor_type (parmse->expr,
965 : gfc_expr_attr (e));
966 322 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
967 : gfc_get_dtype (type));
968 322 : copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
969 322 : if (optional)
970 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
971 96 : TREE_TYPE (parmse->expr),
972 : cond_optional, parmse->expr,
973 96 : fold_convert (TREE_TYPE (parmse->expr),
974 : null_pointer_node));
975 322 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
976 : }
977 : else
978 : {
979 2691 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
980 2691 : if (optional)
981 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
982 : cond_optional, tmp,
983 132 : fold_convert (TREE_TYPE (tmp),
984 : null_pointer_node));
985 2691 : gfc_add_modify (&parmse->pre, ctree, tmp);
986 : }
987 : }
988 : else
989 : {
990 1254 : stmtblock_t block;
991 1254 : gfc_init_block (&block);
992 1254 : gfc_ref *ref;
993 1254 : int dim;
994 1254 : tree lbshift = NULL_TREE;
995 :
996 : /* Array refs with sections indicate, that a for a formal argument
997 : expecting contiguous repacking needs to be done. */
998 2357 : for (ref = e->ref; ref; ref = ref->next)
999 1253 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1000 : break;
1001 1254 : if (IS_CLASS_ARRAY (fsym)
1002 1146 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
1003 888 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
1004 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
1005 144 : fsym->attr.contiguous = 1;
1006 :
1007 : /* Detect any array references with vector subscripts. */
1008 2501 : for (ref = e->ref; ref; ref = ref->next)
1009 1253 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
1010 1211 : && ref->u.ar.type != AR_FULL)
1011 : {
1012 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
1013 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
1014 : break;
1015 150 : if (dim < ref->u.ar.dimen)
1016 : break;
1017 : }
1018 : /* Array references with vector subscripts and non-variable
1019 : expressions need be converted to a one-based descriptor. */
1020 1254 : if (ref || e->expr_type != EXPR_VARIABLE)
1021 49 : lbshift = gfc_index_one_node;
1022 :
1023 1254 : parmse->expr = var;
1024 1254 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
1025 : &lbshift, &packed);
1026 :
1027 1254 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
1028 : {
1029 1158 : *derived_array
1030 1158 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
1031 1158 : if (e->rank == -1)
1032 : {
1033 : /* Assumed-rank actual: parmse->expr physically holds only
1034 : dtype.rank dims; a full struct assign reads past the end.
1035 : Copy field-by-field with a runtime-sized dim[] memcpy.
1036 : PR fortran/60576. */
1037 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
1038 :
1039 78 : gfc_conv_descriptor_data_set
1040 78 : (&block, *derived_array,
1041 : gfc_conv_descriptor_data_get (parmse->expr));
1042 78 : gfc_conv_descriptor_offset_set
1043 78 : (&block, *derived_array,
1044 : gfc_conv_descriptor_offset_get (parmse->expr));
1045 78 : gfc_add_modify (&block,
1046 : gfc_conv_descriptor_dtype (*derived_array),
1047 : gfc_conv_descriptor_dtype (parmse->expr));
1048 78 : rank = fold_convert (size_type_node,
1049 : gfc_conv_descriptor_rank (parmse->expr));
1050 78 : dim_field = gfc_get_descriptor_dimension (parmse->expr);
1051 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
1052 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
1053 : size_type_node, rank, dim_size);
1054 78 : dst_ptr = gfc_build_addr_expr
1055 78 : (pvoid_type_node, gfc_get_descriptor_dimension (*derived_array));
1056 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
1057 78 : gfc_add_expr_to_block (&block,
1058 : build_call_expr_loc (input_location,
1059 : builtin_decl_explicit (BUILT_IN_MEMCPY),
1060 : 3, dst_ptr, src_ptr, copy_size));
1061 : }
1062 : else
1063 1080 : gfc_add_modify (&block, *derived_array, parmse->expr);
1064 : }
1065 :
1066 1254 : if (optional)
1067 : {
1068 348 : tmp = gfc_finish_block (&block);
1069 :
1070 348 : gfc_init_block (&block);
1071 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
1072 348 : if (derived_array && *derived_array != NULL_TREE)
1073 348 : gfc_conv_descriptor_data_set (&block, *derived_array,
1074 : null_pointer_node);
1075 :
1076 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
1077 : gfc_finish_block (&block));
1078 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
1079 : }
1080 : else
1081 906 : gfc_add_block_to_block (&parmse->pre, &block);
1082 : }
1083 : }
1084 :
1085 : /* Pass the address of the class object. */
1086 5247 : if (packed)
1087 96 : parmse->expr = packed;
1088 : else
1089 5151 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1090 :
1091 5247 : if (optional && optional_alloc_ptr)
1092 84 : parmse->expr
1093 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1094 : cond_optional, parmse->expr,
1095 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1096 5247 : }
1097 :
1098 : /* Create a new class container, which is required as scalar coarrays
1099 : have an array descriptor while normal scalars haven't. Optionally,
1100 : NULL pointer checks are added if the argument is OPTIONAL. */
1101 :
1102 : static void
1103 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1104 : gfc_typespec class_ts, bool optional)
1105 : {
1106 48 : tree var, ctree, tmp;
1107 48 : stmtblock_t block;
1108 48 : gfc_ref *ref;
1109 48 : gfc_ref *class_ref;
1110 :
1111 48 : gfc_init_block (&block);
1112 :
1113 48 : class_ref = NULL;
1114 144 : for (ref = e->ref; ref; ref = ref->next)
1115 : {
1116 96 : if (ref->type == REF_COMPONENT
1117 48 : && ref->u.c.component->ts.type == BT_CLASS)
1118 96 : class_ref = ref;
1119 : }
1120 :
1121 48 : if (class_ref == NULL
1122 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1123 48 : tmp = e->symtree->n.sym->backend_decl;
1124 : else
1125 : {
1126 : /* Remove everything after the last class reference, convert the
1127 : expression and then recover its tailend once more. */
1128 0 : gfc_se tmpse;
1129 0 : ref = class_ref->next;
1130 0 : class_ref->next = NULL;
1131 0 : gfc_init_se (&tmpse, NULL);
1132 0 : gfc_conv_expr (&tmpse, e);
1133 0 : class_ref->next = ref;
1134 0 : tmp = tmpse.expr;
1135 : }
1136 :
1137 48 : var = gfc_typenode_for_spec (&class_ts);
1138 48 : var = gfc_create_var (var, "class");
1139 :
1140 48 : ctree = gfc_class_vptr_get (var);
1141 96 : gfc_add_modify (&block, ctree,
1142 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1143 :
1144 48 : ctree = gfc_class_data_get (var);
1145 48 : tmp = gfc_conv_descriptor_data_get (
1146 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1147 : ? tmp
1148 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1149 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1150 :
1151 : /* Pass the address of the class object. */
1152 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1153 :
1154 48 : if (optional)
1155 : {
1156 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1157 48 : tree tmp2;
1158 :
1159 48 : tmp = gfc_finish_block (&block);
1160 :
1161 48 : gfc_init_block (&block);
1162 48 : tmp2 = gfc_class_data_get (var);
1163 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1164 : null_pointer_node));
1165 48 : tmp2 = gfc_finish_block (&block);
1166 :
1167 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1168 : cond, tmp, tmp2);
1169 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1170 : }
1171 : else
1172 0 : gfc_add_block_to_block (&parmse->pre, &block);
1173 48 : }
1174 :
1175 :
1176 : /* Takes an intrinsic type expression and returns the address of a temporary
1177 : class object of the 'declared' type. */
1178 : void
1179 882 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1180 : gfc_typespec class_ts)
1181 : {
1182 882 : gfc_symbol *vtab;
1183 882 : gfc_ss *ss;
1184 882 : tree ctree;
1185 882 : tree var;
1186 882 : tree tmp;
1187 882 : int dim;
1188 882 : bool unlimited_poly;
1189 :
1190 1764 : unlimited_poly = class_ts.type == BT_CLASS
1191 882 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1192 882 : && class_ts.u.derived->components->ts.u.derived
1193 882 : ->attr.unlimited_polymorphic;
1194 :
1195 : /* The intrinsic type needs to be converted to a temporary
1196 : CLASS object. */
1197 882 : tmp = gfc_typenode_for_spec (&class_ts);
1198 882 : var = gfc_create_var (tmp, "class");
1199 :
1200 : /* Force a temporary for component or substring references. */
1201 882 : if (unlimited_poly
1202 882 : && class_ts.u.derived->components->attr.dimension
1203 623 : && !class_ts.u.derived->components->attr.allocatable
1204 623 : && !class_ts.u.derived->components->attr.class_pointer
1205 1505 : && is_subref_array (e))
1206 17 : parmse->force_tmp = 1;
1207 :
1208 : /* Set the vptr. */
1209 882 : ctree = gfc_class_vptr_get (var);
1210 :
1211 882 : vtab = gfc_find_vtab (&e->ts);
1212 882 : gcc_assert (vtab);
1213 882 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1214 882 : gfc_add_modify (&parmse->pre, ctree,
1215 882 : fold_convert (TREE_TYPE (ctree), tmp));
1216 :
1217 : /* Now set the data field. */
1218 882 : ctree = gfc_class_data_get (var);
1219 882 : if (parmse->ss && parmse->ss->info->useflags)
1220 : {
1221 : /* For an array reference in an elemental procedure call we need
1222 : to retain the ss to provide the scalarized array reference. */
1223 36 : gfc_conv_expr_reference (parmse, e);
1224 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1225 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1226 : }
1227 : else
1228 : {
1229 846 : ss = gfc_walk_expr (e);
1230 846 : if (ss == gfc_ss_terminator)
1231 : {
1232 247 : parmse->ss = NULL;
1233 247 : gfc_conv_expr_reference (parmse, e);
1234 247 : if (class_ts.u.derived->components->as
1235 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1236 : {
1237 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1238 : gfc_expr_attr (e));
1239 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1240 24 : TREE_TYPE (ctree), tmp);
1241 : }
1242 : else
1243 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1244 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1245 : }
1246 : else
1247 : {
1248 599 : parmse->ss = ss;
1249 599 : gfc_conv_expr_descriptor (parmse, e);
1250 :
1251 : /* Array references with vector subscripts and non-variable expressions
1252 : need be converted to a one-based descriptor. */
1253 599 : if (e->expr_type != EXPR_VARIABLE)
1254 : {
1255 368 : for (dim = 0; dim < e->rank; ++dim)
1256 193 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1257 : dim, gfc_index_one_node);
1258 : }
1259 :
1260 599 : if (class_ts.u.derived->components->as->rank != e->rank)
1261 : {
1262 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1263 49 : TREE_TYPE (ctree), parmse->expr);
1264 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1265 : }
1266 : else
1267 550 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1268 : }
1269 : }
1270 :
1271 882 : gcc_assert (class_ts.type == BT_CLASS);
1272 882 : if (unlimited_poly)
1273 : {
1274 882 : ctree = gfc_class_len_get (var);
1275 : /* When the actual arg is a char array, then set the _len component of the
1276 : unlimited polymorphic entity to the length of the string. */
1277 882 : if (e->ts.type == BT_CHARACTER)
1278 : {
1279 : /* Start with parmse->string_length because this seems to be set to a
1280 : correct value more often. */
1281 175 : if (parmse->string_length)
1282 : tmp = parmse->string_length;
1283 : /* When the string_length is not yet set, then try the backend_decl of
1284 : the cl. */
1285 0 : else if (e->ts.u.cl->backend_decl)
1286 : tmp = e->ts.u.cl->backend_decl;
1287 : /* If both of the above approaches fail, then try to generate an
1288 : expression from the input, which is only feasible currently, when the
1289 : expression can be evaluated to a constant one. */
1290 : else
1291 : {
1292 : /* Try to simplify the expression. */
1293 0 : gfc_simplify_expr (e, 0);
1294 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1295 : {
1296 : /* Amazingly all data is present to compute the length of a
1297 : constant string, but the expression is not yet there. */
1298 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1299 : gfc_charlen_int_kind,
1300 : &e->where);
1301 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1302 0 : e->value.character.length);
1303 0 : gfc_conv_const_charlen (e->ts.u.cl);
1304 0 : e->ts.u.cl->resolved = 1;
1305 0 : tmp = e->ts.u.cl->backend_decl;
1306 : }
1307 : else
1308 : {
1309 0 : gfc_error ("Cannot compute the length of the char array "
1310 : "at %L.", &e->where);
1311 : }
1312 : }
1313 : }
1314 : else
1315 707 : tmp = integer_zero_node;
1316 :
1317 882 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1318 : }
1319 :
1320 : /* Pass the address of the class object. */
1321 882 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1322 882 : }
1323 :
1324 :
1325 : /* Takes a scalarized class array expression and returns the
1326 : address of a temporary scalar class object of the 'declared'
1327 : type.
1328 : OOP-TODO: This could be improved by adding code that branched on
1329 : the dynamic type being the same as the declared type. In this case
1330 : the original class expression can be passed directly.
1331 : optional_alloc_ptr is false when the dummy is neither allocatable
1332 : nor a pointer; that's relevant for the optional handling.
1333 : Set copyback to true if class container's _data and _vtab pointers
1334 : might get modified. */
1335 :
1336 : void
1337 3618 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1338 : bool elemental, bool copyback, bool optional,
1339 : bool optional_alloc_ptr)
1340 : {
1341 3618 : tree ctree;
1342 3618 : tree var;
1343 3618 : tree tmp;
1344 3618 : tree vptr;
1345 3618 : tree cond = NULL_TREE;
1346 3618 : tree slen = NULL_TREE;
1347 3618 : gfc_ref *ref;
1348 3618 : gfc_ref *class_ref;
1349 3618 : stmtblock_t block;
1350 3618 : bool full_array = false;
1351 :
1352 : /* If this is the data field of a class temporary, the class expression
1353 : can be obtained and returned directly. */
1354 3618 : if (e->expr_type != EXPR_VARIABLE
1355 180 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1356 36 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))
1357 3654 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse->expr, 0))))
1358 : {
1359 36 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1360 36 : if (!VAR_P (parmse->expr))
1361 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1362 36 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1363 174 : return;
1364 : }
1365 :
1366 3582 : gfc_init_block (&block);
1367 :
1368 3582 : class_ref = NULL;
1369 7183 : for (ref = e->ref; ref; ref = ref->next)
1370 : {
1371 6807 : if (ref->type == REF_COMPONENT
1372 3634 : && ref->u.c.component->ts.type == BT_CLASS)
1373 6807 : class_ref = ref;
1374 :
1375 6807 : if (ref->next == NULL)
1376 : break;
1377 : }
1378 :
1379 3582 : if ((ref == NULL || class_ref == ref)
1380 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1381 4052 : && (!class_ts.u.derived->components->as
1382 379 : || class_ts.u.derived->components->as->rank != -1))
1383 : return;
1384 :
1385 : /* Test for FULL_ARRAY. */
1386 3444 : if (e->rank == 0
1387 3444 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1388 494 : || (class_ts.u.derived->components->as
1389 366 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1390 411 : full_array = true;
1391 : else
1392 3033 : gfc_is_class_array_ref (e, &full_array);
1393 :
1394 : /* The derived type needs to be converted to a temporary
1395 : CLASS object. */
1396 3444 : tmp = gfc_typenode_for_spec (&class_ts);
1397 3444 : var = gfc_create_var (tmp, "class");
1398 :
1399 : /* Set the data. */
1400 3444 : ctree = gfc_class_data_get (var);
1401 3444 : if (class_ts.u.derived->components->as
1402 3160 : && e->rank != class_ts.u.derived->components->as->rank)
1403 : {
1404 965 : if (e->rank == 0)
1405 : {
1406 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1407 : gfc_expr_attr (e));
1408 356 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1409 : gfc_get_dtype (type));
1410 :
1411 356 : tmp = gfc_class_data_get (parmse->expr);
1412 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1413 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1414 :
1415 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1416 : }
1417 : else
1418 609 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1419 : }
1420 : else
1421 : {
1422 2479 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1423 1427 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1424 1427 : TREE_TYPE (ctree), parmse->expr);
1425 2479 : gfc_add_modify (&block, ctree, parmse->expr);
1426 : }
1427 :
1428 : /* Return the data component, except in the case of scalarized array
1429 : references, where nullification of the cannot occur and so there
1430 : is no need. */
1431 3444 : if (!elemental && full_array && copyback)
1432 : {
1433 1158 : if (class_ts.u.derived->components->as
1434 1158 : && e->rank != class_ts.u.derived->components->as->rank)
1435 : {
1436 270 : if (e->rank == 0)
1437 : {
1438 102 : tmp = gfc_class_data_get (parmse->expr);
1439 204 : gfc_add_modify (&parmse->post, tmp,
1440 102 : fold_convert (TREE_TYPE (tmp),
1441 : gfc_conv_descriptor_data_get (ctree)));
1442 : }
1443 : else
1444 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1445 : true);
1446 : }
1447 : else
1448 888 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1449 : }
1450 :
1451 : /* Set the vptr. */
1452 3444 : ctree = gfc_class_vptr_get (var);
1453 :
1454 : /* The vptr is the second field of the actual argument.
1455 : First we have to find the corresponding class reference. */
1456 :
1457 3444 : tmp = NULL_TREE;
1458 3444 : if (gfc_is_class_array_function (e)
1459 3444 : && parmse->class_vptr != NULL_TREE)
1460 : tmp = parmse->class_vptr;
1461 3426 : else if (class_ref == NULL
1462 2981 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1463 : {
1464 2981 : tmp = e->symtree->n.sym->backend_decl;
1465 :
1466 2981 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1467 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1468 :
1469 2981 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1470 397 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1471 :
1472 2981 : slen = build_zero_cst (size_type_node);
1473 : }
1474 445 : else if (parmse->class_container != NULL_TREE)
1475 : /* Don't redundantly evaluate the expression if the required information
1476 : is already available. */
1477 : tmp = parmse->class_container;
1478 : else
1479 : {
1480 : /* Remove everything after the last class reference, convert the
1481 : expression and then recover its tailend once more. */
1482 18 : gfc_se tmpse;
1483 18 : ref = class_ref->next;
1484 18 : class_ref->next = NULL;
1485 18 : gfc_init_se (&tmpse, NULL);
1486 18 : gfc_conv_expr (&tmpse, e);
1487 18 : class_ref->next = ref;
1488 18 : tmp = tmpse.expr;
1489 18 : slen = tmpse.string_length;
1490 : }
1491 :
1492 3444 : gcc_assert (tmp != NULL_TREE);
1493 :
1494 : /* Dereference if needs be. */
1495 3444 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1496 345 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1497 :
1498 3444 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1499 3426 : vptr = gfc_class_vptr_get (tmp);
1500 : else
1501 : vptr = tmp;
1502 :
1503 3444 : gfc_add_modify (&block, ctree,
1504 3444 : fold_convert (TREE_TYPE (ctree), vptr));
1505 :
1506 : /* Return the vptr component, except in the case of scalarized array
1507 : references, where the dynamic type cannot change. */
1508 3444 : if (!elemental && full_array && copyback)
1509 1158 : gfc_add_modify (&parmse->post, vptr,
1510 1158 : fold_convert (TREE_TYPE (vptr), ctree));
1511 :
1512 : /* For unlimited polymorphic objects also set the _len component. */
1513 3444 : if (class_ts.type == BT_CLASS
1514 3444 : && class_ts.u.derived->components
1515 3444 : && class_ts.u.derived->components->ts.u
1516 3444 : .derived->attr.unlimited_polymorphic)
1517 : {
1518 1110 : ctree = gfc_class_len_get (var);
1519 1110 : if (UNLIMITED_POLY (e))
1520 913 : tmp = gfc_class_len_get (tmp);
1521 197 : else if (e->ts.type == BT_CHARACTER)
1522 : {
1523 0 : gcc_assert (slen != NULL_TREE);
1524 : tmp = slen;
1525 : }
1526 : else
1527 197 : tmp = build_zero_cst (size_type_node);
1528 1110 : gfc_add_modify (&parmse->pre, ctree,
1529 1110 : fold_convert (TREE_TYPE (ctree), tmp));
1530 :
1531 : /* Return the len component, except in the case of scalarized array
1532 : references, where the dynamic type cannot change. */
1533 1110 : if (!elemental && full_array && copyback
1534 441 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1535 428 : gfc_add_modify (&parmse->post, tmp,
1536 428 : fold_convert (TREE_TYPE (tmp), ctree));
1537 : }
1538 :
1539 3444 : if (optional)
1540 : {
1541 510 : tree tmp2;
1542 :
1543 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1544 : /* parmse->pre may contain some preparatory instructions for the
1545 : temporary array descriptor. Those may only be executed when the
1546 : optional argument is set, therefore add parmse->pre's instructions
1547 : to block, which is later guarded by an if (optional_arg_given). */
1548 510 : gfc_add_block_to_block (&parmse->pre, &block);
1549 510 : block.head = parmse->pre.head;
1550 510 : parmse->pre.head = NULL_TREE;
1551 510 : tmp = gfc_finish_block (&block);
1552 :
1553 510 : if (optional_alloc_ptr)
1554 102 : tmp2 = build_empty_stmt (input_location);
1555 : else
1556 : {
1557 408 : gfc_init_block (&block);
1558 :
1559 408 : tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1560 408 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1561 : null_pointer_node));
1562 408 : tmp2 = gfc_finish_block (&block);
1563 : }
1564 :
1565 510 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1566 : cond, tmp, tmp2);
1567 510 : gfc_add_expr_to_block (&parmse->pre, tmp);
1568 :
1569 510 : if (!elemental && full_array && copyback)
1570 : {
1571 30 : tmp2 = build_empty_stmt (input_location);
1572 30 : tmp = gfc_finish_block (&parmse->post);
1573 30 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1574 : cond, tmp, tmp2);
1575 30 : gfc_add_expr_to_block (&parmse->post, tmp);
1576 : }
1577 : }
1578 : else
1579 2934 : gfc_add_block_to_block (&parmse->pre, &block);
1580 :
1581 : /* Pass the address of the class object. */
1582 3444 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1583 :
1584 3444 : if (optional && optional_alloc_ptr)
1585 204 : parmse->expr = build3_loc (input_location, COND_EXPR,
1586 102 : TREE_TYPE (parmse->expr),
1587 : cond, parmse->expr,
1588 102 : fold_convert (TREE_TYPE (parmse->expr),
1589 : null_pointer_node));
1590 : }
1591 :
1592 :
1593 : /* Given a class array declaration and an index, returns the address
1594 : of the referenced element. */
1595 :
1596 : static tree
1597 720 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1598 : bool unlimited)
1599 : {
1600 720 : tree data, size, tmp, ctmp, offset, ptr;
1601 :
1602 720 : data = data_comp != NULL_TREE ? data_comp :
1603 0 : gfc_class_data_get (class_decl);
1604 720 : size = gfc_class_vtab_size_get (class_decl);
1605 :
1606 720 : if (unlimited)
1607 : {
1608 208 : tmp = fold_convert (gfc_array_index_type,
1609 : gfc_class_len_get (class_decl));
1610 208 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1611 : gfc_array_index_type, size, tmp);
1612 208 : tmp = fold_build2_loc (input_location, GT_EXPR,
1613 : logical_type_node, tmp,
1614 208 : build_zero_cst (TREE_TYPE (tmp)));
1615 208 : size = fold_build3_loc (input_location, COND_EXPR,
1616 : gfc_array_index_type, tmp, ctmp, size);
1617 : }
1618 :
1619 720 : offset = fold_build2_loc (input_location, MULT_EXPR,
1620 : gfc_array_index_type,
1621 : index, size);
1622 :
1623 720 : data = gfc_conv_descriptor_data_get (data);
1624 720 : ptr = fold_convert (pvoid_type_node, data);
1625 720 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1626 720 : return fold_convert (TREE_TYPE (data), ptr);
1627 : }
1628 :
1629 :
1630 : /* Copies one class expression to another, assuming that if either
1631 : 'to' or 'from' are arrays they are packed. Should 'from' be
1632 : NULL_TREE, the initialization expression for 'to' is used, assuming
1633 : that the _vptr is set. */
1634 :
1635 : tree
1636 762 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1637 : {
1638 762 : tree fcn;
1639 762 : tree fcn_type;
1640 762 : tree from_data;
1641 762 : tree from_len;
1642 762 : tree to_data;
1643 762 : tree to_len;
1644 762 : tree to_ref;
1645 762 : tree from_ref;
1646 762 : vec<tree, va_gc> *args;
1647 762 : tree tmp;
1648 762 : tree stdcopy;
1649 762 : tree extcopy;
1650 762 : tree index;
1651 762 : bool is_from_desc = false, is_to_class = false;
1652 :
1653 762 : args = NULL;
1654 : /* To prevent warnings on uninitialized variables. */
1655 762 : from_len = to_len = NULL_TREE;
1656 :
1657 762 : if (from != NULL_TREE)
1658 762 : fcn = gfc_class_vtab_copy_get (from);
1659 : else
1660 0 : fcn = gfc_class_vtab_copy_get (to);
1661 :
1662 762 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1663 :
1664 762 : if (from != NULL_TREE)
1665 : {
1666 762 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1667 762 : if (is_from_desc)
1668 : {
1669 0 : from_data = from;
1670 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1671 : }
1672 : else
1673 : {
1674 : /* Check that from is a class. When the class is part of a coarray,
1675 : then from is a common pointer and is to be used as is. */
1676 1524 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1677 762 : ? build_fold_indirect_ref (from) : from;
1678 1524 : from_data =
1679 762 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1680 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1681 762 : ? gfc_class_data_get (from) : from;
1682 762 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1683 : }
1684 : }
1685 : else
1686 0 : from_data = gfc_class_vtab_def_init_get (to);
1687 :
1688 762 : if (unlimited)
1689 : {
1690 164 : if (from != NULL_TREE && unlimited)
1691 164 : from_len = gfc_class_len_or_zero_get (from);
1692 : else
1693 0 : from_len = build_zero_cst (size_type_node);
1694 : }
1695 :
1696 762 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1697 : {
1698 762 : is_to_class = true;
1699 762 : to_data = gfc_class_data_get (to);
1700 762 : if (unlimited)
1701 164 : to_len = gfc_class_len_get (to);
1702 : }
1703 : else
1704 : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1705 0 : to_data = to;
1706 :
1707 762 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1708 : {
1709 360 : stmtblock_t loopbody;
1710 360 : stmtblock_t body;
1711 360 : stmtblock_t ifbody;
1712 360 : gfc_loopinfo loop;
1713 :
1714 360 : gfc_init_block (&body);
1715 360 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1716 : gfc_array_index_type, nelems,
1717 : gfc_index_one_node);
1718 360 : nelems = gfc_evaluate_now (tmp, &body);
1719 360 : index = gfc_create_var (gfc_array_index_type, "S");
1720 :
1721 360 : if (is_from_desc)
1722 : {
1723 360 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1724 : unlimited);
1725 360 : vec_safe_push (args, from_ref);
1726 : }
1727 : else
1728 0 : vec_safe_push (args, from_data);
1729 :
1730 360 : if (is_to_class)
1731 360 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1732 : else
1733 : {
1734 0 : tmp = gfc_conv_array_data (to);
1735 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1736 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1737 : gfc_build_array_ref (tmp, index, to));
1738 : }
1739 360 : vec_safe_push (args, to_ref);
1740 :
1741 : /* Add bounds check. */
1742 360 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1743 : {
1744 25 : const char *name = "<<unknown>>";
1745 25 : int dim, rank;
1746 :
1747 25 : if (DECL_P (to))
1748 0 : name = IDENTIFIER_POINTER (DECL_NAME (to));
1749 :
1750 25 : rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
1751 55 : for (dim = 1; dim <= rank; dim++)
1752 : {
1753 30 : tree from_len, to_len, cond;
1754 30 : char *msg;
1755 :
1756 30 : from_len = gfc_conv_descriptor_size (from_data, dim);
1757 30 : from_len = fold_convert (long_integer_type_node, from_len);
1758 30 : to_len = gfc_conv_descriptor_size (to_data, dim);
1759 30 : to_len = fold_convert (long_integer_type_node, to_len);
1760 30 : msg = xasprintf ("Array bound mismatch for dimension %d "
1761 : "of array '%s' (%%ld/%%ld)",
1762 : dim, name);
1763 30 : cond = fold_build2_loc (input_location, NE_EXPR,
1764 : logical_type_node, from_len, to_len);
1765 30 : gfc_trans_runtime_check (true, false, cond, &body,
1766 : NULL, msg, to_len, from_len);
1767 30 : free (msg);
1768 : }
1769 : }
1770 :
1771 360 : tmp = build_call_vec (fcn_type, fcn, args);
1772 :
1773 : /* Build the body of the loop. */
1774 360 : gfc_init_block (&loopbody);
1775 360 : gfc_add_expr_to_block (&loopbody, tmp);
1776 :
1777 : /* Build the loop and return. */
1778 360 : gfc_init_loopinfo (&loop);
1779 360 : loop.dimen = 1;
1780 360 : loop.from[0] = gfc_index_zero_node;
1781 360 : loop.loopvar[0] = index;
1782 360 : loop.to[0] = nelems;
1783 360 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1784 360 : gfc_init_block (&ifbody);
1785 360 : gfc_add_block_to_block (&ifbody, &loop.pre);
1786 360 : stdcopy = gfc_finish_block (&ifbody);
1787 : /* In initialization mode from_len is a constant zero. */
1788 360 : if (unlimited && !integer_zerop (from_len))
1789 : {
1790 104 : vec_safe_push (args, from_len);
1791 104 : vec_safe_push (args, to_len);
1792 104 : tmp = build_call_vec (fcn_type, fcn, args);
1793 : /* Build the body of the loop. */
1794 104 : gfc_init_block (&loopbody);
1795 104 : gfc_add_expr_to_block (&loopbody, tmp);
1796 :
1797 : /* Build the loop and return. */
1798 104 : gfc_init_loopinfo (&loop);
1799 104 : loop.dimen = 1;
1800 104 : loop.from[0] = gfc_index_zero_node;
1801 104 : loop.loopvar[0] = index;
1802 104 : loop.to[0] = nelems;
1803 104 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1804 104 : gfc_init_block (&ifbody);
1805 104 : gfc_add_block_to_block (&ifbody, &loop.pre);
1806 104 : extcopy = gfc_finish_block (&ifbody);
1807 :
1808 104 : tmp = fold_build2_loc (input_location, GT_EXPR,
1809 : logical_type_node, from_len,
1810 104 : build_zero_cst (TREE_TYPE (from_len)));
1811 104 : tmp = fold_build3_loc (input_location, COND_EXPR,
1812 : void_type_node, tmp, extcopy, stdcopy);
1813 104 : gfc_add_expr_to_block (&body, tmp);
1814 104 : tmp = gfc_finish_block (&body);
1815 : }
1816 : else
1817 : {
1818 256 : gfc_add_expr_to_block (&body, stdcopy);
1819 256 : tmp = gfc_finish_block (&body);
1820 : }
1821 360 : gfc_cleanup_loop (&loop);
1822 : }
1823 : else
1824 : {
1825 402 : gcc_assert (!is_from_desc);
1826 402 : vec_safe_push (args, from_data);
1827 402 : vec_safe_push (args, to_data);
1828 402 : stdcopy = build_call_vec (fcn_type, fcn, args);
1829 :
1830 : /* In initialization mode from_len is a constant zero. */
1831 402 : if (unlimited && !integer_zerop (from_len))
1832 : {
1833 60 : vec_safe_push (args, from_len);
1834 60 : vec_safe_push (args, to_len);
1835 60 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1836 60 : tmp = fold_build2_loc (input_location, GT_EXPR,
1837 : logical_type_node, from_len,
1838 60 : build_zero_cst (TREE_TYPE (from_len)));
1839 60 : tmp = fold_build3_loc (input_location, COND_EXPR,
1840 : void_type_node, tmp, extcopy, stdcopy);
1841 : }
1842 : else
1843 : tmp = stdcopy;
1844 : }
1845 :
1846 : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1847 762 : if (from == NULL_TREE)
1848 : {
1849 0 : tree cond;
1850 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1851 : logical_type_node,
1852 : from_data, null_pointer_node);
1853 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1854 : void_type_node, cond,
1855 : tmp, build_empty_stmt (input_location));
1856 : }
1857 :
1858 762 : return tmp;
1859 : }
1860 :
1861 :
1862 : static tree
1863 106 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1864 : {
1865 106 : gfc_actual_arglist *actual;
1866 106 : gfc_expr *ppc;
1867 106 : gfc_code *ppc_code;
1868 106 : tree res;
1869 :
1870 106 : actual = gfc_get_actual_arglist ();
1871 106 : actual->expr = gfc_copy_expr (rhs);
1872 106 : actual->next = gfc_get_actual_arglist ();
1873 106 : actual->next->expr = gfc_copy_expr (lhs);
1874 106 : ppc = gfc_copy_expr (obj);
1875 106 : gfc_add_vptr_component (ppc);
1876 106 : gfc_add_component_ref (ppc, "_copy");
1877 106 : ppc_code = gfc_get_code (EXEC_CALL);
1878 106 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1879 : /* Although '_copy' is set to be elemental in class.cc, it is
1880 : not staying that way. Find out why, sometime.... */
1881 106 : ppc_code->resolved_sym->attr.elemental = 1;
1882 106 : ppc_code->ext.actual = actual;
1883 106 : ppc_code->expr1 = ppc;
1884 : /* Since '_copy' is elemental, the scalarizer will take care
1885 : of arrays in gfc_trans_call. */
1886 106 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1887 106 : gfc_free_statements (ppc_code);
1888 :
1889 106 : if (UNLIMITED_POLY(obj))
1890 : {
1891 : /* Check if rhs is non-NULL. */
1892 24 : gfc_se src;
1893 24 : gfc_init_se (&src, NULL);
1894 24 : gfc_conv_expr (&src, rhs);
1895 24 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1896 24 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1897 24 : src.expr, fold_convert (TREE_TYPE (src.expr),
1898 : null_pointer_node));
1899 24 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1900 : build_empty_stmt (input_location));
1901 : }
1902 :
1903 106 : return res;
1904 : }
1905 :
1906 : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1907 : A MEMCPY is needed to copy the full data from the default initializer
1908 : of the dynamic type. */
1909 :
1910 : tree
1911 461 : gfc_trans_class_init_assign (gfc_code *code)
1912 : {
1913 461 : stmtblock_t block;
1914 461 : tree tmp;
1915 461 : bool cmp_flag = true;
1916 461 : gfc_se dst,src,memsz;
1917 461 : gfc_expr *lhs, *rhs, *sz;
1918 461 : gfc_component *cmp;
1919 461 : gfc_symbol *sym;
1920 461 : gfc_ref *ref;
1921 :
1922 461 : gfc_start_block (&block);
1923 :
1924 461 : lhs = gfc_copy_expr (code->expr1);
1925 :
1926 461 : rhs = gfc_copy_expr (code->expr1);
1927 461 : gfc_add_vptr_component (rhs);
1928 :
1929 : /* Make sure that the component backend_decls have been built, which
1930 : will not have happened if the derived types concerned have not
1931 : been referenced. */
1932 461 : gfc_get_derived_type (rhs->ts.u.derived);
1933 461 : gfc_add_def_init_component (rhs);
1934 : /* The _def_init is always scalar. */
1935 461 : rhs->rank = 0;
1936 :
1937 : /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
1938 : default initializer components NULL, use the passed value even though
1939 : F2018(8.5.10) asserts that it should considered to be undefined. This is
1940 : needed for consistency with other brands. */
1941 461 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1942 : : NULL;
1943 461 : if (code->op != EXEC_ALLOCATE
1944 400 : && sym && sym->attr.dummy
1945 400 : && sym->attr.intent == INTENT_OUT)
1946 : {
1947 400 : ref = rhs->ref;
1948 800 : while (ref && ref->next)
1949 : ref = ref->next;
1950 400 : cmp = ref->u.c.component->ts.u.derived->components;
1951 611 : for (; cmp; cmp = cmp->next)
1952 : {
1953 428 : if (cmp->initializer)
1954 : break;
1955 211 : else if (!cmp->next)
1956 146 : cmp_flag = false;
1957 : }
1958 : }
1959 :
1960 461 : if (code->expr1->ts.type == BT_CLASS
1961 438 : && CLASS_DATA (code->expr1)->attr.dimension)
1962 : {
1963 106 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1964 106 : *tmparr = *CLASS_DATA (code->expr1)->as;
1965 : /* Adding the array ref to the class expression results in correct
1966 : indexing to the dynamic type. */
1967 106 : gfc_add_full_array_ref (lhs, tmparr);
1968 106 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1969 106 : }
1970 355 : else if (cmp_flag)
1971 : {
1972 : /* Scalar initialization needs the _data component. */
1973 222 : gfc_add_data_component (lhs);
1974 222 : sz = gfc_copy_expr (code->expr1);
1975 222 : gfc_add_vptr_component (sz);
1976 222 : gfc_add_size_component (sz);
1977 :
1978 222 : gfc_init_se (&dst, NULL);
1979 222 : gfc_init_se (&src, NULL);
1980 222 : gfc_init_se (&memsz, NULL);
1981 222 : gfc_conv_expr (&dst, lhs);
1982 222 : gfc_conv_expr (&src, rhs);
1983 222 : gfc_conv_expr (&memsz, sz);
1984 222 : gfc_add_block_to_block (&block, &src.pre);
1985 222 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1986 :
1987 222 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1988 :
1989 222 : if (UNLIMITED_POLY(code->expr1))
1990 : {
1991 : /* Check if _def_init is non-NULL. */
1992 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1993 : logical_type_node, src.expr,
1994 7 : fold_convert (TREE_TYPE (src.expr),
1995 : null_pointer_node));
1996 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1997 : tmp, build_empty_stmt (input_location));
1998 : }
1999 : }
2000 : else
2001 133 : tmp = build_empty_stmt (input_location);
2002 :
2003 461 : if (code->expr1->symtree->n.sym->attr.dummy
2004 410 : && (code->expr1->symtree->n.sym->attr.optional
2005 404 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
2006 : {
2007 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
2008 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2009 : present, tmp,
2010 : build_empty_stmt (input_location));
2011 : }
2012 :
2013 461 : gfc_add_expr_to_block (&block, tmp);
2014 461 : gfc_free_expr (lhs);
2015 461 : gfc_free_expr (rhs);
2016 :
2017 461 : return gfc_finish_block (&block);
2018 : }
2019 :
2020 :
2021 : /* Class valued elemental function calls or class array elements arriving
2022 : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
2023 : is used to ensure that the rhs dynamic type is assigned to the lhs. */
2024 :
2025 : static bool
2026 788 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
2027 : {
2028 788 : tree fcn;
2029 788 : tree rse_expr;
2030 788 : tree class_data;
2031 788 : tree tmp;
2032 788 : tree zero;
2033 788 : tree cond;
2034 788 : tree final_cond;
2035 788 : stmtblock_t inner_block;
2036 788 : bool is_descriptor;
2037 788 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
2038 788 : bool not_lhs_array_type;
2039 :
2040 : /* Temporaries arising from dependencies in assignment get cast as a
2041 : character type of the dynamic size of the rhs. Use the vptr copy
2042 : for this case. */
2043 788 : tmp = TREE_TYPE (lse->expr);
2044 788 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
2045 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
2046 :
2047 : /* Use ordinary assignment if the rhs is not a call expression or
2048 : the lhs is not a class entity or an array(ie. character) type. */
2049 740 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
2050 1061 : && not_lhs_array_type)
2051 : return false;
2052 :
2053 : /* Ordinary assignment can be used if both sides are class expressions
2054 : since the dynamic type is preserved by copying the vptr. This
2055 : should only occur, where temporaries are involved. */
2056 515 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
2057 515 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
2058 : return false;
2059 :
2060 : /* Fix the class expression and the class data of the rhs. */
2061 454 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
2062 454 : || not_call_expr)
2063 : {
2064 454 : tmp = gfc_get_class_from_expr (rse->expr);
2065 454 : if (tmp == NULL_TREE)
2066 : return false;
2067 146 : rse_expr = gfc_evaluate_now (tmp, block);
2068 : }
2069 : else
2070 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
2071 :
2072 146 : class_data = gfc_class_data_get (rse_expr);
2073 :
2074 : /* Check that the rhs data is not null. */
2075 146 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
2076 146 : if (is_descriptor)
2077 146 : class_data = gfc_conv_descriptor_data_get (class_data);
2078 146 : class_data = gfc_evaluate_now (class_data, block);
2079 :
2080 146 : zero = build_int_cst (TREE_TYPE (class_data), 0);
2081 146 : cond = fold_build2_loc (input_location, NE_EXPR,
2082 : logical_type_node,
2083 : class_data, zero);
2084 :
2085 : /* Copy the rhs to the lhs. */
2086 146 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
2087 146 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2088 146 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
2089 146 : tmp = is_descriptor ? tmp : class_data;
2090 146 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
2091 : gfc_build_addr_expr (NULL, lse->expr));
2092 146 : gfc_add_expr_to_block (block, tmp);
2093 :
2094 : /* Only elemental function results need to be finalised and freed. */
2095 146 : if (not_call_expr)
2096 : return true;
2097 :
2098 : /* Finalize the class data if needed. */
2099 0 : gfc_init_block (&inner_block);
2100 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
2101 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
2102 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
2103 : logical_type_node, fcn, zero);
2104 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2105 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
2106 0 : tmp = build3_v (COND_EXPR, final_cond,
2107 : tmp, build_empty_stmt (input_location));
2108 0 : gfc_add_expr_to_block (&inner_block, tmp);
2109 :
2110 : /* Free the class data. */
2111 0 : tmp = gfc_call_free (class_data);
2112 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2113 : build_empty_stmt (input_location));
2114 0 : gfc_add_expr_to_block (&inner_block, tmp);
2115 :
2116 : /* Finish the inner block and subject it to the condition on the
2117 : class data being non-zero. */
2118 0 : tmp = gfc_finish_block (&inner_block);
2119 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2120 : build_empty_stmt (input_location));
2121 0 : gfc_add_expr_to_block (block, tmp);
2122 :
2123 0 : return true;
2124 : }
2125 :
2126 : /* End of prototype trans-class.c */
2127 :
2128 :
2129 : static void
2130 12825 : realloc_lhs_warning (bt type, bool array, locus *where)
2131 : {
2132 12825 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
2133 25 : gfc_warning (OPT_Wrealloc_lhs,
2134 : "Code for reallocating the allocatable array at %L will "
2135 : "be added", where);
2136 12800 : else if (warn_realloc_lhs_all)
2137 4 : gfc_warning (OPT_Wrealloc_lhs_all,
2138 : "Code for reallocating the allocatable variable at %L "
2139 : "will be added", where);
2140 12825 : }
2141 :
2142 :
2143 : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
2144 : gfc_expr *);
2145 :
2146 : /* Copy the scalarization loop variables. */
2147 :
2148 : static void
2149 1281338 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2150 : {
2151 1281338 : dest->ss = src->ss;
2152 1281338 : dest->loop = src->loop;
2153 1281338 : }
2154 :
2155 :
2156 : /* Initialize a simple expression holder.
2157 :
2158 : Care must be taken when multiple se are created with the same parent.
2159 : The child se must be kept in sync. The easiest way is to delay creation
2160 : of a child se until after the previous se has been translated. */
2161 :
2162 : void
2163 4651452 : gfc_init_se (gfc_se * se, gfc_se * parent)
2164 : {
2165 4651452 : memset (se, 0, sizeof (gfc_se));
2166 4651452 : gfc_init_block (&se->pre);
2167 4651452 : gfc_init_block (&se->finalblock);
2168 4651452 : gfc_init_block (&se->post);
2169 :
2170 4651452 : se->parent = parent;
2171 :
2172 4651452 : if (parent)
2173 1281338 : gfc_copy_se_loopvars (se, parent);
2174 4651452 : }
2175 :
2176 :
2177 : /* Advances to the next SS in the chain. Use this rather than setting
2178 : se->ss = se->ss->next because all the parents needs to be kept in sync.
2179 : See gfc_init_se. */
2180 :
2181 : void
2182 243178 : gfc_advance_se_ss_chain (gfc_se * se)
2183 : {
2184 243178 : gfc_se *p;
2185 :
2186 243178 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2187 :
2188 : p = se;
2189 : /* Walk down the parent chain. */
2190 638580 : while (p != NULL)
2191 : {
2192 : /* Simple consistency check. */
2193 395402 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2194 : || p->parent->ss->nested_ss == p->ss);
2195 :
2196 395402 : p->ss = p->ss->next;
2197 :
2198 395402 : p = p->parent;
2199 : }
2200 243178 : }
2201 :
2202 :
2203 : /* Ensures the result of the expression as either a temporary variable
2204 : or a constant so that it can be used repeatedly. */
2205 :
2206 : void
2207 8136 : gfc_make_safe_expr (gfc_se * se)
2208 : {
2209 8136 : tree var;
2210 :
2211 8136 : if (CONSTANT_CLASS_P (se->expr))
2212 : return;
2213 :
2214 : /* We need a temporary for this result. */
2215 274 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2216 274 : gfc_add_modify (&se->pre, var, se->expr);
2217 274 : se->expr = var;
2218 : }
2219 :
2220 :
2221 : /* Return an expression which determines if a dummy parameter is present.
2222 : Also used for arguments to procedures with multiple entry points. */
2223 :
2224 : tree
2225 11604 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2226 : {
2227 11604 : tree decl, orig_decl, cond;
2228 :
2229 11604 : gcc_assert (sym->attr.dummy);
2230 11604 : orig_decl = decl = gfc_get_symbol_decl (sym);
2231 :
2232 : /* Intrinsic scalars and derived types with VALUE attribute which are passed
2233 : by value use a hidden argument to denote the presence status. */
2234 11604 : if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
2235 : {
2236 1052 : char name[GFC_MAX_SYMBOL_LEN + 2];
2237 1052 : tree tree_name;
2238 :
2239 1052 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2240 1052 : name[0] = '.';
2241 1052 : strcpy (&name[1], sym->name);
2242 1052 : tree_name = get_identifier (name);
2243 :
2244 : /* Walk function argument list to find hidden arg. */
2245 1052 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2246 5320 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2247 5320 : if (DECL_NAME (cond) == tree_name
2248 5320 : && DECL_ARTIFICIAL (cond))
2249 : break;
2250 :
2251 1052 : gcc_assert (cond);
2252 1052 : return cond;
2253 : }
2254 :
2255 : /* Assumed-shape arrays use a local variable for the array data;
2256 : the actual PARAM_DECL is in a saved decl. As the local variable
2257 : is NULL, it can be checked instead, unless use_saved_desc is
2258 : requested. */
2259 :
2260 10552 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2261 : {
2262 822 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2263 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2264 822 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2265 : }
2266 :
2267 10552 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2268 10552 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2269 :
2270 : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2271 : as actual argument to denote absent dummies. For array descriptors,
2272 : we thus also need to check the array descriptor. For BT_CLASS, it
2273 : can also occur for scalars and F2003 due to type->class wrapping and
2274 : class->class wrapping. Note further that BT_CLASS always uses an
2275 : array descriptor for arrays, also for explicit-shape/assumed-size.
2276 : For assumed-rank arrays, no local variable is generated, hence,
2277 : the following also applies with !use_saved_desc. */
2278 :
2279 10552 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2280 7511 : && !sym->attr.allocatable
2281 6299 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2282 2296 : || (sym->ts.type == BT_CLASS
2283 1041 : && !CLASS_DATA (sym)->attr.allocatable
2284 567 : && !CLASS_DATA (sym)->attr.class_pointer))
2285 4210 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2286 6 : || sym->ts.type == BT_CLASS))
2287 : {
2288 4204 : tree tmp;
2289 :
2290 4204 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2291 1495 : || sym->as->type == AS_ASSUMED_RANK
2292 1407 : || sym->attr.codimension))
2293 3336 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2294 : {
2295 1039 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2296 1039 : if (sym->ts.type == BT_CLASS)
2297 171 : tmp = gfc_class_data_get (tmp);
2298 1039 : tmp = gfc_conv_array_data (tmp);
2299 : }
2300 3165 : else if (sym->ts.type == BT_CLASS)
2301 36 : tmp = gfc_class_data_get (decl);
2302 : else
2303 : tmp = NULL_TREE;
2304 :
2305 1075 : if (tmp != NULL_TREE)
2306 : {
2307 1075 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2308 1075 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2309 1075 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2310 : logical_type_node, cond, tmp);
2311 : }
2312 : }
2313 :
2314 : return cond;
2315 : }
2316 :
2317 :
2318 : /* Converts a missing, dummy argument into a null or zero. */
2319 :
2320 : void
2321 844 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2322 : {
2323 844 : tree present;
2324 844 : tree tmp;
2325 :
2326 844 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2327 :
2328 844 : if (kind > 0)
2329 : {
2330 : /* Create a temporary and convert it to the correct type. */
2331 54 : tmp = gfc_get_int_type (kind);
2332 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2333 : se->expr));
2334 :
2335 : /* Test for a NULL value. */
2336 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2337 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2338 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2339 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2340 : }
2341 : else
2342 : {
2343 790 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2344 : present, se->expr,
2345 790 : build_zero_cst (TREE_TYPE (se->expr)));
2346 790 : tmp = gfc_evaluate_now (tmp, &se->pre);
2347 790 : se->expr = tmp;
2348 : }
2349 :
2350 844 : if (ts.type == BT_CHARACTER)
2351 : {
2352 : /* Handle deferred-length dummies that pass the character length by
2353 : reference so that the value can be returned. */
2354 244 : if (ts.deferred && INDIRECT_REF_P (se->string_length))
2355 : {
2356 18 : tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
2357 18 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2358 : present, tmp, null_pointer_node);
2359 18 : tmp = gfc_evaluate_now (tmp, &se->pre);
2360 18 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2361 : }
2362 : else
2363 : {
2364 226 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2365 226 : tmp = fold_build3_loc (input_location, COND_EXPR,
2366 : gfc_charlen_type_node,
2367 : present, se->string_length, tmp);
2368 226 : tmp = gfc_evaluate_now (tmp, &se->pre);
2369 : }
2370 244 : se->string_length = tmp;
2371 : }
2372 844 : return;
2373 : }
2374 :
2375 :
2376 : /* Get the character length of an expression, looking through gfc_refs
2377 : if necessary. */
2378 :
2379 : tree
2380 20153 : gfc_get_expr_charlen (gfc_expr *e)
2381 : {
2382 20153 : gfc_ref *r;
2383 20153 : tree length;
2384 20153 : tree previous = NULL_TREE;
2385 20153 : gfc_se se;
2386 :
2387 20153 : gcc_assert (e->expr_type == EXPR_VARIABLE
2388 : && e->ts.type == BT_CHARACTER);
2389 :
2390 20153 : length = NULL; /* To silence compiler warning. */
2391 :
2392 20153 : if (is_subref_array (e) && e->ts.u.cl->length)
2393 : {
2394 767 : gfc_se tmpse;
2395 767 : gfc_init_se (&tmpse, NULL);
2396 767 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2397 767 : e->ts.u.cl->backend_decl = tmpse.expr;
2398 767 : return tmpse.expr;
2399 : }
2400 :
2401 : /* First candidate: if the variable is of type CHARACTER, the
2402 : expression's length could be the length of the character
2403 : variable. */
2404 19386 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2405 19086 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2406 :
2407 : /* Look through the reference chain for component references. */
2408 38915 : for (r = e->ref; r; r = r->next)
2409 : {
2410 19529 : previous = length;
2411 19529 : switch (r->type)
2412 : {
2413 300 : case REF_COMPONENT:
2414 300 : if (r->u.c.component->ts.type == BT_CHARACTER)
2415 300 : length = r->u.c.component->ts.u.cl->backend_decl;
2416 : break;
2417 :
2418 : case REF_ARRAY:
2419 : /* Do nothing. */
2420 : break;
2421 :
2422 20 : case REF_SUBSTRING:
2423 20 : gfc_init_se (&se, NULL);
2424 20 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2425 20 : length = se.expr;
2426 20 : if (r->u.ss.end)
2427 0 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2428 : else
2429 20 : se.expr = previous;
2430 20 : length = fold_build2_loc (input_location, MINUS_EXPR,
2431 : gfc_charlen_type_node,
2432 : se.expr, length);
2433 20 : length = fold_build2_loc (input_location, PLUS_EXPR,
2434 : gfc_charlen_type_node, length,
2435 : gfc_index_one_node);
2436 20 : break;
2437 :
2438 0 : default:
2439 0 : gcc_unreachable ();
2440 19529 : break;
2441 : }
2442 : }
2443 :
2444 19386 : gcc_assert (length != NULL);
2445 : return length;
2446 : }
2447 :
2448 :
2449 : /* Return for an expression the backend decl of the coarray. */
2450 :
2451 : tree
2452 2052 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2453 : {
2454 2052 : tree caf_decl;
2455 2052 : bool found = false;
2456 2052 : gfc_ref *ref;
2457 :
2458 2052 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2459 :
2460 : /* Not-implemented diagnostic. */
2461 2052 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2462 39 : && UNLIMITED_POLY (expr->symtree->n.sym)
2463 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2464 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2465 : "%L is not supported", &expr->where);
2466 :
2467 4335 : for (ref = expr->ref; ref; ref = ref->next)
2468 2283 : if (ref->type == REF_COMPONENT)
2469 : {
2470 195 : if (ref->u.c.component->ts.type == BT_CLASS
2471 0 : && UNLIMITED_POLY (ref->u.c.component)
2472 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2473 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2474 : "component at %L is not supported", &expr->where);
2475 : }
2476 :
2477 : /* Make sure the backend_decl is present before accessing it. */
2478 2052 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2479 2052 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2480 : : expr->symtree->n.sym->backend_decl;
2481 :
2482 2052 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2483 : {
2484 39 : if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2485 45 : && GFC_DECL_SAVED_DESCRIPTOR (caf_decl))
2486 6 : caf_decl = GFC_DECL_SAVED_DESCRIPTOR (caf_decl);
2487 :
2488 39 : if (expr->ref && expr->ref->type == REF_ARRAY)
2489 : {
2490 28 : caf_decl = gfc_class_data_get (caf_decl);
2491 28 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2492 : return caf_decl;
2493 : }
2494 11 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2495 2 : && GFC_DECL_TOKEN (caf_decl)
2496 13 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2497 : return caf_decl;
2498 :
2499 23 : for (ref = expr->ref; ref; ref = ref->next)
2500 : {
2501 18 : if (ref->type == REF_COMPONENT
2502 9 : && strcmp (ref->u.c.component->name, "_data") != 0)
2503 : {
2504 0 : caf_decl = gfc_class_data_get (caf_decl);
2505 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2506 : return caf_decl;
2507 : break;
2508 : }
2509 18 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2510 : break;
2511 : }
2512 : }
2513 2022 : if (expr->symtree->n.sym->attr.codimension)
2514 : return caf_decl;
2515 :
2516 : /* The following code assumes that the coarray is a component reachable via
2517 : only scalar components/variables; the Fortran standard guarantees this. */
2518 :
2519 46 : for (ref = expr->ref; ref; ref = ref->next)
2520 46 : if (ref->type == REF_COMPONENT)
2521 : {
2522 46 : gfc_component *comp = ref->u.c.component;
2523 :
2524 46 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2525 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2526 46 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2527 46 : TREE_TYPE (comp->backend_decl), caf_decl,
2528 : comp->backend_decl, NULL_TREE);
2529 46 : if (comp->ts.type == BT_CLASS)
2530 : {
2531 0 : caf_decl = gfc_class_data_get (caf_decl);
2532 0 : if (CLASS_DATA (comp)->attr.codimension)
2533 : {
2534 : found = true;
2535 : break;
2536 : }
2537 : }
2538 46 : if (comp->attr.codimension)
2539 : {
2540 : found = true;
2541 : break;
2542 : }
2543 : }
2544 46 : gcc_assert (found && caf_decl);
2545 : return caf_decl;
2546 : }
2547 :
2548 :
2549 : /* Obtain the Coarray token - and optionally also the offset. */
2550 :
2551 : void
2552 1923 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2553 : tree se_expr, gfc_expr *expr)
2554 : {
2555 1923 : tree tmp;
2556 :
2557 1923 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2558 :
2559 : /* Coarray token. */
2560 1923 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2561 548 : *token = gfc_conv_descriptor_token (caf_decl);
2562 1373 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2563 1574 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2564 6 : *token = GFC_DECL_TOKEN (caf_decl);
2565 : else
2566 : {
2567 1369 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2568 : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2569 1369 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2570 : }
2571 :
2572 1923 : if (offset == NULL)
2573 : return;
2574 :
2575 : /* Offset between the coarray base address and the address wanted. */
2576 179 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2577 179 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2578 0 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2579 0 : *offset = build_int_cst (gfc_array_index_type, 0);
2580 179 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2581 179 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2582 0 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2583 179 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2584 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2585 : else
2586 179 : *offset = build_int_cst (gfc_array_index_type, 0);
2587 :
2588 179 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2589 179 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2590 : {
2591 0 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2592 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2593 : }
2594 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2595 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2596 : else
2597 : {
2598 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2599 : tmp = se_expr;
2600 : }
2601 :
2602 179 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2603 : *offset, fold_convert (gfc_array_index_type, tmp));
2604 :
2605 179 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2606 0 : && expr->symtree->n.sym->attr.codimension
2607 0 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2608 : {
2609 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2610 0 : gfc_ref *ref = base_expr->ref;
2611 0 : gfc_se base_se;
2612 :
2613 : // Iterate through the refs until the last one.
2614 0 : while (ref->next)
2615 : ref = ref->next;
2616 :
2617 0 : if (ref->type == REF_ARRAY
2618 0 : && ref->u.ar.type != AR_FULL)
2619 : {
2620 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2621 0 : int i;
2622 0 : for (i = 0; i < ranksum; ++i)
2623 : {
2624 0 : ref->u.ar.start[i] = NULL;
2625 0 : ref->u.ar.end[i] = NULL;
2626 : }
2627 0 : ref->u.ar.type = AR_FULL;
2628 : }
2629 0 : gfc_init_se (&base_se, NULL);
2630 0 : if (gfc_caf_attr (base_expr).dimension)
2631 : {
2632 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2633 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2634 : }
2635 : else
2636 : {
2637 0 : gfc_conv_expr (&base_se, base_expr);
2638 0 : tmp = base_se.expr;
2639 : }
2640 :
2641 0 : gfc_free_expr (base_expr);
2642 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2643 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2644 0 : }
2645 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2646 0 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2647 179 : else if (INDIRECT_REF_P (caf_decl))
2648 0 : tmp = TREE_OPERAND (caf_decl, 0);
2649 : else
2650 : {
2651 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2652 : tmp = caf_decl;
2653 : }
2654 :
2655 179 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2656 : fold_convert (gfc_array_index_type, *offset),
2657 : fold_convert (gfc_array_index_type, tmp));
2658 : }
2659 :
2660 :
2661 : /* Convert the coindex of a coarray into an image index; the result is
2662 : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2663 : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2664 :
2665 : tree
2666 1634 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2667 : {
2668 1634 : gfc_ref *ref;
2669 1634 : tree lbound, ubound, extent, tmp, img_idx;
2670 1634 : gfc_se se;
2671 1634 : int i;
2672 :
2673 1665 : for (ref = e->ref; ref; ref = ref->next)
2674 1665 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2675 : break;
2676 1634 : gcc_assert (ref != NULL);
2677 :
2678 1634 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2679 95 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2680 95 : null_pointer_node);
2681 :
2682 1539 : img_idx = build_zero_cst (gfc_array_index_type);
2683 1539 : extent = build_one_cst (gfc_array_index_type);
2684 1539 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2685 630 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2686 : {
2687 321 : gfc_init_se (&se, NULL);
2688 321 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2689 321 : gfc_add_block_to_block (block, &se.pre);
2690 321 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2691 321 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2692 321 : TREE_TYPE (lbound), se.expr, lbound);
2693 321 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2694 : extent, tmp);
2695 321 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2696 321 : TREE_TYPE (tmp), img_idx, tmp);
2697 321 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2698 : {
2699 12 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2700 12 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2701 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
2702 12 : TREE_TYPE (tmp), extent, tmp);
2703 : }
2704 : }
2705 : else
2706 2476 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2707 : {
2708 1246 : gfc_init_se (&se, NULL);
2709 1246 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2710 1246 : gfc_add_block_to_block (block, &se.pre);
2711 1246 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2712 1246 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2713 1246 : TREE_TYPE (lbound), se.expr, lbound);
2714 1246 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2715 : extent, tmp);
2716 1246 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2717 : img_idx, tmp);
2718 1246 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2719 : {
2720 16 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2721 16 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2722 16 : TREE_TYPE (ubound), ubound, lbound);
2723 16 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2724 16 : tmp, build_one_cst (TREE_TYPE (tmp)));
2725 16 : extent = fold_build2_loc (input_location, MULT_EXPR,
2726 16 : TREE_TYPE (tmp), extent, tmp);
2727 : }
2728 : }
2729 1539 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2730 1539 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2731 1539 : return fold_convert (integer_type_node, img_idx);
2732 : }
2733 :
2734 :
2735 : /* For each character array constructor subexpression without a ts.u.cl->length,
2736 : replace it by its first element (if there aren't any elements, the length
2737 : should already be set to zero). */
2738 :
2739 : static void
2740 110 : flatten_array_ctors_without_strlen (gfc_expr* e)
2741 : {
2742 110 : gfc_actual_arglist* arg;
2743 110 : gfc_constructor* c;
2744 :
2745 110 : if (!e)
2746 : return;
2747 :
2748 110 : switch (e->expr_type)
2749 : {
2750 :
2751 0 : case EXPR_OP:
2752 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2753 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2754 0 : break;
2755 :
2756 0 : case EXPR_COMPCALL:
2757 : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2758 0 : gcc_unreachable ();
2759 :
2760 13 : case EXPR_FUNCTION:
2761 40 : for (arg = e->value.function.actual; arg; arg = arg->next)
2762 27 : flatten_array_ctors_without_strlen (arg->expr);
2763 : break;
2764 :
2765 0 : case EXPR_ARRAY:
2766 :
2767 : /* We've found what we're looking for. */
2768 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2769 : {
2770 0 : gfc_constructor *c;
2771 0 : gfc_expr* new_expr;
2772 :
2773 0 : gcc_assert (e->value.constructor);
2774 :
2775 0 : c = gfc_constructor_first (e->value.constructor);
2776 0 : new_expr = c->expr;
2777 0 : c->expr = NULL;
2778 :
2779 0 : flatten_array_ctors_without_strlen (new_expr);
2780 0 : gfc_replace_expr (e, new_expr);
2781 0 : break;
2782 : }
2783 :
2784 : /* Otherwise, fall through to handle constructor elements. */
2785 0 : gcc_fallthrough ();
2786 0 : case EXPR_STRUCTURE:
2787 0 : for (c = gfc_constructor_first (e->value.constructor);
2788 0 : c; c = gfc_constructor_next (c))
2789 0 : flatten_array_ctors_without_strlen (c->expr);
2790 : break;
2791 :
2792 : default:
2793 : break;
2794 :
2795 : }
2796 : }
2797 :
2798 :
2799 : /* Generate code to initialize a string length variable. Returns the
2800 : value. For array constructors, cl->length might be NULL and in this case,
2801 : the first element of the constructor is needed. expr is the original
2802 : expression so we can access it but can be NULL if this is not needed. */
2803 :
2804 : void
2805 3843 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2806 : {
2807 3843 : gfc_se se;
2808 :
2809 3843 : gfc_init_se (&se, NULL);
2810 :
2811 3843 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2812 1361 : return;
2813 :
2814 : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2815 : "flatten" array constructors by taking their first element; all elements
2816 : should be the same length or a cl->length should be present. */
2817 2575 : if (!cl->length)
2818 : {
2819 176 : gfc_expr* expr_flat;
2820 176 : if (!expr)
2821 : return;
2822 83 : expr_flat = gfc_copy_expr (expr);
2823 83 : flatten_array_ctors_without_strlen (expr_flat);
2824 83 : gfc_resolve_expr (expr_flat);
2825 83 : if (expr_flat->rank)
2826 13 : gfc_conv_expr_descriptor (&se, expr_flat);
2827 : else
2828 70 : gfc_conv_expr (&se, expr_flat);
2829 83 : if (expr_flat->expr_type != EXPR_VARIABLE)
2830 77 : gfc_add_block_to_block (pblock, &se.pre);
2831 83 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2832 83 : gfc_add_block_to_block (pblock, &se.post);
2833 83 : gfc_free_expr (expr_flat);
2834 : }
2835 : else
2836 : {
2837 : /* Convert cl->length. */
2838 2399 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2839 2399 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2840 : gfc_charlen_type_node, se.expr,
2841 2399 : build_zero_cst (TREE_TYPE (se.expr)));
2842 2399 : gfc_add_block_to_block (pblock, &se.pre);
2843 : }
2844 :
2845 2482 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2846 1564 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2847 : else
2848 918 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2849 : }
2850 :
2851 :
2852 : static void
2853 7264 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2854 : const char *name, locus *where)
2855 : {
2856 7264 : tree tmp;
2857 7264 : tree type;
2858 7264 : tree fault;
2859 7264 : gfc_se start;
2860 7264 : gfc_se end;
2861 7264 : char *msg;
2862 7264 : mpz_t length;
2863 :
2864 7264 : type = gfc_get_character_type (kind, ref->u.ss.length);
2865 7264 : type = build_pointer_type (type);
2866 :
2867 7264 : gfc_init_se (&start, se);
2868 7264 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2869 7264 : gfc_add_block_to_block (&se->pre, &start.pre);
2870 :
2871 7264 : if (integer_onep (start.expr))
2872 2732 : gfc_conv_string_parameter (se);
2873 : else
2874 : {
2875 4532 : tmp = start.expr;
2876 4532 : STRIP_NOPS (tmp);
2877 : /* Avoid multiple evaluation of substring start. */
2878 4532 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2879 1697 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2880 :
2881 : /* Change the start of the string. */
2882 4532 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2883 1194 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2884 3458 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2885 5606 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2886 1074 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2887 : tmp = se->expr;
2888 : else
2889 1066 : tmp = build_fold_indirect_ref_loc (input_location,
2890 : se->expr);
2891 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2892 4532 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2893 : {
2894 4404 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2895 4404 : se->expr = gfc_build_addr_expr (type, tmp);
2896 : }
2897 128 : else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2898 : {
2899 8 : tree diff;
2900 8 : diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr,
2901 : build_one_cst (gfc_charlen_type_node));
2902 8 : diff = fold_convert (size_type_node, diff);
2903 8 : se->expr
2904 8 : = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff);
2905 : }
2906 : }
2907 :
2908 : /* Length = end + 1 - start. */
2909 7264 : gfc_init_se (&end, se);
2910 7264 : if (ref->u.ss.end == NULL)
2911 202 : end.expr = se->string_length;
2912 : else
2913 : {
2914 7062 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2915 7062 : gfc_add_block_to_block (&se->pre, &end.pre);
2916 : }
2917 7264 : tmp = end.expr;
2918 7264 : STRIP_NOPS (tmp);
2919 7264 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2920 2301 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2921 :
2922 7264 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2923 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2924 7719 : && !gfc_contains_implied_index_p (ref->u.ss.end))
2925 : {
2926 455 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2927 : logical_type_node, start.expr,
2928 : end.expr);
2929 :
2930 : /* Check lower bound. */
2931 455 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2932 : start.expr,
2933 455 : build_one_cst (TREE_TYPE (start.expr)));
2934 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2935 : logical_type_node, nonempty, fault);
2936 455 : if (name)
2937 454 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2938 : "is less than one", name);
2939 : else
2940 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2941 : "is less than one");
2942 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2943 : fold_convert (long_integer_type_node,
2944 : start.expr));
2945 455 : free (msg);
2946 :
2947 : /* Check upper bound. */
2948 455 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2949 : end.expr, se->string_length);
2950 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2951 : logical_type_node, nonempty, fault);
2952 455 : if (name)
2953 454 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2954 : "exceeds string length (%%ld)", name);
2955 : else
2956 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2957 : "exceeds string length (%%ld)");
2958 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2959 : fold_convert (long_integer_type_node, end.expr),
2960 : fold_convert (long_integer_type_node,
2961 : se->string_length));
2962 455 : free (msg);
2963 : }
2964 :
2965 : /* Try to calculate the length from the start and end expressions. */
2966 7264 : if (ref->u.ss.end
2967 7264 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2968 : {
2969 6045 : HOST_WIDE_INT i_len;
2970 :
2971 6045 : i_len = gfc_mpz_get_hwi (length) + 1;
2972 6045 : if (i_len < 0)
2973 : i_len = 0;
2974 :
2975 6045 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2976 6045 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2977 : }
2978 : else
2979 : {
2980 1219 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2981 : fold_convert (gfc_charlen_type_node, end.expr),
2982 : fold_convert (gfc_charlen_type_node, start.expr));
2983 1219 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2984 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2985 1219 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2986 : tmp, build_int_cst (gfc_charlen_type_node, 0));
2987 : }
2988 :
2989 7264 : se->string_length = tmp;
2990 7264 : }
2991 :
2992 :
2993 : /* Convert a derived type component reference. */
2994 :
2995 : void
2996 176794 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2997 : {
2998 176794 : gfc_component *c;
2999 176794 : tree tmp;
3000 176794 : tree decl;
3001 176794 : tree field;
3002 176794 : tree context;
3003 :
3004 176794 : c = ref->u.c.component;
3005 :
3006 176794 : if (c->backend_decl == NULL_TREE
3007 6 : && ref->u.c.sym != NULL)
3008 6 : gfc_get_derived_type (ref->u.c.sym);
3009 :
3010 176794 : field = c->backend_decl;
3011 176794 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
3012 176794 : decl = se->expr;
3013 176794 : context = DECL_FIELD_CONTEXT (field);
3014 :
3015 : /* Components can correspond to fields of different containing
3016 : types, as components are created without context, whereas
3017 : a concrete use of a component has the type of decl as context.
3018 : So, if the type doesn't match, we search the corresponding
3019 : FIELD_DECL in the parent type. To not waste too much time
3020 : we cache this result in norestrict_decl.
3021 : On the other hand, if the context is a UNION or a MAP (a
3022 : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
3023 :
3024 176794 : if (context != TREE_TYPE (decl)
3025 176794 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
3026 12219 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
3027 : {
3028 12219 : tree f2 = c->norestrict_decl;
3029 20729 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
3030 7332 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
3031 7332 : if (TREE_CODE (f2) == FIELD_DECL
3032 7332 : && DECL_NAME (f2) == DECL_NAME (field))
3033 : break;
3034 12219 : gcc_assert (f2);
3035 12219 : c->norestrict_decl = f2;
3036 12219 : field = f2;
3037 : }
3038 :
3039 176794 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
3040 0 : && strcmp ("_data", c->name) == 0)
3041 : {
3042 : /* Found a ref to the _data component. Store the associated ref to
3043 : the vptr in se->class_vptr. */
3044 0 : se->class_vptr = gfc_class_vptr_get (decl);
3045 : }
3046 : else
3047 176794 : se->class_vptr = NULL_TREE;
3048 :
3049 176794 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
3050 : decl, field, NULL_TREE);
3051 :
3052 176794 : se->expr = tmp;
3053 :
3054 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
3055 : strlen () conditional below. */
3056 176794 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
3057 8772 : && !c->ts.deferred
3058 5632 : && !c->attr.pdt_string)
3059 : {
3060 5458 : tmp = c->ts.u.cl->backend_decl;
3061 : /* Components must always be constant length. */
3062 5458 : gcc_assert (tmp && INTEGER_CST_P (tmp));
3063 5458 : se->string_length = tmp;
3064 : }
3065 :
3066 176794 : if (gfc_deferred_strlen (c, &field))
3067 : {
3068 3314 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
3069 3314 : TREE_TYPE (field),
3070 : decl, field, NULL_TREE);
3071 3314 : se->string_length = tmp;
3072 : }
3073 :
3074 176794 : if (((c->attr.pointer || c->attr.allocatable)
3075 103613 : && (!c->attr.dimension && !c->attr.codimension)
3076 55648 : && c->ts.type != BT_CHARACTER)
3077 123351 : || c->attr.proc_pointer)
3078 59727 : se->expr = build_fold_indirect_ref_loc (input_location,
3079 : se->expr);
3080 176794 : }
3081 :
3082 :
3083 : /* This function deals with component references to components of the
3084 : parent type for derived type extensions. */
3085 : void
3086 64173 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
3087 : {
3088 64173 : gfc_component *c;
3089 64173 : gfc_component *cmp;
3090 64173 : gfc_symbol *dt;
3091 64173 : gfc_ref parent;
3092 :
3093 64173 : dt = ref->u.c.sym;
3094 64173 : c = ref->u.c.component;
3095 :
3096 : /* Return if the component is in this type, i.e. not in the parent type. */
3097 110514 : for (cmp = dt->components; cmp; cmp = cmp->next)
3098 99990 : if (c == cmp)
3099 53649 : return;
3100 :
3101 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3102 10524 : parent.type = REF_COMPONENT;
3103 10524 : parent.next = NULL;
3104 10524 : parent.u.c.sym = dt;
3105 10524 : parent.u.c.component = dt->components;
3106 :
3107 10524 : if (dt->backend_decl == NULL)
3108 0 : gfc_get_derived_type (dt);
3109 :
3110 : /* Build the reference and call self. */
3111 10524 : gfc_conv_component_ref (se, &parent);
3112 10524 : parent.u.c.sym = dt->components->ts.u.derived;
3113 10524 : parent.u.c.component = c;
3114 10524 : conv_parent_component_references (se, &parent);
3115 : }
3116 :
3117 :
3118 : static void
3119 549 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
3120 : {
3121 549 : tree res = se->expr;
3122 :
3123 549 : switch (ref->u.i)
3124 : {
3125 265 : case INQUIRY_RE:
3126 530 : res = fold_build1_loc (input_location, REALPART_EXPR,
3127 265 : TREE_TYPE (TREE_TYPE (res)), res);
3128 265 : break;
3129 :
3130 239 : case INQUIRY_IM:
3131 478 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
3132 239 : TREE_TYPE (TREE_TYPE (res)), res);
3133 239 : break;
3134 :
3135 7 : case INQUIRY_KIND:
3136 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
3137 7 : ts->kind);
3138 7 : se->string_length = NULL_TREE;
3139 7 : break;
3140 :
3141 38 : case INQUIRY_LEN:
3142 38 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
3143 : se->string_length);
3144 38 : se->string_length = NULL_TREE;
3145 38 : break;
3146 :
3147 0 : default:
3148 0 : gcc_unreachable ();
3149 : }
3150 549 : se->expr = res;
3151 549 : }
3152 :
3153 : /* Dereference VAR where needed if it is a pointer, reference, etc.
3154 : according to Fortran semantics. */
3155 :
3156 : tree
3157 1451230 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3158 : bool is_classarray)
3159 : {
3160 1451230 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3161 : return var;
3162 292809 : if (is_CFI_desc (sym, NULL))
3163 11892 : return build_fold_indirect_ref_loc (input_location, var);
3164 :
3165 : /* Characters are entirely different from other types, they are treated
3166 : separately. */
3167 280917 : if (sym->ts.type == BT_CHARACTER)
3168 : {
3169 : /* Dereference character pointer dummy arguments
3170 : or results. */
3171 32807 : if ((sym->attr.pointer || sym->attr.allocatable
3172 18917 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3173 14226 : && (sym->attr.dummy
3174 10910 : || sym->attr.function
3175 10536 : || sym->attr.result))
3176 4375 : var = build_fold_indirect_ref_loc (input_location, var);
3177 : }
3178 248110 : else if (!sym->attr.value)
3179 : {
3180 : /* Dereference temporaries for class array dummy arguments. */
3181 171091 : if (sym->attr.dummy && is_classarray
3182 254963 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3183 : {
3184 5313 : if (!descriptor_only_p)
3185 2704 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3186 :
3187 5313 : var = build_fold_indirect_ref_loc (input_location, var);
3188 : }
3189 :
3190 : /* Dereference non-character scalar dummy arguments. */
3191 247306 : if (sym->attr.dummy && !sym->attr.dimension
3192 104153 : && !(sym->attr.codimension && sym->attr.allocatable)
3193 104087 : && (sym->ts.type != BT_CLASS
3194 19529 : || (!CLASS_DATA (sym)->attr.dimension
3195 11402 : && !(CLASS_DATA (sym)->attr.codimension
3196 283 : && CLASS_DATA (sym)->attr.allocatable))))
3197 95819 : var = build_fold_indirect_ref_loc (input_location, var);
3198 :
3199 : /* Dereference scalar hidden result. */
3200 247306 : if (flag_f2c && sym->ts.type == BT_COMPLEX
3201 286 : && (sym->attr.function || sym->attr.result)
3202 108 : && !sym->attr.dimension && !sym->attr.pointer
3203 60 : && !sym->attr.always_explicit)
3204 36 : var = build_fold_indirect_ref_loc (input_location, var);
3205 :
3206 : /* Dereference non-character, non-class pointer variables.
3207 : These must be dummies, results, or scalars. */
3208 247306 : if (!is_classarray
3209 239203 : && (sym->attr.pointer || sym->attr.allocatable
3210 190453 : || gfc_is_associate_pointer (sym)
3211 185760 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3212 323120 : && (sym->attr.dummy
3213 35598 : || sym->attr.function
3214 34668 : || sym->attr.result
3215 33562 : || (!sym->attr.dimension
3216 33557 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3217 75809 : var = build_fold_indirect_ref_loc (input_location, var);
3218 : /* Now treat the class array pointer variables accordingly. */
3219 171497 : else if (sym->ts.type == BT_CLASS
3220 19975 : && sym->attr.dummy
3221 19529 : && (CLASS_DATA (sym)->attr.dimension
3222 11402 : || CLASS_DATA (sym)->attr.codimension)
3223 8410 : && ((CLASS_DATA (sym)->as
3224 8410 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3225 7371 : || CLASS_DATA (sym)->attr.allocatable
3226 6046 : || CLASS_DATA (sym)->attr.class_pointer))
3227 2955 : var = build_fold_indirect_ref_loc (input_location, var);
3228 : /* And the case where a non-dummy, non-result, non-function,
3229 : non-allocable and non-pointer classarray is present. This case was
3230 : previously covered by the first if, but with introducing the
3231 : condition !is_classarray there, that case has to be covered
3232 : explicitly. */
3233 168542 : else if (sym->ts.type == BT_CLASS
3234 17020 : && !sym->attr.dummy
3235 446 : && !sym->attr.function
3236 446 : && !sym->attr.result
3237 446 : && (CLASS_DATA (sym)->attr.dimension
3238 4 : || CLASS_DATA (sym)->attr.codimension)
3239 446 : && (sym->assoc
3240 0 : || !CLASS_DATA (sym)->attr.allocatable)
3241 446 : && !CLASS_DATA (sym)->attr.class_pointer)
3242 446 : var = build_fold_indirect_ref_loc (input_location, var);
3243 : }
3244 :
3245 : return var;
3246 : }
3247 :
3248 : /* Return the contents of a variable. Also handles reference/pointer
3249 : variables (all Fortran pointer references are implicit). */
3250 :
3251 : static void
3252 1605109 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3253 : {
3254 1605109 : gfc_ss *ss;
3255 1605109 : gfc_ref *ref;
3256 1605109 : gfc_symbol *sym;
3257 1605109 : tree parent_decl = NULL_TREE;
3258 1605109 : int parent_flag;
3259 1605109 : bool return_value;
3260 1605109 : bool alternate_entry;
3261 1605109 : bool entry_master;
3262 1605109 : bool is_classarray;
3263 1605109 : bool first_time = true;
3264 :
3265 1605109 : sym = expr->symtree->n.sym;
3266 1605109 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3267 1605109 : ss = se->ss;
3268 1605109 : if (ss != NULL)
3269 : {
3270 133138 : gfc_ss_info *ss_info = ss->info;
3271 :
3272 : /* Check that something hasn't gone horribly wrong. */
3273 133138 : gcc_assert (ss != gfc_ss_terminator);
3274 133138 : gcc_assert (ss_info->expr == expr);
3275 :
3276 : /* A scalarized term. We already know the descriptor. */
3277 133138 : se->expr = ss_info->data.array.descriptor;
3278 133138 : se->string_length = ss_info->string_length;
3279 133138 : ref = ss_info->data.array.ref;
3280 133138 : if (ref)
3281 132784 : gcc_assert (ref->type == REF_ARRAY
3282 : && ref->u.ar.type != AR_ELEMENT);
3283 : else
3284 354 : gfc_conv_tmp_array_ref (se);
3285 : }
3286 : else
3287 : {
3288 1471971 : tree se_expr = NULL_TREE;
3289 :
3290 1471971 : se->expr = gfc_get_symbol_decl (sym);
3291 :
3292 : /* Deal with references to a parent results or entries by storing
3293 : the current_function_decl and moving to the parent_decl. */
3294 1471971 : return_value = sym->attr.function && sym->result == sym;
3295 19090 : alternate_entry = sym->attr.function && sym->attr.entry
3296 1473110 : && sym->result == sym;
3297 2943942 : entry_master = sym->attr.result
3298 14487 : && sym->ns->proc_name->attr.entry_master
3299 1472352 : && !gfc_return_by_reference (sym->ns->proc_name);
3300 1471971 : if (current_function_decl)
3301 1451391 : parent_decl = DECL_CONTEXT (current_function_decl);
3302 :
3303 1471971 : if ((se->expr == parent_decl && return_value)
3304 1471860 : || (sym->ns && sym->ns->proc_name
3305 1466932 : && parent_decl
3306 1446352 : && sym->ns->proc_name->backend_decl == parent_decl
3307 38152 : && (alternate_entry || entry_master)))
3308 : parent_flag = 1;
3309 : else
3310 1471827 : parent_flag = 0;
3311 :
3312 : /* Special case for assigning the return value of a function.
3313 : Self recursive functions must have an explicit return value. */
3314 1471971 : if (return_value && (se->expr == current_function_decl || parent_flag))
3315 10298 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3316 :
3317 : /* Similarly for alternate entry points. */
3318 1461673 : else if (alternate_entry
3319 1106 : && (sym->ns->proc_name->backend_decl == current_function_decl
3320 0 : || parent_flag))
3321 : {
3322 1106 : gfc_entry_list *el = NULL;
3323 :
3324 1705 : for (el = sym->ns->entries; el; el = el->next)
3325 1705 : if (sym == el->sym)
3326 : {
3327 1106 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3328 1106 : break;
3329 : }
3330 : }
3331 :
3332 1460567 : else if (entry_master
3333 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3334 0 : || parent_flag))
3335 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3336 :
3337 11699 : if (se_expr)
3338 11699 : se->expr = se_expr;
3339 :
3340 : /* Procedure actual arguments. Look out for temporary variables
3341 : with the same attributes as function values. */
3342 1460272 : else if (!sym->attr.temporary
3343 1460204 : && sym->attr.flavor == FL_PROCEDURE
3344 22886 : && se->expr != current_function_decl)
3345 : {
3346 22819 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3347 : {
3348 21107 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3349 21107 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3350 : }
3351 22819 : return;
3352 : }
3353 :
3354 1449152 : if (sym->ts.type == BT_CLASS
3355 72354 : && sym->attr.class_ok
3356 72112 : && sym->ts.u.derived->attr.is_class)
3357 : {
3358 28033 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3359 79580 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3360 5455 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3361 : else
3362 66657 : se->class_container = se->expr;
3363 : }
3364 :
3365 : /* Dereference the expression, where needed. */
3366 1449152 : if (se->class_container && CLASS_DATA (sym)->attr.codimension
3367 2042 : && !CLASS_DATA (sym)->attr.dimension)
3368 877 : se->expr
3369 877 : = gfc_maybe_dereference_var (sym, se->class_container,
3370 877 : se->descriptor_only, is_classarray);
3371 : else
3372 1448275 : se->expr
3373 1448275 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3374 : is_classarray);
3375 :
3376 1449152 : ref = expr->ref;
3377 : }
3378 :
3379 : /* For character variables, also get the length. */
3380 1582290 : if (sym->ts.type == BT_CHARACTER)
3381 : {
3382 : /* If the character length of an entry isn't set, get the length from
3383 : the master function instead. */
3384 166281 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3385 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3386 : else
3387 166281 : se->string_length = sym->ts.u.cl->backend_decl;
3388 166281 : gcc_assert (se->string_length);
3389 :
3390 : /* For coarray strings return the pointer to the data and not the
3391 : descriptor. */
3392 5143 : if (sym->attr.codimension && sym->attr.associate_var
3393 6 : && !se->descriptor_only
3394 166287 : && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
3395 6 : se->expr = gfc_conv_descriptor_data_get (se->expr);
3396 : }
3397 :
3398 : /* F202Y: Runtime warning that an assumed rank object is associated
3399 : with an assumed size object. */
3400 1582290 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3401 90726 : && (gfc_option.allow_std & GFC_STD_F202Y)
3402 1582524 : && expr->rank == -1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3403 : {
3404 60 : tree dim, lower, upper, cond;
3405 60 : char *msg;
3406 :
3407 60 : dim = fold_convert (signed_char_type_node,
3408 : gfc_conv_descriptor_rank (se->expr));
3409 60 : dim = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
3410 : dim, build_int_cst (signed_char_type_node, 1));
3411 60 : lower = gfc_conv_descriptor_lbound_get (se->expr, dim);
3412 60 : upper = gfc_conv_descriptor_ubound_get (se->expr, dim);
3413 :
3414 60 : msg = xasprintf ("Assumed rank object %s is associated with an "
3415 : "assumed size object", sym->name);
3416 60 : cond = fold_build2_loc (input_location, LT_EXPR,
3417 : logical_type_node, upper, lower);
3418 60 : gfc_trans_runtime_check (false, true, cond, &se->pre,
3419 : &gfc_current_locus, msg);
3420 60 : free (msg);
3421 : }
3422 :
3423 : /* Some expressions leak through that haven't been fixed up. */
3424 1582290 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3425 418 : gfc_fixup_inferred_type_refs (expr);
3426 :
3427 1582290 : gfc_typespec *ts = &sym->ts;
3428 2016906 : while (ref)
3429 : {
3430 783875 : switch (ref->type)
3431 : {
3432 610260 : case REF_ARRAY:
3433 : /* Return the descriptor if that's what we want and this is an array
3434 : section reference. */
3435 610260 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3436 : return;
3437 : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3438 : /* Return the descriptor for array pointers and allocations. */
3439 270372 : if (se->want_pointer
3440 24024 : && ref->next == NULL && (se->descriptor_only))
3441 : return;
3442 :
3443 261001 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3444 : /* Return a pointer to an element. */
3445 261001 : break;
3446 :
3447 166060 : case REF_COMPONENT:
3448 166060 : ts = &ref->u.c.component->ts;
3449 166060 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3450 5799 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3451 3118 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3452 3118 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3453 2609 : && strcmp ("_data", ref->u.c.component->name) == 0)
3454 : /* Skip the first ref of a _data component, because for class
3455 : arrays that one is already done by introducing a temporary
3456 : array descriptor. */
3457 : break;
3458 :
3459 163451 : if (ref->u.c.sym->attr.extension)
3460 53558 : conv_parent_component_references (se, ref);
3461 :
3462 163451 : gfc_conv_component_ref (se, ref);
3463 :
3464 163451 : if (ref->u.c.component->ts.type == BT_CLASS
3465 11825 : && ref->u.c.component->attr.class_ok
3466 11825 : && ref->u.c.component->ts.u.derived->attr.is_class)
3467 11825 : se->class_container = se->expr;
3468 151626 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3469 149132 : && ref->u.c.sym->attr.is_class))
3470 83855 : se->class_container = NULL_TREE;
3471 :
3472 163451 : if (!ref->next && ref->u.c.sym->attr.codimension
3473 0 : && se->want_pointer && se->descriptor_only)
3474 : return;
3475 :
3476 : break;
3477 :
3478 7006 : case REF_SUBSTRING:
3479 7006 : gfc_conv_substring (se, ref, expr->ts.kind,
3480 7006 : expr->symtree->name, &expr->where);
3481 7006 : break;
3482 :
3483 549 : case REF_INQUIRY:
3484 549 : conv_inquiry (se, ref, expr, ts);
3485 549 : break;
3486 :
3487 0 : default:
3488 0 : gcc_unreachable ();
3489 434616 : break;
3490 : }
3491 434616 : first_time = false;
3492 434616 : ref = ref->next;
3493 : }
3494 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3495 : separately. */
3496 1233031 : if (se->want_pointer)
3497 : {
3498 134262 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3499 8032 : gfc_conv_string_parameter (se);
3500 : else
3501 126230 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3502 : }
3503 : }
3504 :
3505 :
3506 : /* Unary ops are easy... Or they would be if ! was a valid op. */
3507 :
3508 : static void
3509 28841 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3510 : {
3511 28841 : gfc_se operand;
3512 28841 : tree type;
3513 :
3514 28841 : gcc_assert (expr->ts.type != BT_CHARACTER);
3515 : /* Initialize the operand. */
3516 28841 : gfc_init_se (&operand, se);
3517 28841 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3518 28841 : gfc_add_block_to_block (&se->pre, &operand.pre);
3519 :
3520 28841 : type = gfc_typenode_for_spec (&expr->ts);
3521 :
3522 : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3523 : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3524 : All other unary operators have an equivalent GIMPLE unary operator. */
3525 28841 : if (code == TRUTH_NOT_EXPR)
3526 20238 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3527 : build_int_cst (type, 0));
3528 : else
3529 8603 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3530 :
3531 28841 : }
3532 :
3533 : /* Expand power operator to optimal multiplications when a value is raised
3534 : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3535 : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3536 : Programming", 3rd Edition, 1998. */
3537 :
3538 : /* This code is mostly duplicated from expand_powi in the backend.
3539 : We establish the "optimal power tree" lookup table with the defined size.
3540 : The items in the table are the exponents used to calculate the index
3541 : exponents. Any integer n less than the value can get an "addition chain",
3542 : with the first node being one. */
3543 : #define POWI_TABLE_SIZE 256
3544 :
3545 : /* The table is from builtins.cc. */
3546 : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3547 : {
3548 : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3549 : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3550 : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3551 : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3552 : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3553 : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3554 : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3555 : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3556 : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3557 : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3558 : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3559 : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3560 : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3561 : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3562 : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3563 : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3564 : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3565 : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3566 : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3567 : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3568 : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3569 : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3570 : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3571 : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3572 : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3573 : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3574 : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3575 : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3576 : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3577 : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3578 : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3579 : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3580 : };
3581 :
3582 : /* If n is larger than lookup table's max index, we use the "window
3583 : method". */
3584 : #define POWI_WINDOW_SIZE 3
3585 :
3586 : /* Recursive function to expand the power operator. The temporary
3587 : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3588 : static tree
3589 178323 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3590 : {
3591 178323 : tree op0;
3592 178323 : tree op1;
3593 178323 : tree tmp;
3594 178323 : int digit;
3595 :
3596 178323 : if (n < POWI_TABLE_SIZE)
3597 : {
3598 137336 : if (tmpvar[n])
3599 : return tmpvar[n];
3600 :
3601 56612 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3602 56612 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3603 : }
3604 40987 : else if (n & 1)
3605 : {
3606 10015 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3607 10015 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3608 10015 : op1 = gfc_conv_powi (se, digit, tmpvar);
3609 : }
3610 : else
3611 : {
3612 30972 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3613 30972 : op1 = op0;
3614 : }
3615 :
3616 97599 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3617 97599 : tmp = gfc_evaluate_now (tmp, &se->pre);
3618 :
3619 97599 : if (n < POWI_TABLE_SIZE)
3620 56612 : tmpvar[n] = tmp;
3621 :
3622 : return tmp;
3623 : }
3624 :
3625 :
3626 : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3627 : return 1. Else return 0 and a call to runtime library functions
3628 : will have to be built. */
3629 : static int
3630 3305 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3631 : {
3632 3305 : tree cond;
3633 3305 : tree tmp;
3634 3305 : tree type;
3635 3305 : tree vartmp[POWI_TABLE_SIZE];
3636 3305 : HOST_WIDE_INT m;
3637 3305 : unsigned HOST_WIDE_INT n;
3638 3305 : int sgn;
3639 3305 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3640 :
3641 : /* If exponent is too large, we won't expand it anyway, so don't bother
3642 : with large integer values. */
3643 3305 : if (!wi::fits_shwi_p (wrhs))
3644 : return 0;
3645 :
3646 2945 : m = wrhs.to_shwi ();
3647 : /* Use the wide_int's routine to reliably get the absolute value on all
3648 : platforms. Then convert it to a HOST_WIDE_INT like above. */
3649 2945 : n = wi::abs (wrhs).to_shwi ();
3650 :
3651 2945 : type = TREE_TYPE (lhs);
3652 2945 : sgn = tree_int_cst_sgn (rhs);
3653 :
3654 2945 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3655 5890 : || optimize_size) && (m > 2 || m < -1))
3656 : return 0;
3657 :
3658 : /* rhs == 0 */
3659 1639 : if (sgn == 0)
3660 : {
3661 282 : se->expr = gfc_build_const (type, integer_one_node);
3662 282 : return 1;
3663 : }
3664 :
3665 : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3666 1357 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3667 : {
3668 220 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3669 220 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3670 220 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3671 220 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3672 :
3673 : /* If rhs is even,
3674 : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3675 220 : if ((n & 1) == 0)
3676 : {
3677 104 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3678 : logical_type_node, tmp, cond);
3679 104 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3680 : tmp, build_int_cst (type, 1),
3681 : build_int_cst (type, 0));
3682 104 : return 1;
3683 : }
3684 : /* If rhs is odd,
3685 : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3686 116 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3687 : build_int_cst (type, -1),
3688 : build_int_cst (type, 0));
3689 116 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3690 : cond, build_int_cst (type, 1), tmp);
3691 116 : return 1;
3692 : }
3693 :
3694 1137 : memset (vartmp, 0, sizeof (vartmp));
3695 1137 : vartmp[1] = lhs;
3696 1137 : if (sgn == -1)
3697 : {
3698 141 : tmp = gfc_build_const (type, integer_one_node);
3699 141 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3700 : vartmp[1]);
3701 : }
3702 :
3703 1137 : se->expr = gfc_conv_powi (se, n, vartmp);
3704 :
3705 1137 : return 1;
3706 : }
3707 :
3708 : /* Convert lhs**rhs, for constant rhs, when both are unsigned.
3709 : Method:
3710 : if (rhs == 0) ! Checked here.
3711 : return 1;
3712 : if (lhs & 1 == 1) ! odd_cnd
3713 : {
3714 : if (bit_size(rhs) < bit_size(lhs)) ! Checked here.
3715 : return lhs ** rhs;
3716 :
3717 : mask = 1 << (bit_size(a) - 1) / 2;
3718 : return lhs ** (n & rhs);
3719 : }
3720 : if (rhs > bit_size(lhs)) ! Checked here.
3721 : return 0;
3722 :
3723 : return lhs ** rhs;
3724 : */
3725 :
3726 : static int
3727 15120 : gfc_conv_cst_uint_power (gfc_se * se, tree lhs, tree rhs)
3728 : {
3729 15120 : tree type = TREE_TYPE (lhs);
3730 15120 : tree tmp, is_odd, odd_branch, even_branch;
3731 15120 : unsigned HOST_WIDE_INT lhs_prec, rhs_prec;
3732 15120 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3733 15120 : unsigned HOST_WIDE_INT n, n_odd;
3734 15120 : tree vartmp_odd[POWI_TABLE_SIZE], vartmp_even[POWI_TABLE_SIZE];
3735 :
3736 : /* Anything ** 0 is one. */
3737 15120 : if (integer_zerop (rhs))
3738 : {
3739 1800 : se->expr = build_int_cst (type, 1);
3740 1800 : return 1;
3741 : }
3742 :
3743 13320 : if (!wi::fits_uhwi_p (wrhs))
3744 : return 0;
3745 :
3746 12960 : n = wrhs.to_uhwi ();
3747 :
3748 : /* tmp = a & 1; . */
3749 12960 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3750 : lhs, build_int_cst (type, 1));
3751 12960 : is_odd = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3752 : tmp, build_int_cst (type, 1));
3753 :
3754 12960 : lhs_prec = TYPE_PRECISION (type);
3755 12960 : rhs_prec = TYPE_PRECISION (TREE_TYPE (rhs));
3756 :
3757 12960 : if (rhs_prec >= lhs_prec && lhs_prec <= HOST_BITS_PER_WIDE_INT)
3758 : {
3759 7044 : unsigned HOST_WIDE_INT mask = (HOST_WIDE_INT_1U << (lhs_prec - 1)) - 1;
3760 7044 : n_odd = n & mask;
3761 : }
3762 : else
3763 : n_odd = n;
3764 :
3765 12960 : memset (vartmp_odd, 0, sizeof (vartmp_odd));
3766 12960 : vartmp_odd[0] = build_int_cst (type, 1);
3767 12960 : vartmp_odd[1] = lhs;
3768 12960 : odd_branch = gfc_conv_powi (se, n_odd, vartmp_odd);
3769 12960 : even_branch = NULL_TREE;
3770 :
3771 12960 : if (n > lhs_prec)
3772 4260 : even_branch = build_int_cst (type, 0);
3773 : else
3774 : {
3775 8700 : if (n_odd != n)
3776 : {
3777 0 : memset (vartmp_even, 0, sizeof (vartmp_even));
3778 0 : vartmp_even[0] = build_int_cst (type, 1);
3779 0 : vartmp_even[1] = lhs;
3780 0 : even_branch = gfc_conv_powi (se, n, vartmp_even);
3781 : }
3782 : }
3783 4260 : if (even_branch != NULL_TREE)
3784 4260 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, is_odd,
3785 : odd_branch, even_branch);
3786 : else
3787 8700 : se->expr = odd_branch;
3788 :
3789 : return 1;
3790 : }
3791 :
3792 : /* Power op (**). Constant integer exponent and powers of 2 have special
3793 : handling. */
3794 :
3795 : static void
3796 49129 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3797 : {
3798 49129 : tree gfc_int4_type_node;
3799 49129 : int kind;
3800 49129 : int ikind;
3801 49129 : int res_ikind_1, res_ikind_2;
3802 49129 : gfc_se lse;
3803 49129 : gfc_se rse;
3804 49129 : tree fndecl = NULL;
3805 :
3806 49129 : gfc_init_se (&lse, se);
3807 49129 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3808 49129 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3809 49129 : gfc_add_block_to_block (&se->pre, &lse.pre);
3810 :
3811 49129 : gfc_init_se (&rse, se);
3812 49129 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3813 49129 : gfc_add_block_to_block (&se->pre, &rse.pre);
3814 :
3815 49129 : if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
3816 : {
3817 17563 : if (expr->value.op.op2->ts.type == BT_INTEGER)
3818 : {
3819 2292 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3820 20418 : return;
3821 : }
3822 15271 : else if (expr->value.op.op2->ts.type == BT_UNSIGNED)
3823 : {
3824 15120 : if (gfc_conv_cst_uint_power (se, lse.expr, rse.expr))
3825 : return;
3826 : }
3827 : }
3828 :
3829 32730 : if ((expr->value.op.op2->ts.type == BT_INTEGER
3830 31468 : || expr->value.op.op2->ts.type == BT_UNSIGNED)
3831 31862 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3832 1013 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3833 : return;
3834 :
3835 32730 : if (INTEGER_CST_P (lse.expr)
3836 15371 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE
3837 48101 : && expr->value.op.op2->ts.type == BT_INTEGER)
3838 : {
3839 251 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3840 251 : HOST_WIDE_INT v;
3841 251 : unsigned HOST_WIDE_INT w;
3842 251 : int kind, ikind, bit_size;
3843 :
3844 251 : v = wlhs.to_shwi ();
3845 251 : w = absu_hwi (v);
3846 :
3847 251 : kind = expr->value.op.op1->ts.kind;
3848 251 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3849 251 : bit_size = gfc_integer_kinds[ikind].bit_size;
3850 :
3851 251 : if (v == 1)
3852 : {
3853 : /* 1**something is always 1. */
3854 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3855 239 : return;
3856 : }
3857 216 : else if (v == -1)
3858 : {
3859 : /* (-1)**n is 1 - ((n & 1) << 1) */
3860 34 : tree type;
3861 34 : tree tmp;
3862 :
3863 34 : type = TREE_TYPE (lse.expr);
3864 34 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3865 : rse.expr, build_int_cst (type, 1));
3866 34 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3867 : tmp, build_int_cst (type, 1));
3868 34 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3869 : build_int_cst (type, 1), tmp);
3870 34 : se->expr = tmp;
3871 34 : return;
3872 : }
3873 182 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3874 : {
3875 : /* Here v is +/- 2**e. The further simplification uses
3876 : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3877 : 1<<(4*n), etc., but we have to make sure to return zero
3878 : if the number of bits is too large. */
3879 170 : tree lshift;
3880 170 : tree type;
3881 170 : tree shift;
3882 170 : tree ge;
3883 170 : tree cond;
3884 170 : tree num_bits;
3885 170 : tree cond2;
3886 170 : tree tmp1;
3887 :
3888 170 : type = TREE_TYPE (lse.expr);
3889 :
3890 170 : if (w == 2)
3891 110 : shift = rse.expr;
3892 60 : else if (w == 4)
3893 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3894 12 : TREE_TYPE (rse.expr),
3895 : rse.expr, rse.expr);
3896 : else
3897 : {
3898 : /* use popcount for fast log2(w) */
3899 48 : int e = wi::popcount (w-1);
3900 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3901 48 : TREE_TYPE (rse.expr),
3902 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3903 : rse.expr);
3904 : }
3905 :
3906 170 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3907 : build_int_cst (type, 1), shift);
3908 170 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3909 : rse.expr, build_int_cst (type, 0));
3910 170 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3911 : build_int_cst (type, 0));
3912 170 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3913 170 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3914 : rse.expr, num_bits);
3915 170 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3916 : build_int_cst (type, 0), cond);
3917 170 : if (v > 0)
3918 : {
3919 128 : se->expr = tmp1;
3920 : }
3921 : else
3922 : {
3923 : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3924 42 : tree tmp2;
3925 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3926 : rse.expr, build_int_cst (type, 1));
3927 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3928 : tmp2, build_int_cst (type, 1));
3929 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3930 : build_int_cst (type, 1), tmp2);
3931 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3932 : tmp1, tmp2);
3933 : }
3934 170 : return;
3935 : }
3936 : }
3937 : /* Handle unsigned separate from signed above, things would be too
3938 : complicated otherwise. */
3939 :
3940 32491 : if (INTEGER_CST_P (lse.expr) && expr->value.op.op1->ts.type == BT_UNSIGNED)
3941 : {
3942 15120 : gfc_expr * op1 = expr->value.op.op1;
3943 15120 : tree type;
3944 :
3945 15120 : type = TREE_TYPE (lse.expr);
3946 :
3947 15120 : if (mpz_cmp_ui (op1->value.integer, 1) == 0)
3948 : {
3949 : /* 1**something is always 1. */
3950 1260 : se->expr = build_int_cst (type, 1);
3951 1260 : return;
3952 : }
3953 :
3954 : /* Simplify 2u**x to a shift, with the value set to zero if it falls
3955 : outside the range. */
3956 26460 : if (mpz_popcount (op1->value.integer) == 1)
3957 : {
3958 2520 : tree prec_m1, lim, shift, lshift, cond, tmp;
3959 2520 : tree rtype = TREE_TYPE (rse.expr);
3960 2520 : int e = mpz_scan1 (op1->value.integer, 0);
3961 :
3962 2520 : shift = fold_build2_loc (input_location, MULT_EXPR,
3963 2520 : rtype, build_int_cst (rtype, e),
3964 : rse.expr);
3965 2520 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3966 : build_int_cst (type, 1), shift);
3967 5040 : prec_m1 = fold_build2_loc (input_location, MINUS_EXPR, rtype,
3968 2520 : build_int_cst (rtype, TYPE_PRECISION (type)),
3969 : build_int_cst (rtype, 1));
3970 2520 : lim = fold_build2_loc (input_location, TRUNC_DIV_EXPR, rtype,
3971 2520 : prec_m1, build_int_cst (rtype, e));
3972 2520 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3973 : rse.expr, lim);
3974 2520 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond,
3975 : build_int_cst (type, 0), lshift);
3976 2520 : se->expr = tmp;
3977 2520 : return;
3978 : }
3979 : }
3980 :
3981 28711 : gfc_int4_type_node = gfc_get_int_type (4);
3982 :
3983 : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3984 : library routine. But in the end, we have to convert the result back
3985 : if this case applies -- with res_ikind_K, we keep track whether operand K
3986 : falls into this case. */
3987 28711 : res_ikind_1 = -1;
3988 28711 : res_ikind_2 = -1;
3989 :
3990 28711 : kind = expr->value.op.op1->ts.kind;
3991 28711 : switch (expr->value.op.op2->ts.type)
3992 : {
3993 1023 : case BT_INTEGER:
3994 1023 : ikind = expr->value.op.op2->ts.kind;
3995 1023 : switch (ikind)
3996 : {
3997 144 : case 1:
3998 144 : case 2:
3999 144 : rse.expr = convert (gfc_int4_type_node, rse.expr);
4000 144 : res_ikind_2 = ikind;
4001 : /* Fall through. */
4002 :
4003 : case 4:
4004 : ikind = 0;
4005 : break;
4006 :
4007 : case 8:
4008 : ikind = 1;
4009 : break;
4010 :
4011 6 : case 16:
4012 6 : ikind = 2;
4013 6 : break;
4014 :
4015 0 : default:
4016 0 : gcc_unreachable ();
4017 : }
4018 1023 : switch (kind)
4019 : {
4020 0 : case 1:
4021 0 : case 2:
4022 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
4023 : {
4024 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
4025 0 : res_ikind_1 = kind;
4026 : }
4027 : else
4028 0 : gcc_unreachable ();
4029 : /* Fall through. */
4030 :
4031 : case 4:
4032 : kind = 0;
4033 : break;
4034 :
4035 : case 8:
4036 : kind = 1;
4037 : break;
4038 :
4039 6 : case 10:
4040 6 : kind = 2;
4041 6 : break;
4042 :
4043 18 : case 16:
4044 18 : kind = 3;
4045 18 : break;
4046 :
4047 0 : default:
4048 0 : gcc_unreachable ();
4049 : }
4050 :
4051 1023 : switch (expr->value.op.op1->ts.type)
4052 : {
4053 129 : case BT_INTEGER:
4054 129 : if (kind == 3) /* Case 16 was not handled properly above. */
4055 : kind = 2;
4056 129 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
4057 129 : break;
4058 :
4059 662 : case BT_REAL:
4060 : /* Use builtins for real ** int4. */
4061 662 : if (ikind == 0)
4062 : {
4063 565 : switch (kind)
4064 : {
4065 392 : case 0:
4066 392 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
4067 392 : break;
4068 :
4069 155 : case 1:
4070 155 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
4071 155 : break;
4072 :
4073 6 : case 2:
4074 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4075 6 : break;
4076 :
4077 12 : case 3:
4078 : /* Use the __builtin_powil() only if real(kind=16) is
4079 : actually the C long double type. */
4080 12 : if (!gfc_real16_is_float128)
4081 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4082 : break;
4083 :
4084 : default:
4085 : gcc_unreachable ();
4086 : }
4087 : }
4088 :
4089 : /* If we don't have a good builtin for this, go for the
4090 : library function. */
4091 553 : if (!fndecl)
4092 109 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
4093 : break;
4094 :
4095 232 : case BT_COMPLEX:
4096 232 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
4097 232 : break;
4098 :
4099 0 : default:
4100 0 : gcc_unreachable ();
4101 : }
4102 : break;
4103 :
4104 139 : case BT_REAL:
4105 139 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
4106 139 : break;
4107 :
4108 729 : case BT_COMPLEX:
4109 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
4110 729 : break;
4111 :
4112 26820 : case BT_UNSIGNED:
4113 26820 : {
4114 : /* Valid kinds for unsigned are 1, 2, 4, 8, 16. Instead of using a
4115 : large switch statement, let's just use __builtin_ctz. */
4116 26820 : int base = __builtin_ctz (expr->value.op.op1->ts.kind);
4117 26820 : int expon = __builtin_ctz (expr->value.op.op2->ts.kind);
4118 26820 : fndecl = gfor_fndecl_unsigned_pow_list[base][expon];
4119 : }
4120 26820 : break;
4121 :
4122 0 : default:
4123 0 : gcc_unreachable ();
4124 28711 : break;
4125 : }
4126 :
4127 28711 : se->expr = build_call_expr_loc (input_location,
4128 : fndecl, 2, lse.expr, rse.expr);
4129 :
4130 : /* Convert the result back if it is of wrong integer kind. */
4131 28711 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
4132 : {
4133 : /* We want the maximum of both operand kinds as result. */
4134 0 : if (res_ikind_1 < res_ikind_2)
4135 0 : res_ikind_1 = res_ikind_2;
4136 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
4137 : }
4138 : }
4139 :
4140 :
4141 : /* Generate code to allocate a string temporary. */
4142 :
4143 : tree
4144 4879 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4145 : {
4146 4879 : tree var;
4147 4879 : tree tmp;
4148 :
4149 4879 : if (gfc_can_put_var_on_stack (len))
4150 : {
4151 : /* Create a temporary variable to hold the result. */
4152 4584 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4153 2292 : TREE_TYPE (len), len,
4154 2292 : build_int_cst (TREE_TYPE (len), 1));
4155 2292 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4156 :
4157 2292 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4158 2292 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4159 : else
4160 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
4161 :
4162 2292 : var = gfc_create_var (tmp, "str");
4163 2292 : var = gfc_build_addr_expr (type, var);
4164 : }
4165 : else
4166 : {
4167 : /* Allocate a temporary to hold the result. */
4168 2587 : var = gfc_create_var (type, "pstr");
4169 2587 : gcc_assert (POINTER_TYPE_P (type));
4170 2587 : tmp = TREE_TYPE (type);
4171 2587 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4172 2587 : tmp = TREE_TYPE (tmp);
4173 2587 : tmp = TYPE_SIZE_UNIT (tmp);
4174 2587 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4175 : fold_convert (size_type_node, len),
4176 : fold_convert (size_type_node, tmp));
4177 2587 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4178 2587 : gfc_add_modify (&se->pre, var, tmp);
4179 :
4180 : /* Free the temporary afterwards. */
4181 2587 : tmp = gfc_call_free (var);
4182 2587 : gfc_add_expr_to_block (&se->post, tmp);
4183 : }
4184 :
4185 4879 : return var;
4186 : }
4187 :
4188 :
4189 : /* Handle a string concatenation operation. A temporary will be allocated to
4190 : hold the result. */
4191 :
4192 : static void
4193 1294 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4194 : {
4195 1294 : gfc_se lse, rse;
4196 1294 : tree len, type, var, tmp, fndecl;
4197 :
4198 1294 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4199 : && expr->value.op.op2->ts.type == BT_CHARACTER);
4200 1294 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4201 :
4202 1294 : gfc_init_se (&lse, se);
4203 1294 : gfc_conv_expr (&lse, expr->value.op.op1);
4204 1294 : gfc_conv_string_parameter (&lse);
4205 1294 : gfc_init_se (&rse, se);
4206 1294 : gfc_conv_expr (&rse, expr->value.op.op2);
4207 1294 : gfc_conv_string_parameter (&rse);
4208 :
4209 1294 : gfc_add_block_to_block (&se->pre, &lse.pre);
4210 1294 : gfc_add_block_to_block (&se->pre, &rse.pre);
4211 :
4212 1294 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4213 1294 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4214 1294 : if (len == NULL_TREE)
4215 : {
4216 1075 : len = fold_build2_loc (input_location, PLUS_EXPR,
4217 : gfc_charlen_type_node,
4218 : fold_convert (gfc_charlen_type_node,
4219 : lse.string_length),
4220 : fold_convert (gfc_charlen_type_node,
4221 : rse.string_length));
4222 : }
4223 :
4224 1294 : type = build_pointer_type (type);
4225 :
4226 1294 : var = gfc_conv_string_tmp (se, type, len);
4227 :
4228 : /* Do the actual concatenation. */
4229 1294 : if (expr->ts.kind == 1)
4230 1203 : fndecl = gfor_fndecl_concat_string;
4231 91 : else if (expr->ts.kind == 4)
4232 91 : fndecl = gfor_fndecl_concat_string_char4;
4233 : else
4234 0 : gcc_unreachable ();
4235 :
4236 1294 : tmp = build_call_expr_loc (input_location,
4237 : fndecl, 6, len, var, lse.string_length, lse.expr,
4238 : rse.string_length, rse.expr);
4239 1294 : gfc_add_expr_to_block (&se->pre, tmp);
4240 :
4241 : /* Add the cleanup for the operands. */
4242 1294 : gfc_add_block_to_block (&se->pre, &rse.post);
4243 1294 : gfc_add_block_to_block (&se->pre, &lse.post);
4244 :
4245 1294 : se->expr = var;
4246 1294 : se->string_length = len;
4247 1294 : }
4248 :
4249 : /* Translates an op expression. Common (binary) cases are handled by this
4250 : function, others are passed on. Recursion is used in either case.
4251 : We use the fact that (op1.ts == op2.ts) (except for the power
4252 : operator **).
4253 : Operators need no special handling for scalarized expressions as long as
4254 : they call gfc_conv_simple_val to get their operands.
4255 : Character strings get special handling. */
4256 :
4257 : static void
4258 507069 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4259 : {
4260 507069 : enum tree_code code;
4261 507069 : gfc_se lse;
4262 507069 : gfc_se rse;
4263 507069 : tree tmp, type;
4264 507069 : int lop;
4265 507069 : int checkstring;
4266 :
4267 507069 : checkstring = 0;
4268 507069 : lop = 0;
4269 507069 : switch (expr->value.op.op)
4270 : {
4271 15531 : case INTRINSIC_PARENTHESES:
4272 15531 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4273 3801 : && flag_protect_parens)
4274 : {
4275 3668 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
4276 3668 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
4277 91133 : return;
4278 : }
4279 :
4280 : /* Fallthrough. */
4281 11869 : case INTRINSIC_UPLUS:
4282 11869 : gfc_conv_expr (se, expr->value.op.op1);
4283 11869 : return;
4284 :
4285 4935 : case INTRINSIC_UMINUS:
4286 4935 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4287 4935 : return;
4288 :
4289 20238 : case INTRINSIC_NOT:
4290 20238 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4291 20238 : return;
4292 :
4293 : case INTRINSIC_PLUS:
4294 : code = PLUS_EXPR;
4295 : break;
4296 :
4297 29016 : case INTRINSIC_MINUS:
4298 29016 : code = MINUS_EXPR;
4299 29016 : break;
4300 :
4301 32684 : case INTRINSIC_TIMES:
4302 32684 : code = MULT_EXPR;
4303 32684 : break;
4304 :
4305 6913 : case INTRINSIC_DIVIDE:
4306 : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
4307 : an integer or unsigned, we must round towards zero, so we use a
4308 : TRUNC_DIV_EXPR. */
4309 6913 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4310 : code = TRUNC_DIV_EXPR;
4311 : else
4312 415936 : code = RDIV_EXPR;
4313 : break;
4314 :
4315 49129 : case INTRINSIC_POWER:
4316 49129 : gfc_conv_power_op (se, expr);
4317 49129 : return;
4318 :
4319 1294 : case INTRINSIC_CONCAT:
4320 1294 : gfc_conv_concat_op (se, expr);
4321 1294 : return;
4322 :
4323 4786 : case INTRINSIC_AND:
4324 4786 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4325 : lop = 1;
4326 : break;
4327 :
4328 56025 : case INTRINSIC_OR:
4329 56025 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
4330 : lop = 1;
4331 : break;
4332 :
4333 : /* EQV and NEQV only work on logicals, but since we represent them
4334 : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4335 12650 : case INTRINSIC_EQ:
4336 12650 : case INTRINSIC_EQ_OS:
4337 12650 : case INTRINSIC_EQV:
4338 12650 : code = EQ_EXPR;
4339 12650 : checkstring = 1;
4340 12650 : lop = 1;
4341 12650 : break;
4342 :
4343 207066 : case INTRINSIC_NE:
4344 207066 : case INTRINSIC_NE_OS:
4345 207066 : case INTRINSIC_NEQV:
4346 207066 : code = NE_EXPR;
4347 207066 : checkstring = 1;
4348 207066 : lop = 1;
4349 207066 : break;
4350 :
4351 11976 : case INTRINSIC_GT:
4352 11976 : case INTRINSIC_GT_OS:
4353 11976 : code = GT_EXPR;
4354 11976 : checkstring = 1;
4355 11976 : lop = 1;
4356 11976 : break;
4357 :
4358 1667 : case INTRINSIC_GE:
4359 1667 : case INTRINSIC_GE_OS:
4360 1667 : code = GE_EXPR;
4361 1667 : checkstring = 1;
4362 1667 : lop = 1;
4363 1667 : break;
4364 :
4365 4340 : case INTRINSIC_LT:
4366 4340 : case INTRINSIC_LT_OS:
4367 4340 : code = LT_EXPR;
4368 4340 : checkstring = 1;
4369 4340 : lop = 1;
4370 4340 : break;
4371 :
4372 2604 : case INTRINSIC_LE:
4373 2604 : case INTRINSIC_LE_OS:
4374 2604 : code = LE_EXPR;
4375 2604 : checkstring = 1;
4376 2604 : lop = 1;
4377 2604 : break;
4378 :
4379 0 : case INTRINSIC_USER:
4380 0 : case INTRINSIC_ASSIGN:
4381 : /* These should be converted into function calls by the frontend. */
4382 0 : gcc_unreachable ();
4383 :
4384 0 : default:
4385 0 : fatal_error (input_location, "Unknown intrinsic op");
4386 415936 : return;
4387 : }
4388 :
4389 : /* The only exception to this is **, which is handled separately anyway. */
4390 415936 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4391 :
4392 415936 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4393 381963 : checkstring = 0;
4394 :
4395 : /* lhs */
4396 415936 : gfc_init_se (&lse, se);
4397 415936 : gfc_conv_expr (&lse, expr->value.op.op1);
4398 415936 : gfc_add_block_to_block (&se->pre, &lse.pre);
4399 :
4400 : /* rhs */
4401 415936 : gfc_init_se (&rse, se);
4402 415936 : gfc_conv_expr (&rse, expr->value.op.op2);
4403 415936 : gfc_add_block_to_block (&se->pre, &rse.pre);
4404 :
4405 415936 : if (checkstring)
4406 : {
4407 33973 : gfc_conv_string_parameter (&lse);
4408 33973 : gfc_conv_string_parameter (&rse);
4409 :
4410 67946 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4411 : rse.string_length, rse.expr,
4412 33973 : expr->value.op.op1->ts.kind,
4413 : code);
4414 33973 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4415 33973 : gfc_add_block_to_block (&lse.post, &rse.post);
4416 : }
4417 :
4418 415936 : type = gfc_typenode_for_spec (&expr->ts);
4419 :
4420 415936 : if (lop)
4421 : {
4422 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4423 301114 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4424 170047 : && expr->value.op.op1->ts.type == BT_INTEGER
4425 73351 : && expr->value.op.op1->symtree
4426 73351 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4427 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4428 :
4429 301114 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4430 72269 : && expr->value.op.op2->ts.type == BT_INTEGER
4431 12902 : && expr->value.op.op2->symtree
4432 12902 : && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
4433 12 : TREE_THIS_VOLATILE (rse.expr) = 1;
4434 :
4435 : /* The result of logical ops is always logical_type_node. */
4436 301114 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4437 : lse.expr, rse.expr);
4438 301114 : se->expr = convert (type, tmp);
4439 : }
4440 : else
4441 114822 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4442 :
4443 : /* Add the post blocks. */
4444 415936 : gfc_add_block_to_block (&se->post, &rse.post);
4445 415936 : gfc_add_block_to_block (&se->post, &lse.post);
4446 : }
4447 :
4448 : static void
4449 151 : gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
4450 : {
4451 151 : gfc_se cond_se, true_se, false_se;
4452 151 : tree condition, true_val, false_val;
4453 151 : tree type;
4454 :
4455 151 : gfc_init_se (&cond_se, se);
4456 151 : gfc_init_se (&true_se, se);
4457 151 : gfc_init_se (&false_se, se);
4458 :
4459 151 : gfc_conv_expr (&cond_se, expr->value.conditional.condition);
4460 151 : gfc_add_block_to_block (&se->pre, &cond_se.pre);
4461 151 : condition = gfc_evaluate_now (cond_se.expr, &se->pre);
4462 :
4463 151 : true_se.want_pointer = se->want_pointer;
4464 151 : gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
4465 151 : true_val = true_se.expr;
4466 151 : false_se.want_pointer = se->want_pointer;
4467 151 : gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
4468 151 : false_val = false_se.expr;
4469 :
4470 151 : if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
4471 24 : gfc_add_expr_to_block (
4472 : &se->pre,
4473 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4474 24 : true_se.pre.head != NULL_TREE
4475 6 : ? gfc_finish_block (&true_se.pre)
4476 18 : : build_empty_stmt (input_location),
4477 24 : false_se.pre.head != NULL_TREE
4478 24 : ? gfc_finish_block (&false_se.pre)
4479 0 : : build_empty_stmt (input_location)));
4480 :
4481 151 : if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
4482 6 : gfc_add_expr_to_block (
4483 : &se->post,
4484 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4485 6 : true_se.post.head != NULL_TREE
4486 0 : ? gfc_finish_block (&true_se.post)
4487 6 : : build_empty_stmt (input_location),
4488 6 : false_se.post.head != NULL_TREE
4489 6 : ? gfc_finish_block (&false_se.post)
4490 0 : : build_empty_stmt (input_location)));
4491 :
4492 151 : type = gfc_typenode_for_spec (&expr->ts);
4493 151 : if (se->want_pointer)
4494 18 : type = build_pointer_type (type);
4495 :
4496 151 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
4497 : true_val, false_val);
4498 151 : if (expr->ts.type == BT_CHARACTER)
4499 66 : se->string_length
4500 66 : = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
4501 : condition, true_se.string_length,
4502 : false_se.string_length);
4503 151 : }
4504 :
4505 : /* If a string's length is one, we convert it to a single character. */
4506 :
4507 : tree
4508 140144 : gfc_string_to_single_character (tree len, tree str, int kind)
4509 : {
4510 :
4511 140144 : if (len == NULL
4512 140144 : || !tree_fits_uhwi_p (len)
4513 257566 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4514 : return NULL_TREE;
4515 :
4516 117370 : if (TREE_INT_CST_LOW (len) == 1)
4517 : {
4518 22550 : str = fold_convert (gfc_get_pchar_type (kind), str);
4519 22550 : return build_fold_indirect_ref_loc (input_location, str);
4520 : }
4521 :
4522 94820 : if (kind == 1
4523 77450 : && TREE_CODE (str) == ADDR_EXPR
4524 66792 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4525 47722 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4526 29344 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4527 29344 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4528 29344 : && TREE_INT_CST_LOW (len) > 1
4529 122358 : && TREE_INT_CST_LOW (len)
4530 : == (unsigned HOST_WIDE_INT)
4531 27538 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4532 : {
4533 27538 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4534 27538 : ret = build_fold_indirect_ref_loc (input_location, ret);
4535 27538 : if (TREE_CODE (ret) == INTEGER_CST)
4536 : {
4537 27538 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4538 27538 : int i, length = TREE_STRING_LENGTH (string_cst);
4539 27538 : const char *ptr = TREE_STRING_POINTER (string_cst);
4540 :
4541 41258 : for (i = 1; i < length; i++)
4542 40584 : if (ptr[i] != ' ')
4543 : return NULL_TREE;
4544 :
4545 : return ret;
4546 : }
4547 : }
4548 :
4549 : return NULL_TREE;
4550 : }
4551 :
4552 :
4553 : static void
4554 172 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4555 : {
4556 172 : gcc_assert (expr);
4557 :
4558 : /* We used to modify the tree here. Now it is done earlier in
4559 : the front-end, so we only check it here to avoid regressions. */
4560 172 : if (sym->backend_decl)
4561 : {
4562 67 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4563 67 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4564 67 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4565 67 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4566 : }
4567 :
4568 : /* If we have a constant character expression, make it into an
4569 : integer of type C char. */
4570 172 : if ((*expr)->expr_type == EXPR_CONSTANT)
4571 : {
4572 166 : gfc_typespec ts;
4573 166 : gfc_clear_ts (&ts);
4574 :
4575 332 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4576 166 : (*expr)->value.character.string[0]);
4577 166 : gfc_replace_expr (*expr, tmp);
4578 : }
4579 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4580 : {
4581 6 : if ((*expr)->ref == NULL)
4582 : {
4583 6 : se->expr = gfc_string_to_single_character
4584 6 : (integer_one_node,
4585 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4586 : gfc_get_symbol_decl
4587 6 : ((*expr)->symtree->n.sym)),
4588 : (*expr)->ts.kind);
4589 : }
4590 : else
4591 : {
4592 0 : gfc_conv_variable (se, *expr);
4593 0 : se->expr = gfc_string_to_single_character
4594 0 : (integer_one_node,
4595 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4596 : se->expr),
4597 0 : (*expr)->ts.kind);
4598 : }
4599 : }
4600 172 : }
4601 :
4602 : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4603 : if STR is a string literal, otherwise return -1. */
4604 :
4605 : static int
4606 32256 : gfc_optimize_len_trim (tree len, tree str, int kind)
4607 : {
4608 32256 : if (kind == 1
4609 27214 : && TREE_CODE (str) == ADDR_EXPR
4610 23876 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4611 15220 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4612 9794 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4613 9794 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4614 9794 : && tree_fits_uhwi_p (len)
4615 9794 : && tree_to_uhwi (len) >= 1
4616 32256 : && tree_to_uhwi (len)
4617 9750 : == (unsigned HOST_WIDE_INT)
4618 9750 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4619 : {
4620 9750 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4621 9750 : folded = build_fold_indirect_ref_loc (input_location, folded);
4622 9750 : if (TREE_CODE (folded) == INTEGER_CST)
4623 : {
4624 9750 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4625 9750 : int length = TREE_STRING_LENGTH (string_cst);
4626 9750 : const char *ptr = TREE_STRING_POINTER (string_cst);
4627 :
4628 14659 : for (; length > 0; length--)
4629 14659 : if (ptr[length - 1] != ' ')
4630 : break;
4631 :
4632 : return length;
4633 : }
4634 : }
4635 : return -1;
4636 : }
4637 :
4638 : /* Helper to build a call to memcmp. */
4639 :
4640 : static tree
4641 13093 : build_memcmp_call (tree s1, tree s2, tree n)
4642 : {
4643 13093 : tree tmp;
4644 :
4645 13093 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4646 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4647 : else
4648 13093 : s1 = fold_convert (pvoid_type_node, s1);
4649 :
4650 13093 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4651 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4652 : else
4653 13093 : s2 = fold_convert (pvoid_type_node, s2);
4654 :
4655 13093 : n = fold_convert (size_type_node, n);
4656 :
4657 13093 : tmp = build_call_expr_loc (input_location,
4658 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4659 : 3, s1, s2, n);
4660 :
4661 13093 : return fold_convert (integer_type_node, tmp);
4662 : }
4663 :
4664 : /* Compare two strings. If they are all single characters, the result is the
4665 : subtraction of them. Otherwise, we build a library call. */
4666 :
4667 : tree
4668 34072 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4669 : enum tree_code code)
4670 : {
4671 34072 : tree sc1;
4672 34072 : tree sc2;
4673 34072 : tree fndecl;
4674 :
4675 34072 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4676 34072 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4677 :
4678 34072 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4679 34072 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4680 :
4681 34072 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4682 : {
4683 : /* Deal with single character specially. */
4684 4839 : sc1 = fold_convert (integer_type_node, sc1);
4685 4839 : sc2 = fold_convert (integer_type_node, sc2);
4686 4839 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4687 4839 : sc1, sc2);
4688 : }
4689 :
4690 29233 : if ((code == EQ_EXPR || code == NE_EXPR)
4691 28671 : && optimize
4692 24017 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4693 : {
4694 : /* If one string is a string literal with LEN_TRIM longer
4695 : than the length of the second string, the strings
4696 : compare unequal. */
4697 16128 : int len = gfc_optimize_len_trim (len1, str1, kind);
4698 16128 : if (len > 0 && compare_tree_int (len2, len) < 0)
4699 0 : return integer_one_node;
4700 16128 : len = gfc_optimize_len_trim (len2, str2, kind);
4701 16128 : if (len > 0 && compare_tree_int (len1, len) < 0)
4702 0 : return integer_one_node;
4703 : }
4704 :
4705 : /* We can compare via memcpy if the strings are known to be equal
4706 : in length and they are
4707 : - kind=1
4708 : - kind=4 and the comparison is for (in)equality. */
4709 :
4710 19659 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4711 19321 : && tree_int_cst_equal (len1, len2)
4712 42386 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4713 : {
4714 13093 : tree tmp;
4715 13093 : tree chartype;
4716 :
4717 13093 : chartype = gfc_get_char_type (kind);
4718 13093 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4719 13093 : fold_convert (TREE_TYPE(len1),
4720 : TYPE_SIZE_UNIT(chartype)),
4721 : len1);
4722 13093 : return build_memcmp_call (str1, str2, tmp);
4723 : }
4724 :
4725 : /* Build a call for the comparison. */
4726 16140 : if (kind == 1)
4727 13297 : fndecl = gfor_fndecl_compare_string;
4728 2843 : else if (kind == 4)
4729 2843 : fndecl = gfor_fndecl_compare_string_char4;
4730 : else
4731 0 : gcc_unreachable ();
4732 :
4733 16140 : return build_call_expr_loc (input_location, fndecl, 4,
4734 16140 : len1, str1, len2, str2);
4735 : }
4736 :
4737 :
4738 : /* Return the backend_decl for a procedure pointer component. */
4739 :
4740 : static tree
4741 1900 : get_proc_ptr_comp (gfc_expr *e)
4742 : {
4743 1900 : gfc_se comp_se;
4744 1900 : gfc_expr *e2;
4745 1900 : expr_t old_type;
4746 :
4747 1900 : gfc_init_se (&comp_se, NULL);
4748 1900 : e2 = gfc_copy_expr (e);
4749 : /* We have to restore the expr type later so that gfc_free_expr frees
4750 : the exact same thing that was allocated.
4751 : TODO: This is ugly. */
4752 1900 : old_type = e2->expr_type;
4753 1900 : e2->expr_type = EXPR_VARIABLE;
4754 1900 : gfc_conv_expr (&comp_se, e2);
4755 1900 : e2->expr_type = old_type;
4756 1900 : gfc_free_expr (e2);
4757 1900 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4758 : }
4759 :
4760 :
4761 : /* Convert a typebound function reference from a class object. */
4762 : static void
4763 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4764 : {
4765 80 : gfc_ref *ref;
4766 80 : tree var;
4767 :
4768 80 : if (!VAR_P (base_object))
4769 : {
4770 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4771 0 : gfc_add_modify (&se->pre, var, base_object);
4772 : }
4773 80 : se->expr = gfc_class_vptr_get (base_object);
4774 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4775 80 : ref = expr->ref;
4776 308 : while (ref && ref->next)
4777 : ref = ref->next;
4778 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4779 80 : if (ref->u.c.sym->attr.extension)
4780 0 : conv_parent_component_references (se, ref);
4781 80 : gfc_conv_component_ref (se, ref);
4782 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4783 80 : }
4784 :
4785 : static tree
4786 127745 : get_builtin_fn (gfc_symbol * sym)
4787 : {
4788 127745 : if (!gfc_option.disable_omp_is_initial_device
4789 127741 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4790 631 : && !strcmp (sym->name, "omp_is_initial_device"))
4791 41 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4792 :
4793 127704 : if (!gfc_option.disable_omp_get_initial_device
4794 127697 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4795 4188 : && !strcmp (sym->name, "omp_get_initial_device"))
4796 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4797 :
4798 127675 : if (!gfc_option.disable_omp_get_num_devices
4799 127668 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4800 4159 : && !strcmp (sym->name, "omp_get_num_devices"))
4801 99 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4802 :
4803 127576 : if (!gfc_option.disable_acc_on_device
4804 127396 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4805 1163 : && !strcmp (sym->name, "acc_on_device_h"))
4806 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4807 :
4808 : return NULL_TREE;
4809 : }
4810 :
4811 : static tree
4812 559 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4813 : {
4814 559 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4815 :
4816 559 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4817 : /* In Fortran omp_is_initial_device returns logical(4)
4818 : but the builtin uses 'int'. */
4819 41 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4820 :
4821 518 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4822 : {
4823 : /* Likewise for the return type; additionally, the argument it a
4824 : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4825 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4826 390 : CALL_EXPR_ARG (fn_call, 0));
4827 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4828 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4829 : }
4830 : return fn_call;
4831 : }
4832 :
4833 : static void
4834 130461 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4835 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4836 : {
4837 130461 : tree tmp;
4838 :
4839 130461 : if (gfc_is_proc_ptr_comp (expr))
4840 1900 : tmp = get_proc_ptr_comp (expr);
4841 128561 : else if (sym->attr.dummy)
4842 : {
4843 816 : tmp = gfc_get_symbol_decl (sym);
4844 816 : if (sym->attr.proc_pointer)
4845 89 : tmp = build_fold_indirect_ref_loc (input_location,
4846 : tmp);
4847 816 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4848 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4849 : }
4850 : else
4851 : {
4852 127745 : if (!sym->backend_decl)
4853 32038 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4854 :
4855 127745 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4856 559 : *is_builtin = true;
4857 : else
4858 : {
4859 127186 : TREE_USED (sym->backend_decl) = 1;
4860 127186 : tmp = sym->backend_decl;
4861 : }
4862 :
4863 127745 : if (sym->attr.cray_pointee)
4864 : {
4865 : /* TODO - make the cray pointee a pointer to a procedure,
4866 : assign the pointer to it and use it for the call. This
4867 : will do for now! */
4868 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4869 19 : gfc_get_symbol_decl (sym->cp_pointer));
4870 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4871 : }
4872 :
4873 127745 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4874 : {
4875 127117 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4876 127117 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4877 : }
4878 : }
4879 130461 : se->expr = tmp;
4880 130461 : }
4881 :
4882 :
4883 : /* Initialize MAPPING. */
4884 :
4885 : void
4886 130578 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4887 : {
4888 130578 : mapping->syms = NULL;
4889 130578 : mapping->charlens = NULL;
4890 130578 : }
4891 :
4892 :
4893 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4894 :
4895 : void
4896 130578 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4897 : {
4898 130578 : gfc_interface_sym_mapping *sym;
4899 130578 : gfc_interface_sym_mapping *nextsym;
4900 130578 : gfc_charlen *cl;
4901 130578 : gfc_charlen *nextcl;
4902 :
4903 171162 : for (sym = mapping->syms; sym; sym = nextsym)
4904 : {
4905 40584 : nextsym = sym->next;
4906 40584 : sym->new_sym->n.sym->formal = NULL;
4907 40584 : gfc_free_symbol (sym->new_sym->n.sym);
4908 40584 : gfc_free_expr (sym->expr);
4909 40584 : free (sym->new_sym);
4910 40584 : free (sym);
4911 : }
4912 135218 : for (cl = mapping->charlens; cl; cl = nextcl)
4913 : {
4914 4640 : nextcl = cl->next;
4915 4640 : gfc_free_expr (cl->length);
4916 4640 : free (cl);
4917 : }
4918 130578 : }
4919 :
4920 :
4921 : /* Return a copy of gfc_charlen CL. Add the returned structure to
4922 : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4923 :
4924 : static gfc_charlen *
4925 4640 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4926 : gfc_charlen * cl)
4927 : {
4928 4640 : gfc_charlen *new_charlen;
4929 :
4930 4640 : new_charlen = gfc_get_charlen ();
4931 4640 : new_charlen->next = mapping->charlens;
4932 4640 : new_charlen->length = gfc_copy_expr (cl->length);
4933 :
4934 4640 : mapping->charlens = new_charlen;
4935 4640 : return new_charlen;
4936 : }
4937 :
4938 :
4939 : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4940 : array variable that can be used as the actual argument for dummy
4941 : argument SYM, except in the case of assumed rank dummies of
4942 : non-intrinsic functions where the descriptor must be passed. Add any
4943 : initialization code to BLOCK. PACKED is as for gfc_get_nodesc_array_type
4944 : and DATA points to the first element in the passed array. */
4945 :
4946 : static tree
4947 8394 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4948 : gfc_packed packed, tree data, tree len,
4949 : bool assumed_rank_formal)
4950 : {
4951 8394 : tree type;
4952 8394 : tree var;
4953 :
4954 8394 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4955 58 : type = gfc_get_character_type_len (sym->ts.kind, len);
4956 : else
4957 8336 : type = gfc_typenode_for_spec (&sym->ts);
4958 :
4959 8394 : if (assumed_rank_formal)
4960 13 : type = TREE_TYPE (data);
4961 : else
4962 8381 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4963 8357 : !sym->attr.target && !sym->attr.pointer
4964 16738 : && !sym->attr.proc_pointer);
4965 :
4966 8394 : var = gfc_create_var (type, "ifm");
4967 8394 : gfc_add_modify (block, var, fold_convert (type, data));
4968 :
4969 8394 : return var;
4970 : }
4971 :
4972 :
4973 : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4974 : and offset of descriptorless array type TYPE given that it has the same
4975 : size as DESC. Add any set-up code to BLOCK. */
4976 :
4977 : static void
4978 8124 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4979 : {
4980 8124 : int n;
4981 8124 : tree dim;
4982 8124 : tree offset;
4983 8124 : tree tmp;
4984 :
4985 8124 : offset = gfc_index_zero_node;
4986 9238 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4987 : {
4988 1114 : dim = gfc_rank_cst[n];
4989 1114 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4990 1114 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4991 : {
4992 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
4993 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
4994 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
4995 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
4996 : }
4997 1113 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4998 : {
4999 1087 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5000 : gfc_array_index_type,
5001 : gfc_conv_descriptor_ubound_get (desc, dim),
5002 : gfc_conv_descriptor_lbound_get (desc, dim));
5003 3261 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5004 : gfc_array_index_type,
5005 1087 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
5006 1087 : tmp = gfc_evaluate_now (tmp, block);
5007 1087 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
5008 : }
5009 4456 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5010 1114 : GFC_TYPE_ARRAY_LBOUND (type, n),
5011 1114 : GFC_TYPE_ARRAY_STRIDE (type, n));
5012 1114 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5013 : gfc_array_index_type, offset, tmp);
5014 : }
5015 8124 : offset = gfc_evaluate_now (offset, block);
5016 8124 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
5017 8124 : }
5018 :
5019 :
5020 : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
5021 : in SE. The caller may still use se->expr and se->string_length after
5022 : calling this function. */
5023 :
5024 : void
5025 40584 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
5026 : gfc_symbol * sym, gfc_se * se,
5027 : gfc_expr *expr)
5028 : {
5029 40584 : gfc_interface_sym_mapping *sm;
5030 40584 : tree desc;
5031 40584 : tree tmp;
5032 40584 : tree value;
5033 40584 : gfc_symbol *new_sym;
5034 40584 : gfc_symtree *root;
5035 40584 : gfc_symtree *new_symtree;
5036 :
5037 : /* Create a new symbol to represent the actual argument. */
5038 40584 : new_sym = gfc_new_symbol (sym->name, NULL);
5039 40584 : new_sym->ts = sym->ts;
5040 40584 : new_sym->as = gfc_copy_array_spec (sym->as);
5041 40584 : new_sym->attr.referenced = 1;
5042 40584 : new_sym->attr.dimension = sym->attr.dimension;
5043 40584 : new_sym->attr.contiguous = sym->attr.contiguous;
5044 40584 : new_sym->attr.codimension = sym->attr.codimension;
5045 40584 : new_sym->attr.pointer = sym->attr.pointer;
5046 40584 : new_sym->attr.allocatable = sym->attr.allocatable;
5047 40584 : new_sym->attr.flavor = sym->attr.flavor;
5048 40584 : new_sym->attr.function = sym->attr.function;
5049 40584 : new_sym->attr.dummy = 0;
5050 :
5051 : /* Ensure that the interface is available and that
5052 : descriptors are passed for array actual arguments. */
5053 40584 : if (sym->attr.flavor == FL_PROCEDURE)
5054 : {
5055 36 : new_sym->formal = expr->symtree->n.sym->formal;
5056 36 : new_sym->attr.always_explicit
5057 36 : = expr->symtree->n.sym->attr.always_explicit;
5058 : }
5059 :
5060 : /* Create a fake symtree for it. */
5061 40584 : root = NULL;
5062 40584 : new_symtree = gfc_new_symtree (&root, sym->name);
5063 40584 : new_symtree->n.sym = new_sym;
5064 40584 : gcc_assert (new_symtree == root);
5065 :
5066 : /* Create a dummy->actual mapping. */
5067 40584 : sm = XCNEW (gfc_interface_sym_mapping);
5068 40584 : sm->next = mapping->syms;
5069 40584 : sm->old = sym;
5070 40584 : sm->new_sym = new_symtree;
5071 40584 : sm->expr = gfc_copy_expr (expr);
5072 40584 : mapping->syms = sm;
5073 :
5074 : /* Stabilize the argument's value. */
5075 40584 : if (!sym->attr.function && se)
5076 40486 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5077 :
5078 40584 : if (sym->ts.type == BT_CHARACTER)
5079 : {
5080 : /* Create a copy of the dummy argument's length. */
5081 2856 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
5082 2856 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
5083 :
5084 : /* If the length is specified as "*", record the length that
5085 : the caller is passing. We should use the callee's length
5086 : in all other cases. */
5087 2856 : if (!new_sym->ts.u.cl->length && se)
5088 : {
5089 2628 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5090 2628 : new_sym->ts.u.cl->backend_decl = se->string_length;
5091 : }
5092 : }
5093 :
5094 40570 : if (!se)
5095 62 : return;
5096 :
5097 : /* Use the passed value as-is if the argument is a function. */
5098 40522 : if (sym->attr.flavor == FL_PROCEDURE)
5099 36 : value = se->expr;
5100 :
5101 : /* If the argument is a pass-by-value scalar, use the value as is. */
5102 40486 : else if (!sym->attr.dimension && sym->attr.value)
5103 78 : value = se->expr;
5104 :
5105 : /* If the argument is either a string or a pointer to a string,
5106 : convert it to a boundless character type. */
5107 40408 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5108 : {
5109 1287 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5110 1287 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5111 1287 : tmp = build_pointer_type (tmp);
5112 1287 : if (sym->attr.pointer)
5113 126 : value = build_fold_indirect_ref_loc (input_location,
5114 : se->expr);
5115 : else
5116 1161 : value = se->expr;
5117 1287 : value = fold_convert (tmp, value);
5118 : }
5119 :
5120 : /* If the argument is a scalar, a pointer to an array or an allocatable,
5121 : dereference it. */
5122 39121 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5123 29230 : value = build_fold_indirect_ref_loc (input_location,
5124 : se->expr);
5125 :
5126 : /* For character(*), use the actual argument's descriptor. */
5127 9891 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5128 1497 : value = build_fold_indirect_ref_loc (input_location,
5129 : se->expr);
5130 :
5131 : /* If the argument is an array descriptor, use it to determine
5132 : information about the actual argument's shape. */
5133 8394 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5134 8394 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5135 : {
5136 8124 : bool assumed_rank_formal = false;
5137 :
5138 : /* Get the actual argument's descriptor. */
5139 8124 : desc = build_fold_indirect_ref_loc (input_location,
5140 : se->expr);
5141 :
5142 : /* Create the replacement variable. */
5143 8124 : if (sym->as && sym->as->type == AS_ASSUMED_RANK
5144 7334 : && !(sym->ns && sym->ns->proc_name
5145 7334 : && sym->ns->proc_name->attr.proc == PROC_INTRINSIC))
5146 : {
5147 : assumed_rank_formal = true;
5148 : tmp = desc;
5149 : }
5150 : else
5151 8111 : tmp = gfc_conv_descriptor_data_get (desc);
5152 :
5153 8124 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5154 : PACKED_NO, tmp,
5155 : se->string_length,
5156 : assumed_rank_formal);
5157 :
5158 : /* Use DESC to work out the upper bounds, strides and offset. */
5159 8124 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5160 : }
5161 : else
5162 : /* Otherwise we have a packed array. */
5163 270 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5164 : PACKED_FULL, se->expr,
5165 : se->string_length,
5166 : false);
5167 :
5168 40522 : new_sym->backend_decl = value;
5169 : }
5170 :
5171 :
5172 : /* Called once all dummy argument mappings have been added to MAPPING,
5173 : but before the mapping is used to evaluate expressions. Pre-evaluate
5174 : the length of each argument, adding any initialization code to PRE and
5175 : any finalization code to POST. */
5176 :
5177 : static void
5178 130541 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5179 : stmtblock_t * pre, stmtblock_t * post)
5180 : {
5181 130541 : gfc_interface_sym_mapping *sym;
5182 130541 : gfc_expr *expr;
5183 130541 : gfc_se se;
5184 :
5185 171063 : for (sym = mapping->syms; sym; sym = sym->next)
5186 40522 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5187 2842 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5188 : {
5189 214 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5190 214 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5191 214 : gfc_init_se (&se, NULL);
5192 214 : gfc_conv_expr (&se, expr);
5193 214 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5194 214 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5195 214 : gfc_add_block_to_block (pre, &se.pre);
5196 214 : gfc_add_block_to_block (post, &se.post);
5197 :
5198 214 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5199 : }
5200 130541 : }
5201 :
5202 :
5203 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5204 : constructor C. */
5205 :
5206 : static void
5207 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5208 : gfc_constructor_base base)
5209 : {
5210 47 : gfc_constructor *c;
5211 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5212 : {
5213 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5214 381 : if (c->iterator)
5215 : {
5216 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5217 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5218 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5219 : }
5220 : }
5221 47 : }
5222 :
5223 :
5224 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5225 : reference REF. */
5226 :
5227 : static void
5228 12585 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5229 : gfc_ref * ref)
5230 : {
5231 12585 : int n;
5232 :
5233 14070 : for (; ref; ref = ref->next)
5234 1485 : switch (ref->type)
5235 : {
5236 : case REF_ARRAY:
5237 2915 : for (n = 0; n < ref->u.ar.dimen; n++)
5238 : {
5239 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5240 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5241 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5242 : }
5243 : break;
5244 :
5245 : case REF_COMPONENT:
5246 : case REF_INQUIRY:
5247 : break;
5248 :
5249 43 : case REF_SUBSTRING:
5250 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5251 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5252 43 : break;
5253 : }
5254 12585 : }
5255 :
5256 :
5257 : /* Convert intrinsic function calls into result expressions. */
5258 :
5259 : static bool
5260 2214 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5261 : {
5262 2214 : gfc_symbol *sym;
5263 2214 : gfc_expr *new_expr;
5264 2214 : gfc_expr *arg1;
5265 2214 : gfc_expr *arg2;
5266 2214 : int d, dup;
5267 :
5268 2214 : arg1 = expr->value.function.actual->expr;
5269 2214 : if (expr->value.function.actual->next)
5270 2093 : arg2 = expr->value.function.actual->next->expr;
5271 : else
5272 : arg2 = NULL;
5273 :
5274 2214 : sym = arg1->symtree->n.sym;
5275 :
5276 2214 : if (sym->attr.dummy)
5277 : return false;
5278 :
5279 2190 : new_expr = NULL;
5280 :
5281 2190 : switch (expr->value.function.isym->id)
5282 : {
5283 929 : case GFC_ISYM_LEN:
5284 : /* TODO figure out why this condition is necessary. */
5285 929 : if (sym->attr.function
5286 43 : && (arg1->ts.u.cl->length == NULL
5287 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5288 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5289 : return false;
5290 :
5291 886 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5292 886 : break;
5293 :
5294 228 : case GFC_ISYM_LEN_TRIM:
5295 228 : new_expr = gfc_copy_expr (arg1);
5296 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5297 :
5298 228 : if (!new_expr)
5299 : return false;
5300 :
5301 228 : gfc_replace_expr (arg1, new_expr);
5302 228 : return true;
5303 :
5304 606 : case GFC_ISYM_SIZE:
5305 606 : if (!sym->as || sym->as->rank == 0)
5306 : return false;
5307 :
5308 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5309 : {
5310 360 : dup = mpz_get_si (arg2->value.integer);
5311 360 : d = dup - 1;
5312 : }
5313 : else
5314 : {
5315 530 : dup = sym->as->rank;
5316 530 : d = 0;
5317 : }
5318 :
5319 542 : for (; d < dup; d++)
5320 : {
5321 530 : gfc_expr *tmp;
5322 :
5323 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5324 : {
5325 518 : gfc_free_expr (new_expr);
5326 518 : return false;
5327 : }
5328 :
5329 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5330 : gfc_get_int_expr (gfc_default_integer_kind,
5331 : NULL, 1));
5332 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5333 12 : if (new_expr)
5334 0 : new_expr = gfc_multiply (new_expr, tmp);
5335 : else
5336 : new_expr = tmp;
5337 : }
5338 : break;
5339 :
5340 44 : case GFC_ISYM_LBOUND:
5341 44 : case GFC_ISYM_UBOUND:
5342 : /* TODO These implementations of lbound and ubound do not limit if
5343 : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5344 :
5345 44 : if (!sym->as || sym->as->rank == 0)
5346 : return false;
5347 :
5348 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5349 38 : d = mpz_get_si (arg2->value.integer) - 1;
5350 : else
5351 : return false;
5352 :
5353 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5354 : {
5355 23 : if (sym->as->lower[d])
5356 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5357 : }
5358 : else
5359 : {
5360 15 : if (sym->as->upper[d])
5361 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5362 : }
5363 : break;
5364 :
5365 : default:
5366 : break;
5367 : }
5368 :
5369 1319 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5370 1319 : if (!new_expr)
5371 : return false;
5372 :
5373 113 : gfc_replace_expr (expr, new_expr);
5374 113 : return true;
5375 : }
5376 :
5377 :
5378 : static void
5379 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5380 : gfc_interface_mapping * mapping)
5381 : {
5382 24 : gfc_formal_arglist *f;
5383 24 : gfc_actual_arglist *actual;
5384 :
5385 24 : actual = expr->value.function.actual;
5386 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5387 :
5388 72 : for (; f && actual; f = f->next, actual = actual->next)
5389 : {
5390 24 : if (!actual->expr)
5391 0 : continue;
5392 :
5393 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5394 : }
5395 :
5396 24 : if (map_expr->symtree->n.sym->attr.dimension)
5397 : {
5398 6 : int d;
5399 6 : gfc_array_spec *as;
5400 :
5401 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5402 :
5403 18 : for (d = 0; d < as->rank; d++)
5404 : {
5405 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5406 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5407 : }
5408 :
5409 6 : expr->value.function.esym->as = as;
5410 : }
5411 :
5412 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5413 : {
5414 0 : expr->value.function.esym->ts.u.cl->length
5415 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5416 :
5417 0 : gfc_apply_interface_mapping_to_expr (mapping,
5418 0 : expr->value.function.esym->ts.u.cl->length);
5419 : }
5420 24 : }
5421 :
5422 :
5423 : /* EXPR is a copy of an expression that appeared in the interface
5424 : associated with MAPPING. Walk it recursively looking for references to
5425 : dummy arguments that MAPPING maps to actual arguments. Replace each such
5426 : reference with a reference to the associated actual argument. */
5427 :
5428 : static void
5429 21118 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5430 : gfc_expr * expr)
5431 : {
5432 22683 : gfc_interface_sym_mapping *sym;
5433 22683 : gfc_actual_arglist *actual;
5434 :
5435 22683 : if (!expr)
5436 : return;
5437 :
5438 : /* Copying an expression does not copy its length, so do that here. */
5439 12585 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5440 : {
5441 1784 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5442 1784 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5443 : }
5444 :
5445 : /* Apply the mapping to any references. */
5446 12585 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5447 :
5448 : /* ...and to the expression's symbol, if it has one. */
5449 : /* TODO Find out why the condition on expr->symtree had to be moved into
5450 : the loop rather than being outside it, as originally. */
5451 29942 : for (sym = mapping->syms; sym; sym = sym->next)
5452 17357 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5453 : {
5454 3370 : if (sym->new_sym->n.sym->backend_decl)
5455 3326 : expr->symtree = sym->new_sym;
5456 44 : else if (sym->expr)
5457 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5458 : }
5459 :
5460 : /* ...and to subexpressions in expr->value. */
5461 12585 : switch (expr->expr_type)
5462 : {
5463 : case EXPR_VARIABLE:
5464 : case EXPR_CONSTANT:
5465 : case EXPR_NULL:
5466 : case EXPR_SUBSTRING:
5467 : break;
5468 :
5469 1565 : case EXPR_OP:
5470 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5471 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5472 1565 : break;
5473 :
5474 0 : case EXPR_CONDITIONAL:
5475 0 : gfc_apply_interface_mapping_to_expr (mapping,
5476 0 : expr->value.conditional.true_expr);
5477 0 : gfc_apply_interface_mapping_to_expr (mapping,
5478 0 : expr->value.conditional.false_expr);
5479 0 : break;
5480 :
5481 2957 : case EXPR_FUNCTION:
5482 9502 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5483 6545 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5484 :
5485 2957 : if (expr->value.function.esym == NULL
5486 2644 : && expr->value.function.isym != NULL
5487 2632 : && expr->value.function.actual
5488 2631 : && expr->value.function.actual->expr
5489 2631 : && expr->value.function.actual->expr->symtree
5490 5171 : && gfc_map_intrinsic_function (expr, mapping))
5491 : break;
5492 :
5493 6154 : for (sym = mapping->syms; sym; sym = sym->next)
5494 3538 : if (sym->old == expr->value.function.esym)
5495 : {
5496 24 : expr->value.function.esym = sym->new_sym->n.sym;
5497 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5498 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5499 : }
5500 : break;
5501 :
5502 47 : case EXPR_ARRAY:
5503 47 : case EXPR_STRUCTURE:
5504 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5505 47 : break;
5506 :
5507 0 : case EXPR_COMPCALL:
5508 0 : case EXPR_PPC:
5509 0 : case EXPR_UNKNOWN:
5510 0 : gcc_unreachable ();
5511 : break;
5512 : }
5513 :
5514 : return;
5515 : }
5516 :
5517 :
5518 : /* Evaluate interface expression EXPR using MAPPING. Store the result
5519 : in SE. */
5520 :
5521 : void
5522 4016 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5523 : gfc_se * se, gfc_expr * expr)
5524 : {
5525 4016 : expr = gfc_copy_expr (expr);
5526 4016 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5527 4016 : gfc_conv_expr (se, expr);
5528 4016 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5529 4016 : gfc_free_expr (expr);
5530 4016 : }
5531 :
5532 :
5533 : /* Returns a reference to a temporary array into which a component of
5534 : an actual argument derived type array is copied and then returned
5535 : after the function call. */
5536 : void
5537 2601 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5538 : sym_intent intent, bool formal_ptr,
5539 : const gfc_symbol *fsym, const char *proc_name,
5540 : gfc_symbol *sym, bool check_contiguous)
5541 : {
5542 2601 : gfc_se lse;
5543 2601 : gfc_se rse;
5544 2601 : gfc_ss *lss;
5545 2601 : gfc_ss *rss;
5546 2601 : gfc_loopinfo loop;
5547 2601 : gfc_loopinfo loop2;
5548 2601 : gfc_array_info *info;
5549 2601 : tree offset;
5550 2601 : tree tmp_index;
5551 2601 : tree tmp;
5552 2601 : tree base_type;
5553 2601 : tree size;
5554 2601 : stmtblock_t body;
5555 2601 : int n;
5556 2601 : int dimen;
5557 2601 : gfc_se work_se;
5558 2601 : gfc_se *parmse;
5559 2601 : bool pass_optional;
5560 2601 : bool readonly;
5561 :
5562 2601 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5563 :
5564 2590 : if (pass_optional || check_contiguous)
5565 : {
5566 1348 : gfc_init_se (&work_se, NULL);
5567 1348 : parmse = &work_se;
5568 : }
5569 : else
5570 : parmse = se;
5571 :
5572 2601 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5573 : {
5574 : /* We will create a temporary array, so let us warn. */
5575 868 : char * msg;
5576 :
5577 868 : if (fsym && proc_name)
5578 868 : msg = xasprintf ("An array temporary was created for argument "
5579 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5580 : else
5581 0 : msg = xasprintf ("An array temporary was created");
5582 :
5583 868 : tmp = build_int_cst (logical_type_node, 1);
5584 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5585 : &expr->where, msg);
5586 868 : free (msg);
5587 : }
5588 :
5589 2601 : gfc_init_se (&lse, NULL);
5590 2601 : gfc_init_se (&rse, NULL);
5591 :
5592 : /* Walk the argument expression. */
5593 2601 : rss = gfc_walk_expr (expr);
5594 :
5595 2601 : gcc_assert (rss != gfc_ss_terminator);
5596 :
5597 : /* Initialize the scalarizer. */
5598 2601 : gfc_init_loopinfo (&loop);
5599 2601 : gfc_add_ss_to_loop (&loop, rss);
5600 :
5601 : /* Calculate the bounds of the scalarization. */
5602 2601 : gfc_conv_ss_startstride (&loop);
5603 :
5604 : /* Build an ss for the temporary. */
5605 2601 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5606 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5607 :
5608 2601 : base_type = gfc_typenode_for_spec (&expr->ts);
5609 2601 : if (GFC_ARRAY_TYPE_P (base_type)
5610 2601 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5611 0 : base_type = gfc_get_element_type (base_type);
5612 :
5613 2601 : if (expr->ts.type == BT_CLASS)
5614 121 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5615 :
5616 3765 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5617 1164 : ? expr->ts.u.cl->backend_decl
5618 : : NULL),
5619 : loop.dimen);
5620 :
5621 2601 : parmse->string_length = loop.temp_ss->info->string_length;
5622 :
5623 : /* Associate the SS with the loop. */
5624 2601 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5625 :
5626 : /* Setup the scalarizing loops. */
5627 2601 : gfc_conv_loop_setup (&loop, &expr->where);
5628 :
5629 : /* Pass the temporary descriptor back to the caller. */
5630 2601 : info = &loop.temp_ss->info->data.array;
5631 2601 : parmse->expr = info->descriptor;
5632 :
5633 : /* Setup the gfc_se structures. */
5634 2601 : gfc_copy_loopinfo_to_se (&lse, &loop);
5635 2601 : gfc_copy_loopinfo_to_se (&rse, &loop);
5636 :
5637 2601 : rse.ss = rss;
5638 2601 : lse.ss = loop.temp_ss;
5639 2601 : gfc_mark_ss_chain_used (rss, 1);
5640 2601 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5641 :
5642 : /* Start the scalarized loop body. */
5643 2601 : gfc_start_scalarized_body (&loop, &body);
5644 :
5645 : /* Translate the expression. */
5646 2601 : gfc_conv_expr (&rse, expr);
5647 :
5648 2601 : gfc_conv_tmp_array_ref (&lse);
5649 :
5650 2601 : if (intent != INTENT_OUT)
5651 : {
5652 2563 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5653 2563 : gfc_add_expr_to_block (&body, tmp);
5654 2563 : gcc_assert (rse.ss == gfc_ss_terminator);
5655 2563 : gfc_trans_scalarizing_loops (&loop, &body);
5656 : }
5657 : else
5658 : {
5659 : /* Make sure that the temporary declaration survives by merging
5660 : all the loop declarations into the current context. */
5661 85 : for (n = 0; n < loop.dimen; n++)
5662 : {
5663 47 : gfc_merge_block_scope (&body);
5664 47 : body = loop.code[loop.order[n]];
5665 : }
5666 38 : gfc_merge_block_scope (&body);
5667 : }
5668 :
5669 : /* Add the post block after the second loop, so that any
5670 : freeing of allocated memory is done at the right time. */
5671 2601 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5672 :
5673 : /**********Copy the temporary back again.*********/
5674 :
5675 2601 : gfc_init_se (&lse, NULL);
5676 2601 : gfc_init_se (&rse, NULL);
5677 :
5678 : /* Walk the argument expression. */
5679 2601 : lss = gfc_walk_expr (expr);
5680 2601 : rse.ss = loop.temp_ss;
5681 2601 : lse.ss = lss;
5682 :
5683 : /* Initialize the scalarizer. */
5684 2601 : gfc_init_loopinfo (&loop2);
5685 2601 : gfc_add_ss_to_loop (&loop2, lss);
5686 :
5687 2601 : dimen = rse.ss->dimen;
5688 :
5689 : /* Skip the write-out loop for this case. */
5690 2601 : if (gfc_is_class_array_function (expr))
5691 13 : goto class_array_fcn;
5692 :
5693 : /* Calculate the bounds of the scalarization. */
5694 2588 : gfc_conv_ss_startstride (&loop2);
5695 :
5696 : /* Setup the scalarizing loops. */
5697 2588 : gfc_conv_loop_setup (&loop2, &expr->where);
5698 :
5699 2588 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5700 2588 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5701 :
5702 2588 : gfc_mark_ss_chain_used (lss, 1);
5703 2588 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5704 :
5705 : /* Declare the variable to hold the temporary offset and start the
5706 : scalarized loop body. */
5707 2588 : offset = gfc_create_var (gfc_array_index_type, NULL);
5708 2588 : gfc_start_scalarized_body (&loop2, &body);
5709 :
5710 : /* Build the offsets for the temporary from the loop variables. The
5711 : temporary array has lbounds of zero and strides of one in all
5712 : dimensions, so this is very simple. The offset is only computed
5713 : outside the innermost loop, so the overall transfer could be
5714 : optimized further. */
5715 2588 : info = &rse.ss->info->data.array;
5716 :
5717 2588 : tmp_index = gfc_index_zero_node;
5718 3929 : for (n = dimen - 1; n > 0; n--)
5719 : {
5720 1341 : tree tmp_str;
5721 1341 : tmp = rse.loop->loopvar[n];
5722 1341 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5723 : tmp, rse.loop->from[n]);
5724 1341 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5725 : tmp, tmp_index);
5726 :
5727 2682 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5728 : gfc_array_index_type,
5729 1341 : rse.loop->to[n-1], rse.loop->from[n-1]);
5730 1341 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5731 : gfc_array_index_type,
5732 : tmp_str, gfc_index_one_node);
5733 :
5734 1341 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5735 : gfc_array_index_type, tmp, tmp_str);
5736 : }
5737 :
5738 5176 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5739 : gfc_array_index_type,
5740 2588 : tmp_index, rse.loop->from[0]);
5741 2588 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5742 :
5743 5176 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5744 : gfc_array_index_type,
5745 2588 : rse.loop->loopvar[0], offset);
5746 :
5747 : /* Now use the offset for the reference. */
5748 2588 : tmp = build_fold_indirect_ref_loc (input_location,
5749 : info->data);
5750 2588 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5751 :
5752 2588 : if (expr->ts.type == BT_CHARACTER)
5753 1164 : rse.string_length = expr->ts.u.cl->backend_decl;
5754 :
5755 2588 : gfc_conv_expr (&lse, expr);
5756 :
5757 2588 : gcc_assert (lse.ss == gfc_ss_terminator);
5758 :
5759 : /* Do not do deallocations when we are looking at a g77-style argument. */
5760 :
5761 2588 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, !g77);
5762 2588 : gfc_add_expr_to_block (&body, tmp);
5763 :
5764 : /* Generate the copying loops. */
5765 2588 : gfc_trans_scalarizing_loops (&loop2, &body);
5766 :
5767 : /* Wrap the whole thing up by adding the second loop to the post-block
5768 : and following it by the post-block of the first loop. In this way,
5769 : if the temporary needs freeing, it is done after use!
5770 : If input expr is read-only, e.g. a PARAMETER array, copying back
5771 : modified values is undefined behavior. */
5772 5176 : readonly = (expr->expr_type == EXPR_VARIABLE
5773 2534 : && expr->symtree
5774 5122 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5775 :
5776 2588 : if ((intent != INTENT_IN) && !readonly)
5777 : {
5778 1155 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5779 1155 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5780 : }
5781 :
5782 1433 : class_array_fcn:
5783 :
5784 2601 : gfc_add_block_to_block (&parmse->post, &loop.post);
5785 :
5786 2601 : gfc_cleanup_loop (&loop);
5787 2601 : gfc_cleanup_loop (&loop2);
5788 :
5789 : /* Pass the string length to the argument expression. */
5790 2601 : if (expr->ts.type == BT_CHARACTER)
5791 1164 : parmse->string_length = expr->ts.u.cl->backend_decl;
5792 :
5793 : /* Determine the offset for pointer formal arguments and set the
5794 : lbounds to one. */
5795 2601 : if (formal_ptr)
5796 : {
5797 18 : size = gfc_index_one_node;
5798 18 : offset = gfc_index_zero_node;
5799 36 : for (n = 0; n < dimen; n++)
5800 : {
5801 18 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5802 : gfc_rank_cst[n]);
5803 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5804 : gfc_array_index_type, tmp,
5805 : gfc_index_one_node);
5806 18 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5807 : parmse->expr,
5808 : gfc_rank_cst[n],
5809 : tmp);
5810 18 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5811 : parmse->expr,
5812 : gfc_rank_cst[n],
5813 : gfc_index_one_node);
5814 18 : size = gfc_evaluate_now (size, &parmse->pre);
5815 18 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5816 : gfc_array_index_type,
5817 : offset, size);
5818 18 : offset = gfc_evaluate_now (offset, &parmse->pre);
5819 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5820 : gfc_array_index_type,
5821 18 : rse.loop->to[n], rse.loop->from[n]);
5822 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5823 : gfc_array_index_type,
5824 : tmp, gfc_index_one_node);
5825 18 : size = fold_build2_loc (input_location, MULT_EXPR,
5826 : gfc_array_index_type, size, tmp);
5827 : }
5828 :
5829 18 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5830 : offset);
5831 : }
5832 :
5833 : /* We want either the address for the data or the address of the descriptor,
5834 : depending on the mode of passing array arguments. */
5835 2601 : if (g77)
5836 426 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5837 : else
5838 2175 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5839 :
5840 : /* Basically make this into
5841 :
5842 : if (present)
5843 : {
5844 : if (contiguous)
5845 : {
5846 : pointer = a;
5847 : }
5848 : else
5849 : {
5850 : parmse->pre();
5851 : pointer = parmse->expr;
5852 : }
5853 : }
5854 : else
5855 : pointer = NULL;
5856 :
5857 : foo (pointer);
5858 : if (present && !contiguous)
5859 : se->post();
5860 :
5861 : */
5862 :
5863 2601 : if (pass_optional || check_contiguous)
5864 : {
5865 1348 : tree type;
5866 1348 : stmtblock_t else_block;
5867 1348 : tree pre_stmts, post_stmts;
5868 1348 : tree pointer;
5869 1348 : tree else_stmt;
5870 1348 : tree present_var = NULL_TREE;
5871 1348 : tree cont_var = NULL_TREE;
5872 1348 : tree post_cond;
5873 :
5874 1348 : type = TREE_TYPE (parmse->expr);
5875 1348 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5876 1027 : type = TREE_TYPE (type);
5877 1348 : pointer = gfc_create_var (type, "arg_ptr");
5878 :
5879 1348 : if (check_contiguous)
5880 : {
5881 1348 : gfc_se cont_se, array_se;
5882 1348 : stmtblock_t if_block, else_block;
5883 1348 : tree if_stmt, else_stmt;
5884 1348 : mpz_t size;
5885 1348 : bool size_set;
5886 :
5887 1348 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5888 :
5889 : /* If the size is known to be one at compile-time, set
5890 : cont_var to true unconditionally. This may look
5891 : inelegant, but we're only doing this during
5892 : optimization, so the statements will be optimized away,
5893 : and this saves complexity here. */
5894 :
5895 1348 : size_set = gfc_array_size (expr, &size);
5896 1348 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5897 : {
5898 6 : gfc_add_modify (&se->pre, cont_var,
5899 : build_one_cst (boolean_type_node));
5900 : }
5901 : else
5902 : {
5903 : /* cont_var = is_contiguous (expr); . */
5904 1342 : gfc_init_se (&cont_se, parmse);
5905 1342 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5906 1342 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5907 1342 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5908 1342 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5909 : }
5910 :
5911 1348 : if (size_set)
5912 1149 : mpz_clear (size);
5913 :
5914 : /* arrayse->expr = descriptor of a. */
5915 1348 : gfc_init_se (&array_se, se);
5916 1348 : gfc_conv_expr_descriptor (&array_se, expr);
5917 1348 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5918 1348 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5919 :
5920 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5921 1348 : gfc_init_block (&if_block);
5922 1348 : if (GFC_DESCRIPTOR_TYPE_P (type))
5923 1027 : gfc_add_modify (&if_block, pointer, array_se.expr);
5924 : else
5925 : {
5926 321 : tmp = gfc_conv_array_data (array_se.expr);
5927 321 : tmp = fold_convert (type, tmp);
5928 321 : gfc_add_modify (&if_block, pointer, tmp);
5929 : }
5930 1348 : if_stmt = gfc_finish_block (&if_block);
5931 :
5932 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5933 1348 : gfc_init_block (&else_block);
5934 1348 : gfc_add_block_to_block (&else_block, &parmse->pre);
5935 1669 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5936 1348 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5937 : : parmse->expr);
5938 1348 : gfc_add_modify (&else_block, pointer, tmp);
5939 1348 : else_stmt = gfc_finish_block (&else_block);
5940 :
5941 : /* And put the above into an if statement. */
5942 1348 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5943 : gfc_likely (cont_var,
5944 : PRED_FORTRAN_CONTIGUOUS),
5945 : if_stmt, else_stmt);
5946 : }
5947 : else
5948 : {
5949 : /* pointer = pramse->expr; . */
5950 0 : gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5951 0 : pre_stmts = gfc_finish_block (&parmse->pre);
5952 : }
5953 :
5954 1348 : if (pass_optional)
5955 : {
5956 11 : present_var = gfc_create_var (boolean_type_node, "present");
5957 :
5958 : /* present_var = present(sym); . */
5959 11 : tmp = gfc_conv_expr_present (sym);
5960 11 : tmp = fold_convert (boolean_type_node, tmp);
5961 11 : gfc_add_modify (&se->pre, present_var, tmp);
5962 :
5963 : /* else_stmt = { pointer = NULL; } . */
5964 11 : gfc_init_block (&else_block);
5965 11 : if (GFC_DESCRIPTOR_TYPE_P (type))
5966 0 : gfc_conv_descriptor_data_set (&else_block, pointer,
5967 : null_pointer_node);
5968 : else
5969 11 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5970 11 : else_stmt = gfc_finish_block (&else_block);
5971 :
5972 11 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5973 : gfc_likely (present_var,
5974 : PRED_FORTRAN_ABSENT_DUMMY),
5975 : pre_stmts, else_stmt);
5976 11 : gfc_add_expr_to_block (&se->pre, tmp);
5977 : }
5978 : else
5979 1337 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5980 :
5981 1348 : post_stmts = gfc_finish_block (&parmse->post);
5982 :
5983 : /* Put together the post stuff, plus the optional
5984 : deallocation. */
5985 1348 : if (check_contiguous)
5986 : {
5987 : /* !cont_var. */
5988 1348 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5989 : cont_var,
5990 : build_zero_cst (boolean_type_node));
5991 1348 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5992 :
5993 1348 : if (pass_optional)
5994 : {
5995 11 : tree present_likely = gfc_likely (present_var,
5996 : PRED_FORTRAN_ABSENT_DUMMY);
5997 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5998 : boolean_type_node, present_likely,
5999 : tmp);
6000 : }
6001 : else
6002 : post_cond = tmp;
6003 : }
6004 : else
6005 : {
6006 0 : gcc_assert (pass_optional);
6007 : post_cond = present_var;
6008 : }
6009 :
6010 1348 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
6011 : post_stmts, build_empty_stmt (input_location));
6012 1348 : gfc_add_expr_to_block (&se->post, tmp);
6013 1348 : if (GFC_DESCRIPTOR_TYPE_P (type))
6014 : {
6015 1027 : type = TREE_TYPE (parmse->expr);
6016 1027 : if (POINTER_TYPE_P (type))
6017 : {
6018 1027 : pointer = gfc_build_addr_expr (type, pointer);
6019 1027 : if (pass_optional)
6020 : {
6021 0 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
6022 0 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
6023 : tmp, pointer,
6024 : fold_convert (type,
6025 : null_pointer_node));
6026 : }
6027 : }
6028 : else
6029 0 : gcc_assert (!pass_optional);
6030 : }
6031 1348 : se->expr = pointer;
6032 : }
6033 :
6034 2601 : return;
6035 : }
6036 :
6037 :
6038 : /* Generate the code for argument list functions. */
6039 :
6040 : static void
6041 5826 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
6042 : {
6043 : /* Pass by value for g77 %VAL(arg), pass the address
6044 : indirectly for %LOC, else by reference. Thus %REF
6045 : is a "do-nothing" and %LOC is the same as an F95
6046 : pointer. */
6047 5826 : if (strcmp (name, "%VAL") == 0)
6048 5814 : gfc_conv_expr (se, expr);
6049 12 : else if (strcmp (name, "%LOC") == 0)
6050 : {
6051 6 : gfc_conv_expr_reference (se, expr);
6052 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
6053 : }
6054 6 : else if (strcmp (name, "%REF") == 0)
6055 6 : gfc_conv_expr_reference (se, expr);
6056 : else
6057 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
6058 5826 : }
6059 :
6060 :
6061 : /* This function tells whether the middle-end representation of the expression
6062 : E given as input may point to data otherwise accessible through a variable
6063 : (sub-)reference.
6064 : It is assumed that the only expressions that may alias are variables,
6065 : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
6066 : may alias.
6067 : This function is used to decide whether freeing an expression's allocatable
6068 : components is safe or should be avoided.
6069 :
6070 : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
6071 : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
6072 : is necessary because for array constructors, aliasing depends on how
6073 : the array is used:
6074 : - If E is an array constructor used as argument to an elemental procedure,
6075 : the array, which is generated through shallow copy by the scalarizer,
6076 : is used directly and can alias the expressions it was copied from.
6077 : - If E is an array constructor used as argument to a non-elemental
6078 : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
6079 : the array as in the previous case, but then that array is used
6080 : to initialize a new descriptor through deep copy. There is no alias
6081 : possible in that case.
6082 : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
6083 : above. */
6084 :
6085 : static bool
6086 7630 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6087 : {
6088 7630 : gfc_constructor *c;
6089 :
6090 7630 : if (e->expr_type == EXPR_VARIABLE)
6091 : return true;
6092 562 : else if (e->expr_type == EXPR_FUNCTION)
6093 : {
6094 161 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
6095 :
6096 161 : if (proc_ifc->result != NULL
6097 161 : && ((proc_ifc->result->ts.type == BT_CLASS
6098 25 : && proc_ifc->result->ts.u.derived->attr.is_class
6099 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
6100 161 : || proc_ifc->result->attr.pointer))
6101 : return true;
6102 : else
6103 : return false;
6104 : }
6105 401 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6106 : return false;
6107 :
6108 79 : for (c = gfc_constructor_first (e->value.constructor);
6109 233 : c; c = gfc_constructor_next (c))
6110 189 : if (c->expr
6111 189 : && expr_may_alias_variables (c->expr, array_may_alias))
6112 : return true;
6113 :
6114 : return false;
6115 : }
6116 :
6117 :
6118 : /* A helper function to set the dtype for unallocated or unassociated
6119 : entities. */
6120 :
6121 : static void
6122 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6123 : {
6124 891 : tree tmp;
6125 891 : tree desc;
6126 891 : tree cond;
6127 891 : tree type;
6128 891 : stmtblock_t block;
6129 :
6130 : /* TODO Figure out how to handle optional dummies. */
6131 891 : if (e && e->expr_type == EXPR_VARIABLE
6132 807 : && e->symtree->n.sym->attr.optional)
6133 108 : return;
6134 :
6135 819 : desc = parmse->expr;
6136 819 : if (desc == NULL_TREE)
6137 : return;
6138 :
6139 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6140 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6141 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6142 192 : desc = gfc_class_data_get (desc);
6143 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6144 : return;
6145 :
6146 783 : gfc_init_block (&block);
6147 783 : tmp = gfc_conv_descriptor_data_get (desc);
6148 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6149 : logical_type_node, tmp,
6150 783 : build_int_cst (TREE_TYPE (tmp), 0));
6151 783 : tmp = gfc_conv_descriptor_dtype (desc);
6152 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6153 1566 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6154 783 : TREE_TYPE (tmp), tmp,
6155 : gfc_get_dtype_rank_type (e->rank, type));
6156 783 : gfc_add_expr_to_block (&block, tmp);
6157 783 : cond = build3_v (COND_EXPR, cond,
6158 : gfc_finish_block (&block),
6159 : build_empty_stmt (input_location));
6160 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6161 : }
6162 :
6163 :
6164 :
6165 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6166 : ISO_Fortran_binding array descriptors. */
6167 :
6168 : static void
6169 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6170 : {
6171 6537 : stmtblock_t block, block2;
6172 6537 : tree cfi, gfc, tmp, tmp2;
6173 6537 : tree present = NULL;
6174 6537 : tree gfc_strlen = NULL;
6175 6537 : tree rank;
6176 6537 : gfc_se se;
6177 :
6178 6537 : if (fsym->attr.optional
6179 1094 : && e->expr_type == EXPR_VARIABLE
6180 1094 : && e->symtree->n.sym->attr.optional)
6181 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6182 :
6183 6537 : gfc_init_block (&block);
6184 :
6185 : /* Convert original argument to a tree. */
6186 6537 : gfc_init_se (&se, NULL);
6187 6537 : if (e->rank == 0)
6188 : {
6189 687 : se.want_pointer = 1;
6190 687 : gfc_conv_expr (&se, e);
6191 687 : gfc = se.expr;
6192 : }
6193 : else
6194 : {
6195 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6196 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6197 : length assumed-length/assumed-size CHARACTER array. This only
6198 : applies if the actual argument is a "variable"; if it's some
6199 : non-lvalue expression, we are going to evaluate it to a
6200 : temporary below anyway. */
6201 5850 : se.force_no_tmp = 1;
6202 5850 : if ((fsym->attr.contiguous
6203 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6204 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6205 937 : || fsym->as->type == AS_EXPLICIT)))
6206 2023 : && !gfc_is_simply_contiguous (e, false, true)
6207 6883 : && gfc_expr_is_variable (e))
6208 : {
6209 1027 : bool optional = fsym->attr.optional;
6210 1027 : fsym->attr.optional = 0;
6211 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6212 1027 : fsym->attr.pointer, fsym,
6213 1027 : fsym->ns->proc_name->name, NULL,
6214 : /* check_contiguous= */ true);
6215 1027 : fsym->attr.optional = optional;
6216 : }
6217 : else
6218 4823 : gfc_conv_expr_descriptor (&se, e);
6219 5850 : gfc = se.expr;
6220 : /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
6221 : elem_len = sizeof(dt) and base_addr = dt(lb) instead.
6222 : gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
6223 : While sm is fine as it uses span*stride and not elem_len. */
6224 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6225 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6226 4823 : else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
6227 12 : gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
6228 : }
6229 6537 : if (e->ts.type == BT_CHARACTER)
6230 : {
6231 3409 : if (se.string_length)
6232 : gfc_strlen = se.string_length;
6233 883 : else if (e->ts.u.cl->backend_decl)
6234 : gfc_strlen = e->ts.u.cl->backend_decl;
6235 : else
6236 0 : gcc_unreachable ();
6237 : }
6238 6537 : gfc_add_block_to_block (&block, &se.pre);
6239 :
6240 : /* Create array descriptor and set version, rank, attribute, type. */
6241 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6242 : ? GFC_MAX_DIMENSIONS : e->rank,
6243 : false), "cfi");
6244 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6245 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6246 : {
6247 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6248 2338 : tmp = build_pointer_type (tmp);
6249 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6250 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6251 : }
6252 : else
6253 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6254 :
6255 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6256 6537 : gfc_add_modify (&block, tmp,
6257 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6258 6537 : if (e->rank < 0)
6259 305 : rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
6260 : else
6261 6232 : rank = build_int_cst (signed_char_type_node, e->rank);
6262 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6263 6537 : gfc_add_modify (&block, tmp, rank);
6264 6537 : int itype = CFI_type_other;
6265 6537 : if (e->ts.f90_type == BT_VOID)
6266 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6267 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6268 : else
6269 : {
6270 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6271 1 : e->ts = fsym->ts;
6272 6441 : switch (e->ts.type)
6273 : {
6274 2296 : case BT_INTEGER:
6275 2296 : case BT_LOGICAL:
6276 2296 : case BT_REAL:
6277 2296 : case BT_COMPLEX:
6278 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6279 2296 : break;
6280 3410 : case BT_CHARACTER:
6281 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6282 3410 : break;
6283 : case BT_DERIVED:
6284 6537 : itype = CFI_type_struct;
6285 : break;
6286 0 : case BT_VOID:
6287 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6288 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6289 : break;
6290 : case BT_ASSUMED:
6291 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6292 : break;
6293 1 : case BT_CLASS:
6294 1 : if (fsym->ts.type == BT_ASSUMED)
6295 : {
6296 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6297 : // type specifier is assumed-type and is an unlimited polymorphic
6298 : // entity." The actual argument _data component is passed.
6299 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6300 : break;
6301 : }
6302 : else
6303 0 : gcc_unreachable ();
6304 :
6305 0 : case BT_UNSIGNED:
6306 0 : gfc_internal_error ("Unsigned not yet implemented");
6307 :
6308 0 : case BT_PROCEDURE:
6309 0 : case BT_HOLLERITH:
6310 0 : case BT_UNION:
6311 0 : case BT_BOZ:
6312 0 : case BT_UNKNOWN:
6313 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6314 0 : gcc_unreachable ();
6315 : }
6316 : }
6317 :
6318 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6319 6537 : gfc_add_modify (&block, tmp,
6320 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6321 :
6322 6537 : int attr = CFI_attribute_other;
6323 6537 : if (fsym->attr.pointer)
6324 : attr = CFI_attribute_pointer;
6325 5774 : else if (fsym->attr.allocatable)
6326 433 : attr = CFI_attribute_allocatable;
6327 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6328 6537 : gfc_add_modify (&block, tmp,
6329 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6330 :
6331 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6332 : That is very sensible for undefined pointers, but the C code might assume
6333 : that the pointer retains the value, in particular, if it was NULL. */
6334 6537 : if (e->rank == 0)
6335 : {
6336 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6337 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6338 : }
6339 : else
6340 : {
6341 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6342 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6343 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6344 : }
6345 :
6346 : /* Set elem_len if known - must be before the next if block.
6347 : Note that allocatable implies 'len=:'. */
6348 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6349 : {
6350 : /* Length is known at compile time; use 'block' for it. */
6351 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6352 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6353 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6354 : }
6355 :
6356 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6357 91 : goto done;
6358 :
6359 : /* When allocatable + intent out, free the cfi descriptor. */
6360 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6361 : {
6362 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6363 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6364 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6365 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6366 90 : gfc_add_modify (&block, tmp,
6367 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6368 90 : goto done;
6369 : }
6370 :
6371 : /* If not unallocated/unassociated. */
6372 6356 : gfc_init_block (&block2);
6373 :
6374 : /* Set elem_len, which may be only known at run time. */
6375 6356 : if (e->ts.type == BT_CHARACTER
6376 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6377 : {
6378 3408 : gcc_assert (gfc_strlen);
6379 3409 : tmp = gfc_strlen;
6380 3409 : if (e->ts.kind != 1)
6381 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6382 : gfc_charlen_type_node, tmp,
6383 : build_int_cst (gfc_charlen_type_node,
6384 1117 : e->ts.kind));
6385 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6386 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6387 : }
6388 2947 : else if (e->ts.type == BT_ASSUMED)
6389 : {
6390 54 : tmp = gfc_conv_descriptor_elem_len (gfc);
6391 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6392 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6393 : }
6394 :
6395 6356 : if (e->ts.type == BT_ASSUMED)
6396 : {
6397 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6398 : an CFI descriptor. Use the type in the descriptor as it provide
6399 : mode information. (Quality of implementation feature.) */
6400 54 : tree cond;
6401 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6402 54 : tree type = fold_convert (TREE_TYPE (ctype),
6403 : gfc_conv_descriptor_type (gfc));
6404 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6405 : gfc_conv_descriptor_elem_len (gfc));
6406 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6407 54 : kind, build_int_cst (TREE_TYPE (type),
6408 : CFI_type_kind_shift));
6409 :
6410 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6411 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6412 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6413 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6414 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6415 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6416 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6417 : ctype,
6418 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6419 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6420 : tmp, tmp2);
6421 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6422 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6423 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6424 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6425 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6426 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6427 : tmp, tmp2);
6428 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6429 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6430 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6431 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6432 54 : tmp = build_int_cst (TREE_TYPE (type),
6433 : CFI_type_from_type_kind (CFI_type_Character, 1));
6434 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6435 : ctype, tmp);
6436 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6437 : tmp, tmp2);
6438 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6439 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6440 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6441 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6442 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6443 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6444 54 : build_int_cst (TREE_TYPE (type),
6445 : CFI_type_Complex));
6446 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6447 : ctype, tmp);
6448 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6449 : tmp, tmp2);
6450 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6451 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6452 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6453 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6454 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6455 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6456 : cond, tmp);
6457 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6458 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6459 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6460 : cond, tmp);
6461 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6462 : type, kind);
6463 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6464 : ctype, tmp);
6465 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6466 : tmp, tmp2);
6467 54 : gfc_add_expr_to_block (&block2, tmp2);
6468 : }
6469 :
6470 6356 : if (e->rank != 0)
6471 : {
6472 : /* Loop: for (i = 0; i < rank; ++i). */
6473 5735 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6474 : /* Loop body. */
6475 5735 : stmtblock_t loop_body;
6476 5735 : gfc_init_block (&loop_body);
6477 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6478 : ? gfc->dim[i].lbound : 0 */
6479 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6480 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6481 : else
6482 5087 : tmp = gfc_index_zero_node;
6483 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6484 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6485 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6486 : gfc_conv_descriptor_ubound_get (gfc, idx),
6487 : gfc_conv_descriptor_lbound_get (gfc, idx));
6488 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6489 : tmp, gfc_index_one_node);
6490 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6491 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6492 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6493 : gfc_conv_descriptor_stride_get (gfc, idx),
6494 : gfc_conv_descriptor_span_get (gfc));
6495 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6496 :
6497 : /* Generate loop. */
6498 11470 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6499 5735 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6500 : gfc_finish_block (&loop_body));
6501 :
6502 5735 : if (e->expr_type == EXPR_VARIABLE
6503 5573 : && e->ref
6504 5573 : && e->ref->u.ar.type == AR_FULL
6505 2732 : && e->symtree->n.sym->attr.dummy
6506 988 : && e->symtree->n.sym->as
6507 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6508 : {
6509 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6510 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6511 : }
6512 : }
6513 :
6514 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6515 : {
6516 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6517 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6518 : tmp, null_pointer_node);
6519 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6520 : build_empty_stmt (input_location));
6521 1015 : gfc_add_expr_to_block (&block, tmp);
6522 : }
6523 : else
6524 5341 : gfc_add_block_to_block (&block, &block2);
6525 :
6526 :
6527 6537 : done:
6528 6537 : if (present)
6529 : {
6530 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6531 103 : TREE_TYPE (parmse->expr),
6532 : present, parmse->expr, null_pointer_node);
6533 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6534 : build_empty_stmt (input_location));
6535 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6536 : }
6537 : else
6538 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6539 :
6540 6537 : gfc_init_block (&block);
6541 :
6542 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6543 1196 : || fsym->attr.intent == INTENT_IN)
6544 5550 : goto post_call;
6545 :
6546 987 : gfc_init_block (&block2);
6547 987 : if (e->rank == 0)
6548 : {
6549 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6550 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6551 : }
6552 : else
6553 : {
6554 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6555 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6556 :
6557 559 : if (fsym->attr.allocatable)
6558 : {
6559 : /* gfc->span = cfi->elem_len. */
6560 252 : tmp = fold_convert (gfc_array_index_type,
6561 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6562 : }
6563 : else
6564 : {
6565 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6566 : ? cfi->dim[0].sm : cfi->elem_len). */
6567 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6568 307 : tmp2 = fold_convert (gfc_array_index_type,
6569 : gfc_get_cfi_desc_elem_len (cfi));
6570 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6571 : gfc_array_index_type, tmp, tmp2);
6572 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6573 : tmp, gfc_index_zero_node);
6574 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6575 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6576 : }
6577 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6578 :
6579 : /* Calculate offset + set lbound, ubound and stride. */
6580 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6581 : /* Loop: for (i = 0; i < rank; ++i). */
6582 559 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6583 : /* Loop body. */
6584 559 : stmtblock_t loop_body;
6585 559 : gfc_init_block (&loop_body);
6586 : /* gfc->dim[i].lbound = ... */
6587 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6588 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6589 :
6590 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6591 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6592 : gfc_conv_descriptor_lbound_get (gfc, idx),
6593 : gfc_index_one_node);
6594 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6595 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6596 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6597 :
6598 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6599 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6600 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6601 : gfc_array_index_type, tmp,
6602 : fold_convert (gfc_array_index_type,
6603 : gfc_get_cfi_desc_elem_len (cfi)));
6604 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6605 :
6606 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6607 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6608 : gfc_conv_descriptor_stride_get (gfc, idx),
6609 : gfc_conv_descriptor_lbound_get (gfc, idx));
6610 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6611 : gfc_conv_descriptor_offset_get (gfc), tmp);
6612 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6613 : /* Generate loop. */
6614 1118 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6615 559 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6616 : gfc_finish_block (&loop_body));
6617 : }
6618 :
6619 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6620 : {
6621 60 : tmp = fold_convert (gfc_charlen_type_node,
6622 : gfc_get_cfi_desc_elem_len (cfi));
6623 60 : if (e->ts.kind != 1)
6624 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6625 : gfc_charlen_type_node, tmp,
6626 : build_int_cst (gfc_charlen_type_node,
6627 24 : e->ts.kind));
6628 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6629 : }
6630 :
6631 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6632 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6633 : tmp, null_pointer_node);
6634 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6635 : build_empty_stmt (input_location));
6636 987 : gfc_add_expr_to_block (&block, tmp);
6637 :
6638 6537 : post_call:
6639 6537 : gfc_add_block_to_block (&block, &se.post);
6640 6537 : if (present && block.head)
6641 : {
6642 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6643 : build_empty_stmt (input_location));
6644 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6645 : }
6646 6531 : else if (block.head)
6647 1564 : gfc_add_block_to_block (&parmse->post, &block);
6648 6537 : }
6649 :
6650 :
6651 : /* Create "conditional temporary" to handle scalar dummy variables with the
6652 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6653 : as fallback. Does not handle CLASS. */
6654 :
6655 : static void
6656 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6657 : {
6658 234 : tree temp;
6659 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6660 234 : gcc_assert (e->rank == 0);
6661 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6662 234 : TREE_STATIC (temp) = 1;
6663 234 : TREE_CONSTANT (temp) = 1;
6664 234 : TREE_READONLY (temp) = 1;
6665 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6666 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6667 234 : TREE_TYPE (parmse->expr),
6668 : cond, parmse->expr, temp);
6669 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6670 234 : }
6671 :
6672 :
6673 : /* Returns true if the type specified in TS is a character type whose length
6674 : is constant. Otherwise returns false. */
6675 :
6676 : static bool
6677 22048 : gfc_const_length_character_type_p (gfc_typespec *ts)
6678 : {
6679 22048 : return (ts->type == BT_CHARACTER
6680 467 : && ts->u.cl
6681 467 : && ts->u.cl->length
6682 467 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6683 22515 : && ts->u.cl->length->ts.type == BT_INTEGER);
6684 : }
6685 :
6686 :
6687 : /* Helper function for the handling of (currently) scalar dummy variables
6688 : with the VALUE attribute. Argument parmse should already be set up. */
6689 : static void
6690 22481 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6691 : vec<tree, va_gc> *& optionalargs)
6692 : {
6693 22481 : tree tmp;
6694 :
6695 22481 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6696 :
6697 22481 : if (IS_PDT (e))
6698 : {
6699 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6700 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6701 6 : gfc_add_expr_to_block (&parmse->pre,
6702 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6703 : parmse->expr, tmp,
6704 : e->rank, 0));
6705 6 : parmse->expr = tmp;
6706 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6707 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6708 6 : return;
6709 : }
6710 :
6711 : /* Absent actual argument for optional scalar dummy. */
6712 22475 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6713 : {
6714 : /* For scalar arguments with VALUE attribute which are passed by
6715 : value, pass "0" and a hidden argument for the optional status. */
6716 427 : if (fsym->ts.type == BT_CHARACTER)
6717 : {
6718 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6719 : zero. */
6720 90 : parmse->expr = null_pointer_node;
6721 90 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6722 : }
6723 337 : else if (gfc_bt_struct (fsym->ts.type)
6724 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6725 : {
6726 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6727 : are pointers and passed as such below. */
6728 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6729 24 : TREE_CONSTANT (temp) = 1;
6730 24 : TREE_READONLY (temp) = 1;
6731 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6732 24 : parmse->expr = temp;
6733 24 : }
6734 : else
6735 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6736 : integer_zero_node);
6737 427 : vec_safe_push (optionalargs, boolean_false_node);
6738 :
6739 427 : return;
6740 : }
6741 :
6742 : /* Truncate a too long constant character actual argument. */
6743 22048 : if (gfc_const_length_character_type_p (&fsym->ts)
6744 467 : && e->expr_type == EXPR_CONSTANT
6745 22131 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6746 : e->value.character.length) < 0)
6747 : {
6748 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6749 :
6750 : /* Truncate actual string argument. */
6751 17 : gfc_conv_expr (parmse, e);
6752 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6753 17 : e->value.character.string);
6754 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6755 :
6756 17 : if (flen == 1)
6757 : {
6758 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6759 14 : gfc_conv_string_parameter (parmse);
6760 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6761 : e->ts.kind);
6762 : }
6763 :
6764 : /* Indicate value,optional scalar dummy argument as present. */
6765 17 : if (fsym->attr.optional)
6766 1 : vec_safe_push (optionalargs, boolean_true_node);
6767 17 : return;
6768 : }
6769 :
6770 : /* gfortran argument passing conventions:
6771 : actual arguments to CHARACTER(len=1),VALUE
6772 : dummy arguments are actually passed by value.
6773 : Strings are truncated to length 1. */
6774 22031 : if (gfc_length_one_character_type_p (&fsym->ts))
6775 : {
6776 378 : if (e->expr_type == EXPR_CONSTANT
6777 54 : && e->value.character.length > 1)
6778 : {
6779 0 : e->value.character.length = 1;
6780 0 : gfc_conv_expr (parmse, e);
6781 : }
6782 :
6783 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6784 378 : gfc_conv_string_parameter (parmse);
6785 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6786 : e->ts.kind);
6787 : /* Truncate resulting string to length 1. */
6788 378 : parmse->string_length = slen1;
6789 : }
6790 :
6791 22031 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6792 : {
6793 : /* F2018:15.5.2.12 Argument presence and
6794 : restrictions on arguments not present. */
6795 823 : if (e->expr_type == EXPR_VARIABLE
6796 650 : && e->rank == 0
6797 1419 : && (gfc_expr_attr (e).allocatable
6798 482 : || gfc_expr_attr (e).pointer))
6799 : {
6800 198 : gfc_se argse;
6801 198 : tree cond;
6802 198 : gfc_init_se (&argse, NULL);
6803 198 : argse.want_pointer = 1;
6804 198 : gfc_conv_expr (&argse, e);
6805 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6806 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6807 : argse.expr, cond);
6808 198 : if (e->symtree->n.sym->attr.dummy)
6809 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6810 : logical_type_node,
6811 : gfc_conv_expr_present (e->symtree->n.sym),
6812 : cond);
6813 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
6814 : /* Create "conditional temporary". */
6815 198 : conv_cond_temp (parmse, e, cond);
6816 : }
6817 625 : else if (e->expr_type != EXPR_VARIABLE
6818 452 : || !e->symtree->n.sym->attr.optional
6819 260 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6820 365 : vec_safe_push (optionalargs, boolean_true_node);
6821 : else
6822 : {
6823 260 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6824 260 : if (gfc_bt_struct (fsym->ts.type)
6825 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6826 36 : conv_cond_temp (parmse, e, tmp);
6827 224 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6828 84 : parmse->expr
6829 168 : = fold_build3_loc (input_location, COND_EXPR,
6830 84 : TREE_TYPE (parmse->expr),
6831 : tmp, parmse->expr,
6832 84 : fold_convert (TREE_TYPE (parmse->expr),
6833 : integer_zero_node));
6834 :
6835 520 : vec_safe_push (optionalargs,
6836 260 : fold_convert (boolean_type_node, tmp));
6837 : }
6838 : }
6839 : }
6840 :
6841 :
6842 : /* Helper function for the handling of NULL() actual arguments associated with
6843 : non-optional dummy variables. Argument parmse should already be set up. */
6844 : static void
6845 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
6846 : {
6847 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
6848 :
6849 : /* Obtain the character length for a NULL() actual with a character
6850 : MOLD argument. Otherwise substitute a suitable dummy length.
6851 : Here we handle only non-optional dummies of non-bind(c) procedures. */
6852 426 : if (fsym->ts.type == BT_CHARACTER)
6853 : {
6854 216 : if (e->ts.type == BT_CHARACTER
6855 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
6856 : {
6857 : /* MOLD is present. Substitute a temporary character NULL pointer.
6858 : For an assumed-rank dummy we need a descriptor that passes the
6859 : correct rank. */
6860 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
6861 : {
6862 54 : tree rank;
6863 54 : tree tmp = parmse->expr;
6864 54 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6865 54 : rank = gfc_conv_descriptor_rank (tmp);
6866 54 : gfc_add_modify (&parmse->pre, rank,
6867 54 : build_int_cst (TREE_TYPE (rank), e->rank));
6868 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6869 54 : }
6870 : else
6871 : {
6872 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
6873 108 : gfc_add_modify (&parmse->pre, tmp,
6874 108 : build_zero_cst (TREE_TYPE (tmp)));
6875 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6876 : }
6877 :
6878 : /* Ensure that a usable length is available. */
6879 162 : if (parmse->string_length == NULL_TREE)
6880 : {
6881 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
6882 :
6883 162 : if (ts->u.cl->length != NULL
6884 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6885 108 : gfc_conv_const_charlen (ts->u.cl);
6886 :
6887 162 : if (ts->u.cl->backend_decl)
6888 162 : parmse->string_length = ts->u.cl->backend_decl;
6889 : }
6890 : }
6891 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
6892 : {
6893 : /* MOLD is not present. Pass length of associated dummy character
6894 : argument if constant, or zero. */
6895 54 : if (fsym->ts.u.cl->length != NULL
6896 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6897 : {
6898 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
6899 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
6900 : }
6901 : else
6902 : {
6903 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
6904 : "slen");
6905 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
6906 : build_zero_cst (gfc_charlen_type_node));
6907 : }
6908 : }
6909 : }
6910 210 : else if (fsym->ts.type == BT_DERIVED)
6911 : {
6912 210 : if (e->ts.type != BT_UNKNOWN)
6913 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
6914 : For an assumed-rank dummy we provide a descriptor that passes
6915 : the correct rank. */
6916 : {
6917 138 : tree rank;
6918 138 : tree tmp = parmse->expr;
6919 :
6920 138 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, gfc_expr_attr (e));
6921 138 : rank = gfc_conv_descriptor_rank (tmp);
6922 138 : gfc_add_modify (&parmse->pre, rank,
6923 138 : build_int_cst (TREE_TYPE (rank), e->rank));
6924 138 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6925 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6926 : }
6927 : else
6928 : /* MOLD is not present. Use attributes from dummy argument, which is
6929 : not allowed to be assumed-rank. */
6930 : {
6931 72 : int dummy_rank;
6932 72 : tree tmp = parmse->expr;
6933 :
6934 72 : if ((fsym->attr.allocatable || fsym->attr.pointer)
6935 72 : && fsym->attr.intent == INTENT_UNKNOWN)
6936 36 : fsym->attr.intent = INTENT_IN;
6937 72 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6938 72 : dummy_rank = fsym->as ? fsym->as->rank : 0;
6939 24 : if (dummy_rank > 0)
6940 : {
6941 24 : tree rank = gfc_conv_descriptor_rank (tmp);
6942 24 : gfc_add_modify (&parmse->pre, rank,
6943 24 : build_int_cst (TREE_TYPE (rank), dummy_rank));
6944 : }
6945 72 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6946 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6947 : }
6948 : }
6949 426 : }
6950 :
6951 :
6952 : /* Generate code for a procedure call. Note can return se->post != NULL.
6953 : If se->direct_byref is set then se->expr contains the return parameter.
6954 : Return nonzero, if the call has alternate specifiers.
6955 : 'expr' is only needed for procedure pointer components. */
6956 :
6957 : int
6958 136319 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6959 : gfc_actual_arglist * args, gfc_expr * expr,
6960 : vec<tree, va_gc> *append_args)
6961 : {
6962 136319 : gfc_interface_mapping mapping;
6963 136319 : vec<tree, va_gc> *arglist;
6964 136319 : vec<tree, va_gc> *retargs;
6965 136319 : tree tmp;
6966 136319 : tree fntype;
6967 136319 : gfc_se parmse;
6968 136319 : gfc_array_info *info;
6969 136319 : int byref;
6970 136319 : int parm_kind;
6971 136319 : tree type;
6972 136319 : tree var;
6973 136319 : tree len;
6974 136319 : tree base_object;
6975 136319 : vec<tree, va_gc> *stringargs;
6976 136319 : vec<tree, va_gc> *optionalargs;
6977 136319 : tree result = NULL;
6978 136319 : gfc_formal_arglist *formal;
6979 136319 : gfc_actual_arglist *arg;
6980 136319 : int has_alternate_specifier = 0;
6981 136319 : bool need_interface_mapping;
6982 136319 : bool is_builtin;
6983 136319 : bool callee_alloc;
6984 136319 : bool ulim_copy;
6985 136319 : gfc_typespec ts;
6986 136319 : gfc_charlen cl;
6987 136319 : gfc_expr *e;
6988 136319 : gfc_symbol *fsym;
6989 136319 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6990 136319 : gfc_component *comp = NULL;
6991 136319 : int arglen;
6992 136319 : unsigned int argc;
6993 136319 : tree arg1_cntnr = NULL_TREE;
6994 136319 : arglist = NULL;
6995 136319 : retargs = NULL;
6996 136319 : stringargs = NULL;
6997 136319 : optionalargs = NULL;
6998 136319 : var = NULL_TREE;
6999 136319 : len = NULL_TREE;
7000 136319 : gfc_clear_ts (&ts);
7001 136319 : gfc_intrinsic_sym *isym = expr && expr->rank ?
7002 : expr->value.function.isym : NULL;
7003 :
7004 136319 : comp = gfc_get_proc_ptr_comp (expr);
7005 :
7006 272638 : bool elemental_proc = (comp
7007 2029 : && comp->ts.interface
7008 1975 : && comp->ts.interface->attr.elemental)
7009 1830 : || (comp && comp->attr.elemental)
7010 138149 : || sym->attr.elemental;
7011 :
7012 136319 : if (se->ss != NULL)
7013 : {
7014 25047 : if (!elemental_proc)
7015 : {
7016 21494 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
7017 21494 : if (se->ss->info->useflags)
7018 : {
7019 5778 : gcc_assert ((!comp && gfc_return_by_reference (sym)
7020 : && sym->result->attr.dimension)
7021 : || (comp && comp->attr.dimension)
7022 : || gfc_is_class_array_function (expr));
7023 5778 : gcc_assert (se->loop != NULL);
7024 : /* Access the previously obtained result. */
7025 5778 : gfc_conv_tmp_array_ref (se);
7026 5778 : return 0;
7027 : }
7028 : }
7029 19269 : info = &se->ss->info->data.array;
7030 : }
7031 : else
7032 : info = NULL;
7033 :
7034 130541 : stmtblock_t post, clobbers, dealloc_blk;
7035 130541 : gfc_init_block (&post);
7036 130541 : gfc_init_block (&clobbers);
7037 130541 : gfc_init_block (&dealloc_blk);
7038 130541 : gfc_init_interface_mapping (&mapping);
7039 130541 : if (!comp)
7040 : {
7041 128561 : formal = gfc_sym_get_dummy_args (sym);
7042 128561 : need_interface_mapping = sym->attr.dimension ||
7043 113097 : (sym->ts.type == BT_CHARACTER
7044 3179 : && sym->ts.u.cl->length
7045 2433 : && sym->ts.u.cl->length->expr_type
7046 : != EXPR_CONSTANT);
7047 : }
7048 : else
7049 : {
7050 1980 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
7051 1980 : need_interface_mapping = comp->attr.dimension ||
7052 1911 : (comp->ts.type == BT_CHARACTER
7053 229 : && comp->ts.u.cl->length
7054 220 : && comp->ts.u.cl->length->expr_type
7055 : != EXPR_CONSTANT);
7056 : }
7057 :
7058 130541 : base_object = NULL_TREE;
7059 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7060 : is the third and fourth argument to such a function call a value
7061 : denoting the number of elements to copy (i.e., most of the time the
7062 : length of a deferred length string). */
7063 261082 : ulim_copy = (formal == NULL)
7064 31939 : && UNLIMITED_POLY (sym)
7065 130621 : && comp && (strcmp ("_copy", comp->name) == 0);
7066 :
7067 : /* Scan for allocatable actual arguments passed to allocatable dummy
7068 : arguments with INTENT(OUT). As the corresponding actual arguments are
7069 : deallocated before execution of the procedure, we evaluate actual
7070 : argument expressions to avoid problems with possible dependencies. */
7071 130541 : bool force_eval_args = false;
7072 130541 : gfc_formal_arglist *tmp_formal;
7073 400943 : for (arg = args, tmp_formal = formal; arg != NULL;
7074 237079 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7075 : {
7076 270903 : e = arg->expr;
7077 270903 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7078 257487 : if (e && fsym
7079 225591 : && e->expr_type == EXPR_VARIABLE
7080 99238 : && fsym->attr.intent == INTENT_OUT
7081 6319 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7082 6319 : ? CLASS_DATA (fsym)->attr.allocatable
7083 4791 : : fsym->attr.allocatable)
7084 501 : && e->symtree
7085 501 : && e->symtree->n.sym
7086 528390 : && gfc_variable_attr (e, NULL).allocatable)
7087 : {
7088 : force_eval_args = true;
7089 : break;
7090 : }
7091 : }
7092 :
7093 : /* Evaluate the arguments. */
7094 401846 : for (arg = args, argc = 0; arg != NULL;
7095 271305 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7096 : {
7097 271305 : bool finalized = false;
7098 271305 : tree derived_array = NULL_TREE;
7099 271305 : symbol_attribute *attr;
7100 :
7101 271305 : e = arg->expr;
7102 271305 : fsym = formal ? formal->sym : NULL;
7103 509287 : parm_kind = MISSING;
7104 :
7105 237982 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7106 : : fsym->attr)
7107 : : nullptr;
7108 : /* If the procedure requires an explicit interface, the actual
7109 : argument is passed according to the corresponding formal
7110 : argument. If the corresponding formal argument is a POINTER,
7111 : ALLOCATABLE or assumed shape, we do not use g77's calling
7112 : convention, and pass the address of the array descriptor
7113 : instead. Otherwise we use g77's calling convention, in other words
7114 : pass the array data pointer without descriptor. */
7115 237929 : bool nodesc_arg = fsym != NULL
7116 237929 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7117 228831 : && fsym->as
7118 40664 : && fsym->as->type != AS_ASSUMED_SHAPE
7119 24760 : && fsym->as->type != AS_ASSUMED_RANK;
7120 271305 : if (comp)
7121 2733 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7122 : else
7123 268572 : nodesc_arg
7124 : = nodesc_arg
7125 268572 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7126 :
7127 : /* Class array expressions are sometimes coming completely unadorned
7128 : with either arrayspec or _data component. Correct that here.
7129 : OOP-TODO: Move this to the frontend. */
7130 271305 : if (e && e->expr_type == EXPR_VARIABLE
7131 113342 : && !e->ref
7132 51643 : && e->ts.type == BT_CLASS
7133 2603 : && (CLASS_DATA (e)->attr.codimension
7134 2603 : || CLASS_DATA (e)->attr.dimension))
7135 : {
7136 0 : gfc_typespec temp_ts = e->ts;
7137 0 : gfc_add_class_array_ref (e);
7138 0 : e->ts = temp_ts;
7139 : }
7140 :
7141 271305 : if (e == NULL
7142 257883 : || (e->expr_type == EXPR_NULL
7143 745 : && fsym
7144 745 : && fsym->attr.value
7145 72 : && fsym->attr.optional
7146 72 : && !fsym->attr.dimension
7147 72 : && fsym->ts.type != BT_CLASS))
7148 : {
7149 13494 : if (se->ignore_optional)
7150 : {
7151 : /* Some intrinsics have already been resolved to the correct
7152 : parameters. */
7153 632 : continue;
7154 : }
7155 13296 : else if (arg->label)
7156 : {
7157 224 : has_alternate_specifier = 1;
7158 224 : continue;
7159 : }
7160 : else
7161 : {
7162 13072 : gfc_init_se (&parmse, NULL);
7163 :
7164 : /* For scalar arguments with VALUE attribute which are passed by
7165 : value, pass "0" and a hidden argument gives the optional
7166 : status. */
7167 13072 : if (fsym && fsym->attr.optional && fsym->attr.value
7168 427 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7169 : {
7170 427 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7171 : }
7172 : else
7173 : {
7174 : /* Pass a NULL pointer for an absent arg. */
7175 12645 : parmse.expr = null_pointer_node;
7176 :
7177 : /* Is it an absent character dummy? */
7178 12645 : bool absent_char = false;
7179 12645 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7180 :
7181 : /* Fall back to inferred type only if no formal. */
7182 12645 : if (fsym)
7183 11587 : absent_char = (fsym->ts.type == BT_CHARACTER);
7184 1058 : else if (dummy_arg)
7185 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7186 : == BT_CHARACTER);
7187 12645 : if (absent_char)
7188 1115 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7189 : 0);
7190 : }
7191 : }
7192 : }
7193 257811 : else if (e->expr_type == EXPR_NULL
7194 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7195 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7196 293 : && fsym->ts.type == BT_DERIVED)
7197 : {
7198 210 : gfc_init_se (&parmse, NULL);
7199 210 : gfc_conv_expr_reference (&parmse, e);
7200 210 : conv_null_actual (&parmse, e, fsym);
7201 : }
7202 257601 : else if (arg->expr->expr_type == EXPR_NULL
7203 463 : && fsym && !fsym->attr.pointer
7204 163 : && (fsym->ts.type != BT_CLASS
7205 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7206 : {
7207 : /* Pass a NULL pointer to denote an absent arg. */
7208 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7209 : && (fsym->ts.type != BT_CLASS
7210 : || !CLASS_DATA (fsym)->attr.allocatable));
7211 163 : gfc_init_se (&parmse, NULL);
7212 163 : parmse.expr = null_pointer_node;
7213 163 : if (fsym->ts.type == BT_CHARACTER)
7214 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7215 : }
7216 257438 : else if (fsym && fsym->ts.type == BT_CLASS
7217 11225 : && e->ts.type == BT_DERIVED)
7218 : {
7219 : /* The derived type needs to be converted to a temporary
7220 : CLASS object. */
7221 4712 : gfc_init_se (&parmse, se);
7222 4712 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7223 4712 : fsym->attr.optional
7224 1008 : && e->expr_type == EXPR_VARIABLE
7225 5720 : && e->symtree->n.sym->attr.optional,
7226 4712 : CLASS_DATA (fsym)->attr.class_pointer
7227 4712 : || CLASS_DATA (fsym)->attr.allocatable,
7228 : sym->name, &derived_array);
7229 : }
7230 220830 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7231 906 : && e->ts.type != BT_PROCEDURE
7232 882 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7233 12 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7234 : {
7235 : /* The intrinsic type needs to be converted to a temporary
7236 : CLASS object for the unlimited polymorphic formal. */
7237 882 : gfc_find_vtab (&e->ts);
7238 882 : gfc_init_se (&parmse, se);
7239 882 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7240 :
7241 : }
7242 251844 : else if (se->ss && se->ss->info->useflags)
7243 : {
7244 5831 : gfc_ss *ss;
7245 :
7246 5831 : ss = se->ss;
7247 :
7248 : /* An elemental function inside a scalarized loop. */
7249 5831 : gfc_init_se (&parmse, se);
7250 5831 : parm_kind = ELEMENTAL;
7251 :
7252 : /* When no fsym is present, ulim_copy is set and this is a third or
7253 : fourth argument, use call-by-value instead of by reference to
7254 : hand the length properties to the copy routine (i.e., most of the
7255 : time this will be a call to a __copy_character_* routine where the
7256 : third and fourth arguments are the lengths of a deferred length
7257 : char array). */
7258 5831 : if ((fsym && fsym->attr.value)
7259 5597 : || (ulim_copy && (argc == 2 || argc == 3)))
7260 234 : gfc_conv_expr (&parmse, e);
7261 5597 : else if (e->expr_type == EXPR_ARRAY)
7262 : {
7263 306 : gfc_conv_expr (&parmse, e);
7264 306 : if (e->ts.type != BT_CHARACTER)
7265 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7266 : }
7267 : else
7268 5291 : gfc_conv_expr_reference (&parmse, e);
7269 :
7270 5831 : if (e->ts.type == BT_CHARACTER && !e->rank
7271 174 : && e->expr_type == EXPR_FUNCTION)
7272 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7273 : parmse.expr);
7274 :
7275 5781 : if (fsym && fsym->ts.type == BT_DERIVED
7276 7447 : && gfc_is_class_container_ref (e))
7277 : {
7278 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7279 :
7280 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7281 24 : && e->symtree->n.sym->attr.optional)
7282 : {
7283 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7284 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7285 0 : TREE_TYPE (parmse.expr),
7286 : cond, parmse.expr,
7287 0 : fold_convert (TREE_TYPE (parmse.expr),
7288 : null_pointer_node));
7289 : }
7290 : }
7291 :
7292 : /* Scalar dummy arguments of intrinsic type or derived type with
7293 : VALUE attribute. */
7294 5831 : if (fsym
7295 5781 : && fsym->attr.value
7296 234 : && fsym->ts.type != BT_CLASS)
7297 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7298 :
7299 : /* If we are passing an absent array as optional dummy to an
7300 : elemental procedure, make sure that we pass NULL when the data
7301 : pointer is NULL. We need this extra conditional because of
7302 : scalarization which passes arrays elements to the procedure,
7303 : ignoring the fact that the array can be absent/unallocated/... */
7304 5597 : else if (ss->info->can_be_null_ref
7305 415 : && ss->info->type != GFC_SS_REFERENCE)
7306 : {
7307 193 : tree descriptor_data;
7308 :
7309 193 : descriptor_data = ss->info->data.array.data;
7310 193 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7311 : descriptor_data,
7312 193 : fold_convert (TREE_TYPE (descriptor_data),
7313 : null_pointer_node));
7314 193 : parmse.expr
7315 386 : = fold_build3_loc (input_location, COND_EXPR,
7316 193 : TREE_TYPE (parmse.expr),
7317 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7318 193 : fold_convert (TREE_TYPE (parmse.expr),
7319 : null_pointer_node),
7320 : parmse.expr);
7321 : }
7322 :
7323 : /* The scalarizer does not repackage the reference to a class
7324 : array - instead it returns a pointer to the data element. */
7325 5831 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7326 186 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7327 186 : fsym->attr.intent != INTENT_IN
7328 186 : && (CLASS_DATA (fsym)->attr.class_pointer
7329 24 : || CLASS_DATA (fsym)->attr.allocatable),
7330 186 : fsym->attr.optional
7331 0 : && e->expr_type == EXPR_VARIABLE
7332 186 : && e->symtree->n.sym->attr.optional,
7333 186 : CLASS_DATA (fsym)->attr.class_pointer
7334 186 : || CLASS_DATA (fsym)->attr.allocatable);
7335 : }
7336 : else
7337 : {
7338 246013 : bool scalar;
7339 246013 : gfc_ss *argss;
7340 :
7341 246013 : gfc_init_se (&parmse, NULL);
7342 :
7343 : /* Check whether the expression is a scalar or not; we cannot use
7344 : e->rank as it can be nonzero for functions arguments. */
7345 246013 : argss = gfc_walk_expr (e);
7346 246013 : scalar = argss == gfc_ss_terminator;
7347 246013 : if (!scalar)
7348 60439 : gfc_free_ss_chain (argss);
7349 :
7350 : /* Special handling for passing scalar polymorphic coarrays;
7351 : otherwise one passes "class->_data.data" instead of "&class". */
7352 246013 : if (e->rank == 0 && e->ts.type == BT_CLASS
7353 3551 : && fsym && fsym->ts.type == BT_CLASS
7354 3129 : && CLASS_DATA (fsym)->attr.codimension
7355 55 : && !CLASS_DATA (fsym)->attr.dimension)
7356 : {
7357 55 : gfc_add_class_array_ref (e);
7358 55 : parmse.want_coarray = 1;
7359 55 : scalar = false;
7360 : }
7361 :
7362 : /* A scalar or transformational function. */
7363 246013 : if (scalar)
7364 : {
7365 185519 : if (e->expr_type == EXPR_VARIABLE
7366 55011 : && e->symtree->n.sym->attr.cray_pointee
7367 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7368 : {
7369 : /* The Cray pointer needs to be converted to a pointer to
7370 : a type given by the expression. */
7371 6 : gfc_conv_expr (&parmse, e);
7372 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7373 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7374 6 : parmse.expr = convert (type, tmp);
7375 : }
7376 :
7377 185513 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7378 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7379 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7380 :
7381 184826 : else if (fsym && fsym->attr.value)
7382 : {
7383 21992 : if (fsym->ts.type == BT_CHARACTER
7384 543 : && fsym->ts.is_c_interop
7385 181 : && fsym->ns->proc_name != NULL
7386 181 : && fsym->ns->proc_name->attr.is_bind_c)
7387 : {
7388 172 : parmse.expr = NULL;
7389 172 : conv_scalar_char_value (fsym, &parmse, &e);
7390 172 : if (parmse.expr == NULL)
7391 166 : gfc_conv_expr (&parmse, e);
7392 : }
7393 : else
7394 : {
7395 21820 : gfc_conv_expr (&parmse, e);
7396 21820 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7397 : }
7398 : }
7399 :
7400 162834 : else if (arg->name && arg->name[0] == '%')
7401 : /* Argument list functions %VAL, %LOC and %REF are signalled
7402 : through arg->name. */
7403 5826 : conv_arglist_function (&parmse, arg->expr, arg->name);
7404 157008 : else if ((e->expr_type == EXPR_FUNCTION)
7405 8305 : && ((e->value.function.esym
7406 2154 : && e->value.function.esym->result->attr.pointer)
7407 8210 : || (!e->value.function.esym
7408 6151 : && e->symtree->n.sym->attr.pointer))
7409 95 : && fsym && fsym->attr.target)
7410 : /* Make sure the function only gets called once. */
7411 8 : gfc_conv_expr_reference (&parmse, e);
7412 157000 : else if (e->expr_type == EXPR_FUNCTION
7413 8297 : && e->symtree->n.sym->result
7414 7262 : && e->symtree->n.sym->result != e->symtree->n.sym
7415 138 : && e->symtree->n.sym->result->attr.proc_pointer)
7416 : {
7417 : /* Functions returning procedure pointers. */
7418 18 : gfc_conv_expr (&parmse, e);
7419 18 : if (fsym && fsym->attr.proc_pointer)
7420 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7421 : }
7422 :
7423 : else
7424 : {
7425 156982 : bool defer_to_dealloc_blk = false;
7426 156982 : if (e->ts.type == BT_CLASS && fsym
7427 3484 : && fsym->ts.type == BT_CLASS
7428 3062 : && (!CLASS_DATA (fsym)->as
7429 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7430 2706 : && CLASS_DATA (e)->attr.codimension)
7431 : {
7432 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7433 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7434 48 : gfc_add_class_array_ref (e);
7435 48 : parmse.want_coarray = 1;
7436 48 : gfc_conv_expr_reference (&parmse, e);
7437 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7438 48 : fsym->attr.optional
7439 48 : && e->expr_type == EXPR_VARIABLE);
7440 : }
7441 156934 : else if (e->ts.type == BT_CLASS && fsym
7442 3436 : && fsym->ts.type == BT_CLASS
7443 3014 : && !CLASS_DATA (fsym)->as
7444 2658 : && !CLASS_DATA (e)->as
7445 2548 : && strcmp (fsym->ts.u.derived->name,
7446 : e->ts.u.derived->name))
7447 : {
7448 1625 : type = gfc_typenode_for_spec (&fsym->ts);
7449 1625 : var = gfc_create_var (type, fsym->name);
7450 1625 : gfc_conv_expr (&parmse, e);
7451 1625 : if (fsym->attr.optional
7452 153 : && e->expr_type == EXPR_VARIABLE
7453 153 : && e->symtree->n.sym->attr.optional)
7454 : {
7455 66 : stmtblock_t block;
7456 66 : tree cond;
7457 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7458 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7459 : logical_type_node, tmp,
7460 66 : fold_convert (TREE_TYPE (tmp),
7461 : null_pointer_node));
7462 66 : gfc_start_block (&block);
7463 66 : gfc_add_modify (&block, var,
7464 : fold_build1_loc (input_location,
7465 : VIEW_CONVERT_EXPR,
7466 : type, parmse.expr));
7467 66 : gfc_add_expr_to_block (&parmse.pre,
7468 : fold_build3_loc (input_location,
7469 : COND_EXPR, void_type_node,
7470 : cond, gfc_finish_block (&block),
7471 : build_empty_stmt (input_location)));
7472 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7473 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7474 66 : TREE_TYPE (parmse.expr),
7475 : cond, parmse.expr,
7476 66 : fold_convert (TREE_TYPE (parmse.expr),
7477 : null_pointer_node));
7478 66 : }
7479 : else
7480 : {
7481 : /* Since the internal representation of unlimited
7482 : polymorphic expressions includes an extra field
7483 : that other class objects do not, a cast to the
7484 : formal type does not work. */
7485 1559 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7486 : {
7487 91 : tree efield;
7488 :
7489 : /* Evaluate arguments just once, when they have
7490 : side effects. */
7491 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7492 : {
7493 25 : tree cldata, zero;
7494 :
7495 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7496 : &parmse.pre);
7497 :
7498 : /* Prevent memory leak, when old component
7499 : was allocated already. */
7500 25 : cldata = gfc_class_data_get (parmse.expr);
7501 25 : zero = build_int_cst (TREE_TYPE (cldata),
7502 : 0);
7503 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7504 : logical_type_node,
7505 : cldata, zero);
7506 25 : tmp = build3_v (COND_EXPR, tmp,
7507 : gfc_call_free (cldata),
7508 : build_empty_stmt (
7509 : input_location));
7510 25 : gfc_add_expr_to_block (&parmse.finalblock,
7511 : tmp);
7512 25 : gfc_add_modify (&parmse.finalblock,
7513 : cldata, zero);
7514 : }
7515 :
7516 : /* Set the _data field. */
7517 91 : tmp = gfc_class_data_get (var);
7518 91 : efield = fold_convert (TREE_TYPE (tmp),
7519 : gfc_class_data_get (parmse.expr));
7520 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7521 :
7522 : /* Set the _vptr field. */
7523 91 : tmp = gfc_class_vptr_get (var);
7524 91 : efield = fold_convert (TREE_TYPE (tmp),
7525 : gfc_class_vptr_get (parmse.expr));
7526 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7527 :
7528 : /* Set the _len field. */
7529 91 : tmp = gfc_class_len_get (var);
7530 91 : gfc_add_modify (&parmse.pre, tmp,
7531 91 : build_int_cst (TREE_TYPE (tmp), 0));
7532 91 : }
7533 : else
7534 : {
7535 1468 : tmp = fold_build1_loc (input_location,
7536 : VIEW_CONVERT_EXPR,
7537 : type, parmse.expr);
7538 1468 : gfc_add_modify (&parmse.pre, var, tmp);
7539 1559 : ;
7540 : }
7541 1559 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7542 : }
7543 : }
7544 : else
7545 : {
7546 155309 : gfc_conv_expr_reference (&parmse, e);
7547 :
7548 155309 : gfc_symbol *dsym = fsym;
7549 155309 : gfc_dummy_arg *dummy;
7550 :
7551 : /* Use associated dummy as fallback for formal
7552 : argument if there is no explicit interface. */
7553 155309 : if (dsym == NULL
7554 27413 : && (dummy = arg->associated_dummy)
7555 24886 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7556 178791 : && dummy->u.non_intrinsic->sym)
7557 : dsym = dummy->u.non_intrinsic->sym;
7558 :
7559 155309 : if (dsym
7560 151378 : && dsym->attr.intent == INTENT_OUT
7561 3254 : && !dsym->attr.allocatable
7562 3112 : && !dsym->attr.pointer
7563 3094 : && e->expr_type == EXPR_VARIABLE
7564 3093 : && e->ref == NULL
7565 2984 : && e->symtree
7566 2984 : && e->symtree->n.sym
7567 2984 : && !e->symtree->n.sym->attr.dimension
7568 2984 : && e->ts.type != BT_CHARACTER
7569 2882 : && e->ts.type != BT_CLASS
7570 2652 : && (e->ts.type != BT_DERIVED
7571 492 : || (dsym->ts.type == BT_DERIVED
7572 492 : && e->ts.u.derived == dsym->ts.u.derived
7573 : /* Types with allocatable components are
7574 : excluded from clobbering because we need
7575 : the unclobbered pointers to free the
7576 : allocatable components in the callee.
7577 : Same goes for finalizable types or types
7578 : with finalizable components, we need to
7579 : pass the unclobbered values to the
7580 : finalization routines.
7581 : For parameterized types, it's less clear
7582 : but they may not have a constant size
7583 : so better exclude them in any case. */
7584 477 : && !e->ts.u.derived->attr.alloc_comp
7585 351 : && !e->ts.u.derived->attr.pdt_type
7586 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7587 2469 : && e->ts.type != BT_PROCEDURE
7588 157742 : && !sym->attr.elemental)
7589 : {
7590 1100 : tree var;
7591 1100 : var = build_fold_indirect_ref_loc (input_location,
7592 : parmse.expr);
7593 1100 : tree clobber = build_clobber (TREE_TYPE (var));
7594 1100 : gfc_add_modify (&clobbers, var, clobber);
7595 : }
7596 : }
7597 : /* Catch base objects that are not variables. */
7598 156982 : if (e->ts.type == BT_CLASS
7599 3484 : && e->expr_type != EXPR_VARIABLE
7600 306 : && expr && e == expr->base_expr)
7601 80 : base_object = build_fold_indirect_ref_loc (input_location,
7602 : parmse.expr);
7603 :
7604 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7605 : allocated on entry, it must be deallocated. */
7606 129569 : if (fsym && fsym->attr.intent == INTENT_OUT
7607 3183 : && (fsym->attr.allocatable
7608 3041 : || (fsym->ts.type == BT_CLASS
7609 259 : && CLASS_DATA (fsym)->attr.allocatable))
7610 157273 : && !is_CFI_desc (fsym, NULL))
7611 : {
7612 291 : stmtblock_t block;
7613 291 : tree ptr;
7614 :
7615 291 : defer_to_dealloc_blk = true;
7616 :
7617 291 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7618 : &parmse.pre);
7619 :
7620 291 : if (parmse.class_container != NULL_TREE)
7621 156 : parmse.class_container
7622 156 : = gfc_evaluate_data_ref_now (parmse.class_container,
7623 : &parmse.pre);
7624 :
7625 291 : gfc_init_block (&block);
7626 291 : ptr = parmse.expr;
7627 291 : if (e->ts.type == BT_CLASS)
7628 156 : ptr = gfc_class_data_get (ptr);
7629 :
7630 291 : tree cls = parmse.class_container;
7631 291 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7632 : NULL_TREE, true,
7633 : e, e->ts, cls);
7634 291 : gfc_add_expr_to_block (&block, tmp);
7635 291 : gfc_add_modify (&block, ptr,
7636 291 : fold_convert (TREE_TYPE (ptr),
7637 : null_pointer_node));
7638 :
7639 291 : if (fsym->ts.type == BT_CLASS)
7640 149 : gfc_reset_vptr (&block, nullptr,
7641 : build_fold_indirect_ref (parmse.expr),
7642 149 : fsym->ts.u.derived);
7643 :
7644 291 : if (fsym->attr.optional
7645 42 : && e->expr_type == EXPR_VARIABLE
7646 42 : && e->symtree->n.sym->attr.optional)
7647 : {
7648 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7649 : void_type_node,
7650 18 : gfc_conv_expr_present (e->symtree->n.sym),
7651 : gfc_finish_block (&block),
7652 : build_empty_stmt (input_location));
7653 : }
7654 : else
7655 273 : tmp = gfc_finish_block (&block);
7656 :
7657 291 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7658 : }
7659 :
7660 : /* A class array element needs converting back to be a
7661 : class object, if the formal argument is a class object. */
7662 156982 : if (fsym && fsym->ts.type == BT_CLASS
7663 3086 : && e->ts.type == BT_CLASS
7664 3062 : && ((CLASS_DATA (fsym)->as
7665 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7666 2706 : || CLASS_DATA (e)->attr.dimension))
7667 : {
7668 466 : gfc_se class_se = parmse;
7669 466 : gfc_init_block (&class_se.pre);
7670 466 : gfc_init_block (&class_se.post);
7671 :
7672 466 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7673 466 : fsym->attr.intent != INTENT_IN
7674 466 : && (CLASS_DATA (fsym)->attr.class_pointer
7675 267 : || CLASS_DATA (fsym)->attr.allocatable),
7676 466 : fsym->attr.optional
7677 198 : && e->expr_type == EXPR_VARIABLE
7678 664 : && e->symtree->n.sym->attr.optional,
7679 466 : CLASS_DATA (fsym)->attr.class_pointer
7680 466 : || CLASS_DATA (fsym)->attr.allocatable);
7681 :
7682 466 : parmse.expr = class_se.expr;
7683 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7684 466 : ? &dealloc_blk
7685 : : &parmse.pre;
7686 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7687 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7688 : }
7689 :
7690 129569 : if (fsym && (fsym->ts.type == BT_DERIVED
7691 117677 : || fsym->ts.type == BT_ASSUMED)
7692 12759 : && e->ts.type == BT_CLASS
7693 410 : && !CLASS_DATA (e)->attr.dimension
7694 374 : && !CLASS_DATA (e)->attr.codimension)
7695 : {
7696 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7697 : /* The result is a class temporary, whose _data component
7698 : must be freed to avoid a memory leak. */
7699 374 : if (e->expr_type == EXPR_FUNCTION
7700 23 : && CLASS_DATA (e)->attr.allocatable)
7701 : {
7702 19 : tree zero;
7703 :
7704 : /* Finalize the expression. */
7705 19 : gfc_finalize_tree_expr (&parmse, NULL,
7706 19 : gfc_expr_attr (e), e->rank);
7707 19 : gfc_add_block_to_block (&parmse.post,
7708 : &parmse.finalblock);
7709 :
7710 : /* Then free the class _data. */
7711 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7712 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7713 : logical_type_node,
7714 : parmse.expr, zero);
7715 19 : tmp = build3_v (COND_EXPR, tmp,
7716 : gfc_call_free (parmse.expr),
7717 : build_empty_stmt (input_location));
7718 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7719 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7720 : }
7721 : }
7722 :
7723 : /* Wrap scalar variable in a descriptor. We need to convert
7724 : the address of a pointer back to the pointer itself before,
7725 : we can assign it to the data field. */
7726 :
7727 129569 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7728 1314 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7729 : {
7730 1242 : tmp = parmse.expr;
7731 1242 : if (TREE_CODE (tmp) == ADDR_EXPR)
7732 736 : tmp = TREE_OPERAND (tmp, 0);
7733 1242 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7734 : fsym->attr);
7735 1242 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
7736 : parmse.expr);
7737 : }
7738 128327 : else if (fsym && e->expr_type != EXPR_NULL
7739 128029 : && ((fsym->attr.pointer
7740 1740 : && fsym->attr.flavor != FL_PROCEDURE)
7741 126295 : || (fsym->attr.proc_pointer
7742 199 : && !(e->expr_type == EXPR_VARIABLE
7743 199 : && e->symtree->n.sym->attr.dummy))
7744 126108 : || (fsym->attr.proc_pointer
7745 12 : && e->expr_type == EXPR_VARIABLE
7746 12 : && gfc_is_proc_ptr_comp (e))
7747 126102 : || (fsym->attr.allocatable
7748 1040 : && fsym->attr.flavor != FL_PROCEDURE)))
7749 : {
7750 : /* Scalar pointer dummy args require an extra level of
7751 : indirection. The null pointer already contains
7752 : this level of indirection. */
7753 2961 : parm_kind = SCALAR_POINTER;
7754 2961 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7755 : }
7756 : }
7757 : }
7758 60494 : else if (e->ts.type == BT_CLASS
7759 2693 : && fsym && fsym->ts.type == BT_CLASS
7760 2347 : && (CLASS_DATA (fsym)->attr.dimension
7761 55 : || CLASS_DATA (fsym)->attr.codimension))
7762 : {
7763 : /* Pass a class array. */
7764 2347 : gfc_conv_expr_descriptor (&parmse, e);
7765 2347 : bool defer_to_dealloc_blk = false;
7766 :
7767 2347 : if (fsym->attr.optional
7768 798 : && e->expr_type == EXPR_VARIABLE
7769 798 : && e->symtree->n.sym->attr.optional)
7770 : {
7771 438 : stmtblock_t block;
7772 :
7773 438 : gfc_init_block (&block);
7774 438 : gfc_add_block_to_block (&block, &parmse.pre);
7775 :
7776 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
7777 : void_type_node,
7778 438 : gfc_conv_expr_present (e->symtree->n.sym),
7779 : gfc_finish_block (&block),
7780 : build_empty_stmt (input_location));
7781 :
7782 438 : gfc_add_expr_to_block (&parmse.pre, t);
7783 : }
7784 :
7785 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7786 : allocated on entry, it must be deallocated. */
7787 2347 : if (fsym->attr.intent == INTENT_OUT
7788 141 : && CLASS_DATA (fsym)->attr.allocatable)
7789 : {
7790 110 : stmtblock_t block;
7791 110 : tree ptr;
7792 :
7793 : /* In case the data reference to deallocate is dependent on
7794 : its own content, save the resulting pointer to a variable
7795 : and only use that variable from now on, before the
7796 : expression becomes invalid. */
7797 110 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7798 : &parmse.pre);
7799 :
7800 110 : if (parmse.class_container != NULL_TREE)
7801 110 : parmse.class_container
7802 110 : = gfc_evaluate_data_ref_now (parmse.class_container,
7803 : &parmse.pre);
7804 :
7805 110 : gfc_init_block (&block);
7806 110 : ptr = parmse.expr;
7807 110 : ptr = gfc_class_data_get (ptr);
7808 :
7809 110 : tree cls = parmse.class_container;
7810 110 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
7811 : NULL_TREE, NULL_TREE,
7812 : NULL_TREE, true, e,
7813 : GFC_CAF_COARRAY_NOCOARRAY,
7814 : cls);
7815 110 : gfc_add_expr_to_block (&block, tmp);
7816 110 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7817 : void_type_node, ptr,
7818 : null_pointer_node);
7819 110 : gfc_add_expr_to_block (&block, tmp);
7820 110 : gfc_reset_vptr (&block, e, parmse.class_container);
7821 :
7822 110 : if (fsym->attr.optional
7823 30 : && e->expr_type == EXPR_VARIABLE
7824 30 : && (!e->ref
7825 30 : || (e->ref->type == REF_ARRAY
7826 0 : && e->ref->u.ar.type != AR_FULL))
7827 0 : && e->symtree->n.sym->attr.optional)
7828 : {
7829 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7830 : void_type_node,
7831 0 : gfc_conv_expr_present (e->symtree->n.sym),
7832 : gfc_finish_block (&block),
7833 : build_empty_stmt (input_location));
7834 : }
7835 : else
7836 110 : tmp = gfc_finish_block (&block);
7837 :
7838 110 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7839 110 : defer_to_dealloc_blk = true;
7840 : }
7841 :
7842 2347 : gfc_se class_se = parmse;
7843 2347 : gfc_init_block (&class_se.pre);
7844 2347 : gfc_init_block (&class_se.post);
7845 :
7846 2347 : if (e->expr_type != EXPR_VARIABLE)
7847 : {
7848 : int n;
7849 : /* Set the bounds and offset correctly. */
7850 60 : for (n = 0; n < e->rank; n++)
7851 30 : gfc_conv_shift_descriptor_lbound (&class_se.pre,
7852 : class_se.expr,
7853 : n, gfc_index_one_node);
7854 : }
7855 :
7856 : /* The conversion does not repackage the reference to a class
7857 : array - _data descriptor. */
7858 2347 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7859 2347 : fsym->attr.intent != INTENT_IN
7860 2347 : && (CLASS_DATA (fsym)->attr.class_pointer
7861 1211 : || CLASS_DATA (fsym)->attr.allocatable),
7862 2347 : fsym->attr.optional
7863 798 : && e->expr_type == EXPR_VARIABLE
7864 3145 : && e->symtree->n.sym->attr.optional,
7865 2347 : CLASS_DATA (fsym)->attr.class_pointer
7866 2347 : || CLASS_DATA (fsym)->attr.allocatable);
7867 :
7868 2347 : parmse.expr = class_se.expr;
7869 2237 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7870 2347 : ? &dealloc_blk
7871 : : &parmse.pre;
7872 2347 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7873 2347 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7874 :
7875 2347 : if (e->expr_type == EXPR_OP
7876 12 : && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
7877 2359 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
7878 : {
7879 12 : tree cond;
7880 12 : tree dealloc_expr = gfc_finish_block (&parmse.post);
7881 12 : tmp = TREE_OPERAND (parmse.expr, 0);
7882 12 : gfc_init_block (&parmse.post);
7883 12 : cond = gfc_class_data_get (tmp);
7884 12 : tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
7885 : tmp, e->rank, true);
7886 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7887 12 : cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
7888 12 : cond = gfc_conv_descriptor_data_get (cond);
7889 12 : cond = fold_build2_loc (input_location, NE_EXPR,
7890 : logical_type_node, cond,
7891 12 : build_int_cst (TREE_TYPE (cond), 0));
7892 12 : tmp = build3_v (COND_EXPR, cond, dealloc_expr,
7893 : build_empty_stmt (input_location));
7894 :
7895 : /* This specific case should not be processed further and so
7896 : bundle everything up and proceed to the next argument. */
7897 12 : if (fsym && need_interface_mapping && e)
7898 12 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
7899 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7900 12 : gfc_add_block_to_block (&se->pre, &parmse.pre);
7901 12 : gfc_add_block_to_block (&post, &parmse.post);
7902 12 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
7903 12 : vec_safe_push (arglist, parmse.expr);
7904 12 : continue;
7905 12 : }
7906 2335 : }
7907 : else
7908 : {
7909 : /* If the argument is a function call that may not create
7910 : a temporary for the result, we have to check that we
7911 : can do it, i.e. that there is no alias between this
7912 : argument and another one. */
7913 58147 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7914 : {
7915 358 : gfc_expr *iarg;
7916 358 : sym_intent intent;
7917 :
7918 358 : if (fsym != NULL)
7919 349 : intent = fsym->attr.intent;
7920 : else
7921 : intent = INTENT_UNKNOWN;
7922 :
7923 358 : if (gfc_check_fncall_dependency (e, intent, sym, args,
7924 : NOT_ELEMENTAL))
7925 21 : parmse.force_tmp = 1;
7926 :
7927 358 : iarg = e->value.function.actual->expr;
7928 :
7929 : /* Temporary needed if aliasing due to host association. */
7930 358 : if (sym->attr.contained
7931 114 : && !sym->attr.pure
7932 114 : && !sym->attr.implicit_pure
7933 36 : && !sym->attr.use_assoc
7934 36 : && iarg->expr_type == EXPR_VARIABLE
7935 36 : && sym->ns == iarg->symtree->n.sym->ns)
7936 36 : parmse.force_tmp = 1;
7937 :
7938 : /* Ditto within module. */
7939 358 : if (sym->attr.use_assoc
7940 6 : && !sym->attr.pure
7941 6 : && !sym->attr.implicit_pure
7942 0 : && iarg->expr_type == EXPR_VARIABLE
7943 0 : && sym->module == iarg->symtree->n.sym->module)
7944 0 : parmse.force_tmp = 1;
7945 : }
7946 :
7947 : /* Special case for assumed-rank arrays: when passing an
7948 : argument to a nonallocatable/nonpointer dummy, the bounds have
7949 : to be reset as otherwise a last-dim ubound of -1 is
7950 : indistinguishable from an assumed-size array in the callee. */
7951 58147 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
7952 35112 : && fsym->as->type == AS_ASSUMED_RANK
7953 11918 : && e->rank != -1
7954 11604 : && e->expr_type == EXPR_VARIABLE
7955 11163 : && ((fsym->ts.type == BT_CLASS
7956 0 : && !CLASS_DATA (fsym)->attr.class_pointer
7957 0 : && !CLASS_DATA (fsym)->attr.allocatable)
7958 11163 : || (fsym->ts.type != BT_CLASS
7959 11163 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
7960 : {
7961 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7962 10620 : gfc_ref *ref;
7963 10878 : for (ref = e->ref; ref->next; ref = ref->next)
7964 : {
7965 330 : if (ref->next->type == REF_INQUIRY)
7966 : break;
7967 282 : if (ref->type == REF_ARRAY
7968 24 : && ref->u.ar.type != AR_ELEMENT)
7969 : break;
7970 10620 : };
7971 10620 : if (ref->u.ar.type == AR_FULL
7972 9870 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
7973 9750 : ref->u.ar.type = AR_SECTION;
7974 : }
7975 :
7976 58147 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7977 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7978 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7979 :
7980 52297 : else if (e->expr_type == EXPR_VARIABLE
7981 40887 : && is_subref_array (e)
7982 53277 : && !(fsym && fsym->attr.pointer))
7983 : /* The actual argument is a component reference to an
7984 : array of derived types. In this case, the argument
7985 : is converted to a temporary, which is passed and then
7986 : written back after the procedure call. */
7987 727 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7988 685 : fsym ? fsym->attr.intent : INTENT_INOUT,
7989 727 : fsym && fsym->attr.pointer);
7990 :
7991 51570 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
7992 345 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
7993 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
7994 : /* An assumed size class actual argument being passed to
7995 : a 'no descriptor' formal argument just requires the
7996 : data pointer to be passed. For class dummy arguments
7997 : this is stored in the symbol backend decl.. */
7998 6 : parmse.expr = e->symtree->n.sym->backend_decl;
7999 :
8000 51564 : else if (gfc_is_class_array_ref (e, NULL)
8001 51564 : && fsym && fsym->ts.type == BT_DERIVED)
8002 : /* The actual argument is a component reference to an
8003 : array of derived types. In this case, the argument
8004 : is converted to a temporary, which is passed and then
8005 : written back after the procedure call.
8006 : OOP-TODO: Insert code so that if the dynamic type is
8007 : the same as the declared type, copy-in/copy-out does
8008 : not occur. */
8009 108 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8010 108 : fsym->attr.intent,
8011 108 : fsym->attr.pointer);
8012 :
8013 51456 : else if (gfc_is_class_array_function (e)
8014 51456 : && fsym && fsym->ts.type == BT_DERIVED)
8015 : /* See previous comment. For function actual argument,
8016 : the write out is not needed so the intent is set as
8017 : intent in. */
8018 : {
8019 13 : e->must_finalize = 1;
8020 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8021 13 : INTENT_IN, fsym->attr.pointer);
8022 : }
8023 47864 : else if (fsym && fsym->attr.contiguous
8024 60 : && (fsym->attr.target
8025 1708 : ? gfc_is_not_contiguous (e)
8026 1648 : : !gfc_is_simply_contiguous (e, false, true))
8027 327 : && gfc_expr_is_variable (e)
8028 53466 : && e->rank != -1)
8029 : {
8030 303 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8031 303 : fsym->attr.intent,
8032 303 : fsym->attr.pointer);
8033 : }
8034 : else
8035 : /* This is where we introduce a temporary to store the
8036 : result of a non-lvalue array expression. */
8037 51140 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
8038 : sym->name, NULL);
8039 :
8040 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8041 : allocated on entry, it must be deallocated.
8042 : CFI descriptors are handled elsewhere. */
8043 54526 : if (fsym && fsym->attr.allocatable
8044 1784 : && fsym->attr.intent == INTENT_OUT
8045 57923 : && !is_CFI_desc (fsym, NULL))
8046 : {
8047 158 : if (fsym->ts.type == BT_DERIVED
8048 45 : && fsym->ts.u.derived->attr.alloc_comp)
8049 : {
8050 : // deallocate the components first
8051 9 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
8052 : parmse.expr, e->rank);
8053 : /* But check whether dummy argument is optional. */
8054 9 : if (tmp != NULL_TREE
8055 9 : && fsym->attr.optional
8056 6 : && e->expr_type == EXPR_VARIABLE
8057 6 : && e->symtree->n.sym->attr.optional)
8058 : {
8059 6 : tree present;
8060 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
8061 6 : tmp = build3_v (COND_EXPR, present, tmp,
8062 : build_empty_stmt (input_location));
8063 : }
8064 9 : if (tmp != NULL_TREE)
8065 9 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8066 : }
8067 :
8068 158 : tmp = parmse.expr;
8069 : /* With bind(C), the actual argument is replaced by a bind-C
8070 : descriptor; in this case, the data component arrives here,
8071 : which shall not be dereferenced, but still freed and
8072 : nullified. */
8073 158 : if (TREE_TYPE(tmp) != pvoid_type_node)
8074 158 : tmp = build_fold_indirect_ref_loc (input_location,
8075 : parmse.expr);
8076 158 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8077 : NULL_TREE, NULL_TREE, true,
8078 : e,
8079 : GFC_CAF_COARRAY_NOCOARRAY);
8080 158 : if (fsym->attr.optional
8081 48 : && e->expr_type == EXPR_VARIABLE
8082 48 : && e->symtree->n.sym->attr.optional)
8083 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
8084 : void_type_node,
8085 24 : gfc_conv_expr_present (e->symtree->n.sym),
8086 : tmp, build_empty_stmt (input_location));
8087 158 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8088 : }
8089 : }
8090 : }
8091 : /* Special case for an assumed-rank dummy argument. */
8092 270871 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
8093 56804 : && (fsym->ts.type == BT_CLASS
8094 56804 : ? (CLASS_DATA (fsym)->as
8095 4564 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
8096 52240 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8097 : {
8098 12743 : if (fsym->ts.type == BT_CLASS
8099 12743 : ? (CLASS_DATA (fsym)->attr.class_pointer
8100 1055 : || CLASS_DATA (fsym)->attr.allocatable)
8101 11688 : : (fsym->attr.pointer || fsym->attr.allocatable))
8102 : {
8103 : /* Unallocated allocatable arrays and unassociated pointer
8104 : arrays need their dtype setting if they are argument
8105 : associated with assumed rank dummies to set the rank. */
8106 891 : set_dtype_for_unallocated (&parmse, e);
8107 : }
8108 11852 : else if (e->expr_type == EXPR_VARIABLE
8109 11373 : && e->symtree->n.sym->attr.dummy
8110 698 : && (e->ts.type == BT_CLASS
8111 891 : ? (e->ref && e->ref->next
8112 193 : && e->ref->next->type == REF_ARRAY
8113 193 : && e->ref->next->u.ar.type == AR_FULL
8114 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8115 505 : : (e->ref && e->ref->type == REF_ARRAY
8116 505 : && e->ref->u.ar.type == AR_FULL
8117 733 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8118 : {
8119 : /* Assumed-size actual to assumed-rank dummy requires
8120 : dim[rank-1].ubound = -1. */
8121 180 : tree minus_one;
8122 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8123 180 : if (fsym->ts.type == BT_CLASS)
8124 60 : tmp = gfc_class_data_get (tmp);
8125 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8126 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8127 180 : gfc_rank_cst[e->rank - 1],
8128 : minus_one);
8129 : }
8130 : }
8131 :
8132 : /* The case with fsym->attr.optional is that of a user subroutine
8133 : with an interface indicating an optional argument. When we call
8134 : an intrinsic subroutine, however, fsym is NULL, but we might still
8135 : have an optional argument, so we proceed to the substitution
8136 : just in case. Arguments passed to bind(c) procedures via CFI
8137 : descriptors are handled elsewhere. */
8138 257871 : if (e && (fsym == NULL || fsym->attr.optional)
8139 331292 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8140 : {
8141 : /* If an optional argument is itself an optional dummy argument,
8142 : check its presence and substitute a null if absent. This is
8143 : only needed when passing an array to an elemental procedure
8144 : as then array elements are accessed - or no NULL pointer is
8145 : allowed and a "1" or "0" should be passed if not present.
8146 : When passing a non-array-descriptor full array to a
8147 : non-array-descriptor dummy, no check is needed. For
8148 : array-descriptor actual to array-descriptor dummy, see
8149 : PR 41911 for why a check has to be inserted.
8150 : fsym == NULL is checked as intrinsics required the descriptor
8151 : but do not always set fsym.
8152 : Also, it is necessary to pass a NULL pointer to library routines
8153 : which usually ignore optional arguments, so they can handle
8154 : these themselves. */
8155 59327 : if (e->expr_type == EXPR_VARIABLE
8156 26431 : && e->symtree->n.sym->attr.optional
8157 2421 : && (((e->rank != 0 && elemental_proc)
8158 2246 : || e->representation.length || e->ts.type == BT_CHARACTER
8159 2020 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8160 1910 : || (e->rank != 0
8161 1070 : && (fsym == NULL
8162 1034 : || (fsym->as
8163 272 : && (fsym->as->type == AS_ASSUMED_SHAPE
8164 235 : || fsym->as->type == AS_ASSUMED_RANK
8165 117 : || fsym->as->type == AS_DEFERRED)))))
8166 1685 : || se->ignore_optional))
8167 764 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8168 764 : e->representation.length);
8169 : }
8170 :
8171 : /* Make the class container for the first argument available with class
8172 : valued transformational functions. */
8173 270871 : if (argc == 0 && e && e->ts.type == BT_CLASS
8174 4949 : && isym && isym->transformational
8175 84 : && se->ss && se->ss->info)
8176 : {
8177 84 : arg1_cntnr = parmse.expr;
8178 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8179 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8180 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8181 84 : se->ss->info->class_container = arg1_cntnr;
8182 : }
8183 :
8184 : /* Obtain the character length of an assumed character length procedure
8185 : from the typespec of the actual argument. */
8186 270871 : if (e
8187 257871 : && parmse.string_length == NULL_TREE
8188 222382 : && e->ts.type == BT_PROCEDURE
8189 1935 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8190 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8191 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8192 : {
8193 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8194 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8195 : }
8196 :
8197 270871 : if (fsym && e)
8198 : {
8199 : /* Obtain the character length for a NULL() actual with a character
8200 : MOLD argument. Otherwise substitute a suitable dummy length.
8201 : Here we handle non-optional dummies of non-bind(c) procedures. */
8202 225975 : if (e->expr_type == EXPR_NULL
8203 745 : && fsym->ts.type == BT_CHARACTER
8204 296 : && !fsym->attr.optional
8205 226193 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8206 216 : conv_null_actual (&parmse, e, fsym);
8207 : }
8208 :
8209 : /* If any actual argument of the procedure is allocatable and passed
8210 : to an allocatable dummy with INTENT(OUT), we conservatively
8211 : evaluate actual argument expressions before deallocations are
8212 : performed and the procedure is executed. May create temporaries.
8213 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8214 257871 : if (e && fsym && force_eval_args
8215 1104 : && fsym->attr.intent != INTENT_OUT
8216 271280 : && !gfc_is_constant_expr (e))
8217 268 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8218 :
8219 270871 : if (fsym && need_interface_mapping && e)
8220 40510 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8221 :
8222 270871 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8223 270871 : gfc_add_block_to_block (&post, &parmse.post);
8224 270871 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8225 :
8226 : /* Allocated allocatable components of derived types must be
8227 : deallocated for non-variable scalars, array arguments to elemental
8228 : procedures, and array arguments with descriptor to non-elemental
8229 : procedures. As bounds information for descriptorless arrays is no
8230 : longer available here, they are dealt with in trans-array.cc
8231 : (gfc_conv_array_parameter). */
8232 257871 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8233 28365 : && e->ts.u.derived->attr.alloc_comp
8234 7579 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8235 278312 : && !expr_may_alias_variables (e, elemental_proc))
8236 : {
8237 372 : int parm_rank;
8238 : /* It is known the e returns a structure type with at least one
8239 : allocatable component. When e is a function, ensure that the
8240 : function is called once only by using a temporary variable. */
8241 372 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8242 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8243 : parmse.expr, &se->pre);
8244 :
8245 372 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8246 152 : tmp = parmse.expr;
8247 : else
8248 220 : tmp = build_fold_indirect_ref_loc (input_location,
8249 : parmse.expr);
8250 :
8251 372 : parm_rank = e->rank;
8252 372 : switch (parm_kind)
8253 : {
8254 : case (ELEMENTAL):
8255 : case (SCALAR):
8256 372 : parm_rank = 0;
8257 : break;
8258 :
8259 0 : case (SCALAR_POINTER):
8260 0 : tmp = build_fold_indirect_ref_loc (input_location,
8261 : tmp);
8262 0 : break;
8263 : }
8264 :
8265 372 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8266 : {
8267 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8268 : Therefore, class actuals can be handled correctly but derived
8269 : types passed to class formals need the _data component. */
8270 82 : tmp = gfc_class_data_get (tmp);
8271 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8272 : {
8273 56 : if (UNLIMITED_POLY (fsym))
8274 : {
8275 12 : tree type = gfc_typenode_for_spec (&e->ts);
8276 12 : type = build_pointer_type (type);
8277 12 : tmp = fold_convert (type, tmp);
8278 : }
8279 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8280 : }
8281 : }
8282 :
8283 372 : if (e->expr_type == EXPR_OP
8284 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8285 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8286 : {
8287 24 : tree local_tmp;
8288 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8289 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8290 : parm_rank, 0);
8291 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8292 : }
8293 :
8294 : /* Items of array expressions passed to a polymorphic formal arguments
8295 : create their own clean up, so prevent double free. */
8296 372 : if (!finalized && !e->must_finalize
8297 371 : && !(e->expr_type == EXPR_ARRAY && fsym
8298 86 : && fsym->ts.type == BT_CLASS))
8299 : {
8300 351 : bool scalar_res_outside_loop;
8301 1041 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8302 151 : && parm_rank == 0
8303 490 : && parmse.loop;
8304 :
8305 : /* Scalars passed to an assumed rank argument are converted to
8306 : a descriptor. Obtain the data field before deallocating any
8307 : allocatable components. */
8308 298 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8309 612 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8310 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8311 :
8312 351 : if (scalar_res_outside_loop)
8313 : {
8314 : /* Go through the ss chain to find the argument and use
8315 : the stored value. */
8316 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8317 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8318 60 : if (tmp_ss->info
8319 48 : && tmp_ss->info->expr == e
8320 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8321 : {
8322 18 : tmp = tmp_ss->info->data.scalar.value;
8323 18 : break;
8324 : }
8325 : }
8326 :
8327 351 : STRIP_NOPS (tmp);
8328 :
8329 351 : if (derived_array != NULL_TREE)
8330 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8331 : derived_array,
8332 : parm_rank);
8333 351 : else if ((e->ts.type == BT_CLASS
8334 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8335 351 : || e->ts.type == BT_DERIVED)
8336 351 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8337 : parm_rank, 0, true);
8338 0 : else if (e->ts.type == BT_CLASS)
8339 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8340 : tmp, parm_rank);
8341 :
8342 351 : if (scalar_res_outside_loop)
8343 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8344 : else
8345 321 : gfc_prepend_expr_to_block (&post, tmp);
8346 : }
8347 : }
8348 :
8349 : /* Add argument checking of passing an unallocated/NULL actual to
8350 : a nonallocatable/nonpointer dummy. */
8351 :
8352 270871 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8353 : {
8354 6546 : symbol_attribute attr;
8355 6546 : char *msg;
8356 6546 : tree cond;
8357 6546 : tree tmp;
8358 6546 : symbol_attribute fsym_attr;
8359 :
8360 6546 : if (fsym)
8361 : {
8362 6385 : if (fsym->ts.type == BT_CLASS)
8363 : {
8364 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8365 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8366 : }
8367 : else
8368 6064 : fsym_attr = fsym->attr;
8369 : }
8370 :
8371 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8372 4094 : attr = gfc_expr_attr (e);
8373 : else
8374 6081 : goto end_pointer_check;
8375 :
8376 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8377 : allocatable to an optional dummy, cf. 12.5.2.12. */
8378 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8379 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8380 1032 : goto end_pointer_check;
8381 :
8382 3062 : if (attr.optional)
8383 : {
8384 : /* If the actual argument is an optional pointer/allocatable and
8385 : the formal argument takes an nonpointer optional value,
8386 : it is invalid to pass a non-present argument on, even
8387 : though there is no technical reason for this in gfortran.
8388 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8389 60 : tree present, null_ptr, type;
8390 :
8391 60 : if (attr.allocatable
8392 0 : && (fsym == NULL || !fsym_attr.allocatable))
8393 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8394 : "allocated or not present",
8395 0 : e->symtree->n.sym->name);
8396 60 : else if (attr.pointer
8397 12 : && (fsym == NULL || !fsym_attr.pointer))
8398 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8399 : "associated or not present",
8400 12 : e->symtree->n.sym->name);
8401 48 : else if (attr.proc_pointer && !e->value.function.actual
8402 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8403 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8404 : "associated or not present",
8405 0 : e->symtree->n.sym->name);
8406 : else
8407 48 : goto end_pointer_check;
8408 :
8409 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8410 12 : type = TREE_TYPE (present);
8411 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8412 : logical_type_node, present,
8413 : fold_convert (type,
8414 : null_pointer_node));
8415 12 : type = TREE_TYPE (parmse.expr);
8416 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8417 : logical_type_node, parmse.expr,
8418 : fold_convert (type,
8419 : null_pointer_node));
8420 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8421 : logical_type_node, present, null_ptr);
8422 : }
8423 : else
8424 : {
8425 3002 : if (attr.allocatable
8426 256 : && (fsym == NULL || !fsym_attr.allocatable))
8427 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8428 190 : "allocated", e->symtree->n.sym->name);
8429 2812 : else if (attr.pointer
8430 272 : && (fsym == NULL || !fsym_attr.pointer))
8431 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8432 184 : "associated", e->symtree->n.sym->name);
8433 2628 : else if (attr.proc_pointer && !e->value.function.actual
8434 80 : && (fsym == NULL
8435 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8436 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8437 79 : "associated", e->symtree->n.sym->name);
8438 : else
8439 2549 : goto end_pointer_check;
8440 :
8441 453 : tmp = parmse.expr;
8442 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8443 : {
8444 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8445 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8446 76 : tmp = gfc_class_data_get (tmp);
8447 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8448 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8449 : }
8450 :
8451 : /* If the argument is passed by value, we need to strip the
8452 : INDIRECT_REF. */
8453 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8454 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8455 :
8456 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8457 : logical_type_node, tmp,
8458 453 : fold_convert (TREE_TYPE (tmp),
8459 : null_pointer_node));
8460 : }
8461 :
8462 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8463 : msg);
8464 465 : free (msg);
8465 : }
8466 264325 : end_pointer_check:
8467 :
8468 : /* Deferred length dummies pass the character length by reference
8469 : so that the value can be returned. */
8470 270871 : if (parmse.string_length && fsym && fsym->ts.deferred)
8471 : {
8472 795 : if (INDIRECT_REF_P (parmse.string_length))
8473 : {
8474 : /* In chains of functions/procedure calls the string_length already
8475 : is a pointer to the variable holding the length. Therefore
8476 : remove the deref on call. */
8477 90 : tmp = parmse.string_length;
8478 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8479 : }
8480 : else
8481 : {
8482 705 : tmp = parmse.string_length;
8483 705 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8484 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8485 705 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8486 : }
8487 :
8488 795 : if (e && e->expr_type == EXPR_VARIABLE
8489 638 : && fsym->attr.allocatable
8490 368 : && e->ts.u.cl->backend_decl
8491 368 : && VAR_P (e->ts.u.cl->backend_decl))
8492 : {
8493 284 : if (INDIRECT_REF_P (tmp))
8494 0 : tmp = TREE_OPERAND (tmp, 0);
8495 284 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8496 : fold_convert (gfc_charlen_type_node, tmp));
8497 : }
8498 : }
8499 :
8500 : /* Character strings are passed as two parameters, a length and a
8501 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8502 : An unlimited polymorphic formal argument likewise does not
8503 : need the length. */
8504 270871 : if (parmse.string_length != NULL_TREE
8505 36887 : && !sym->attr.is_bind_c
8506 36191 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8507 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8508 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8509 30307 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8510 30198 : && !(fsym && UNLIMITED_POLY (fsym)))
8511 35901 : vec_safe_push (stringargs, parmse.string_length);
8512 :
8513 : /* When calling __copy for character expressions to unlimited
8514 : polymorphic entities, the dst argument needs a string length. */
8515 51897 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8516 5325 : && startswith (sym->name, "__vtab_CHARACTER")
8517 0 : && arg->next && arg->next->expr
8518 0 : && (arg->next->expr->ts.type == BT_DERIVED
8519 0 : || arg->next->expr->ts.type == BT_CLASS)
8520 270871 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8521 0 : vec_safe_push (stringargs, parmse.string_length);
8522 :
8523 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8524 : pass the token and the offset as additional arguments. */
8525 270871 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8526 122 : && attr->codimension && !attr->allocatable)
8527 : {
8528 : /* Token and offset. */
8529 5 : vec_safe_push (stringargs, null_pointer_node);
8530 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8531 5 : gcc_assert (fsym->attr.optional);
8532 : }
8533 237912 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8534 145 : && !attr->allocatable)
8535 : {
8536 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8537 123 : tree offset, tmp2;
8538 :
8539 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8540 123 : caf_type = TREE_TYPE (caf_decl);
8541 123 : if (POINTER_TYPE_P (caf_type)
8542 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8543 3 : caf_desc = TREE_TYPE (caf_type);
8544 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8545 : caf_desc = caf_type;
8546 :
8547 51 : if (caf_desc
8548 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8549 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8550 : {
8551 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8552 54 : ? build_fold_indirect_ref (caf_decl)
8553 : : caf_decl;
8554 51 : tmp = gfc_conv_descriptor_token (tmp);
8555 : }
8556 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8557 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8558 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8559 : else
8560 : {
8561 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8562 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8563 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8564 : }
8565 :
8566 123 : vec_safe_push (stringargs, tmp);
8567 :
8568 123 : if (caf_desc
8569 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8570 51 : offset = build_int_cst (gfc_array_index_type, 0);
8571 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8572 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8573 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8574 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8575 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8576 : else
8577 60 : offset = build_int_cst (gfc_array_index_type, 0);
8578 :
8579 123 : if (caf_desc)
8580 : {
8581 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8582 54 : ? build_fold_indirect_ref (caf_decl)
8583 : : caf_decl;
8584 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8585 : }
8586 : else
8587 : {
8588 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8589 72 : tmp = caf_decl;
8590 : }
8591 :
8592 108 : tmp2 = fsym->ts.type == BT_CLASS
8593 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8594 123 : if ((fsym->ts.type != BT_CLASS
8595 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8596 59 : || fsym->as->type == AS_ASSUMED_RANK))
8597 74 : || (fsym->ts.type == BT_CLASS
8598 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8599 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8600 : {
8601 54 : if (fsym->ts.type == BT_CLASS)
8602 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8603 : else
8604 : {
8605 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8606 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8607 : }
8608 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8609 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8610 : }
8611 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8612 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8613 : else
8614 : {
8615 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8616 : }
8617 :
8618 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8619 : gfc_array_index_type,
8620 : fold_convert (gfc_array_index_type, tmp2),
8621 : fold_convert (gfc_array_index_type, tmp));
8622 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8623 : gfc_array_index_type, offset, tmp);
8624 :
8625 123 : vec_safe_push (stringargs, offset);
8626 : }
8627 :
8628 270871 : vec_safe_push (arglist, parmse.expr);
8629 : }
8630 :
8631 130541 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8632 130541 : gfc_add_block_to_block (&se->pre, &clobbers);
8633 130541 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8634 :
8635 130541 : if (comp)
8636 1980 : ts = comp->ts;
8637 128561 : else if (sym->ts.type == BT_CLASS)
8638 851 : ts = CLASS_DATA (sym)->ts;
8639 : else
8640 127710 : ts = sym->ts;
8641 :
8642 130541 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8643 210 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8644 130331 : else if (ts.type == BT_CHARACTER)
8645 : {
8646 5021 : if (ts.u.cl->length == NULL)
8647 : {
8648 : /* Assumed character length results are not allowed by C418 of the 2003
8649 : standard and are trapped in resolve.cc; except in the case of SPREAD
8650 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8651 : we take the character length of the first argument for the result.
8652 : For dummies, we have to look through the formal argument list for
8653 : this function and use the character length found there.
8654 : Likewise, we handle the case of deferred-length character dummy
8655 : arguments to intrinsics that determine the characteristics of
8656 : the result, which cannot be deferred-length. */
8657 2309 : if (expr->value.function.isym)
8658 1703 : ts.deferred = false;
8659 2309 : if (ts.deferred)
8660 599 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8661 1710 : else if (!sym->attr.dummy)
8662 1703 : cl.backend_decl = (*stringargs)[0];
8663 : else
8664 : {
8665 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8666 26 : for (; formal; formal = formal->next)
8667 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8668 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8669 : }
8670 2309 : len = cl.backend_decl;
8671 : }
8672 : else
8673 : {
8674 2712 : tree tmp;
8675 :
8676 : /* Calculate the length of the returned string. */
8677 2712 : gfc_init_se (&parmse, NULL);
8678 2712 : if (need_interface_mapping)
8679 1867 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8680 : else
8681 845 : gfc_conv_expr (&parmse, ts.u.cl->length);
8682 2712 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8683 2712 : gfc_add_block_to_block (&se->post, &parmse.post);
8684 2712 : tmp = parmse.expr;
8685 : /* TODO: It would be better to have the charlens as
8686 : gfc_charlen_type_node already when the interface is
8687 : created instead of converting it here (see PR 84615). */
8688 2712 : tmp = fold_build2_loc (input_location, MAX_EXPR,
8689 : gfc_charlen_type_node,
8690 : fold_convert (gfc_charlen_type_node, tmp),
8691 : build_zero_cst (gfc_charlen_type_node));
8692 2712 : cl.backend_decl = tmp;
8693 : }
8694 :
8695 : /* Set up a charlen structure for it. */
8696 5021 : cl.next = NULL;
8697 5021 : cl.length = NULL;
8698 5021 : ts.u.cl = &cl;
8699 :
8700 5021 : len = cl.backend_decl;
8701 : }
8702 :
8703 1980 : byref = (comp && (comp->attr.dimension
8704 1911 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
8705 130541 : || (!comp && gfc_return_by_reference (sym));
8706 :
8707 18792 : if (byref)
8708 : {
8709 18792 : if (se->direct_byref)
8710 : {
8711 : /* Sometimes, too much indirection can be applied; e.g. for
8712 : function_result = array_valued_recursive_function. */
8713 6999 : if (TREE_TYPE (TREE_TYPE (se->expr))
8714 6999 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
8715 7017 : && GFC_DESCRIPTOR_TYPE_P
8716 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
8717 18 : se->expr = build_fold_indirect_ref_loc (input_location,
8718 : se->expr);
8719 :
8720 : /* If the lhs of an assignment x = f(..) is allocatable and
8721 : f2003 is allowed, we must do the automatic reallocation.
8722 : TODO - deal with intrinsics, without using a temporary. */
8723 6999 : if (flag_realloc_lhs
8724 6924 : && se->ss && se->ss->loop_chain
8725 203 : && se->ss->loop_chain->is_alloc_lhs
8726 203 : && !expr->value.function.isym
8727 203 : && sym->result->as != NULL)
8728 : {
8729 : /* Evaluate the bounds of the result, if known. */
8730 203 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
8731 : sym->result->as);
8732 :
8733 : /* Perform the automatic reallocation. */
8734 203 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
8735 : expr, NULL);
8736 203 : gfc_add_expr_to_block (&se->pre, tmp);
8737 :
8738 : /* Pass the temporary as the first argument. */
8739 203 : result = info->descriptor;
8740 : }
8741 : else
8742 6796 : result = build_fold_indirect_ref_loc (input_location,
8743 : se->expr);
8744 6999 : vec_safe_push (retargs, se->expr);
8745 : }
8746 11793 : else if (comp && comp->attr.dimension)
8747 : {
8748 66 : gcc_assert (se->loop && info);
8749 :
8750 : /* Set the type of the array. vtable charlens are not always reliable.
8751 : Use the interface, if possible. */
8752 66 : if (comp->ts.type == BT_CHARACTER
8753 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
8754 1 : && comp->ts.interface && comp->ts.interface->result)
8755 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
8756 : else
8757 65 : tmp = gfc_typenode_for_spec (&comp->ts);
8758 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
8759 :
8760 : /* Evaluate the bounds of the result, if known. */
8761 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
8762 :
8763 : /* If the lhs of an assignment x = f(..) is allocatable and
8764 : f2003 is allowed, we must not generate the function call
8765 : here but should just send back the results of the mapping.
8766 : This is signalled by the function ss being flagged. */
8767 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8768 : {
8769 0 : gfc_free_interface_mapping (&mapping);
8770 0 : return has_alternate_specifier;
8771 : }
8772 :
8773 : /* Create a temporary to store the result. In case the function
8774 : returns a pointer, the temporary will be a shallow copy and
8775 : mustn't be deallocated. */
8776 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
8777 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8778 : tmp, NULL_TREE, false,
8779 : !comp->attr.pointer, callee_alloc,
8780 66 : &se->ss->info->expr->where);
8781 :
8782 : /* Pass the temporary as the first argument. */
8783 66 : result = info->descriptor;
8784 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8785 66 : vec_safe_push (retargs, tmp);
8786 : }
8787 11498 : else if (!comp && sym->result->attr.dimension)
8788 : {
8789 8468 : gcc_assert (se->loop && info);
8790 :
8791 : /* Set the type of the array. */
8792 8468 : tmp = gfc_typenode_for_spec (&ts);
8793 8468 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
8794 8468 : gcc_assert (se->ss->dimen == se->loop->dimen);
8795 :
8796 : /* Evaluate the bounds of the result, if known. */
8797 8468 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
8798 :
8799 : /* If the lhs of an assignment x = f(..) is allocatable and
8800 : f2003 is allowed, we must not generate the function call
8801 : here but should just send back the results of the mapping.
8802 : This is signalled by the function ss being flagged. */
8803 8468 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8804 : {
8805 0 : gfc_free_interface_mapping (&mapping);
8806 0 : return has_alternate_specifier;
8807 : }
8808 :
8809 : /* Create a temporary to store the result. In case the function
8810 : returns a pointer, the temporary will be a shallow copy and
8811 : mustn't be deallocated. */
8812 8468 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
8813 8468 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8814 : tmp, NULL_TREE, false,
8815 : !sym->attr.pointer, callee_alloc,
8816 8468 : &se->ss->info->expr->where);
8817 :
8818 : /* Pass the temporary as the first argument. */
8819 8468 : result = info->descriptor;
8820 8468 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8821 8468 : vec_safe_push (retargs, tmp);
8822 : }
8823 3259 : else if (ts.type == BT_CHARACTER)
8824 : {
8825 : /* Pass the string length. */
8826 3198 : type = gfc_get_character_type (ts.kind, ts.u.cl);
8827 3198 : type = build_pointer_type (type);
8828 :
8829 : /* Emit a DECL_EXPR for the VLA type. */
8830 3198 : tmp = TREE_TYPE (type);
8831 3198 : if (TYPE_SIZE (tmp)
8832 3198 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
8833 : {
8834 1929 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
8835 1929 : DECL_ARTIFICIAL (tmp) = 1;
8836 1929 : DECL_IGNORED_P (tmp) = 1;
8837 1929 : tmp = fold_build1_loc (input_location, DECL_EXPR,
8838 1929 : TREE_TYPE (tmp), tmp);
8839 1929 : gfc_add_expr_to_block (&se->pre, tmp);
8840 : }
8841 :
8842 : /* Return an address to a char[0:len-1]* temporary for
8843 : character pointers. */
8844 3198 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8845 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8846 : {
8847 642 : var = gfc_create_var (type, "pstr");
8848 :
8849 642 : if ((!comp && sym->attr.allocatable)
8850 21 : || (comp && comp->attr.allocatable))
8851 : {
8852 355 : gfc_add_modify (&se->pre, var,
8853 355 : fold_convert (TREE_TYPE (var),
8854 : null_pointer_node));
8855 355 : tmp = gfc_call_free (var);
8856 355 : gfc_add_expr_to_block (&se->post, tmp);
8857 : }
8858 :
8859 : /* Provide an address expression for the function arguments. */
8860 642 : var = gfc_build_addr_expr (NULL_TREE, var);
8861 : }
8862 : else
8863 2556 : var = gfc_conv_string_tmp (se, type, len);
8864 :
8865 3198 : vec_safe_push (retargs, var);
8866 : }
8867 : else
8868 : {
8869 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
8870 :
8871 61 : type = gfc_get_complex_type (ts.kind);
8872 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
8873 61 : vec_safe_push (retargs, var);
8874 : }
8875 :
8876 : /* Add the string length to the argument list. */
8877 18792 : if (ts.type == BT_CHARACTER && ts.deferred)
8878 : {
8879 599 : tmp = len;
8880 599 : if (!VAR_P (tmp))
8881 0 : tmp = gfc_evaluate_now (len, &se->pre);
8882 599 : TREE_STATIC (tmp) = 1;
8883 599 : gfc_add_modify (&se->pre, tmp,
8884 599 : build_int_cst (TREE_TYPE (tmp), 0));
8885 599 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8886 599 : vec_safe_push (retargs, tmp);
8887 : }
8888 18193 : else if (ts.type == BT_CHARACTER)
8889 4422 : vec_safe_push (retargs, len);
8890 : }
8891 :
8892 130541 : gfc_free_interface_mapping (&mapping);
8893 :
8894 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
8895 243017 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
8896 155885 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
8897 130541 : vec_safe_reserve (retargs, arglen);
8898 :
8899 : /* Add the return arguments. */
8900 130541 : vec_safe_splice (retargs, arglist);
8901 :
8902 : /* Add the hidden present status for optional+value to the arguments. */
8903 130541 : vec_safe_splice (retargs, optionalargs);
8904 :
8905 : /* Add the hidden string length parameters to the arguments. */
8906 130541 : vec_safe_splice (retargs, stringargs);
8907 :
8908 : /* We may want to append extra arguments here. This is used e.g. for
8909 : calls to libgfortran_matmul_??, which need extra information. */
8910 130541 : vec_safe_splice (retargs, append_args);
8911 :
8912 130541 : arglist = retargs;
8913 :
8914 : /* Generate the actual call. */
8915 130541 : is_builtin = false;
8916 130541 : if (base_object == NULL_TREE)
8917 130461 : conv_function_val (se, &is_builtin, sym, expr, args);
8918 : else
8919 80 : conv_base_obj_fcn_val (se, base_object, expr);
8920 :
8921 : /* If there are alternate return labels, function type should be
8922 : integer. Can't modify the type in place though, since it can be shared
8923 : with other functions. For dummy arguments, the typing is done to
8924 : this result, even if it has to be repeated for each call. */
8925 130541 : if (has_alternate_specifier
8926 130541 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
8927 : {
8928 7 : if (!sym->attr.dummy)
8929 : {
8930 0 : TREE_TYPE (sym->backend_decl)
8931 0 : = build_function_type (integer_type_node,
8932 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
8933 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
8934 : }
8935 : else
8936 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
8937 : }
8938 :
8939 130541 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
8940 130541 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
8941 :
8942 130541 : if (is_builtin)
8943 559 : se->expr = update_builtin_function (se->expr, sym);
8944 :
8945 : /* Allocatable scalar function results must be freed and nullified
8946 : after use. This necessitates the creation of a temporary to
8947 : hold the result to prevent duplicate calls. */
8948 130541 : symbol_attribute attr = comp ? comp->attr : sym->attr;
8949 130541 : bool allocatable = attr.allocatable && !attr.dimension;
8950 133851 : gfc_symbol *der = comp ?
8951 1980 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
8952 : :
8953 128561 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
8954 3310 : bool finalizable = der != NULL && der->ns->proc_name
8955 6617 : && gfc_is_finalizable (der, NULL);
8956 :
8957 130541 : if (!byref && finalizable)
8958 182 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8959 :
8960 130541 : if (!byref && sym->ts.type != BT_CHARACTER
8961 111539 : && allocatable && !finalizable)
8962 : {
8963 230 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
8964 230 : gfc_add_modify (&se->pre, tmp, se->expr);
8965 230 : se->expr = tmp;
8966 230 : tmp = gfc_call_free (tmp);
8967 230 : gfc_add_expr_to_block (&post, tmp);
8968 230 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
8969 : }
8970 :
8971 : /* If we have a pointer function, but we don't want a pointer, e.g.
8972 : something like
8973 : x = f()
8974 : where f is pointer valued, we have to dereference the result. */
8975 130541 : if (!se->want_pointer && !byref
8976 111147 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8977 1638 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
8978 456 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8979 :
8980 : /* f2c calling conventions require a scalar default real function to
8981 : return a double precision result. Convert this back to default
8982 : real. We only care about the cases that can happen in Fortran 77.
8983 : */
8984 130541 : if (flag_f2c && sym->ts.type == BT_REAL
8985 98 : && sym->ts.kind == gfc_default_real_kind
8986 74 : && !sym->attr.pointer
8987 55 : && !sym->attr.allocatable
8988 43 : && !sym->attr.always_explicit)
8989 43 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
8990 :
8991 : /* A pure function may still have side-effects - it may modify its
8992 : parameters. */
8993 130541 : TREE_SIDE_EFFECTS (se->expr) = 1;
8994 : #if 0
8995 : if (!sym->attr.pure)
8996 : TREE_SIDE_EFFECTS (se->expr) = 1;
8997 : #endif
8998 :
8999 130541 : if (byref)
9000 : {
9001 : /* Add the function call to the pre chain. There is no expression. */
9002 18792 : gfc_add_expr_to_block (&se->pre, se->expr);
9003 18792 : se->expr = NULL_TREE;
9004 :
9005 18792 : if (!se->direct_byref)
9006 : {
9007 11793 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
9008 : {
9009 8534 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
9010 : {
9011 : /* Check the data pointer hasn't been modified. This would
9012 : happen in a function returning a pointer. */
9013 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9014 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
9015 : logical_type_node,
9016 : tmp, info->data);
9017 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
9018 : gfc_msg_fault);
9019 : }
9020 8534 : se->expr = info->descriptor;
9021 : /* Bundle in the string length. */
9022 8534 : se->string_length = len;
9023 :
9024 8534 : if (finalizable)
9025 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9026 : }
9027 3259 : else if (ts.type == BT_CHARACTER)
9028 : {
9029 : /* Dereference for character pointer results. */
9030 3198 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9031 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9032 642 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9033 : else
9034 2556 : se->expr = var;
9035 :
9036 3198 : se->string_length = len;
9037 : }
9038 : else
9039 : {
9040 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
9041 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9042 : }
9043 : }
9044 : }
9045 :
9046 : /* Associate the rhs class object's meta-data with the result, when the
9047 : result is a temporary. */
9048 112481 : if (args && args->expr && args->expr->ts.type == BT_CLASS
9049 4961 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
9050 130573 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
9051 : {
9052 32 : gfc_se parmse;
9053 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
9054 :
9055 32 : gfc_init_se (&parmse, NULL);
9056 32 : parmse.data_not_needed = 1;
9057 32 : gfc_conv_expr (&parmse, class_expr);
9058 32 : if (!DECL_LANG_SPECIFIC (result))
9059 32 : gfc_allocate_lang_decl (result);
9060 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
9061 32 : gfc_free_expr (class_expr);
9062 : /* -fcheck= can add diagnostic code, which has to be placed before
9063 : the call. */
9064 32 : if (parmse.pre.head != NULL)
9065 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
9066 32 : gcc_assert (parmse.post.head == NULL_TREE);
9067 : }
9068 :
9069 : /* Follow the function call with the argument post block. */
9070 130541 : if (byref)
9071 : {
9072 : /* Transformational functions of derived types with allocatable
9073 : components must have the result allocatable components copied
9074 : BEFORE the argument post block is appended. Copying the result
9075 : first, then freeing the argument, gives the correct order. */
9076 18792 : arg = expr->value.function.actual;
9077 18792 : if (result && arg && expr->rank
9078 14686 : && isym && isym->transformational
9079 13105 : && isym->id != GFC_ISYM_REDUCE
9080 12979 : && arg->expr
9081 12919 : && arg->expr->ts.type == BT_DERIVED
9082 241 : && arg->expr->ts.u.derived->attr.alloc_comp)
9083 : {
9084 48 : tree tmp2;
9085 : /* Copy the allocatable components. We have to use a
9086 : temporary here to prevent source allocatable components
9087 : from being corrupted. */
9088 48 : tmp2 = gfc_evaluate_now (result, &se->pre);
9089 48 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
9090 : result, tmp2, expr->rank, 0);
9091 48 : gfc_add_expr_to_block (&se->pre, tmp);
9092 48 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
9093 : expr->rank);
9094 48 : gfc_add_expr_to_block (&se->pre, tmp);
9095 :
9096 : /* Finally free the temporary's data field. */
9097 48 : tmp = gfc_conv_descriptor_data_get (tmp2);
9098 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9099 : NULL_TREE, NULL_TREE, true,
9100 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9101 48 : gfc_add_expr_to_block (&se->pre, tmp);
9102 : }
9103 :
9104 18792 : gfc_add_block_to_block (&se->pre, &post);
9105 : }
9106 : else
9107 : {
9108 : /* For a function with a class array result, save the result as
9109 : a temporary, set the info fields needed by the scalarizer and
9110 : call the finalization function of the temporary. Note that the
9111 : nullification of allocatable components needed by the result
9112 : is done in gfc_trans_assignment_1. */
9113 34763 : if (expr && (gfc_is_class_array_function (expr)
9114 34441 : || gfc_is_alloc_class_scalar_function (expr))
9115 841 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9116 112578 : && expr->must_finalize)
9117 : {
9118 : /* TODO Eliminate the doubling of temporaries. This
9119 : one is necessary to ensure no memory leakage. */
9120 321 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9121 :
9122 : /* Finalize the result, if necessary. */
9123 642 : attr = expr->value.function.esym
9124 321 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9125 14 : : CLASS_DATA (expr)->attr;
9126 321 : if (!((gfc_is_class_array_function (expr)
9127 108 : || gfc_is_alloc_class_scalar_function (expr))
9128 321 : && attr.pointer))
9129 276 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9130 : }
9131 111749 : gfc_add_block_to_block (&se->post, &post);
9132 : }
9133 :
9134 : return has_alternate_specifier;
9135 : }
9136 :
9137 :
9138 : /* Fill a character string with spaces. */
9139 :
9140 : static tree
9141 30631 : fill_with_spaces (tree start, tree type, tree size)
9142 : {
9143 30631 : stmtblock_t block, loop;
9144 30631 : tree i, el, exit_label, cond, tmp;
9145 :
9146 : /* For a simple char type, we can call memset(). */
9147 30631 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9148 50674 : return build_call_expr_loc (input_location,
9149 : builtin_decl_explicit (BUILT_IN_MEMSET),
9150 : 3, start,
9151 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9152 25337 : lang_hooks.to_target_charset (' ')),
9153 : fold_convert (size_type_node, size));
9154 :
9155 : /* Otherwise, we use a loop:
9156 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9157 : *el = (type) ' ';
9158 : */
9159 :
9160 : /* Initialize variables. */
9161 5294 : gfc_init_block (&block);
9162 5294 : i = gfc_create_var (sizetype, "i");
9163 5294 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9164 5294 : el = gfc_create_var (build_pointer_type (type), "el");
9165 5294 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9166 5294 : exit_label = gfc_build_label_decl (NULL_TREE);
9167 5294 : TREE_USED (exit_label) = 1;
9168 :
9169 :
9170 : /* Loop body. */
9171 5294 : gfc_init_block (&loop);
9172 :
9173 : /* Exit condition. */
9174 5294 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9175 : build_zero_cst (sizetype));
9176 5294 : tmp = build1_v (GOTO_EXPR, exit_label);
9177 5294 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9178 : build_empty_stmt (input_location));
9179 5294 : gfc_add_expr_to_block (&loop, tmp);
9180 :
9181 : /* Assignment. */
9182 5294 : gfc_add_modify (&loop,
9183 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9184 5294 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9185 :
9186 : /* Increment loop variables. */
9187 5294 : gfc_add_modify (&loop, i,
9188 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9189 5294 : TYPE_SIZE_UNIT (type)));
9190 5294 : gfc_add_modify (&loop, el,
9191 : fold_build_pointer_plus_loc (input_location,
9192 5294 : el, TYPE_SIZE_UNIT (type)));
9193 :
9194 : /* Making the loop... actually loop! */
9195 5294 : tmp = gfc_finish_block (&loop);
9196 5294 : tmp = build1_v (LOOP_EXPR, tmp);
9197 5294 : gfc_add_expr_to_block (&block, tmp);
9198 :
9199 : /* The exit label. */
9200 5294 : tmp = build1_v (LABEL_EXPR, exit_label);
9201 5294 : gfc_add_expr_to_block (&block, tmp);
9202 :
9203 :
9204 5294 : return gfc_finish_block (&block);
9205 : }
9206 :
9207 :
9208 : /* Generate code to copy a string. */
9209 :
9210 : void
9211 35793 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9212 : int dkind, tree slength, tree src, int skind)
9213 : {
9214 35793 : tree tmp, dlen, slen;
9215 35793 : tree dsc;
9216 35793 : tree ssc;
9217 35793 : tree cond;
9218 35793 : tree cond2;
9219 35793 : tree tmp2;
9220 35793 : tree tmp3;
9221 35793 : tree tmp4;
9222 35793 : tree chartype;
9223 35793 : stmtblock_t tempblock;
9224 :
9225 35793 : gcc_assert (dkind == skind);
9226 :
9227 35793 : if (slength != NULL_TREE)
9228 : {
9229 35793 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9230 35793 : ssc = gfc_string_to_single_character (slen, src, skind);
9231 : }
9232 : else
9233 : {
9234 0 : slen = build_one_cst (gfc_charlen_type_node);
9235 0 : ssc = src;
9236 : }
9237 :
9238 35793 : if (dlength != NULL_TREE)
9239 : {
9240 35793 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9241 35793 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9242 : }
9243 : else
9244 : {
9245 0 : dlen = build_one_cst (gfc_charlen_type_node);
9246 0 : dsc = dest;
9247 : }
9248 :
9249 : /* Assign directly if the types are compatible. */
9250 35793 : if (dsc != NULL_TREE && ssc != NULL_TREE
9251 35793 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9252 : {
9253 5162 : gfc_add_modify (block, dsc, ssc);
9254 5162 : return;
9255 : }
9256 :
9257 : /* The string copy algorithm below generates code like
9258 :
9259 : if (destlen > 0)
9260 : {
9261 : if (srclen < destlen)
9262 : {
9263 : memmove (dest, src, srclen);
9264 : // Pad with spaces.
9265 : memset (&dest[srclen], ' ', destlen - srclen);
9266 : }
9267 : else
9268 : {
9269 : // Truncate if too long.
9270 : memmove (dest, src, destlen);
9271 : }
9272 : }
9273 : */
9274 :
9275 : /* Do nothing if the destination length is zero. */
9276 30631 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9277 30631 : build_zero_cst (TREE_TYPE (dlen)));
9278 :
9279 : /* For non-default character kinds, we have to multiply the string
9280 : length by the base type size. */
9281 30631 : chartype = gfc_get_char_type (dkind);
9282 30631 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9283 : slen,
9284 30631 : fold_convert (TREE_TYPE (slen),
9285 : TYPE_SIZE_UNIT (chartype)));
9286 30631 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9287 : dlen,
9288 30631 : fold_convert (TREE_TYPE (dlen),
9289 : TYPE_SIZE_UNIT (chartype)));
9290 :
9291 30631 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9292 30583 : dest = fold_convert (pvoid_type_node, dest);
9293 : else
9294 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9295 :
9296 30631 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9297 30627 : src = fold_convert (pvoid_type_node, src);
9298 : else
9299 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9300 :
9301 : /* Truncate string if source is too long. */
9302 30631 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9303 : dlen);
9304 :
9305 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9306 30631 : if (!CONSTANT_CLASS_P (cond2))
9307 : {
9308 9385 : dest = gfc_evaluate_now (dest, block);
9309 9385 : src = gfc_evaluate_now (src, block);
9310 : }
9311 :
9312 : /* Copy and pad with spaces. */
9313 30631 : tmp3 = build_call_expr_loc (input_location,
9314 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9315 : 3, dest, src,
9316 : fold_convert (size_type_node, slen));
9317 :
9318 : /* Wstringop-overflow appears at -O3 even though this warning is not
9319 : explicitly available in fortran nor can it be switched off. If the
9320 : source length is a constant, its negative appears as a very large
9321 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9322 : the result of the MINUS_EXPR suppresses this spurious warning. */
9323 30631 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9324 30631 : TREE_TYPE(dlen), dlen, slen);
9325 30631 : if (slength && TREE_CONSTANT (slength))
9326 27106 : tmp = gfc_evaluate_now (tmp, block);
9327 :
9328 30631 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9329 30631 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9330 :
9331 30631 : gfc_init_block (&tempblock);
9332 30631 : gfc_add_expr_to_block (&tempblock, tmp3);
9333 30631 : gfc_add_expr_to_block (&tempblock, tmp4);
9334 30631 : tmp3 = gfc_finish_block (&tempblock);
9335 :
9336 : /* The truncated memmove if the slen >= dlen. */
9337 30631 : tmp2 = build_call_expr_loc (input_location,
9338 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9339 : 3, dest, src,
9340 : fold_convert (size_type_node, dlen));
9341 :
9342 : /* The whole copy_string function is there. */
9343 30631 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9344 : tmp3, tmp2);
9345 30631 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9346 : build_empty_stmt (input_location));
9347 30631 : gfc_add_expr_to_block (block, tmp);
9348 : }
9349 :
9350 :
9351 : /* Translate a statement function.
9352 : The value of a statement function reference is obtained by evaluating the
9353 : expression using the values of the actual arguments for the values of the
9354 : corresponding dummy arguments. */
9355 :
9356 : static void
9357 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9358 : {
9359 269 : gfc_symbol *sym;
9360 269 : gfc_symbol *fsym;
9361 269 : gfc_formal_arglist *fargs;
9362 269 : gfc_actual_arglist *args;
9363 269 : gfc_se lse;
9364 269 : gfc_se rse;
9365 269 : gfc_saved_var *saved_vars;
9366 269 : tree *temp_vars;
9367 269 : tree type;
9368 269 : tree tmp;
9369 269 : int n;
9370 :
9371 269 : sym = expr->symtree->n.sym;
9372 269 : args = expr->value.function.actual;
9373 269 : gfc_init_se (&lse, NULL);
9374 269 : gfc_init_se (&rse, NULL);
9375 :
9376 269 : n = 0;
9377 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9378 458 : n++;
9379 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9380 269 : temp_vars = XCNEWVEC (tree, n);
9381 :
9382 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9383 458 : fargs = fargs->next, n++)
9384 : {
9385 : /* Each dummy shall be specified, explicitly or implicitly, to be
9386 : scalar. */
9387 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9388 458 : fsym = fargs->sym;
9389 :
9390 458 : if (fsym->ts.type == BT_CHARACTER)
9391 : {
9392 : /* Copy string arguments. */
9393 48 : tree arglen;
9394 :
9395 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9396 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9397 :
9398 : /* Create a temporary to hold the value. */
9399 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9400 1 : fsym->ts.u.cl->backend_decl
9401 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9402 :
9403 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9404 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9405 :
9406 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9407 :
9408 48 : gfc_conv_expr (&rse, args->expr);
9409 48 : gfc_conv_string_parameter (&rse);
9410 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9411 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9412 :
9413 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9414 : rse.string_length, rse.expr, fsym->ts.kind);
9415 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9416 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9417 : }
9418 : else
9419 : {
9420 : /* For everything else, just evaluate the expression. */
9421 :
9422 : /* Create a temporary to hold the value. */
9423 410 : type = gfc_typenode_for_spec (&fsym->ts);
9424 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9425 :
9426 410 : gfc_conv_expr (&lse, args->expr);
9427 :
9428 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9429 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9430 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9431 : }
9432 :
9433 458 : args = args->next;
9434 : }
9435 :
9436 : /* Use the temporary variables in place of the real ones. */
9437 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9438 458 : fargs = fargs->next, n++)
9439 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9440 :
9441 269 : gfc_conv_expr (se, sym->value);
9442 :
9443 269 : if (sym->ts.type == BT_CHARACTER)
9444 : {
9445 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9446 :
9447 : /* Force the expression to the correct length. */
9448 55 : if (!INTEGER_CST_P (se->string_length)
9449 101 : || tree_int_cst_lt (se->string_length,
9450 46 : sym->ts.u.cl->backend_decl))
9451 : {
9452 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9453 31 : tmp = gfc_create_var (type, sym->name);
9454 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9455 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9456 : sym->ts.kind, se->string_length, se->expr,
9457 : sym->ts.kind);
9458 31 : se->expr = tmp;
9459 : }
9460 55 : se->string_length = sym->ts.u.cl->backend_decl;
9461 : }
9462 :
9463 : /* Restore the original variables. */
9464 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9465 458 : fargs = fargs->next, n++)
9466 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9467 269 : free (temp_vars);
9468 269 : free (saved_vars);
9469 269 : }
9470 :
9471 :
9472 : /* Translate a function expression. */
9473 :
9474 : static void
9475 311931 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9476 : {
9477 311931 : gfc_symbol *sym;
9478 :
9479 311931 : if (expr->value.function.isym)
9480 : {
9481 261375 : gfc_conv_intrinsic_function (se, expr);
9482 261375 : return;
9483 : }
9484 :
9485 : /* expr.value.function.esym is the resolved (specific) function symbol for
9486 : most functions. However this isn't set for dummy procedures. */
9487 50556 : sym = expr->value.function.esym;
9488 50556 : if (!sym)
9489 1616 : sym = expr->symtree->n.sym;
9490 :
9491 : /* The IEEE_ARITHMETIC functions are caught here. */
9492 50556 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9493 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9494 : return;
9495 :
9496 : /* We distinguish statement functions from general functions to improve
9497 : runtime performance. */
9498 38099 : if (sym->attr.proc == PROC_ST_FUNCTION)
9499 : {
9500 269 : gfc_conv_statement_function (se, expr);
9501 269 : return;
9502 : }
9503 :
9504 37830 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9505 : NULL);
9506 : }
9507 :
9508 :
9509 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9510 :
9511 : static bool
9512 39699 : is_zero_initializer_p (gfc_expr * expr)
9513 : {
9514 39699 : if (expr->expr_type != EXPR_CONSTANT)
9515 : return false;
9516 :
9517 : /* We ignore constants with prescribed memory representations for now. */
9518 11396 : if (expr->representation.string)
9519 : return false;
9520 :
9521 11378 : switch (expr->ts.type)
9522 : {
9523 5257 : case BT_INTEGER:
9524 5257 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9525 :
9526 4819 : case BT_REAL:
9527 4819 : return mpfr_zero_p (expr->value.real)
9528 4819 : && MPFR_SIGN (expr->value.real) >= 0;
9529 :
9530 925 : case BT_LOGICAL:
9531 925 : return expr->value.logical == 0;
9532 :
9533 243 : case BT_COMPLEX:
9534 243 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9535 155 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9536 155 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9537 386 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9538 :
9539 : default:
9540 : break;
9541 : }
9542 : return false;
9543 : }
9544 :
9545 :
9546 : static void
9547 35866 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9548 : {
9549 35866 : gfc_ss *ss;
9550 :
9551 35866 : ss = se->ss;
9552 35866 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9553 35866 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9554 :
9555 35866 : gfc_conv_tmp_array_ref (se);
9556 35866 : }
9557 :
9558 :
9559 : /* Build a static initializer. EXPR is the expression for the initial value.
9560 : The other parameters describe the variable of the component being
9561 : initialized. EXPR may be null. */
9562 :
9563 : tree
9564 142826 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9565 : bool array, bool pointer, bool procptr)
9566 : {
9567 142826 : gfc_se se;
9568 :
9569 142826 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9570 45459 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9571 171 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9572 59 : return build_constructor (type, NULL);
9573 :
9574 142767 : if (!(expr || pointer || procptr))
9575 : return NULL_TREE;
9576 :
9577 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9578 : (these are the only two iso_c_binding derived types that can be
9579 : used as initialization expressions). If so, we need to modify
9580 : the 'expr' to be that for a (void *). */
9581 134500 : if (expr != NULL && expr->ts.type == BT_DERIVED
9582 41359 : && expr->ts.is_iso_c && expr->ts.u.derived)
9583 : {
9584 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9585 4 : return build_constructor (type, NULL);
9586 182 : else if (POINTER_TYPE_P (type))
9587 182 : return build_int_cst (type, 0);
9588 : else
9589 0 : gcc_unreachable ();
9590 : }
9591 :
9592 134314 : if (array && !procptr)
9593 : {
9594 8675 : tree ctor;
9595 : /* Arrays need special handling. */
9596 8675 : if (pointer)
9597 776 : ctor = gfc_build_null_descriptor (type);
9598 : /* Special case assigning an array to zero. */
9599 7899 : else if (is_zero_initializer_p (expr))
9600 220 : ctor = build_constructor (type, NULL);
9601 : else
9602 7679 : ctor = gfc_conv_array_initializer (type, expr);
9603 8675 : TREE_STATIC (ctor) = 1;
9604 8675 : return ctor;
9605 : }
9606 125639 : else if (pointer || procptr)
9607 : {
9608 60747 : if (ts->type == BT_CLASS && !procptr)
9609 : {
9610 1762 : gfc_init_se (&se, NULL);
9611 1762 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9612 1762 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9613 1762 : TREE_STATIC (se.expr) = 1;
9614 1762 : return se.expr;
9615 : }
9616 58985 : else if (!expr || expr->expr_type == EXPR_NULL)
9617 31795 : return fold_convert (type, null_pointer_node);
9618 : else
9619 : {
9620 27190 : gfc_init_se (&se, NULL);
9621 27190 : se.want_pointer = 1;
9622 27190 : gfc_conv_expr (&se, expr);
9623 27190 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9624 : return se.expr;
9625 : }
9626 : }
9627 : else
9628 : {
9629 64892 : switch (ts->type)
9630 : {
9631 19325 : case_bt_struct:
9632 19325 : case BT_CLASS:
9633 19325 : gfc_init_se (&se, NULL);
9634 19325 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9635 761 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9636 : else
9637 18564 : gfc_conv_structure (&se, expr, 1);
9638 19325 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9639 19325 : TREE_STATIC (se.expr) = 1;
9640 19325 : return se.expr;
9641 :
9642 2699 : case BT_CHARACTER:
9643 2699 : if (expr->expr_type == EXPR_CONSTANT)
9644 : {
9645 2698 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9646 2698 : TREE_STATIC (ctor) = 1;
9647 2698 : return ctor;
9648 : }
9649 :
9650 : /* Fallthrough. */
9651 42869 : default:
9652 42869 : gfc_init_se (&se, NULL);
9653 42869 : gfc_conv_constant (&se, expr);
9654 42869 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9655 : return se.expr;
9656 : }
9657 : }
9658 : }
9659 :
9660 : static tree
9661 956 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9662 : {
9663 956 : gfc_se rse;
9664 956 : gfc_se lse;
9665 956 : gfc_ss *rss;
9666 956 : gfc_ss *lss;
9667 956 : gfc_array_info *lss_array;
9668 956 : stmtblock_t body;
9669 956 : stmtblock_t block;
9670 956 : gfc_loopinfo loop;
9671 956 : int n;
9672 956 : tree tmp;
9673 :
9674 956 : gfc_start_block (&block);
9675 :
9676 : /* Initialize the scalarizer. */
9677 956 : gfc_init_loopinfo (&loop);
9678 :
9679 956 : gfc_init_se (&lse, NULL);
9680 956 : gfc_init_se (&rse, NULL);
9681 :
9682 : /* Walk the rhs. */
9683 956 : rss = gfc_walk_expr (expr);
9684 956 : if (rss == gfc_ss_terminator)
9685 : /* The rhs is scalar. Add a ss for the expression. */
9686 208 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
9687 :
9688 : /* Create a SS for the destination. */
9689 956 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
9690 : GFC_SS_COMPONENT);
9691 956 : lss_array = &lss->info->data.array;
9692 956 : lss_array->shape = gfc_get_shape (cm->as->rank);
9693 956 : lss_array->descriptor = dest;
9694 956 : lss_array->data = gfc_conv_array_data (dest);
9695 956 : lss_array->offset = gfc_conv_array_offset (dest);
9696 1969 : for (n = 0; n < cm->as->rank; n++)
9697 : {
9698 1013 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
9699 1013 : lss_array->stride[n] = gfc_index_one_node;
9700 :
9701 1013 : mpz_init (lss_array->shape[n]);
9702 1013 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
9703 1013 : cm->as->lower[n]->value.integer);
9704 1013 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
9705 : }
9706 :
9707 : /* Associate the SS with the loop. */
9708 956 : gfc_add_ss_to_loop (&loop, lss);
9709 956 : gfc_add_ss_to_loop (&loop, rss);
9710 :
9711 : /* Calculate the bounds of the scalarization. */
9712 956 : gfc_conv_ss_startstride (&loop);
9713 :
9714 : /* Setup the scalarizing loops. */
9715 956 : gfc_conv_loop_setup (&loop, &expr->where);
9716 :
9717 : /* Setup the gfc_se structures. */
9718 956 : gfc_copy_loopinfo_to_se (&lse, &loop);
9719 956 : gfc_copy_loopinfo_to_se (&rse, &loop);
9720 :
9721 956 : rse.ss = rss;
9722 956 : gfc_mark_ss_chain_used (rss, 1);
9723 956 : lse.ss = lss;
9724 956 : gfc_mark_ss_chain_used (lss, 1);
9725 :
9726 : /* Start the scalarized loop body. */
9727 956 : gfc_start_scalarized_body (&loop, &body);
9728 :
9729 956 : gfc_conv_tmp_array_ref (&lse);
9730 956 : if (cm->ts.type == BT_CHARACTER)
9731 176 : lse.string_length = cm->ts.u.cl->backend_decl;
9732 :
9733 956 : gfc_conv_expr (&rse, expr);
9734 :
9735 956 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
9736 956 : gfc_add_expr_to_block (&body, tmp);
9737 :
9738 956 : gcc_assert (rse.ss == gfc_ss_terminator);
9739 :
9740 : /* Generate the copying loops. */
9741 956 : gfc_trans_scalarizing_loops (&loop, &body);
9742 :
9743 : /* Wrap the whole thing up. */
9744 956 : gfc_add_block_to_block (&block, &loop.pre);
9745 956 : gfc_add_block_to_block (&block, &loop.post);
9746 :
9747 956 : gcc_assert (lss_array->shape != NULL);
9748 956 : gfc_free_shape (&lss_array->shape, cm->as->rank);
9749 956 : gfc_cleanup_loop (&loop);
9750 :
9751 956 : return gfc_finish_block (&block);
9752 : }
9753 :
9754 :
9755 : static stmtblock_t *final_block;
9756 : static tree
9757 1292 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
9758 : gfc_expr * expr)
9759 : {
9760 1292 : gfc_se se;
9761 1292 : stmtblock_t block;
9762 1292 : tree offset;
9763 1292 : int n;
9764 1292 : tree tmp;
9765 1292 : tree tmp2;
9766 1292 : gfc_array_spec *as;
9767 1292 : gfc_expr *arg = NULL;
9768 :
9769 1292 : gfc_start_block (&block);
9770 1292 : gfc_init_se (&se, NULL);
9771 :
9772 : /* Get the descriptor for the expressions. */
9773 1292 : se.want_pointer = 0;
9774 1292 : gfc_conv_expr_descriptor (&se, expr);
9775 1292 : gfc_add_block_to_block (&block, &se.pre);
9776 1292 : gfc_add_modify (&block, dest, se.expr);
9777 1292 : if (cm->ts.type == BT_CHARACTER
9778 1292 : && gfc_deferred_strlen (cm, &tmp))
9779 : {
9780 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
9781 30 : TREE_TYPE (tmp),
9782 30 : TREE_OPERAND (dest, 0),
9783 : tmp, NULL_TREE);
9784 30 : gfc_add_modify (&block, tmp,
9785 30 : fold_convert (TREE_TYPE (tmp),
9786 : se.string_length));
9787 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
9788 : "slen");
9789 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
9790 : }
9791 :
9792 : /* Deal with arrays of derived types with allocatable components. */
9793 1292 : if (gfc_bt_struct (cm->ts.type)
9794 193 : && cm->ts.u.derived->attr.alloc_comp)
9795 : // TODO: Fix caf_mode
9796 107 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
9797 : se.expr, dest,
9798 107 : cm->as->rank, 0);
9799 1185 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
9800 36 : && CLASS_DATA(cm)->attr.allocatable)
9801 : {
9802 36 : if (cm->ts.u.derived->attr.alloc_comp)
9803 : // TODO: Fix caf_mode
9804 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
9805 : se.expr, dest,
9806 : expr->rank, 0);
9807 : else
9808 : {
9809 36 : tmp = TREE_TYPE (dest);
9810 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9811 : tmp, expr->rank, NULL_TREE);
9812 : }
9813 : }
9814 1149 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9815 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9816 : gfc_typenode_for_spec (&cm->ts),
9817 30 : cm->as->rank, NULL_TREE);
9818 : else
9819 1119 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9820 1119 : TREE_TYPE(cm->backend_decl),
9821 1119 : cm->as->rank, NULL_TREE);
9822 :
9823 :
9824 1292 : gfc_add_expr_to_block (&block, tmp);
9825 1292 : gfc_add_block_to_block (&block, &se.post);
9826 :
9827 1292 : if (final_block && !cm->attr.allocatable
9828 96 : && expr->expr_type == EXPR_ARRAY)
9829 : {
9830 96 : tree data_ptr;
9831 96 : data_ptr = gfc_conv_descriptor_data_get (dest);
9832 96 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
9833 96 : }
9834 1196 : else if (final_block && cm->attr.allocatable)
9835 162 : gfc_add_block_to_block (final_block, &se.finalblock);
9836 :
9837 1292 : if (expr->expr_type != EXPR_VARIABLE)
9838 1171 : gfc_conv_descriptor_data_set (&block, se.expr,
9839 : null_pointer_node);
9840 :
9841 : /* We need to know if the argument of a conversion function is a
9842 : variable, so that the correct lower bound can be used. */
9843 1292 : if (expr->expr_type == EXPR_FUNCTION
9844 56 : && expr->value.function.isym
9845 44 : && expr->value.function.isym->conversion
9846 44 : && expr->value.function.actual->expr
9847 44 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
9848 44 : arg = expr->value.function.actual->expr;
9849 :
9850 : /* Obtain the array spec of full array references. */
9851 44 : if (arg)
9852 44 : as = gfc_get_full_arrayspec_from_expr (arg);
9853 : else
9854 1248 : as = gfc_get_full_arrayspec_from_expr (expr);
9855 :
9856 : /* Shift the lbound and ubound of temporaries to being unity,
9857 : rather than zero, based. Always calculate the offset. */
9858 1292 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
9859 1292 : offset = gfc_conv_descriptor_offset_get (dest);
9860 1292 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
9861 :
9862 2640 : for (n = 0; n < expr->rank; n++)
9863 : {
9864 1348 : tree span;
9865 1348 : tree lbound;
9866 :
9867 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
9868 : TODO It looks as if gfc_conv_expr_descriptor should return
9869 : the correct bounds and that the following should not be
9870 : necessary. This would simplify gfc_conv_intrinsic_bound
9871 : as well. */
9872 1348 : if (as && as->lower[n])
9873 : {
9874 80 : gfc_se lbse;
9875 80 : gfc_init_se (&lbse, NULL);
9876 80 : gfc_conv_expr (&lbse, as->lower[n]);
9877 80 : gfc_add_block_to_block (&block, &lbse.pre);
9878 80 : lbound = gfc_evaluate_now (lbse.expr, &block);
9879 80 : }
9880 1268 : else if (as && arg)
9881 : {
9882 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
9883 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
9884 : gfc_rank_cst[n]);
9885 : }
9886 1234 : else if (as)
9887 64 : lbound = gfc_conv_descriptor_lbound_get (dest,
9888 : gfc_rank_cst[n]);
9889 : else
9890 1170 : lbound = gfc_index_one_node;
9891 :
9892 1348 : lbound = fold_convert (gfc_array_index_type, lbound);
9893 :
9894 : /* Shift the bounds and set the offset accordingly. */
9895 1348 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
9896 1348 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9897 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
9898 1348 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9899 : span, lbound);
9900 1348 : gfc_conv_descriptor_ubound_set (&block, dest,
9901 : gfc_rank_cst[n], tmp);
9902 1348 : gfc_conv_descriptor_lbound_set (&block, dest,
9903 : gfc_rank_cst[n], lbound);
9904 :
9905 1348 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9906 : gfc_conv_descriptor_lbound_get (dest,
9907 : gfc_rank_cst[n]),
9908 : gfc_conv_descriptor_stride_get (dest,
9909 : gfc_rank_cst[n]));
9910 1348 : gfc_add_modify (&block, tmp2, tmp);
9911 1348 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9912 : offset, tmp2);
9913 1348 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
9914 : }
9915 :
9916 1292 : if (arg)
9917 : {
9918 : /* If a conversion expression has a null data pointer
9919 : argument, nullify the allocatable component. */
9920 44 : tree non_null_expr;
9921 44 : tree null_expr;
9922 :
9923 44 : if (arg->symtree->n.sym->attr.allocatable
9924 12 : || arg->symtree->n.sym->attr.pointer)
9925 : {
9926 32 : non_null_expr = gfc_finish_block (&block);
9927 32 : gfc_start_block (&block);
9928 32 : gfc_conv_descriptor_data_set (&block, dest,
9929 : null_pointer_node);
9930 32 : null_expr = gfc_finish_block (&block);
9931 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
9932 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
9933 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9934 32 : return build3_v (COND_EXPR, tmp,
9935 : null_expr, non_null_expr);
9936 : }
9937 : }
9938 :
9939 1260 : return gfc_finish_block (&block);
9940 : }
9941 :
9942 :
9943 : /* Allocate or reallocate scalar component, as necessary. */
9944 :
9945 : static void
9946 410 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
9947 : gfc_component *cm, gfc_expr *expr2,
9948 : tree slen)
9949 : {
9950 410 : tree tmp;
9951 410 : tree ptr;
9952 410 : tree size;
9953 410 : tree size_in_bytes;
9954 410 : tree lhs_cl_size = NULL_TREE;
9955 410 : gfc_se se;
9956 :
9957 410 : if (!comp)
9958 0 : return;
9959 :
9960 410 : if (!expr2 || expr2->rank)
9961 : return;
9962 :
9963 410 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9964 :
9965 410 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9966 : {
9967 139 : gcc_assert (expr2->ts.type == BT_CHARACTER);
9968 139 : size = expr2->ts.u.cl->backend_decl;
9969 139 : if (!size || !VAR_P (size))
9970 139 : size = gfc_create_var (TREE_TYPE (slen), "slen");
9971 139 : gfc_add_modify (block, size, slen);
9972 :
9973 139 : gfc_deferred_strlen (cm, &tmp);
9974 139 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
9975 : gfc_charlen_type_node,
9976 139 : TREE_OPERAND (comp, 0),
9977 : tmp, NULL_TREE);
9978 :
9979 139 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
9980 139 : tmp = TYPE_SIZE_UNIT (tmp);
9981 278 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9982 139 : TREE_TYPE (tmp), tmp,
9983 139 : fold_convert (TREE_TYPE (tmp), size));
9984 : }
9985 271 : else if (cm->ts.type == BT_CLASS)
9986 : {
9987 103 : if (expr2->ts.type != BT_CLASS)
9988 : {
9989 103 : if (expr2->ts.type == BT_CHARACTER)
9990 : {
9991 24 : gfc_init_se (&se, NULL);
9992 24 : gfc_conv_expr (&se, expr2);
9993 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
9994 24 : size = fold_build2_loc (input_location, MULT_EXPR,
9995 : gfc_charlen_type_node,
9996 : se.string_length, size);
9997 24 : size = fold_convert (size_type_node, size);
9998 : }
9999 : else
10000 : {
10001 79 : if (expr2->ts.type == BT_DERIVED)
10002 48 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
10003 : else
10004 31 : tmp = gfc_typenode_for_spec (&expr2->ts);
10005 79 : size = TYPE_SIZE_UNIT (tmp);
10006 : }
10007 : }
10008 : else
10009 : {
10010 0 : gfc_expr *e2vtab;
10011 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
10012 0 : gfc_add_vptr_component (e2vtab);
10013 0 : gfc_add_size_component (e2vtab);
10014 0 : gfc_init_se (&se, NULL);
10015 0 : gfc_conv_expr (&se, e2vtab);
10016 0 : gfc_add_block_to_block (block, &se.pre);
10017 0 : size = fold_convert (size_type_node, se.expr);
10018 0 : gfc_free_expr (e2vtab);
10019 : }
10020 : size_in_bytes = size;
10021 : }
10022 : else
10023 : {
10024 : /* Otherwise use the length in bytes of the rhs. */
10025 168 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
10026 168 : size_in_bytes = size;
10027 : }
10028 :
10029 410 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10030 : size_in_bytes, size_one_node);
10031 :
10032 410 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
10033 : {
10034 0 : tmp = build_call_expr_loc (input_location,
10035 : builtin_decl_explicit (BUILT_IN_CALLOC),
10036 : 2, build_one_cst (size_type_node),
10037 : size_in_bytes);
10038 0 : tmp = fold_convert (TREE_TYPE (comp), tmp);
10039 0 : gfc_add_modify (block, comp, tmp);
10040 : }
10041 : else
10042 : {
10043 410 : tmp = build_call_expr_loc (input_location,
10044 : builtin_decl_explicit (BUILT_IN_MALLOC),
10045 : 1, size_in_bytes);
10046 410 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
10047 103 : ptr = gfc_class_data_get (comp);
10048 : else
10049 : ptr = comp;
10050 410 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
10051 410 : gfc_add_modify (block, ptr, tmp);
10052 : }
10053 :
10054 410 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10055 : /* Update the lhs character length. */
10056 139 : gfc_add_modify (block, lhs_cl_size,
10057 139 : fold_convert (TREE_TYPE (lhs_cl_size), size));
10058 : }
10059 :
10060 :
10061 : /* Assign a single component of a derived type constructor. */
10062 :
10063 : static tree
10064 29305 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
10065 : gfc_expr * expr, bool init)
10066 : {
10067 29305 : gfc_se se;
10068 29305 : gfc_se lse;
10069 29305 : stmtblock_t block;
10070 29305 : tree tmp;
10071 29305 : tree vtab;
10072 :
10073 29305 : gfc_start_block (&block);
10074 :
10075 29305 : if (cm->attr.pointer || cm->attr.proc_pointer)
10076 : {
10077 : /* Only care about pointers here, not about allocatables. */
10078 2640 : gfc_init_se (&se, NULL);
10079 : /* Pointer component. */
10080 2640 : if ((cm->attr.dimension || cm->attr.codimension)
10081 676 : && !cm->attr.proc_pointer)
10082 : {
10083 : /* Array pointer. */
10084 660 : if (expr->expr_type == EXPR_NULL)
10085 654 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10086 : else
10087 : {
10088 6 : se.direct_byref = 1;
10089 6 : se.expr = dest;
10090 6 : gfc_conv_expr_descriptor (&se, expr);
10091 6 : gfc_add_block_to_block (&block, &se.pre);
10092 6 : gfc_add_block_to_block (&block, &se.post);
10093 : }
10094 : }
10095 : else
10096 : {
10097 : /* Scalar pointers. */
10098 1980 : se.want_pointer = 1;
10099 1980 : gfc_conv_expr (&se, expr);
10100 1980 : gfc_add_block_to_block (&block, &se.pre);
10101 :
10102 1980 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10103 12 : && expr->symtree->n.sym->attr.dummy)
10104 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10105 :
10106 1980 : gfc_add_modify (&block, dest,
10107 1980 : fold_convert (TREE_TYPE (dest), se.expr));
10108 1980 : gfc_add_block_to_block (&block, &se.post);
10109 : }
10110 : }
10111 26665 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10112 : {
10113 : /* NULL initialization for CLASS components. */
10114 922 : tmp = gfc_trans_structure_assign (dest,
10115 : gfc_class_initializer (&cm->ts, expr),
10116 : false);
10117 922 : gfc_add_expr_to_block (&block, tmp);
10118 : }
10119 25743 : else if ((cm->attr.dimension || cm->attr.codimension)
10120 : && !cm->attr.proc_pointer)
10121 : {
10122 4952 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10123 : {
10124 2740 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10125 2740 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10126 2 : gfc_add_modify (&block, gfc_conv_descriptor_token (dest),
10127 : null_pointer_node);
10128 : }
10129 2212 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10130 : {
10131 1256 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10132 1256 : gfc_add_expr_to_block (&block, tmp);
10133 : }
10134 : else
10135 : {
10136 956 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10137 956 : gfc_add_expr_to_block (&block, tmp);
10138 : }
10139 : }
10140 20791 : else if (cm->ts.type == BT_CLASS
10141 145 : && CLASS_DATA (cm)->attr.dimension
10142 36 : && CLASS_DATA (cm)->attr.allocatable
10143 36 : && expr->ts.type == BT_DERIVED)
10144 : {
10145 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10146 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10147 36 : tmp = gfc_class_vptr_get (dest);
10148 36 : gfc_add_modify (&block, tmp,
10149 36 : fold_convert (TREE_TYPE (tmp), vtab));
10150 36 : tmp = gfc_class_data_get (dest);
10151 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10152 36 : gfc_add_expr_to_block (&block, tmp);
10153 : }
10154 20755 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10155 1766 : && (init
10156 1639 : || (cm->ts.type == BT_CHARACTER
10157 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10158 : {
10159 : /* NULL initialization for allocatable components.
10160 : Deferred-length character is dealt with later. */
10161 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10162 : null_pointer_node));
10163 : }
10164 20604 : else if (init && (cm->attr.allocatable
10165 13473 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10166 109 : && expr->ts.type != BT_CLASS)))
10167 : {
10168 410 : tree size;
10169 :
10170 410 : gfc_init_se (&se, NULL);
10171 410 : gfc_conv_expr (&se, expr);
10172 :
10173 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10174 : if (!cm->attr.dimension) part above. */
10175 410 : gfc_add_block_to_block (&block, &se.pre);
10176 : /* Take care about non-array allocatable components here. The alloc_*
10177 : routine below is motivated by the alloc_scalar_allocatable_for_
10178 : assignment() routine, but with the realloc portions removed and
10179 : different input. */
10180 410 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10181 : se.string_length);
10182 :
10183 410 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10184 0 : && expr->symtree->n.sym->attr.dummy)
10185 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10186 :
10187 410 : if (cm->ts.type == BT_CLASS)
10188 : {
10189 103 : tmp = gfc_class_data_get (dest);
10190 103 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10191 103 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10192 103 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10193 103 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10194 103 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10195 : }
10196 : else
10197 307 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10198 :
10199 : /* For deferred strings insert a memcpy. */
10200 410 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10201 : {
10202 139 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10203 139 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10204 : ? se.string_length
10205 0 : : expr->ts.u.cl->backend_decl);
10206 139 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10207 139 : gfc_add_expr_to_block (&block, tmp);
10208 : }
10209 271 : else if (cm->ts.type == BT_CLASS)
10210 : {
10211 : /* Fix the expression for memcpy. */
10212 103 : if (expr->expr_type != EXPR_VARIABLE)
10213 73 : se.expr = gfc_evaluate_now (se.expr, &block);
10214 :
10215 103 : if (expr->ts.type == BT_CHARACTER)
10216 : {
10217 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10218 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10219 : gfc_charlen_type_node,
10220 : se.string_length, size);
10221 24 : size = fold_convert (size_type_node, size);
10222 : }
10223 : else
10224 79 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10225 :
10226 : /* Now copy the expression to the constructor component _data. */
10227 103 : gfc_add_expr_to_block (&block,
10228 : gfc_build_memcpy_call (tmp, se.expr, size));
10229 :
10230 : /* Fill the unlimited polymorphic _len field. */
10231 103 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10232 : {
10233 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10234 24 : gfc_add_modify (&block, tmp,
10235 24 : fold_convert (TREE_TYPE (tmp),
10236 : se.string_length));
10237 : }
10238 : }
10239 : else
10240 168 : gfc_add_modify (&block, tmp,
10241 168 : fold_convert (TREE_TYPE (tmp), se.expr));
10242 410 : gfc_add_block_to_block (&block, &se.post);
10243 410 : }
10244 20194 : else if (expr->ts.type == BT_UNION)
10245 : {
10246 13 : tree tmp;
10247 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10248 : /* We mark that the entire union should be initialized with a contrived
10249 : EXPR_NULL expression at the beginning. */
10250 13 : if (c != NULL && c->n.component == NULL
10251 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10252 : {
10253 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10254 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10255 6 : gfc_add_expr_to_block (&block, tmp);
10256 6 : c = gfc_constructor_next (c);
10257 : }
10258 : /* The following constructor expression, if any, represents a specific
10259 : map initializer, as given by the user. */
10260 13 : if (c != NULL && c->expr != NULL)
10261 : {
10262 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10263 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10264 6 : gfc_add_expr_to_block (&block, tmp);
10265 : }
10266 : }
10267 20181 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10268 : {
10269 3123 : if (expr->expr_type != EXPR_STRUCTURE)
10270 : {
10271 452 : tree dealloc = NULL_TREE;
10272 452 : gfc_init_se (&se, NULL);
10273 452 : gfc_conv_expr (&se, expr);
10274 452 : gfc_add_block_to_block (&block, &se.pre);
10275 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10276 : expression in a temporary variable and deallocate the allocatable
10277 : components. Then we can the copy the expression to the result. */
10278 452 : if (cm->ts.u.derived->attr.alloc_comp
10279 330 : && expr->expr_type != EXPR_VARIABLE)
10280 : {
10281 300 : se.expr = gfc_evaluate_now (se.expr, &block);
10282 300 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10283 : expr->rank);
10284 : }
10285 452 : gfc_add_modify (&block, dest,
10286 452 : fold_convert (TREE_TYPE (dest), se.expr));
10287 452 : if (cm->ts.u.derived->attr.alloc_comp
10288 330 : && expr->expr_type != EXPR_NULL)
10289 : {
10290 : // TODO: Fix caf_mode
10291 48 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10292 : dest, expr->rank, 0);
10293 48 : gfc_add_expr_to_block (&block, tmp);
10294 48 : if (dealloc != NULL_TREE)
10295 18 : gfc_add_expr_to_block (&block, dealloc);
10296 : }
10297 452 : gfc_add_block_to_block (&block, &se.post);
10298 : }
10299 : else
10300 : {
10301 : /* Nested constructors. */
10302 2671 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10303 2671 : gfc_add_expr_to_block (&block, tmp);
10304 : }
10305 : }
10306 17058 : else if (gfc_deferred_strlen (cm, &tmp))
10307 : {
10308 125 : tree strlen;
10309 125 : strlen = tmp;
10310 125 : gcc_assert (strlen);
10311 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10312 125 : TREE_TYPE (strlen),
10313 125 : TREE_OPERAND (dest, 0),
10314 : strlen, NULL_TREE);
10315 :
10316 125 : if (expr->expr_type == EXPR_NULL)
10317 : {
10318 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10319 107 : gfc_add_modify (&block, dest, tmp);
10320 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10321 107 : gfc_add_modify (&block, strlen, tmp);
10322 : }
10323 : else
10324 : {
10325 18 : tree size;
10326 18 : gfc_init_se (&se, NULL);
10327 18 : gfc_conv_expr (&se, expr);
10328 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10329 18 : size = fold_convert (size_type_node, size);
10330 18 : tmp = build_call_expr_loc (input_location,
10331 : builtin_decl_explicit (BUILT_IN_MALLOC),
10332 : 1, size);
10333 18 : gfc_add_modify (&block, dest,
10334 18 : fold_convert (TREE_TYPE (dest), tmp));
10335 18 : gfc_add_modify (&block, strlen,
10336 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10337 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10338 18 : gfc_add_expr_to_block (&block, tmp);
10339 : }
10340 : }
10341 16933 : else if (!cm->attr.artificial)
10342 : {
10343 : /* Scalar component (excluding deferred parameters). */
10344 16818 : gfc_init_se (&se, NULL);
10345 16818 : gfc_init_se (&lse, NULL);
10346 :
10347 16818 : gfc_conv_expr (&se, expr);
10348 16818 : if (cm->ts.type == BT_CHARACTER)
10349 1051 : lse.string_length = cm->ts.u.cl->backend_decl;
10350 16818 : lse.expr = dest;
10351 16818 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10352 16818 : gfc_add_expr_to_block (&block, tmp);
10353 : }
10354 29305 : return gfc_finish_block (&block);
10355 : }
10356 :
10357 : /* Assign a derived type constructor to a variable. */
10358 :
10359 : tree
10360 20477 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10361 : {
10362 20477 : gfc_constructor *c;
10363 20477 : gfc_component *cm;
10364 20477 : stmtblock_t block;
10365 20477 : tree field;
10366 20477 : tree tmp;
10367 20477 : gfc_se se;
10368 :
10369 20477 : gfc_start_block (&block);
10370 :
10371 20477 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10372 179 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10373 13 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10374 : {
10375 179 : gfc_se lse;
10376 :
10377 179 : gfc_init_se (&se, NULL);
10378 179 : gfc_init_se (&lse, NULL);
10379 179 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10380 179 : lse.expr = dest;
10381 179 : gfc_add_modify (&block, lse.expr,
10382 179 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10383 :
10384 179 : return gfc_finish_block (&block);
10385 : }
10386 :
10387 : /* Make sure that the derived type has been completely built. */
10388 20298 : if (!expr->ts.u.derived->backend_decl
10389 20298 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10390 : {
10391 224 : tmp = gfc_typenode_for_spec (&expr->ts);
10392 224 : gcc_assert (tmp);
10393 : }
10394 :
10395 20298 : cm = expr->ts.u.derived->components;
10396 :
10397 :
10398 20298 : if (coarray)
10399 225 : gfc_init_se (&se, NULL);
10400 :
10401 20298 : for (c = gfc_constructor_first (expr->value.constructor);
10402 52735 : c; c = gfc_constructor_next (c), cm = cm->next)
10403 : {
10404 : /* Skip absent members in default initializers. */
10405 32437 : if (!c->expr && !cm->attr.allocatable)
10406 3132 : continue;
10407 :
10408 : /* Register the component with the caf-lib before it is initialized.
10409 : Register only allocatable components, that are not coarray'ed
10410 : components (%comp[*]). Only register when the constructor is the
10411 : null-expression. */
10412 29305 : if (coarray && !cm->attr.codimension
10413 515 : && (cm->attr.allocatable || cm->attr.pointer)
10414 179 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10415 : {
10416 177 : tree token, desc, size;
10417 354 : bool is_array = cm->ts.type == BT_CLASS
10418 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10419 :
10420 177 : field = cm->backend_decl;
10421 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
10422 177 : TREE_TYPE (field), dest, field, NULL_TREE);
10423 177 : if (cm->ts.type == BT_CLASS)
10424 0 : field = gfc_class_data_get (field);
10425 :
10426 177 : token
10427 : = is_array
10428 177 : ? gfc_conv_descriptor_token (field)
10429 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10430 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10431 52 : gfc_comp_caf_token (cm), NULL_TREE);
10432 :
10433 177 : if (is_array)
10434 : {
10435 : /* The _caf_register routine looks at the rank of the array
10436 : descriptor to decide whether the data registered is an array
10437 : or not. */
10438 125 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10439 125 : : cm->as->rank;
10440 : /* When the rank is not known just set a positive rank, which
10441 : suffices to recognize the data as array. */
10442 125 : if (rank < 0)
10443 0 : rank = 1;
10444 125 : size = build_zero_cst (size_type_node);
10445 125 : desc = field;
10446 125 : gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
10447 125 : build_int_cst (signed_char_type_node, rank));
10448 : }
10449 : else
10450 : {
10451 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10452 52 : cm->ts.type == BT_CLASS
10453 52 : ? CLASS_DATA (cm)->attr
10454 : : cm->attr);
10455 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10456 : }
10457 177 : gfc_add_block_to_block (&block, &se.pre);
10458 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10459 : 7, size, build_int_cst (
10460 : integer_type_node,
10461 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10462 : gfc_build_addr_expr (pvoid_type_node,
10463 : token),
10464 : gfc_build_addr_expr (NULL_TREE, desc),
10465 : null_pointer_node, null_pointer_node,
10466 : integer_zero_node);
10467 177 : gfc_add_expr_to_block (&block, tmp);
10468 : }
10469 29305 : field = cm->backend_decl;
10470 29305 : gcc_assert(field);
10471 29305 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10472 : dest, field, NULL_TREE);
10473 29305 : if (!c->expr)
10474 : {
10475 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10476 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10477 0 : gfc_free_expr (e);
10478 : }
10479 : else
10480 29305 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10481 29305 : gfc_add_expr_to_block (&block, tmp);
10482 : }
10483 20298 : return gfc_finish_block (&block);
10484 : }
10485 :
10486 : static void
10487 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10488 : gfc_component *un, gfc_expr *init)
10489 : {
10490 21 : gfc_constructor *ctor;
10491 :
10492 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
10493 : return;
10494 :
10495 21 : ctor = gfc_constructor_first (init->value.constructor);
10496 :
10497 21 : if (ctor == NULL || ctor->expr == NULL)
10498 : return;
10499 :
10500 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
10501 :
10502 : /* If we have an 'initialize all' constructor, do it first. */
10503 21 : if (ctor->expr->expr_type == EXPR_NULL)
10504 : {
10505 9 : tree union_type = TREE_TYPE (un->backend_decl);
10506 9 : tree val = build_constructor (union_type, NULL);
10507 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10508 9 : ctor = gfc_constructor_next (ctor);
10509 : }
10510 :
10511 : /* Add the map initializer on top. */
10512 21 : if (ctor != NULL && ctor->expr != NULL)
10513 : {
10514 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
10515 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
10516 12 : TREE_TYPE (un->backend_decl),
10517 12 : un->attr.dimension, un->attr.pointer,
10518 12 : un->attr.proc_pointer);
10519 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10520 : }
10521 : }
10522 :
10523 : /* Build an expression for a constructor. If init is nonzero then
10524 : this is part of a static variable initializer. */
10525 :
10526 : void
10527 39384 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
10528 : {
10529 39384 : gfc_constructor *c;
10530 39384 : gfc_component *cm;
10531 39384 : tree val;
10532 39384 : tree type;
10533 39384 : tree tmp;
10534 39384 : vec<constructor_elt, va_gc> *v = NULL;
10535 :
10536 39384 : gcc_assert (se->ss == NULL);
10537 39384 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10538 39384 : type = gfc_typenode_for_spec (&expr->ts);
10539 :
10540 39384 : if (!init)
10541 : {
10542 16081 : if (IS_PDT (expr) && expr->must_finalize)
10543 276 : final_block = &se->finalblock;
10544 :
10545 : /* Create a temporary variable and fill it in. */
10546 16081 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
10547 : /* The symtree in expr is NULL, if the code to generate is for
10548 : initializing the static members only. */
10549 32162 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
10550 16081 : se->want_coarray);
10551 16081 : gfc_add_expr_to_block (&se->pre, tmp);
10552 16081 : final_block = NULL;
10553 16081 : return;
10554 : }
10555 :
10556 23303 : cm = expr->ts.u.derived->components;
10557 :
10558 23303 : for (c = gfc_constructor_first (expr->value.constructor);
10559 122763 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
10560 : {
10561 : /* Skip absent members in default initializers and allocatable
10562 : components. Although the latter have a default initializer
10563 : of EXPR_NULL,... by default, the static nullify is not needed
10564 : since this is done every time we come into scope. */
10565 108090 : if (!c->expr
10566 97048 : || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)
10567 190374 : || (IS_PDT (cm) && has_parameterized_comps (cm->ts.u.derived)))
10568 8630 : continue;
10569 :
10570 90830 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
10571 52693 : && strcmp (cm->name, "_extends") == 0
10572 1302 : && cm->initializer->symtree)
10573 : {
10574 1302 : tree vtab;
10575 1302 : gfc_symbol *vtabs;
10576 1302 : vtabs = cm->initializer->symtree->n.sym;
10577 1302 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
10578 1302 : vtab = unshare_expr_without_location (vtab);
10579 1302 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
10580 1302 : }
10581 89528 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
10582 : {
10583 9965 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
10584 9965 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10585 : fold_convert (TREE_TYPE (cm->backend_decl),
10586 : val));
10587 9965 : }
10588 79563 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
10589 407 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10590 : fold_convert (TREE_TYPE (cm->backend_decl),
10591 407 : integer_zero_node));
10592 79156 : else if (cm->ts.type == BT_UNION)
10593 21 : gfc_conv_union_initializer (v, cm, c->expr);
10594 : else
10595 : {
10596 79135 : val = gfc_conv_initializer (c->expr, &cm->ts,
10597 79135 : TREE_TYPE (cm->backend_decl),
10598 79135 : cm->attr.dimension, cm->attr.pointer,
10599 79135 : cm->attr.proc_pointer);
10600 79135 : val = unshare_expr_without_location (val);
10601 :
10602 : /* Append it to the constructor list. */
10603 178595 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
10604 : }
10605 : }
10606 :
10607 23303 : se->expr = build_constructor (type, v);
10608 23303 : if (init)
10609 23303 : TREE_CONSTANT (se->expr) = 1;
10610 : }
10611 :
10612 :
10613 : /* Translate a substring expression. */
10614 :
10615 : static void
10616 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
10617 : {
10618 258 : gfc_ref *ref;
10619 :
10620 258 : ref = expr->ref;
10621 :
10622 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
10623 :
10624 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
10625 258 : expr->value.character.length,
10626 258 : expr->value.character.string);
10627 :
10628 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
10629 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
10630 :
10631 258 : if (ref)
10632 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
10633 258 : }
10634 :
10635 :
10636 : /* Entry point for expression translation. Evaluates a scalar quantity.
10637 : EXPR is the expression to be translated, and SE is the state structure if
10638 : called from within the scalarized. */
10639 :
10640 : void
10641 3653136 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
10642 : {
10643 3653136 : gfc_ss *ss;
10644 :
10645 3653136 : ss = se->ss;
10646 3653136 : if (ss && ss->info->expr == expr
10647 238880 : && (ss->info->type == GFC_SS_SCALAR
10648 : || ss->info->type == GFC_SS_REFERENCE))
10649 : {
10650 40615 : gfc_ss_info *ss_info;
10651 :
10652 40615 : ss_info = ss->info;
10653 : /* Substitute a scalar expression evaluated outside the scalarization
10654 : loop. */
10655 40615 : se->expr = ss_info->data.scalar.value;
10656 40615 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
10657 844 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
10658 :
10659 40615 : se->string_length = ss_info->string_length;
10660 40615 : gfc_advance_se_ss_chain (se);
10661 40615 : return;
10662 : }
10663 :
10664 : /* We need to convert the expressions for the iso_c_binding derived types.
10665 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
10666 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
10667 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
10668 : updated to be an integer with a kind equal to the size of a (void *). */
10669 3612521 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
10670 16131 : && expr->ts.u.derived->attr.is_bind_c)
10671 : {
10672 15288 : if (expr->expr_type == EXPR_VARIABLE
10673 10845 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
10674 10845 : || expr->symtree->n.sym->intmod_sym_id
10675 : == ISOCBINDING_NULL_FUNPTR))
10676 : {
10677 : /* Set expr_type to EXPR_NULL, which will result in
10678 : null_pointer_node being used below. */
10679 0 : expr->expr_type = EXPR_NULL;
10680 : }
10681 : else
10682 : {
10683 : /* Update the type/kind of the expression to be what the new
10684 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
10685 15288 : expr->ts.type = BT_INTEGER;
10686 15288 : expr->ts.f90_type = BT_VOID;
10687 15288 : expr->ts.kind = gfc_index_integer_kind;
10688 : }
10689 : }
10690 :
10691 3612521 : gfc_fix_class_refs (expr);
10692 :
10693 3612521 : switch (expr->expr_type)
10694 : {
10695 507069 : case EXPR_OP:
10696 507069 : gfc_conv_expr_op (se, expr);
10697 507069 : break;
10698 :
10699 151 : case EXPR_CONDITIONAL:
10700 151 : gfc_conv_conditional_expr (se, expr);
10701 151 : break;
10702 :
10703 305015 : case EXPR_FUNCTION:
10704 305015 : gfc_conv_function_expr (se, expr);
10705 305015 : break;
10706 :
10707 1138771 : case EXPR_CONSTANT:
10708 1138771 : gfc_conv_constant (se, expr);
10709 1138771 : break;
10710 :
10711 1605109 : case EXPR_VARIABLE:
10712 1605109 : gfc_conv_variable (se, expr);
10713 1605109 : break;
10714 :
10715 4201 : case EXPR_NULL:
10716 4201 : se->expr = null_pointer_node;
10717 4201 : break;
10718 :
10719 258 : case EXPR_SUBSTRING:
10720 258 : gfc_conv_substring_expr (se, expr);
10721 258 : break;
10722 :
10723 16081 : case EXPR_STRUCTURE:
10724 16081 : gfc_conv_structure (se, expr, 0);
10725 : /* F2008 4.5.6.3 para 5: If an executable construct references a
10726 : structure constructor or array constructor, the entity created by
10727 : the constructor is finalized after execution of the innermost
10728 : executable construct containing the reference. This, in fact,
10729 : was later deleted by the Combined Technical Corrigenda 1 TO 4 for
10730 : fortran 2008 (f08/0011). */
10731 16081 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
10732 16081 : && !(gfc_option.allow_std & GFC_STD_GNU)
10733 139 : && expr->must_finalize
10734 16093 : && gfc_may_be_finalized (expr->ts))
10735 : {
10736 12 : locus loc;
10737 12 : gfc_locus_from_location (&loc, input_location);
10738 12 : gfc_warning (0, "The structure constructor at %L has been"
10739 : " finalized. This feature was removed by f08/0011."
10740 : " Use -std=f2018 or -std=gnu to eliminate the"
10741 : " finalization.", &loc);
10742 12 : symbol_attribute attr;
10743 12 : attr.allocatable = attr.pointer = 0;
10744 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
10745 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
10746 : }
10747 : break;
10748 :
10749 35866 : case EXPR_ARRAY:
10750 35866 : gfc_conv_array_constructor_expr (se, expr);
10751 35866 : gfc_add_block_to_block (&se->post, &se->finalblock);
10752 35866 : break;
10753 :
10754 0 : default:
10755 0 : gcc_unreachable ();
10756 3653136 : break;
10757 : }
10758 : }
10759 :
10760 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
10761 : of an assignment. */
10762 : void
10763 372776 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
10764 : {
10765 372776 : gfc_conv_expr (se, expr);
10766 : /* All numeric lvalues should have empty post chains. If not we need to
10767 : figure out a way of rewriting an lvalue so that it has no post chain. */
10768 372776 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
10769 372776 : }
10770 :
10771 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
10772 : numeric expressions. Used for scalar values where inserting cleanup code
10773 : is inconvenient. */
10774 : void
10775 1033856 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
10776 : {
10777 1033856 : tree val;
10778 :
10779 1033856 : gcc_assert (expr->ts.type != BT_CHARACTER);
10780 1033856 : gfc_conv_expr (se, expr);
10781 1033856 : if (se->post.head)
10782 : {
10783 2551 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
10784 2551 : gfc_add_modify (&se->pre, val, se->expr);
10785 2551 : se->expr = val;
10786 2551 : gfc_add_block_to_block (&se->pre, &se->post);
10787 : }
10788 1033856 : }
10789 :
10790 : /* Helper to translate an expression and convert it to a particular type. */
10791 : void
10792 292224 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
10793 : {
10794 292224 : gfc_conv_expr_val (se, expr);
10795 292224 : se->expr = convert (type, se->expr);
10796 292224 : }
10797 :
10798 :
10799 : /* Converts an expression so that it can be passed by reference. Scalar
10800 : values only. */
10801 :
10802 : void
10803 227911 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
10804 : {
10805 227911 : gfc_ss *ss;
10806 227911 : tree var;
10807 :
10808 227911 : ss = se->ss;
10809 227911 : if (ss && ss->info->expr == expr
10810 7987 : && ss->info->type == GFC_SS_REFERENCE)
10811 : {
10812 : /* Returns a reference to the scalar evaluated outside the loop
10813 : for this case. */
10814 907 : gfc_conv_expr (se, expr);
10815 :
10816 907 : if (expr->ts.type == BT_CHARACTER
10817 114 : && expr->expr_type != EXPR_FUNCTION)
10818 102 : gfc_conv_string_parameter (se);
10819 : else
10820 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10821 :
10822 907 : return;
10823 : }
10824 :
10825 227004 : if (expr->ts.type == BT_CHARACTER)
10826 : {
10827 49642 : gfc_conv_expr (se, expr);
10828 49642 : gfc_conv_string_parameter (se);
10829 49642 : return;
10830 : }
10831 :
10832 177362 : if (expr->expr_type == EXPR_VARIABLE)
10833 : {
10834 70767 : se->want_pointer = 1;
10835 70767 : gfc_conv_expr (se, expr);
10836 70767 : if (se->post.head)
10837 : {
10838 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10839 0 : gfc_add_modify (&se->pre, var, se->expr);
10840 0 : gfc_add_block_to_block (&se->pre, &se->post);
10841 0 : se->expr = var;
10842 : }
10843 70767 : return;
10844 : }
10845 :
10846 106595 : if (expr->expr_type == EXPR_CONDITIONAL)
10847 : {
10848 18 : se->want_pointer = 1;
10849 18 : gfc_conv_expr (se, expr);
10850 18 : return;
10851 : }
10852 :
10853 106577 : if (expr->expr_type == EXPR_FUNCTION
10854 13697 : && ((expr->value.function.esym
10855 2101 : && expr->value.function.esym->result
10856 2100 : && expr->value.function.esym->result->attr.pointer
10857 83 : && !expr->value.function.esym->result->attr.dimension)
10858 13620 : || (!expr->value.function.esym && !expr->ref
10859 11490 : && expr->symtree->n.sym->attr.pointer
10860 0 : && !expr->symtree->n.sym->attr.dimension)))
10861 : {
10862 77 : se->want_pointer = 1;
10863 77 : gfc_conv_expr (se, expr);
10864 77 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10865 77 : gfc_add_modify (&se->pre, var, se->expr);
10866 77 : se->expr = var;
10867 77 : return;
10868 : }
10869 :
10870 106500 : gfc_conv_expr (se, expr);
10871 :
10872 : /* Create a temporary var to hold the value. */
10873 106500 : if (TREE_CONSTANT (se->expr))
10874 : {
10875 : tree tmp = se->expr;
10876 84281 : STRIP_TYPE_NOPS (tmp);
10877 84281 : var = build_decl (input_location,
10878 84281 : CONST_DECL, NULL, TREE_TYPE (tmp));
10879 84281 : DECL_INITIAL (var) = tmp;
10880 84281 : TREE_STATIC (var) = 1;
10881 84281 : pushdecl (var);
10882 : }
10883 : else
10884 : {
10885 22219 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10886 22219 : gfc_add_modify (&se->pre, var, se->expr);
10887 : }
10888 :
10889 106500 : if (!expr->must_finalize)
10890 106404 : gfc_add_block_to_block (&se->pre, &se->post);
10891 :
10892 : /* Take the address of that value. */
10893 106500 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
10894 : }
10895 :
10896 :
10897 : /* Get the _len component for an unlimited polymorphic expression. */
10898 :
10899 : static tree
10900 1788 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
10901 : {
10902 1788 : gfc_se se;
10903 1788 : gfc_ref *ref = expr->ref;
10904 :
10905 1788 : gfc_init_se (&se, NULL);
10906 3690 : while (ref && ref->next)
10907 : ref = ref->next;
10908 1788 : gfc_add_len_component (expr);
10909 1788 : gfc_conv_expr (&se, expr);
10910 1788 : gfc_add_block_to_block (block, &se.pre);
10911 1788 : gcc_assert (se.post.head == NULL_TREE);
10912 1788 : if (ref)
10913 : {
10914 262 : gfc_free_ref_list (ref->next);
10915 262 : ref->next = NULL;
10916 : }
10917 : else
10918 : {
10919 1526 : gfc_free_ref_list (expr->ref);
10920 1526 : expr->ref = NULL;
10921 : }
10922 1788 : return se.expr;
10923 : }
10924 :
10925 :
10926 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
10927 : statement-list outside of the scalarizer-loop. When code is generated, that
10928 : depends on the scalarized expression, it is added to RSE.PRE.
10929 : Returns le's _vptr tree and when set the len expressions in to_lenp and
10930 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
10931 : expression. */
10932 :
10933 : static tree
10934 4523 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
10935 : gfc_expr * re, gfc_se *rse,
10936 : tree * to_lenp, tree * from_lenp,
10937 : tree * from_vptrp)
10938 : {
10939 4523 : gfc_se se;
10940 4523 : gfc_expr * vptr_expr;
10941 4523 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
10942 4523 : bool set_vptr = false, temp_rhs = false;
10943 4523 : stmtblock_t *pre = block;
10944 4523 : tree class_expr = NULL_TREE;
10945 4523 : tree from_vptr = NULL_TREE;
10946 :
10947 : /* Create a temporary for complicated expressions. */
10948 4523 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
10949 1263 : && rse->expr != NULL_TREE)
10950 : {
10951 1263 : if (!DECL_P (rse->expr))
10952 : {
10953 392 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10954 37 : class_expr = gfc_get_class_from_expr (rse->expr);
10955 :
10956 392 : if (rse->loop)
10957 159 : pre = &rse->loop->pre;
10958 : else
10959 233 : pre = &rse->pre;
10960 :
10961 392 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
10962 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
10963 : else
10964 355 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
10965 :
10966 392 : rse->expr = tmp;
10967 : }
10968 : else
10969 871 : pre = &rse->pre;
10970 :
10971 : temp_rhs = true;
10972 : }
10973 :
10974 : /* Get the _vptr for the left-hand side expression. */
10975 4523 : gfc_init_se (&se, NULL);
10976 4523 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
10977 4523 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
10978 : {
10979 : /* Care about _len for unlimited polymorphic entities. */
10980 4523 : if (UNLIMITED_POLY (vptr_expr)
10981 3503 : || (vptr_expr->ts.type == BT_DERIVED
10982 2479 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10983 1504 : to_len = trans_get_upoly_len (block, vptr_expr);
10984 4523 : gfc_add_vptr_component (vptr_expr);
10985 4523 : set_vptr = true;
10986 : }
10987 : else
10988 0 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10989 4523 : se.want_pointer = 1;
10990 4523 : gfc_conv_expr (&se, vptr_expr);
10991 4523 : gfc_free_expr (vptr_expr);
10992 4523 : gfc_add_block_to_block (block, &se.pre);
10993 4523 : gcc_assert (se.post.head == NULL_TREE);
10994 4523 : lhs_vptr = se.expr;
10995 4523 : STRIP_NOPS (lhs_vptr);
10996 :
10997 : /* Set the _vptr only when the left-hand side of the assignment is a
10998 : class-object. */
10999 4523 : if (set_vptr)
11000 : {
11001 : /* Get the vptr from the rhs expression only, when it is variable.
11002 : Functions are expected to be assigned to a temporary beforehand. */
11003 3131 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
11004 5304 : ? gfc_find_and_cut_at_last_class_ref (re)
11005 : : NULL;
11006 781 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
11007 : {
11008 781 : if (to_len != NULL_TREE)
11009 : {
11010 : /* Get the _len information from the rhs. */
11011 299 : if (UNLIMITED_POLY (vptr_expr)
11012 : || (vptr_expr->ts.type == BT_DERIVED
11013 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11014 272 : from_len = trans_get_upoly_len (block, vptr_expr);
11015 : }
11016 781 : gfc_add_vptr_component (vptr_expr);
11017 : }
11018 : else
11019 : {
11020 3742 : if (re->expr_type == EXPR_VARIABLE
11021 2350 : && DECL_P (re->symtree->n.sym->backend_decl)
11022 2350 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
11023 822 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
11024 3809 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
11025 : re->symtree->n.sym->backend_decl))))
11026 : {
11027 43 : vptr_expr = NULL;
11028 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
11029 : re->symtree->n.sym->backend_decl));
11030 43 : if (to_len && UNLIMITED_POLY (re))
11031 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
11032 : re->symtree->n.sym->backend_decl));
11033 : }
11034 3699 : else if (temp_rhs && re->ts.type == BT_CLASS)
11035 : {
11036 215 : vptr_expr = NULL;
11037 215 : if (class_expr)
11038 : tmp = class_expr;
11039 178 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11040 0 : tmp = gfc_get_class_from_expr (rse->expr);
11041 : else
11042 : tmp = rse->expr;
11043 :
11044 215 : se.expr = gfc_class_vptr_get (tmp);
11045 215 : from_vptr = se.expr;
11046 215 : if (UNLIMITED_POLY (re))
11047 74 : from_len = gfc_class_len_get (tmp);
11048 :
11049 : }
11050 3484 : else if (re->expr_type != EXPR_NULL)
11051 : /* Only when rhs is non-NULL use its declared type for vptr
11052 : initialisation. */
11053 3355 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
11054 : else
11055 : /* When the rhs is NULL use the vtab of lhs' declared type. */
11056 129 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11057 : }
11058 :
11059 4339 : if (vptr_expr)
11060 : {
11061 4265 : gfc_init_se (&se, NULL);
11062 4265 : se.want_pointer = 1;
11063 4265 : gfc_conv_expr (&se, vptr_expr);
11064 4265 : gfc_free_expr (vptr_expr);
11065 4265 : gfc_add_block_to_block (block, &se.pre);
11066 4265 : gcc_assert (se.post.head == NULL_TREE);
11067 4265 : from_vptr = se.expr;
11068 : }
11069 4523 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
11070 : se.expr));
11071 :
11072 4523 : if (to_len != NULL_TREE)
11073 : {
11074 : /* The _len component needs to be set. Figure how to get the
11075 : value of the right-hand side. */
11076 1504 : if (from_len == NULL_TREE)
11077 : {
11078 1158 : if (rse->string_length != NULL_TREE)
11079 : from_len = rse->string_length;
11080 712 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
11081 : {
11082 0 : gfc_init_se (&se, NULL);
11083 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
11084 0 : gfc_add_block_to_block (block, &se.pre);
11085 0 : gcc_assert (se.post.head == NULL_TREE);
11086 0 : from_len = gfc_evaluate_now (se.expr, block);
11087 : }
11088 : else
11089 712 : from_len = build_zero_cst (gfc_charlen_type_node);
11090 : }
11091 1504 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
11092 : from_len));
11093 : }
11094 : }
11095 :
11096 : /* Return the _len and _vptr trees only, when requested. */
11097 4523 : if (to_lenp)
11098 3319 : *to_lenp = to_len;
11099 4523 : if (from_lenp)
11100 3319 : *from_lenp = from_len;
11101 4523 : if (from_vptrp)
11102 3319 : *from_vptrp = from_vptr;
11103 4523 : return lhs_vptr;
11104 : }
11105 :
11106 :
11107 : /* Assign tokens for pointer components. */
11108 :
11109 : static void
11110 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11111 : gfc_expr *expr2)
11112 : {
11113 12 : symbol_attribute lhs_attr, rhs_attr;
11114 12 : tree tmp, lhs_tok, rhs_tok;
11115 : /* Flag to indicated component refs on the rhs. */
11116 12 : bool rhs_cr;
11117 :
11118 12 : lhs_attr = gfc_caf_attr (expr1);
11119 12 : if (expr2->expr_type != EXPR_NULL)
11120 : {
11121 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11122 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11123 : {
11124 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11125 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11126 :
11127 4 : if (rhs_cr)
11128 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11129 : else
11130 : {
11131 4 : tree caf_decl;
11132 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11133 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11134 : NULL_TREE, NULL);
11135 : }
11136 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11137 : lhs_tok,
11138 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11139 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11140 : }
11141 : }
11142 4 : else if (lhs_attr.codimension)
11143 : {
11144 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11145 4 : if (!lhs_tok)
11146 : {
11147 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11148 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11149 : }
11150 : else
11151 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11152 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11153 : lhs_tok, null_pointer_node);
11154 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11155 : }
11156 12 : }
11157 :
11158 :
11159 : /* Do everything that is needed for a CLASS function expr2. */
11160 :
11161 : static tree
11162 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11163 : gfc_expr *expr1, gfc_expr *expr2)
11164 : {
11165 18 : tree expr1_vptr = NULL_TREE;
11166 18 : tree tmp;
11167 :
11168 18 : gfc_conv_function_expr (rse, expr2);
11169 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11170 :
11171 18 : if (expr1->ts.type != BT_CLASS)
11172 12 : rse->expr = gfc_class_data_get (rse->expr);
11173 : else
11174 : {
11175 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11176 : expr2, rse,
11177 : NULL, NULL, NULL);
11178 6 : gfc_add_block_to_block (block, &rse->pre);
11179 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11180 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11181 :
11182 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11183 6 : fold_convert (TREE_TYPE (expr1_vptr),
11184 : gfc_class_vptr_get (tmp)));
11185 6 : rse->expr = gfc_class_data_get (tmp);
11186 : }
11187 :
11188 18 : return expr1_vptr;
11189 : }
11190 :
11191 :
11192 : tree
11193 10125 : gfc_trans_pointer_assign (gfc_code * code)
11194 : {
11195 10125 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11196 : }
11197 :
11198 :
11199 : /* Generate code for a pointer assignment. */
11200 :
11201 : tree
11202 10180 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11203 : {
11204 10180 : gfc_se lse;
11205 10180 : gfc_se rse;
11206 10180 : stmtblock_t block;
11207 10180 : tree desc;
11208 10180 : tree tmp;
11209 10180 : tree expr1_vptr = NULL_TREE;
11210 10180 : bool scalar, non_proc_ptr_assign;
11211 10180 : gfc_ss *ss;
11212 :
11213 10180 : gfc_start_block (&block);
11214 :
11215 10180 : gfc_init_se (&lse, NULL);
11216 :
11217 : /* Usually testing whether this is not a proc pointer assignment. */
11218 10180 : non_proc_ptr_assign
11219 10180 : = !(gfc_expr_attr (expr1).proc_pointer
11220 1193 : && ((expr2->expr_type == EXPR_VARIABLE
11221 961 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11222 282 : || expr2->expr_type == EXPR_NULL));
11223 :
11224 : /* Check whether the expression is a scalar or not; we cannot use
11225 : expr1->rank as it can be nonzero for proc pointers. */
11226 10180 : ss = gfc_walk_expr (expr1);
11227 10180 : scalar = ss == gfc_ss_terminator;
11228 10180 : if (!scalar)
11229 4372 : gfc_free_ss_chain (ss);
11230 :
11231 10180 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11232 90 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11233 : {
11234 66 : gfc_add_data_component (expr2);
11235 : /* The following is required as gfc_add_data_component doesn't
11236 : update ts.type if there is a trailing REF_ARRAY. */
11237 66 : expr2->ts.type = BT_DERIVED;
11238 : }
11239 :
11240 10180 : if (scalar)
11241 : {
11242 : /* Scalar pointers. */
11243 5808 : lse.want_pointer = 1;
11244 5808 : gfc_conv_expr (&lse, expr1);
11245 5808 : gfc_init_se (&rse, NULL);
11246 5808 : rse.want_pointer = 1;
11247 5808 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11248 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11249 : else
11250 5802 : gfc_conv_expr (&rse, expr2);
11251 :
11252 5808 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11253 : {
11254 769 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11255 : NULL, NULL);
11256 769 : lse.expr = gfc_class_data_get (lse.expr);
11257 : }
11258 :
11259 5808 : if (expr1->symtree->n.sym->attr.proc_pointer
11260 863 : && expr1->symtree->n.sym->attr.dummy)
11261 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11262 : lse.expr);
11263 :
11264 5808 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11265 47 : && expr2->symtree->n.sym->attr.dummy)
11266 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11267 : rse.expr);
11268 :
11269 5808 : gfc_add_block_to_block (&block, &lse.pre);
11270 5808 : gfc_add_block_to_block (&block, &rse.pre);
11271 :
11272 : /* Check character lengths if character expression. The test is only
11273 : really added if -fbounds-check is enabled. Exclude deferred
11274 : character length lefthand sides. */
11275 954 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11276 780 : && !expr1->ts.deferred
11277 365 : && !expr1->symtree->n.sym->attr.proc_pointer
11278 6166 : && !gfc_is_proc_ptr_comp (expr1))
11279 : {
11280 339 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11281 339 : gcc_assert (lse.string_length && rse.string_length);
11282 339 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11283 : lse.string_length, rse.string_length,
11284 : &block);
11285 : }
11286 :
11287 : /* The assignment to an deferred character length sets the string
11288 : length to that of the rhs. */
11289 5808 : if (expr1->ts.deferred)
11290 : {
11291 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11292 413 : gfc_add_modify (&block, lse.string_length,
11293 413 : fold_convert (TREE_TYPE (lse.string_length),
11294 : rse.string_length));
11295 117 : else if (lse.string_length != NULL)
11296 115 : gfc_add_modify (&block, lse.string_length,
11297 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11298 : }
11299 :
11300 5808 : gfc_add_modify (&block, lse.expr,
11301 5808 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11302 :
11303 5808 : if (flag_coarray == GFC_FCOARRAY_LIB)
11304 : {
11305 342 : if (expr1->ref)
11306 : /* Also set the tokens for pointer components in derived typed
11307 : coarrays. */
11308 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11309 330 : else if (gfc_caf_attr (expr1).codimension)
11310 : {
11311 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11312 :
11313 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11314 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11315 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11316 : NULL_TREE, expr1);
11317 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11318 : NULL_TREE, expr2);
11319 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11320 : }
11321 : }
11322 :
11323 5808 : gfc_add_block_to_block (&block, &rse.post);
11324 5808 : gfc_add_block_to_block (&block, &lse.post);
11325 : }
11326 : else
11327 : {
11328 4372 : gfc_ref* remap;
11329 4372 : bool rank_remap;
11330 4372 : tree strlen_lhs;
11331 4372 : tree strlen_rhs = NULL_TREE;
11332 :
11333 : /* Array pointer. Find the last reference on the LHS and if it is an
11334 : array section ref, we're dealing with bounds remapping. In this case,
11335 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11336 : not see it and process the bounds remapping afterwards explicitly. */
11337 14082 : for (remap = expr1->ref; remap; remap = remap->next)
11338 5717 : if (!remap->next && remap->type == REF_ARRAY
11339 4372 : && remap->u.ar.type == AR_SECTION)
11340 : break;
11341 4372 : rank_remap = (remap && remap->u.ar.end[0]);
11342 :
11343 379 : if (remap && expr2->expr_type == EXPR_NULL)
11344 : {
11345 2 : gfc_error ("If bounds remapping is specified at %L, "
11346 : "the pointer target shall not be NULL", &expr1->where);
11347 2 : return NULL_TREE;
11348 : }
11349 :
11350 4370 : gfc_init_se (&lse, NULL);
11351 4370 : if (remap)
11352 377 : lse.descriptor_only = 1;
11353 4370 : gfc_conv_expr_descriptor (&lse, expr1);
11354 4370 : strlen_lhs = lse.string_length;
11355 4370 : desc = lse.expr;
11356 :
11357 4370 : if (expr2->expr_type == EXPR_NULL)
11358 : {
11359 : /* Just set the data pointer to null. */
11360 692 : gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
11361 : }
11362 3678 : else if (rank_remap)
11363 : {
11364 : /* If we are rank-remapping, just get the RHS's descriptor and
11365 : process this later on. */
11366 254 : gfc_init_se (&rse, NULL);
11367 254 : rse.direct_byref = 1;
11368 254 : rse.byref_noassign = 1;
11369 :
11370 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11371 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11372 : expr1, expr2);
11373 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11374 : {
11375 : tree bound[GFC_MAX_DIMENSIONS];
11376 : int i;
11377 :
11378 26 : for (i = 0; i < expr2->rank; i++)
11379 13 : bound[i] = NULL_TREE;
11380 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11381 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11382 : bound, bound, 0,
11383 : GFC_ARRAY_POINTER_CONT, false);
11384 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11385 13 : rse.descriptor_only = 0;
11386 13 : rse.expr = tmp;
11387 13 : rse.direct_byref = 1;
11388 13 : gfc_conv_expr_descriptor (&rse, expr2);
11389 13 : strlen_rhs = rse.string_length;
11390 13 : rse.expr = tmp;
11391 : }
11392 : else
11393 : {
11394 229 : gfc_conv_expr_descriptor (&rse, expr2);
11395 229 : strlen_rhs = rse.string_length;
11396 229 : if (expr1->ts.type == BT_CLASS)
11397 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11398 : expr2, &rse,
11399 : NULL, NULL,
11400 : NULL);
11401 : }
11402 : }
11403 3424 : else if (expr2->expr_type == EXPR_VARIABLE)
11404 : {
11405 : /* Assign directly to the LHS's descriptor. */
11406 3292 : lse.descriptor_only = 0;
11407 3292 : lse.direct_byref = 1;
11408 3292 : gfc_conv_expr_descriptor (&lse, expr2);
11409 3292 : strlen_rhs = lse.string_length;
11410 3292 : gfc_init_se (&rse, NULL);
11411 :
11412 3292 : if (expr1->ts.type == BT_CLASS)
11413 : {
11414 356 : rse.expr = NULL_TREE;
11415 356 : rse.string_length = strlen_rhs;
11416 356 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11417 : NULL, NULL, NULL);
11418 : }
11419 :
11420 3292 : if (remap == NULL)
11421 : {
11422 : /* If the target is not a whole array, use the target array
11423 : reference for remap. */
11424 6757 : for (remap = expr2->ref; remap; remap = remap->next)
11425 3738 : if (remap->type == REF_ARRAY
11426 3229 : && remap->u.ar.type == AR_FULL
11427 2536 : && remap->next)
11428 : break;
11429 : }
11430 : }
11431 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11432 : {
11433 25 : gfc_init_se (&rse, NULL);
11434 25 : rse.want_pointer = 1;
11435 25 : gfc_conv_function_expr (&rse, expr2);
11436 25 : if (expr1->ts.type != BT_CLASS)
11437 : {
11438 12 : rse.expr = gfc_class_data_get (rse.expr);
11439 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11440 : }
11441 : else
11442 : {
11443 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11444 : expr2, &rse, NULL,
11445 : NULL, NULL);
11446 13 : gfc_add_block_to_block (&block, &rse.pre);
11447 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11448 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11449 :
11450 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11451 13 : fold_convert (TREE_TYPE (expr1_vptr),
11452 : gfc_class_vptr_get (tmp)));
11453 13 : rse.expr = gfc_class_data_get (tmp);
11454 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11455 : }
11456 : }
11457 : else
11458 : {
11459 : /* Assign to a temporary descriptor and then copy that
11460 : temporary to the pointer. */
11461 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11462 107 : lse.descriptor_only = 0;
11463 107 : lse.expr = tmp;
11464 107 : lse.direct_byref = 1;
11465 107 : gfc_conv_expr_descriptor (&lse, expr2);
11466 107 : strlen_rhs = lse.string_length;
11467 107 : gfc_add_modify (&lse.pre, desc, tmp);
11468 : }
11469 :
11470 4370 : if (expr1->ts.type == BT_CHARACTER
11471 596 : && expr1->ts.deferred)
11472 : {
11473 338 : gfc_symbol *psym = expr1->symtree->n.sym;
11474 338 : tmp = NULL_TREE;
11475 338 : if (psym->ts.type == BT_CHARACTER
11476 337 : && psym->ts.u.cl->backend_decl)
11477 337 : tmp = psym->ts.u.cl->backend_decl;
11478 1 : else if (expr1->ts.u.cl->backend_decl
11479 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11480 0 : tmp = expr1->ts.u.cl->backend_decl;
11481 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11482 : {
11483 1 : gfc_ref *ref = expr1->ref;
11484 3 : for (;ref; ref = ref->next)
11485 : {
11486 2 : if (ref->type == REF_COMPONENT
11487 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11488 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11489 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11490 1 : TREE_TYPE (tmp),
11491 1 : TREE_OPERAND (lse.expr, 0),
11492 : tmp, NULL_TREE);
11493 : }
11494 : }
11495 :
11496 338 : gcc_assert (tmp);
11497 :
11498 338 : if (expr2->expr_type != EXPR_NULL)
11499 326 : gfc_add_modify (&block, tmp,
11500 326 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
11501 : else
11502 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
11503 : }
11504 :
11505 4370 : gfc_add_block_to_block (&block, &lse.pre);
11506 4370 : if (rank_remap)
11507 254 : gfc_add_block_to_block (&block, &rse.pre);
11508 :
11509 : /* If we do bounds remapping, update LHS descriptor accordingly. */
11510 4370 : if (remap)
11511 : {
11512 527 : int dim;
11513 527 : gcc_assert (remap->u.ar.dimen == expr1->rank);
11514 :
11515 : /* Always set dtype. */
11516 527 : tree dtype = gfc_conv_descriptor_dtype (desc);
11517 527 : tmp = gfc_get_dtype (TREE_TYPE (desc));
11518 527 : gfc_add_modify (&block, dtype, tmp);
11519 :
11520 : /* For unlimited polymorphic LHS use elem_len from RHS. */
11521 527 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11522 : {
11523 60 : tree elem_len;
11524 60 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11525 60 : elem_len = fold_convert (gfc_array_index_type, tmp);
11526 60 : elem_len = gfc_evaluate_now (elem_len, &block);
11527 60 : tmp = gfc_conv_descriptor_elem_len (desc);
11528 60 : gfc_add_modify (&block, tmp,
11529 60 : fold_convert (TREE_TYPE (tmp), elem_len));
11530 : }
11531 :
11532 527 : if (rank_remap)
11533 : {
11534 : /* Do rank remapping. We already have the RHS's descriptor
11535 : converted in rse and now have to build the correct LHS
11536 : descriptor for it. */
11537 :
11538 254 : tree data, span;
11539 254 : tree offs, stride;
11540 254 : tree lbound, ubound;
11541 :
11542 : /* Copy data pointer. */
11543 254 : data = gfc_conv_descriptor_data_get (rse.expr);
11544 254 : gfc_conv_descriptor_data_set (&block, desc, data);
11545 :
11546 : /* Copy the span. */
11547 254 : if (VAR_P (rse.expr)
11548 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
11549 12 : span = gfc_conv_descriptor_span_get (rse.expr);
11550 : else
11551 : {
11552 242 : tmp = TREE_TYPE (rse.expr);
11553 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
11554 242 : span = fold_convert (gfc_array_index_type, tmp);
11555 : }
11556 254 : gfc_conv_descriptor_span_set (&block, desc, span);
11557 :
11558 : /* Copy offset but adjust it such that it would correspond
11559 : to a lbound of zero. */
11560 254 : if (expr2->rank == -1)
11561 42 : gfc_conv_descriptor_offset_set (&block, desc,
11562 : gfc_index_zero_node);
11563 : else
11564 : {
11565 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
11566 654 : for (dim = 0; dim < expr2->rank; ++dim)
11567 : {
11568 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11569 : gfc_rank_cst[dim]);
11570 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
11571 : gfc_rank_cst[dim]);
11572 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11573 : gfc_array_index_type, stride,
11574 : lbound);
11575 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
11576 : gfc_array_index_type, offs, tmp);
11577 : }
11578 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11579 : }
11580 : /* Set the bounds as declared for the LHS and calculate strides as
11581 : well as another offset update accordingly. */
11582 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11583 : gfc_rank_cst[0]);
11584 641 : for (dim = 0; dim < expr1->rank; ++dim)
11585 : {
11586 387 : gfc_se lower_se;
11587 387 : gfc_se upper_se;
11588 :
11589 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
11590 :
11591 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
11592 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
11593 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
11594 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
11595 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
11596 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
11597 :
11598 : /* Convert declared bounds. */
11599 387 : gfc_init_se (&lower_se, NULL);
11600 387 : gfc_init_se (&upper_se, NULL);
11601 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
11602 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
11603 :
11604 387 : gfc_add_block_to_block (&block, &lower_se.pre);
11605 387 : gfc_add_block_to_block (&block, &upper_se.pre);
11606 :
11607 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
11608 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
11609 :
11610 387 : lbound = gfc_evaluate_now (lbound, &block);
11611 387 : ubound = gfc_evaluate_now (ubound, &block);
11612 :
11613 387 : gfc_add_block_to_block (&block, &lower_se.post);
11614 387 : gfc_add_block_to_block (&block, &upper_se.post);
11615 :
11616 : /* Set bounds in descriptor. */
11617 387 : gfc_conv_descriptor_lbound_set (&block, desc,
11618 : gfc_rank_cst[dim], lbound);
11619 387 : gfc_conv_descriptor_ubound_set (&block, desc,
11620 : gfc_rank_cst[dim], ubound);
11621 :
11622 : /* Set stride. */
11623 387 : stride = gfc_evaluate_now (stride, &block);
11624 387 : gfc_conv_descriptor_stride_set (&block, desc,
11625 : gfc_rank_cst[dim], stride);
11626 :
11627 : /* Update offset. */
11628 387 : offs = gfc_conv_descriptor_offset_get (desc);
11629 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11630 : gfc_array_index_type, lbound, stride);
11631 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
11632 : gfc_array_index_type, offs, tmp);
11633 387 : offs = gfc_evaluate_now (offs, &block);
11634 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11635 :
11636 : /* Update stride. */
11637 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11638 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
11639 : gfc_array_index_type, stride, tmp);
11640 : }
11641 : }
11642 : else
11643 : {
11644 : /* Bounds remapping. Just shift the lower bounds. */
11645 :
11646 273 : gcc_assert (expr1->rank == expr2->rank);
11647 :
11648 654 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
11649 : {
11650 381 : gfc_se lbound_se;
11651 :
11652 381 : gcc_assert (!remap->u.ar.end[dim]);
11653 381 : gfc_init_se (&lbound_se, NULL);
11654 381 : if (remap->u.ar.start[dim])
11655 : {
11656 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
11657 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
11658 : }
11659 : else
11660 : /* This remap arises from a target that is not a whole
11661 : array. The start expressions will be NULL but we need
11662 : the lbounds to be one. */
11663 156 : lbound_se.expr = gfc_index_one_node;
11664 381 : gfc_conv_shift_descriptor_lbound (&block, desc,
11665 : dim, lbound_se.expr);
11666 381 : gfc_add_block_to_block (&block, &lbound_se.post);
11667 : }
11668 : }
11669 : }
11670 :
11671 : /* If rank remapping was done, check with -fcheck=bounds that
11672 : the target is at least as large as the pointer. */
11673 4370 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
11674 72 : && expr2->rank != -1)
11675 : {
11676 54 : tree lsize, rsize;
11677 54 : tree fault;
11678 54 : const char* msg;
11679 :
11680 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
11681 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
11682 :
11683 54 : lsize = gfc_evaluate_now (lsize, &block);
11684 54 : rsize = gfc_evaluate_now (rsize, &block);
11685 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11686 : rsize, lsize);
11687 :
11688 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
11689 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
11690 : msg, rsize, lsize);
11691 : }
11692 :
11693 : /* Check string lengths if applicable. The check is only really added
11694 : to the output code if -fbounds-check is enabled. */
11695 4370 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
11696 : {
11697 530 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11698 530 : gcc_assert (strlen_lhs && strlen_rhs);
11699 530 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11700 : strlen_lhs, strlen_rhs, &block);
11701 : }
11702 :
11703 4370 : gfc_add_block_to_block (&block, &lse.post);
11704 4370 : if (rank_remap)
11705 254 : gfc_add_block_to_block (&block, &rse.post);
11706 : }
11707 :
11708 10178 : return gfc_finish_block (&block);
11709 : }
11710 :
11711 :
11712 : /* Makes sure se is suitable for passing as a function string parameter. */
11713 : /* TODO: Need to check all callers of this function. It may be abused. */
11714 :
11715 : void
11716 246251 : gfc_conv_string_parameter (gfc_se * se)
11717 : {
11718 246251 : tree type;
11719 :
11720 246251 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
11721 246251 : && integer_onep (se->string_length))
11722 : {
11723 691 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11724 691 : return;
11725 : }
11726 :
11727 245560 : if (TREE_CODE (se->expr) == STRING_CST)
11728 : {
11729 102451 : type = TREE_TYPE (TREE_TYPE (se->expr));
11730 102451 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11731 102451 : return;
11732 : }
11733 :
11734 143109 : if (TREE_CODE (se->expr) == COND_EXPR)
11735 : {
11736 478 : tree cond = TREE_OPERAND (se->expr, 0);
11737 478 : tree lhs = TREE_OPERAND (se->expr, 1);
11738 478 : tree rhs = TREE_OPERAND (se->expr, 2);
11739 :
11740 478 : gfc_se lse, rse;
11741 478 : gfc_init_se (&lse, NULL);
11742 478 : gfc_init_se (&rse, NULL);
11743 :
11744 478 : lse.expr = lhs;
11745 478 : lse.string_length = se->string_length;
11746 478 : gfc_conv_string_parameter (&lse);
11747 :
11748 478 : rse.expr = rhs;
11749 478 : rse.string_length = se->string_length;
11750 478 : gfc_conv_string_parameter (&rse);
11751 :
11752 478 : se->expr
11753 478 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
11754 : cond, lse.expr, rse.expr);
11755 : }
11756 :
11757 143109 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
11758 55878 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
11759 143205 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
11760 : {
11761 87327 : type = TREE_TYPE (se->expr);
11762 87327 : if (TREE_CODE (se->expr) != INDIRECT_REF)
11763 82276 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11764 : else
11765 : {
11766 5051 : if (TREE_CODE (type) == ARRAY_TYPE)
11767 5051 : type = TREE_TYPE (type);
11768 5051 : type = gfc_get_character_type_len_for_eltype (type,
11769 : se->string_length);
11770 5051 : type = build_pointer_type (type);
11771 5051 : se->expr = gfc_build_addr_expr (type, se->expr);
11772 : }
11773 : }
11774 :
11775 143109 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
11776 : }
11777 :
11778 :
11779 : /* Generate code for assignment of scalar variables. Includes character
11780 : strings and derived types with allocatable components.
11781 : If you know that the LHS has no allocations, set dealloc to false.
11782 :
11783 : DEEP_COPY has no effect if the typespec TS is not a derived type with
11784 : allocatable components. Otherwise, if it is set, an explicit copy of each
11785 : allocatable component is made. This is necessary as a simple copy of the
11786 : whole object would copy array descriptors as is, so that the lhs's
11787 : allocatable components would point to the rhs's after the assignment.
11788 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
11789 : necessary if the rhs is a non-pointer function, as the allocatable components
11790 : are not accessible by other means than the function's result after the
11791 : function has returned. It is even more subtle when temporaries are involved,
11792 : as the two following examples show:
11793 : 1. When we evaluate an array constructor, a temporary is created. Thus
11794 : there is theoretically no alias possible. However, no deep copy is
11795 : made for this temporary, so that if the constructor is made of one or
11796 : more variable with allocatable components, those components still point
11797 : to the variable's: DEEP_COPY should be set for the assignment from the
11798 : temporary to the lhs in that case.
11799 : 2. When assigning a scalar to an array, we evaluate the scalar value out
11800 : of the loop, store it into a temporary variable, and assign from that.
11801 : In that case, deep copying when assigning to the temporary would be a
11802 : waste of resources; however deep copies should happen when assigning from
11803 : the temporary to each array element: again DEEP_COPY should be set for
11804 : the assignment from the temporary to the lhs. */
11805 :
11806 : tree
11807 338342 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
11808 : bool deep_copy, bool dealloc, bool in_coarray,
11809 : bool assoc_assign)
11810 : {
11811 338342 : stmtblock_t block;
11812 338342 : tree tmp;
11813 338342 : tree cond;
11814 338342 : int caf_mode;
11815 :
11816 338342 : gfc_init_block (&block);
11817 :
11818 338342 : if (ts.type == BT_CHARACTER)
11819 : {
11820 33385 : tree rlen = NULL;
11821 33385 : tree llen = NULL;
11822 :
11823 33385 : if (lse->string_length != NULL_TREE)
11824 : {
11825 33385 : gfc_conv_string_parameter (lse);
11826 33385 : gfc_add_block_to_block (&block, &lse->pre);
11827 33385 : llen = lse->string_length;
11828 : }
11829 :
11830 33385 : if (rse->string_length != NULL_TREE)
11831 : {
11832 33385 : gfc_conv_string_parameter (rse);
11833 33385 : gfc_add_block_to_block (&block, &rse->pre);
11834 33385 : rlen = rse->string_length;
11835 : }
11836 :
11837 33385 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
11838 : rse->expr, ts.kind);
11839 : }
11840 285833 : else if (gfc_bt_struct (ts.type)
11841 304957 : && (ts.u.derived->attr.alloc_comp
11842 12545 : || (deep_copy && has_parameterized_comps (ts.u.derived))))
11843 : {
11844 6723 : tree tmp_var = NULL_TREE;
11845 6723 : cond = NULL_TREE;
11846 :
11847 : /* Are the rhs and the lhs the same? */
11848 6723 : if (deep_copy)
11849 : {
11850 4029 : if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
11851 2907 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11852 4029 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11853 : gfc_build_addr_expr (NULL_TREE, lse->expr),
11854 : gfc_build_addr_expr (NULL_TREE, rse->expr));
11855 4029 : cond = gfc_evaluate_now (cond, &lse->pre);
11856 : }
11857 :
11858 : /* Deallocate the lhs allocated components as long as it is not
11859 : the same as the rhs. This must be done following the assignment
11860 : to prevent deallocating data that could be used in the rhs
11861 : expression. */
11862 6723 : if (dealloc)
11863 : {
11864 1903 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
11865 1903 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
11866 1903 : 0, gfc_may_be_finalized (ts));
11867 1903 : if (deep_copy)
11868 797 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11869 : tmp);
11870 1903 : gfc_add_expr_to_block (&lse->post, tmp);
11871 : }
11872 :
11873 6723 : gfc_add_block_to_block (&block, &rse->pre);
11874 :
11875 : /* Skip finalization for self-assignment. */
11876 6723 : if (deep_copy && lse->finalblock.head)
11877 : {
11878 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11879 : gfc_finish_block (&lse->finalblock));
11880 24 : gfc_add_expr_to_block (&block, tmp);
11881 : }
11882 : else
11883 6699 : gfc_add_block_to_block (&block, &lse->finalblock);
11884 :
11885 6723 : gfc_add_block_to_block (&block, &lse->pre);
11886 :
11887 6723 : if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
11888 6723 : == TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)))
11889 6417 : gfc_add_modify (&block, lse->expr,
11890 6417 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11891 : else
11892 : {
11893 306 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11894 306 : TREE_TYPE (lse->expr), rse->expr);
11895 306 : gfc_add_modify (&block, lse->expr, tmp);
11896 : }
11897 :
11898 : /* Restore pointer address of coarray components. */
11899 6723 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
11900 : {
11901 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
11902 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11903 : tmp);
11904 5 : gfc_add_expr_to_block (&block, tmp);
11905 : }
11906 :
11907 : /* Do a deep copy if the rhs is a variable, if it is not the
11908 : same as the lhs. */
11909 6723 : if (deep_copy)
11910 : {
11911 4029 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11912 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
11913 4029 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
11914 : caf_mode);
11915 4029 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11916 : tmp);
11917 4029 : gfc_add_expr_to_block (&block, tmp);
11918 : }
11919 : }
11920 298234 : else if (gfc_bt_struct (ts.type))
11921 : {
11922 12401 : gfc_add_block_to_block (&block, &rse->pre);
11923 12401 : gfc_add_block_to_block (&block, &lse->finalblock);
11924 12401 : gfc_add_block_to_block (&block, &lse->pre);
11925 12401 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11926 12401 : TREE_TYPE (lse->expr), rse->expr);
11927 12401 : gfc_add_modify (&block, lse->expr, tmp);
11928 : }
11929 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
11930 285833 : else if (ts.type == BT_CLASS)
11931 : {
11932 788 : gfc_add_block_to_block (&block, &lse->pre);
11933 788 : gfc_add_block_to_block (&block, &rse->pre);
11934 788 : gfc_add_block_to_block (&block, &lse->finalblock);
11935 :
11936 788 : if (!trans_scalar_class_assign (&block, lse, rse))
11937 : {
11938 : /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
11939 : for the lhs which ensures that class data rhs cast as a string
11940 : assigns correctly. */
11941 642 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11942 642 : TREE_TYPE (rse->expr), lse->expr);
11943 642 : gfc_add_modify (&block, tmp, rse->expr);
11944 :
11945 : /* Copy allocatable components but guard against class pointer
11946 : assign, which arrives here. */
11947 : #define DATA_DT ts.u.derived->components->ts.u.derived
11948 642 : if (deep_copy
11949 195 : && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11950 43 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11951 152 : && ts.u.derived->components
11952 794 : && DATA_DT && DATA_DT->attr.alloc_comp)
11953 : {
11954 6 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11955 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
11956 : : 0;
11957 6 : tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
11958 : caf_mode);
11959 6 : gfc_add_expr_to_block (&block, tmp);
11960 : }
11961 : #undef DATA_DT
11962 : }
11963 : }
11964 285045 : else if (ts.type != BT_CLASS)
11965 : {
11966 285045 : gfc_add_block_to_block (&block, &lse->pre);
11967 285045 : gfc_add_block_to_block (&block, &rse->pre);
11968 :
11969 285045 : if (in_coarray)
11970 : {
11971 847 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
11972 : {
11973 0 : gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr),
11974 0 : TYPE_LANG_SPECIFIC (
11975 : TREE_TYPE (TREE_TYPE (rse->expr)))
11976 : ->caf_token);
11977 : }
11978 847 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
11979 0 : lse->expr = gfc_conv_array_data (lse->expr);
11980 276 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
11981 847 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
11982 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
11983 : }
11984 285045 : gfc_add_modify (&block, lse->expr,
11985 285045 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11986 : }
11987 :
11988 338342 : gfc_add_block_to_block (&block, &lse->post);
11989 338342 : gfc_add_block_to_block (&block, &rse->post);
11990 :
11991 338342 : return gfc_finish_block (&block);
11992 : }
11993 :
11994 :
11995 : /* There are quite a lot of restrictions on the optimisation in using an
11996 : array function assign without a temporary. */
11997 :
11998 : static bool
11999 14448 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
12000 : {
12001 14448 : gfc_ref * ref;
12002 14448 : bool seen_array_ref;
12003 14448 : bool c = false;
12004 14448 : gfc_symbol *sym = expr1->symtree->n.sym;
12005 :
12006 : /* Play it safe with class functions assigned to a derived type. */
12007 14448 : if (gfc_is_class_array_function (expr2)
12008 14448 : && expr1->ts.type == BT_DERIVED)
12009 : return true;
12010 :
12011 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
12012 14424 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
12013 : return true;
12014 :
12015 : /* Elemental functions are scalarized so that they don't need a
12016 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
12017 : they would need special treatment in gfc_trans_arrayfunc_assign. */
12018 8531 : if (expr2->value.function.esym != NULL
12019 1589 : && expr2->value.function.esym->attr.elemental)
12020 : return true;
12021 :
12022 : /* Need a temporary if rhs is not FULL or a contiguous section. */
12023 8172 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
12024 : return true;
12025 :
12026 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
12027 7922 : if (gfc_ref_needs_temporary_p (expr1->ref))
12028 : return true;
12029 :
12030 : /* Functions returning pointers or allocatables need temporaries. */
12031 7910 : if (gfc_expr_attr (expr2).pointer
12032 7910 : || gfc_expr_attr (expr2).allocatable)
12033 376 : return true;
12034 :
12035 : /* Character array functions need temporaries unless the
12036 : character lengths are the same. */
12037 7534 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
12038 : {
12039 562 : if (UNLIMITED_POLY (expr1))
12040 : return true;
12041 :
12042 556 : if (expr1->ts.u.cl->length == NULL
12043 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12044 : return true;
12045 :
12046 493 : if (expr2->ts.u.cl->length == NULL
12047 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12048 : return true;
12049 :
12050 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
12051 475 : expr2->ts.u.cl->length->value.integer) != 0)
12052 : return true;
12053 : }
12054 :
12055 : /* Check that no LHS component references appear during an array
12056 : reference. This is needed because we do not have the means to
12057 : span any arbitrary stride with an array descriptor. This check
12058 : is not needed for the rhs because the function result has to be
12059 : a complete type. */
12060 7441 : seen_array_ref = false;
12061 14882 : for (ref = expr1->ref; ref; ref = ref->next)
12062 : {
12063 7454 : if (ref->type == REF_ARRAY)
12064 : seen_array_ref= true;
12065 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
12066 : return true;
12067 : }
12068 :
12069 : /* Check for a dependency. */
12070 7428 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
12071 : expr2->value.function.esym,
12072 : expr2->value.function.actual,
12073 : NOT_ELEMENTAL))
12074 : return true;
12075 :
12076 : /* If we have reached here with an intrinsic function, we do not
12077 : need a temporary except in the particular case that reallocation
12078 : on assignment is active and the lhs is allocatable and a target,
12079 : or a pointer which may be a subref pointer. FIXME: The last
12080 : condition can go away when we use span in the intrinsics
12081 : directly.*/
12082 6991 : if (expr2->value.function.isym)
12083 6113 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
12084 12313 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
12085 :
12086 : /* If the LHS is a dummy, we need a temporary if it is not
12087 : INTENT(OUT). */
12088 803 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
12089 : return true;
12090 :
12091 : /* If the lhs has been host_associated, is in common, a pointer or is
12092 : a target and the function is not using a RESULT variable, aliasing
12093 : can occur and a temporary is needed. */
12094 797 : if ((sym->attr.host_assoc
12095 743 : || sym->attr.in_common
12096 737 : || sym->attr.pointer
12097 731 : || sym->attr.cray_pointee
12098 731 : || sym->attr.target)
12099 66 : && expr2->symtree != NULL
12100 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
12101 : return true;
12102 :
12103 : /* A PURE function can unconditionally be called without a temporary. */
12104 755 : if (expr2->value.function.esym != NULL
12105 730 : && expr2->value.function.esym->attr.pure)
12106 : return false;
12107 :
12108 : /* Implicit_pure functions are those which could legally be declared
12109 : to be PURE. */
12110 727 : if (expr2->value.function.esym != NULL
12111 702 : && expr2->value.function.esym->attr.implicit_pure)
12112 : return false;
12113 :
12114 444 : if (!sym->attr.use_assoc
12115 444 : && !sym->attr.in_common
12116 444 : && !sym->attr.pointer
12117 438 : && !sym->attr.target
12118 438 : && !sym->attr.cray_pointee
12119 438 : && expr2->value.function.esym)
12120 : {
12121 : /* A temporary is not needed if the function is not contained and
12122 : the variable is local or host associated and not a pointer or
12123 : a target. */
12124 413 : if (!expr2->value.function.esym->attr.contained)
12125 : return false;
12126 :
12127 : /* A temporary is not needed if the lhs has never been host
12128 : associated and the procedure is contained. */
12129 164 : else if (!sym->attr.host_assoc)
12130 : return false;
12131 :
12132 : /* A temporary is not needed if the variable is local and not
12133 : a pointer, a target or a result. */
12134 6 : if (sym->ns->parent
12135 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12136 : return false;
12137 : }
12138 :
12139 : /* Default to temporary use. */
12140 : return true;
12141 : }
12142 :
12143 :
12144 : /* Provide the loop info so that the lhs descriptor can be built for
12145 : reallocatable assignments from extrinsic function calls. */
12146 :
12147 : static void
12148 203 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12149 : gfc_loopinfo *loop)
12150 : {
12151 : /* Signal that the function call should not be made by
12152 : gfc_conv_loop_setup. */
12153 203 : se->ss->is_alloc_lhs = 1;
12154 203 : gfc_init_loopinfo (loop);
12155 203 : gfc_add_ss_to_loop (loop, *ss);
12156 203 : gfc_add_ss_to_loop (loop, se->ss);
12157 203 : gfc_conv_ss_startstride (loop);
12158 203 : gfc_conv_loop_setup (loop, where);
12159 203 : gfc_copy_loopinfo_to_se (se, loop);
12160 203 : gfc_add_block_to_block (&se->pre, &loop->pre);
12161 203 : gfc_add_block_to_block (&se->pre, &loop->post);
12162 203 : se->ss->is_alloc_lhs = 0;
12163 203 : }
12164 :
12165 :
12166 : /* For assignment to a reallocatable lhs from intrinsic functions,
12167 : replace the se.expr (ie. the result) with a temporary descriptor.
12168 : Null the data field so that the library allocates space for the
12169 : result. Free the data of the original descriptor after the function,
12170 : in case it appears in an argument expression and transfer the
12171 : result to the original descriptor. */
12172 :
12173 : static void
12174 2138 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12175 : {
12176 2138 : tree desc;
12177 2138 : tree res_desc;
12178 2138 : tree tmp;
12179 2138 : tree offset;
12180 2138 : tree zero_cond;
12181 2138 : tree not_same_shape;
12182 2138 : stmtblock_t shape_block;
12183 2138 : int n;
12184 :
12185 : /* Use the allocation done by the library. Substitute the lhs
12186 : descriptor with a copy, whose data field is nulled.*/
12187 2138 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12188 2138 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12189 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12190 :
12191 : /* Unallocated, the descriptor does not have a dtype. */
12192 2138 : tmp = gfc_conv_descriptor_dtype (desc);
12193 2138 : if (dtype != NULL_TREE)
12194 13 : gfc_add_modify (&se->pre, tmp, dtype);
12195 : else
12196 2125 : gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12197 :
12198 2138 : res_desc = gfc_evaluate_now (desc, &se->pre);
12199 2138 : gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
12200 2138 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12201 :
12202 : /* Free the lhs after the function call and copy the result data to
12203 : the lhs descriptor. */
12204 2138 : tmp = gfc_conv_descriptor_data_get (desc);
12205 2138 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12206 : logical_type_node, tmp,
12207 2138 : build_int_cst (TREE_TYPE (tmp), 0));
12208 2138 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12209 2138 : tmp = gfc_call_free (tmp);
12210 2138 : gfc_add_expr_to_block (&se->post, tmp);
12211 :
12212 2138 : tmp = gfc_conv_descriptor_data_get (res_desc);
12213 2138 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12214 :
12215 : /* Check that the shapes are the same between lhs and expression.
12216 : The evaluation of the shape is done in 'shape_block' to avoid
12217 : uninitialized warnings from the lhs bounds. */
12218 2138 : not_same_shape = boolean_false_node;
12219 2138 : gfc_start_block (&shape_block);
12220 6880 : for (n = 0 ; n < rank; n++)
12221 : {
12222 4742 : tree tmp1;
12223 4742 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12224 4742 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12225 4742 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12226 : gfc_array_index_type, tmp, tmp1);
12227 4742 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12228 4742 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12229 : gfc_array_index_type, tmp, tmp1);
12230 4742 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12231 4742 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12232 : gfc_array_index_type, tmp, tmp1);
12233 4742 : tmp = fold_build2_loc (input_location, NE_EXPR,
12234 : logical_type_node, tmp,
12235 : gfc_index_zero_node);
12236 4742 : tmp = gfc_evaluate_now (tmp, &shape_block);
12237 4742 : if (n == 0)
12238 : not_same_shape = tmp;
12239 : else
12240 2604 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12241 : logical_type_node, tmp,
12242 : not_same_shape);
12243 : }
12244 :
12245 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12246 : shapes being different. */
12247 2138 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12248 : zero_cond, not_same_shape);
12249 2138 : gfc_add_modify (&shape_block, zero_cond, tmp);
12250 2138 : tmp = gfc_finish_block (&shape_block);
12251 2138 : tmp = build3_v (COND_EXPR, zero_cond,
12252 : build_empty_stmt (input_location), tmp);
12253 2138 : gfc_add_expr_to_block (&se->post, tmp);
12254 :
12255 : /* Now reset the bounds returned from the function call to bounds based
12256 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12257 : of 'variable and 'expr' are different. Set the offset accordingly. */
12258 2138 : offset = gfc_index_zero_node;
12259 6880 : for (n = 0 ; n < rank; n++)
12260 : {
12261 4742 : tree lbound;
12262 :
12263 4742 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12264 4742 : lbound = fold_build3_loc (input_location, COND_EXPR,
12265 : gfc_array_index_type, zero_cond,
12266 : gfc_index_one_node, lbound);
12267 4742 : lbound = gfc_evaluate_now (lbound, &se->post);
12268 :
12269 4742 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12270 4742 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12271 : gfc_array_index_type, tmp, lbound);
12272 4742 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12273 : gfc_rank_cst[n], lbound);
12274 4742 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12275 : gfc_rank_cst[n], tmp);
12276 :
12277 : /* Set stride and accumulate the offset. */
12278 4742 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12279 4742 : gfc_conv_descriptor_stride_set (&se->post, desc,
12280 : gfc_rank_cst[n], tmp);
12281 4742 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12282 : gfc_array_index_type, lbound, tmp);
12283 4742 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12284 : gfc_array_index_type, offset, tmp);
12285 4742 : offset = gfc_evaluate_now (offset, &se->post);
12286 : }
12287 :
12288 2138 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12289 2138 : }
12290 :
12291 :
12292 :
12293 : /* Try to translate array(:) = func (...), where func is a transformational
12294 : array function, without using a temporary. Returns NULL if this isn't the
12295 : case. */
12296 :
12297 : static tree
12298 14488 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12299 : {
12300 14488 : gfc_se se;
12301 14488 : gfc_ss *ss = NULL;
12302 14488 : gfc_component *comp = NULL;
12303 14488 : gfc_loopinfo loop;
12304 14488 : tree tmp;
12305 14488 : tree lhs;
12306 14488 : gfc_se final_se;
12307 14488 : gfc_symbol *sym = expr1->symtree->n.sym;
12308 14488 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12309 :
12310 : /* If the symbol is host associated and has not been referenced in its name
12311 : space, it might be lacking a backend_decl and vtable. */
12312 14488 : if (sym->backend_decl == NULL_TREE)
12313 : return NULL_TREE;
12314 :
12315 14448 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12316 : return NULL_TREE;
12317 :
12318 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12319 : functions. */
12320 6873 : comp = gfc_get_proc_ptr_comp (expr2);
12321 :
12322 6873 : if (!(expr2->value.function.isym
12323 718 : || (comp && comp->attr.dimension)
12324 718 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12325 718 : && expr2->value.function.esym->result->attr.dimension)))
12326 0 : return NULL_TREE;
12327 :
12328 6873 : gfc_init_se (&se, NULL);
12329 6873 : gfc_start_block (&se.pre);
12330 6873 : se.want_pointer = 1;
12331 :
12332 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12333 : backend decl, stash the original away for the finalization so that the
12334 : value used is that before the assignment. This is necessary because
12335 : evaluation of the rhs expression using direct by reference can change
12336 : the value. However, the standard mandates that the finalization must occur
12337 : after evaluation of the rhs. */
12338 6873 : gfc_init_se (&final_se, NULL);
12339 :
12340 6873 : if (finalizable)
12341 : {
12342 45 : tmp = sym->backend_decl;
12343 45 : lhs = sym->backend_decl;
12344 45 : if (INDIRECT_REF_P (tmp))
12345 0 : tmp = TREE_OPERAND (tmp, 0);
12346 45 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12347 45 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12348 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12349 : {
12350 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12351 : expr1->rank, 0);
12352 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12353 : }
12354 : }
12355 :
12356 45 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12357 : {
12358 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12359 45 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12360 : }
12361 :
12362 6873 : if (finalizable)
12363 45 : sym->backend_decl = lhs;
12364 :
12365 6873 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12366 :
12367 6873 : if (expr1->ts.type == BT_DERIVED
12368 264 : && expr1->ts.u.derived->attr.alloc_comp)
12369 : {
12370 110 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12371 110 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12372 : expr1->rank);
12373 110 : gfc_add_expr_to_block (&se.pre, tmp);
12374 : }
12375 :
12376 6873 : se.direct_byref = 1;
12377 6873 : se.ss = gfc_walk_expr (expr2);
12378 6873 : gcc_assert (se.ss != gfc_ss_terminator);
12379 :
12380 : /* Since this is a direct by reference call, references to the lhs can be
12381 : used for finalization of the function result just as long as the blocks
12382 : from final_se are added at the right time. */
12383 6873 : gfc_init_se (&final_se, NULL);
12384 6873 : if (finalizable && expr2->value.function.esym)
12385 : {
12386 32 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12387 32 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12388 32 : expr2->value.function.esym->attr,
12389 : expr2->rank);
12390 : }
12391 :
12392 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12393 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12394 : Clearly, this cannot be done for an allocatable function result, since
12395 : the shape of the result is unknown and, in any case, the function must
12396 : correctly take care of the reallocation internally. For intrinsic
12397 : calls, the array data is freed and the library takes care of allocation.
12398 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12399 : to the library. */
12400 6873 : if (flag_realloc_lhs
12401 6798 : && gfc_is_reallocatable_lhs (expr1)
12402 9214 : && !gfc_expr_attr (expr1).codimension
12403 2341 : && !gfc_is_coindexed (expr1)
12404 9214 : && !(expr2->value.function.esym
12405 203 : && expr2->value.function.esym->result->attr.allocatable))
12406 : {
12407 2341 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12408 :
12409 2341 : if (!expr2->value.function.isym)
12410 : {
12411 203 : ss = gfc_walk_expr (expr1);
12412 203 : gcc_assert (ss != gfc_ss_terminator);
12413 :
12414 203 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12415 203 : ss->is_alloc_lhs = 1;
12416 : }
12417 : else
12418 : {
12419 2138 : tree dtype = NULL_TREE;
12420 2138 : tree type = gfc_typenode_for_spec (&expr2->ts);
12421 2138 : if (expr1->ts.type == BT_CLASS)
12422 : {
12423 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12424 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12425 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12426 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12427 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12428 : }
12429 2138 : fcncall_realloc_result (&se, expr1->rank, dtype);
12430 : }
12431 : }
12432 :
12433 6873 : gfc_conv_function_expr (&se, expr2);
12434 :
12435 : /* Fix the result. */
12436 6873 : gfc_add_block_to_block (&se.pre, &se.post);
12437 6873 : if (finalizable)
12438 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12439 :
12440 : /* Do the finalization, including final calls from function arguments. */
12441 45 : if (finalizable)
12442 : {
12443 45 : gfc_add_block_to_block (&se.pre, &final_se.post);
12444 45 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12445 45 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12446 : }
12447 :
12448 6873 : if (ss)
12449 203 : gfc_cleanup_loop (&loop);
12450 : else
12451 6670 : gfc_free_ss_chain (se.ss);
12452 :
12453 6873 : return gfc_finish_block (&se.pre);
12454 : }
12455 :
12456 :
12457 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12458 : can't be done. */
12459 :
12460 : static tree
12461 3957 : gfc_trans_zero_assign (gfc_expr * expr)
12462 : {
12463 3957 : tree dest, len, type;
12464 3957 : tree tmp;
12465 3957 : gfc_symbol *sym;
12466 :
12467 3957 : sym = expr->symtree->n.sym;
12468 3957 : dest = gfc_get_symbol_decl (sym);
12469 :
12470 3957 : type = TREE_TYPE (dest);
12471 3957 : if (POINTER_TYPE_P (type))
12472 249 : type = TREE_TYPE (type);
12473 3957 : if (GFC_ARRAY_TYPE_P (type))
12474 : {
12475 : /* Determine the length of the array. */
12476 2778 : len = GFC_TYPE_ARRAY_SIZE (type);
12477 2778 : if (!len || TREE_CODE (len) != INTEGER_CST)
12478 : return NULL_TREE;
12479 : }
12480 1179 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12481 1179 : && gfc_is_simply_contiguous (expr, false, false))
12482 : {
12483 1079 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12484 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12485 1079 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12486 1079 : dest = gfc_conv_descriptor_data_get (dest);
12487 : }
12488 : else
12489 100 : return NULL_TREE;
12490 :
12491 : /* If we are zeroing a local array avoid taking its address by emitting
12492 : a = {} instead. */
12493 3678 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12494 2556 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12495 2556 : dest, build_constructor (TREE_TYPE (dest),
12496 2556 : NULL));
12497 :
12498 : /* Multiply len by element size. */
12499 1122 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12500 1122 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12501 : len, fold_convert (gfc_array_index_type, tmp));
12502 :
12503 : /* Convert arguments to the correct types. */
12504 1122 : dest = fold_convert (pvoid_type_node, dest);
12505 1122 : len = fold_convert (size_type_node, len);
12506 :
12507 : /* Construct call to __builtin_memset. */
12508 1122 : tmp = build_call_expr_loc (input_location,
12509 : builtin_decl_explicit (BUILT_IN_MEMSET),
12510 : 3, dest, integer_zero_node, len);
12511 1122 : return fold_convert (void_type_node, tmp);
12512 : }
12513 :
12514 :
12515 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
12516 : that constructs the call to __builtin_memcpy. */
12517 :
12518 : tree
12519 7938 : gfc_build_memcpy_call (tree dst, tree src, tree len)
12520 : {
12521 7938 : tree tmp;
12522 :
12523 : /* Convert arguments to the correct types. */
12524 7938 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
12525 7637 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
12526 : else
12527 301 : dst = fold_convert (pvoid_type_node, dst);
12528 :
12529 7938 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
12530 7536 : src = gfc_build_addr_expr (pvoid_type_node, src);
12531 : else
12532 402 : src = fold_convert (pvoid_type_node, src);
12533 :
12534 7938 : len = fold_convert (size_type_node, len);
12535 :
12536 : /* Construct call to __builtin_memcpy. */
12537 7938 : tmp = build_call_expr_loc (input_location,
12538 : builtin_decl_explicit (BUILT_IN_MEMCPY),
12539 : 3, dst, src, len);
12540 7938 : return fold_convert (void_type_node, tmp);
12541 : }
12542 :
12543 :
12544 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
12545 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
12546 : source/rhs, both are gfc_full_array_ref_p which have been checked for
12547 : dependencies. */
12548 :
12549 : static tree
12550 2603 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
12551 : {
12552 2603 : tree dst, dlen, dtype;
12553 2603 : tree src, slen, stype;
12554 2603 : tree tmp;
12555 :
12556 2603 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12557 2603 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
12558 :
12559 2603 : dtype = TREE_TYPE (dst);
12560 2603 : if (POINTER_TYPE_P (dtype))
12561 265 : dtype = TREE_TYPE (dtype);
12562 2603 : stype = TREE_TYPE (src);
12563 2603 : if (POINTER_TYPE_P (stype))
12564 293 : stype = TREE_TYPE (stype);
12565 :
12566 2603 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
12567 : return NULL_TREE;
12568 :
12569 : /* Determine the lengths of the arrays. */
12570 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
12571 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
12572 : return NULL_TREE;
12573 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12574 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12575 : dlen, fold_convert (gfc_array_index_type, tmp));
12576 :
12577 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
12578 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
12579 : return NULL_TREE;
12580 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
12581 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12582 : slen, fold_convert (gfc_array_index_type, tmp));
12583 :
12584 : /* Sanity check that they are the same. This should always be
12585 : the case, as we should already have checked for conformance. */
12586 1486 : if (!tree_int_cst_equal (slen, dlen))
12587 : return NULL_TREE;
12588 :
12589 1486 : return gfc_build_memcpy_call (dst, src, dlen);
12590 : }
12591 :
12592 :
12593 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
12594 : this can't be done. EXPR1 is the destination/lhs for which
12595 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
12596 :
12597 : static tree
12598 8169 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
12599 : {
12600 8169 : unsigned HOST_WIDE_INT nelem;
12601 8169 : tree dst, dtype;
12602 8169 : tree src, stype;
12603 8169 : tree len;
12604 8169 : tree tmp;
12605 :
12606 8169 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
12607 8169 : if (nelem == 0)
12608 : return NULL_TREE;
12609 :
12610 6778 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12611 6778 : dtype = TREE_TYPE (dst);
12612 6778 : if (POINTER_TYPE_P (dtype))
12613 265 : dtype = TREE_TYPE (dtype);
12614 6778 : if (!GFC_ARRAY_TYPE_P (dtype))
12615 : return NULL_TREE;
12616 :
12617 : /* Determine the lengths of the array. */
12618 5931 : len = GFC_TYPE_ARRAY_SIZE (dtype);
12619 5931 : if (!len || TREE_CODE (len) != INTEGER_CST)
12620 : return NULL_TREE;
12621 :
12622 : /* Confirm that the constructor is the same size. */
12623 5827 : if (compare_tree_int (len, nelem) != 0)
12624 : return NULL_TREE;
12625 :
12626 5827 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12627 5827 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
12628 : fold_convert (gfc_array_index_type, tmp));
12629 :
12630 5827 : stype = gfc_typenode_for_spec (&expr2->ts);
12631 5827 : src = gfc_build_constant_array_constructor (expr2, stype);
12632 :
12633 5827 : return gfc_build_memcpy_call (dst, src, len);
12634 : }
12635 :
12636 :
12637 : /* Tells whether the expression is to be treated as a variable reference. */
12638 :
12639 : bool
12640 314715 : gfc_expr_is_variable (gfc_expr *expr)
12641 : {
12642 314975 : gfc_expr *arg;
12643 314975 : gfc_component *comp;
12644 314975 : gfc_symbol *func_ifc;
12645 :
12646 314975 : if (expr->expr_type == EXPR_VARIABLE)
12647 : return true;
12648 :
12649 279720 : arg = gfc_get_noncopying_intrinsic_argument (expr);
12650 279720 : if (arg)
12651 : {
12652 260 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
12653 : return gfc_expr_is_variable (arg);
12654 : }
12655 :
12656 : /* A data-pointer-returning function should be considered as a variable
12657 : too. */
12658 279460 : if (expr->expr_type == EXPR_FUNCTION
12659 37072 : && expr->ref == NULL)
12660 : {
12661 36683 : if (expr->value.function.isym != NULL)
12662 : return false;
12663 :
12664 9594 : if (expr->value.function.esym != NULL)
12665 : {
12666 9585 : func_ifc = expr->value.function.esym;
12667 9585 : goto found_ifc;
12668 : }
12669 9 : gcc_assert (expr->symtree);
12670 9 : func_ifc = expr->symtree->n.sym;
12671 9 : goto found_ifc;
12672 : }
12673 :
12674 242777 : comp = gfc_get_proc_ptr_comp (expr);
12675 242777 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
12676 389 : && comp)
12677 : {
12678 275 : func_ifc = comp->ts.interface;
12679 275 : goto found_ifc;
12680 : }
12681 :
12682 242502 : if (expr->expr_type == EXPR_COMPCALL)
12683 : {
12684 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
12685 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
12686 0 : goto found_ifc;
12687 : }
12688 :
12689 : return false;
12690 :
12691 9869 : found_ifc:
12692 9869 : gcc_assert (func_ifc->attr.function
12693 : && func_ifc->result != NULL);
12694 9869 : return func_ifc->result->attr.pointer;
12695 : }
12696 :
12697 :
12698 : /* Is the lhs OK for automatic reallocation? */
12699 :
12700 : static bool
12701 266234 : is_scalar_reallocatable_lhs (gfc_expr *expr)
12702 : {
12703 266234 : gfc_ref * ref;
12704 :
12705 : /* An allocatable variable with no reference. */
12706 266234 : if (expr->symtree->n.sym->attr.allocatable
12707 6777 : && !expr->ref)
12708 : return true;
12709 :
12710 : /* All that can be left are allocatable components. However, we do
12711 : not check for allocatable components here because the expression
12712 : could be an allocatable component of a pointer component. */
12713 263455 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
12714 240797 : && expr->symtree->n.sym->ts.type != BT_CLASS)
12715 : return false;
12716 :
12717 : /* Find an allocatable component ref last. */
12718 40161 : for (ref = expr->ref; ref; ref = ref->next)
12719 16547 : if (ref->type == REF_COMPONENT
12720 12227 : && !ref->next
12721 9425 : && ref->u.c.component->attr.allocatable)
12722 : return true;
12723 :
12724 : return false;
12725 : }
12726 :
12727 :
12728 : /* Allocate or reallocate scalar lhs, as necessary. */
12729 :
12730 : static void
12731 3631 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
12732 : tree string_length,
12733 : gfc_expr *expr1,
12734 : gfc_expr *expr2)
12735 :
12736 : {
12737 3631 : tree cond;
12738 3631 : tree tmp;
12739 3631 : tree size;
12740 3631 : tree size_in_bytes;
12741 3631 : tree jump_label1;
12742 3631 : tree jump_label2;
12743 3631 : gfc_se lse;
12744 3631 : gfc_ref *ref;
12745 :
12746 3631 : if (!expr1 || expr1->rank)
12747 0 : return;
12748 :
12749 3631 : if (!expr2 || expr2->rank)
12750 : return;
12751 :
12752 5091 : for (ref = expr1->ref; ref; ref = ref->next)
12753 1460 : if (ref->type == REF_SUBSTRING)
12754 : return;
12755 :
12756 3631 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
12757 :
12758 : /* Since this is a scalar lhs, we can afford to do this. That is,
12759 : there is no risk of side effects being repeated. */
12760 3631 : gfc_init_se (&lse, NULL);
12761 3631 : lse.want_pointer = 1;
12762 3631 : gfc_conv_expr (&lse, expr1);
12763 :
12764 3631 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12765 3631 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12766 :
12767 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
12768 3631 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
12769 3631 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
12770 : lse.expr, tmp);
12771 3631 : tmp = build3_v (COND_EXPR, cond,
12772 : build1_v (GOTO_EXPR, jump_label1),
12773 : build_empty_stmt (input_location));
12774 3631 : gfc_add_expr_to_block (block, tmp);
12775 :
12776 3631 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12777 : {
12778 : /* Use the rhs string length and the lhs element size. Note that 'size' is
12779 : used below for the string-length comparison, only. */
12780 1518 : size = string_length;
12781 1518 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12782 3036 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
12783 1518 : TREE_TYPE (tmp), tmp,
12784 1518 : fold_convert (TREE_TYPE (tmp), size));
12785 : }
12786 : else
12787 : {
12788 : /* Otherwise use the length in bytes of the rhs. */
12789 2113 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
12790 2113 : size_in_bytes = size;
12791 : }
12792 :
12793 3631 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12794 : size_in_bytes, size_one_node);
12795 :
12796 3631 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
12797 : {
12798 32 : tree caf_decl, token;
12799 32 : gfc_se caf_se;
12800 32 : symbol_attribute attr;
12801 :
12802 32 : gfc_clear_attr (&attr);
12803 32 : gfc_init_se (&caf_se, NULL);
12804 :
12805 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
12806 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
12807 : NULL);
12808 32 : gfc_add_block_to_block (block, &caf_se.pre);
12809 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
12810 : gfc_build_addr_expr (NULL_TREE, token),
12811 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
12812 : expr1, 1);
12813 : }
12814 3599 : else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
12815 : {
12816 55 : tmp = build_call_expr_loc (input_location,
12817 : builtin_decl_explicit (BUILT_IN_CALLOC),
12818 : 2, build_one_cst (size_type_node),
12819 : size_in_bytes);
12820 55 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12821 55 : gfc_add_modify (block, lse.expr, tmp);
12822 : }
12823 : else
12824 : {
12825 3544 : tmp = build_call_expr_loc (input_location,
12826 : builtin_decl_explicit (BUILT_IN_MALLOC),
12827 : 1, size_in_bytes);
12828 3544 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12829 3544 : gfc_add_modify (block, lse.expr, tmp);
12830 : }
12831 :
12832 3631 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12833 : {
12834 : /* Deferred characters need checking for lhs and rhs string
12835 : length. Other deferred parameter variables will have to
12836 : come here too. */
12837 1518 : tmp = build1_v (GOTO_EXPR, jump_label2);
12838 1518 : gfc_add_expr_to_block (block, tmp);
12839 : }
12840 3631 : tmp = build1_v (LABEL_EXPR, jump_label1);
12841 3631 : gfc_add_expr_to_block (block, tmp);
12842 :
12843 : /* For a deferred length character, reallocate if lengths of lhs and
12844 : rhs are different. */
12845 3631 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12846 : {
12847 1518 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12848 : lse.string_length,
12849 1518 : fold_convert (TREE_TYPE (lse.string_length),
12850 : size));
12851 : /* Jump past the realloc if the lengths are the same. */
12852 1518 : tmp = build3_v (COND_EXPR, cond,
12853 : build1_v (GOTO_EXPR, jump_label2),
12854 : build_empty_stmt (input_location));
12855 1518 : gfc_add_expr_to_block (block, tmp);
12856 1518 : tmp = build_call_expr_loc (input_location,
12857 : builtin_decl_explicit (BUILT_IN_REALLOC),
12858 : 2, fold_convert (pvoid_type_node, lse.expr),
12859 : size_in_bytes);
12860 1518 : tree omp_cond = NULL_TREE;
12861 1518 : if (flag_openmp_allocators)
12862 : {
12863 1 : tree omp_tmp;
12864 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
12865 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
12866 :
12867 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12868 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12869 : fold_convert (pvoid_type_node,
12870 : lse.expr), size_in_bytes,
12871 : build_zero_cst (ptr_type_node),
12872 : build_zero_cst (ptr_type_node));
12873 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
12874 : omp_cond, omp_tmp, tmp);
12875 : }
12876 1518 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12877 1518 : gfc_add_modify (block, lse.expr, tmp);
12878 1518 : if (omp_cond)
12879 1 : gfc_add_expr_to_block (block,
12880 : build3_loc (input_location, COND_EXPR,
12881 : void_type_node, omp_cond,
12882 : gfc_omp_call_add_alloc (lse.expr),
12883 : build_empty_stmt (input_location)));
12884 1518 : tmp = build1_v (LABEL_EXPR, jump_label2);
12885 1518 : gfc_add_expr_to_block (block, tmp);
12886 :
12887 : /* Update the lhs character length. */
12888 1518 : size = string_length;
12889 1518 : gfc_add_modify (block, lse.string_length,
12890 1518 : fold_convert (TREE_TYPE (lse.string_length), size));
12891 : }
12892 : }
12893 :
12894 : /* Check for assignments of the type
12895 :
12896 : a = a + 4
12897 :
12898 : to make sure we do not check for reallocation unnecessarily. */
12899 :
12900 :
12901 : /* Strip parentheses from an expression to get the underlying variable.
12902 : This is needed for self-assignment detection since (a) creates a
12903 : parentheses operator node. */
12904 :
12905 : static gfc_expr *
12906 7963 : strip_parentheses (gfc_expr *expr)
12907 : {
12908 0 : while (expr->expr_type == EXPR_OP
12909 316372 : && expr->value.op.op == INTRINSIC_PARENTHESES)
12910 590 : expr = expr->value.op.op1;
12911 315111 : return expr;
12912 : }
12913 :
12914 :
12915 : static bool
12916 7486 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
12917 : {
12918 7963 : gfc_actual_arglist *a;
12919 7963 : gfc_expr *e1, *e2;
12920 :
12921 : /* Strip parentheses to handle cases like a = (a). */
12922 15977 : expr1 = strip_parentheses (expr1);
12923 7963 : expr2 = strip_parentheses (expr2);
12924 :
12925 7963 : switch (expr2->expr_type)
12926 : {
12927 2176 : case EXPR_VARIABLE:
12928 2176 : return gfc_dep_compare_expr (expr1, expr2) == 0;
12929 :
12930 2839 : case EXPR_FUNCTION:
12931 2839 : if (expr2->value.function.esym
12932 305 : && expr2->value.function.esym->attr.elemental)
12933 : {
12934 75 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12935 : {
12936 74 : e1 = a->expr;
12937 74 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12938 : return false;
12939 : }
12940 : return true;
12941 : }
12942 2777 : else if (expr2->value.function.isym
12943 2520 : && expr2->value.function.isym->elemental)
12944 : {
12945 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12946 : {
12947 322 : e1 = a->expr;
12948 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12949 : return false;
12950 : }
12951 : return true;
12952 : }
12953 :
12954 : break;
12955 :
12956 671 : case EXPR_OP:
12957 671 : switch (expr2->value.op.op)
12958 : {
12959 19 : case INTRINSIC_NOT:
12960 19 : case INTRINSIC_UPLUS:
12961 19 : case INTRINSIC_UMINUS:
12962 19 : case INTRINSIC_PARENTHESES:
12963 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
12964 :
12965 627 : case INTRINSIC_PLUS:
12966 627 : case INTRINSIC_MINUS:
12967 627 : case INTRINSIC_TIMES:
12968 627 : case INTRINSIC_DIVIDE:
12969 627 : case INTRINSIC_POWER:
12970 627 : case INTRINSIC_AND:
12971 627 : case INTRINSIC_OR:
12972 627 : case INTRINSIC_EQV:
12973 627 : case INTRINSIC_NEQV:
12974 627 : case INTRINSIC_EQ:
12975 627 : case INTRINSIC_NE:
12976 627 : case INTRINSIC_GT:
12977 627 : case INTRINSIC_GE:
12978 627 : case INTRINSIC_LT:
12979 627 : case INTRINSIC_LE:
12980 627 : case INTRINSIC_EQ_OS:
12981 627 : case INTRINSIC_NE_OS:
12982 627 : case INTRINSIC_GT_OS:
12983 627 : case INTRINSIC_GE_OS:
12984 627 : case INTRINSIC_LT_OS:
12985 627 : case INTRINSIC_LE_OS:
12986 :
12987 627 : e1 = expr2->value.op.op1;
12988 627 : e2 = expr2->value.op.op2;
12989 :
12990 627 : if (e1->rank == 0 && e2->rank > 0)
12991 : return is_runtime_conformable (expr1, e2);
12992 569 : else if (e1->rank > 0 && e2->rank == 0)
12993 : return is_runtime_conformable (expr1, e1);
12994 169 : else if (e1->rank > 0 && e2->rank > 0)
12995 169 : return is_runtime_conformable (expr1, e1)
12996 169 : && is_runtime_conformable (expr1, e2);
12997 : break;
12998 :
12999 : default:
13000 : break;
13001 :
13002 : }
13003 :
13004 : break;
13005 :
13006 : default:
13007 : break;
13008 : }
13009 : return false;
13010 : }
13011 :
13012 :
13013 : static tree
13014 3319 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
13015 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
13016 : bool class_realloc)
13017 : {
13018 3319 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
13019 3319 : vec<tree, va_gc> *args = NULL;
13020 3319 : bool final_expr;
13021 :
13022 3319 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
13023 3319 : if (final_expr)
13024 : {
13025 473 : if (rse->loop)
13026 226 : gfc_prepend_expr_to_block (&rse->loop->pre,
13027 : gfc_finish_block (&lse->finalblock));
13028 : else
13029 247 : gfc_add_block_to_block (block, &lse->finalblock);
13030 : }
13031 :
13032 : /* Store the old vptr so that dynamic types can be compared for
13033 : reallocation to occur or not. */
13034 3319 : if (class_realloc)
13035 : {
13036 283 : tmp = lse->expr;
13037 283 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13038 0 : tmp = gfc_get_class_from_expr (tmp);
13039 : }
13040 :
13041 3319 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
13042 : &from_len, &rhs_vptr);
13043 3319 : if (rhs_vptr == NULL_TREE)
13044 43 : rhs_vptr = vptr;
13045 :
13046 : /* Generate (re)allocation of the lhs. */
13047 3319 : if (class_realloc)
13048 : {
13049 283 : stmtblock_t alloc, re_alloc;
13050 283 : tree class_han, re, size;
13051 :
13052 283 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13053 283 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
13054 : else
13055 0 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
13056 :
13057 283 : size = gfc_vptr_size_get (rhs_vptr);
13058 :
13059 : /* Take into account _len of unlimited polymorphic entities.
13060 : TODO: handle class(*) allocatable function results on rhs. */
13061 283 : if (UNLIMITED_POLY (rhs))
13062 : {
13063 18 : tree len;
13064 18 : if (rhs->expr_type == EXPR_VARIABLE)
13065 12 : len = trans_get_upoly_len (block, rhs);
13066 : else
13067 6 : len = gfc_class_len_get (tmp);
13068 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13069 : fold_convert (size_type_node, len),
13070 : size_one_node);
13071 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
13072 18 : size, fold_convert (TREE_TYPE (size), len));
13073 18 : }
13074 265 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
13075 27 : size = fold_build2_loc (input_location, MULT_EXPR,
13076 : gfc_charlen_type_node, size,
13077 : rse->string_length);
13078 :
13079 :
13080 283 : tmp = lse->expr;
13081 283 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
13082 283 : ? gfc_class_data_get (tmp) : tmp;
13083 :
13084 283 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
13085 0 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
13086 :
13087 : /* Allocate block. */
13088 283 : gfc_init_block (&alloc);
13089 283 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
13090 :
13091 : /* Reallocate if dynamic types are different. */
13092 283 : gfc_init_block (&re_alloc);
13093 283 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
13094 : {
13095 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
13096 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
13097 : }
13098 : else
13099 : {
13100 256 : tmp = fold_convert (pvoid_type_node, class_han);
13101 256 : re = build_call_expr_loc (input_location,
13102 : builtin_decl_explicit (BUILT_IN_REALLOC),
13103 : 2, tmp, size);
13104 256 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
13105 : tmp, re);
13106 256 : tmp = fold_build2_loc (input_location, NE_EXPR,
13107 : logical_type_node, rhs_vptr, old_vptr);
13108 256 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13109 : tmp, re, build_empty_stmt (input_location));
13110 256 : gfc_add_expr_to_block (&re_alloc, re);
13111 : }
13112 283 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
13113 283 : gfc_finish_block (&re_alloc) :
13114 0 : build_empty_stmt (input_location);
13115 :
13116 : /* Allocate if _data is NULL, reallocate otherwise. */
13117 283 : tmp = fold_build2_loc (input_location, EQ_EXPR,
13118 : logical_type_node, class_han,
13119 : build_int_cst (prvoid_type_node, 0));
13120 283 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13121 : gfc_unlikely (tmp,
13122 : PRED_FORTRAN_FAIL_ALLOC),
13123 : gfc_finish_block (&alloc),
13124 : realloc_expr);
13125 283 : gfc_add_expr_to_block (&lse->pre, tmp);
13126 : }
13127 :
13128 3319 : fcn = gfc_vptr_copy_get (vptr);
13129 :
13130 3319 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
13131 3319 : ? gfc_class_data_get (rse->expr) : rse->expr;
13132 3319 : if (use_vptr_copy)
13133 : {
13134 5584 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13135 524 : || INDIRECT_REF_P (tmp)
13136 403 : || (rhs->ts.type == BT_DERIVED
13137 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13138 0 : && !rhs->ts.u.derived->attr.pointer
13139 0 : && !rhs->ts.u.derived->attr.allocatable)
13140 3454 : || (UNLIMITED_POLY (rhs)
13141 134 : && !CLASS_DATA (rhs)->attr.pointer
13142 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13143 2648 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13144 : else
13145 403 : vec_safe_push (args, tmp);
13146 3051 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13147 3051 : ? gfc_class_data_get (lse->expr) : lse->expr;
13148 5322 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13149 780 : || INDIRECT_REF_P (tmp)
13150 283 : || (lhs->ts.type == BT_DERIVED
13151 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13152 0 : && !lhs->ts.u.derived->attr.pointer
13153 0 : && !lhs->ts.u.derived->attr.allocatable)
13154 3334 : || (UNLIMITED_POLY (lhs)
13155 119 : && !CLASS_DATA (lhs)->attr.pointer
13156 119 : && !CLASS_DATA (lhs)->attr.allocatable))
13157 2768 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13158 : else
13159 283 : vec_safe_push (args, tmp);
13160 :
13161 3051 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13162 :
13163 3051 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13164 : {
13165 406 : tree extcopy;
13166 406 : vec_safe_push (args, from_len);
13167 406 : vec_safe_push (args, to_len);
13168 406 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13169 :
13170 406 : tmp = fold_build2_loc (input_location, GT_EXPR,
13171 : logical_type_node, from_len,
13172 406 : build_zero_cst (TREE_TYPE (from_len)));
13173 406 : return fold_build3_loc (input_location, COND_EXPR,
13174 : void_type_node, tmp,
13175 406 : extcopy, stdcopy);
13176 : }
13177 : else
13178 2645 : return stdcopy;
13179 : }
13180 : else
13181 : {
13182 268 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13183 268 : ? gfc_class_data_get (lse->expr) : lse->expr;
13184 268 : stmtblock_t tblock;
13185 268 : gfc_init_block (&tblock);
13186 268 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13187 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13188 268 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13189 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13190 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13191 268 : gfc_add_modify_loc (input_location, &tblock, rhst,
13192 268 : fold_convert (TREE_TYPE (rhst), tmp));
13193 268 : return gfc_finish_block (&tblock);
13194 : }
13195 : }
13196 :
13197 : bool
13198 309092 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13199 : {
13200 309092 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13201 : return false;
13202 :
13203 31859 : return lhs->symtree->n.sym->assoc
13204 31859 : && lhs->symtree->n.sym->assoc->target == rhs;
13205 : }
13206 :
13207 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13208 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13209 : init_flag indicates initialization expressions and dealloc that no
13210 : deallocate prior assignment is needed (if in doubt, set true).
13211 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13212 : routine instead of a pointer assignment. Alias resolution is only done,
13213 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13214 : where it is known, that newly allocated memory on the lhs can never be
13215 : an alias of the rhs. */
13216 :
13217 : static tree
13218 309092 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13219 : bool dealloc, bool use_vptr_copy, bool may_alias)
13220 : {
13221 309092 : gfc_se lse;
13222 309092 : gfc_se rse;
13223 309092 : gfc_ss *lss;
13224 309092 : gfc_ss *lss_section;
13225 309092 : gfc_ss *rss;
13226 309092 : gfc_loopinfo loop;
13227 309092 : tree tmp;
13228 309092 : stmtblock_t block;
13229 309092 : stmtblock_t body;
13230 309092 : bool final_expr;
13231 309092 : bool l_is_temp;
13232 309092 : bool scalar_to_array;
13233 309092 : tree string_length;
13234 309092 : int n;
13235 309092 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13236 309092 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr, rhs_attr;
13237 309092 : bool is_poly_assign;
13238 309092 : bool realloc_flag;
13239 309092 : bool assoc_assign = false;
13240 309092 : bool dummy_class_array_copy;
13241 :
13242 : /* Assignment of the form lhs = rhs. */
13243 309092 : gfc_start_block (&block);
13244 :
13245 309092 : gfc_init_se (&lse, NULL);
13246 309092 : gfc_init_se (&rse, NULL);
13247 :
13248 309092 : gfc_fix_class_refs (expr1);
13249 :
13250 618184 : realloc_flag = flag_realloc_lhs
13251 303012 : && gfc_is_reallocatable_lhs (expr1)
13252 8293 : && expr2->rank
13253 315918 : && !is_runtime_conformable (expr1, expr2);
13254 :
13255 : /* Walk the lhs. */
13256 309092 : lss = gfc_walk_expr (expr1);
13257 309092 : if (realloc_flag)
13258 : {
13259 6443 : lss->no_bounds_check = 1;
13260 6443 : lss->is_alloc_lhs = 1;
13261 : }
13262 : else
13263 302649 : lss->no_bounds_check = expr1->no_bounds_check;
13264 :
13265 309092 : rss = NULL;
13266 :
13267 309092 : if (expr2->expr_type != EXPR_VARIABLE
13268 309092 : && expr2->expr_type != EXPR_CONSTANT
13269 309092 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13270 : {
13271 882 : expr2->must_finalize = 1;
13272 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13273 : function, the result is finalized after execution of the innermost
13274 : executable construct containing the reference. */
13275 882 : if (expr2->expr_type == EXPR_FUNCTION
13276 882 : && (gfc_expr_attr (expr2).pointer
13277 292 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13278 147 : expr2->must_finalize = 0;
13279 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13280 : structure constructor or array constructor, the entity created by
13281 : the constructor is finalized after execution of the innermost
13282 : executable construct containing the reference.
13283 : These finalizations were later deleted by the Combined Technical
13284 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13285 735 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13286 735 : && (expr2->expr_type == EXPR_STRUCTURE
13287 692 : || expr2->expr_type == EXPR_ARRAY))
13288 381 : expr2->must_finalize = 0;
13289 : }
13290 :
13291 :
13292 : /* Checking whether a class assignment is desired is quite complicated and
13293 : needed at two locations, so do it once only before the information is
13294 : needed. */
13295 309092 : lhs_attr = gfc_expr_attr (expr1);
13296 309092 : rhs_attr = gfc_expr_attr (expr2);
13297 309092 : dummy_class_array_copy
13298 618184 : = (expr2->expr_type == EXPR_VARIABLE
13299 31859 : && expr2->rank > 0
13300 8384 : && expr2->symtree != NULL
13301 8384 : && expr2->symtree->n.sym->attr.dummy
13302 1471 : && expr2->ts.type == BT_CLASS
13303 127 : && !rhs_attr.pointer
13304 127 : && !rhs_attr.allocatable
13305 114 : && !CLASS_DATA (expr2)->attr.class_pointer
13306 309206 : && !CLASS_DATA (expr2)->attr.allocatable);
13307 :
13308 : /* What can be sent to trans_class_assignment includes all the obvious
13309 : candidates but scalar assignment of a class expression to a derived type
13310 : must be done using gfc_trans_scalar_assign; partly because it is simpler
13311 : and partly because some cases fail, eg. class assignment to derived_type
13312 : select type temporaries. */
13313 309092 : is_poly_assign
13314 309092 : = (use_vptr_copy
13315 292195 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13316 22786 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13317 20711 : || gfc_is_class_scalar_expr (expr1)
13318 19400 : || gfc_is_class_array_ref (expr2, NULL)
13319 19400 : || (gfc_is_class_scalar_expr (expr2)
13320 30 : && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
13321 312478 : && lhs_attr.flavor != FL_PROCEDURE;
13322 :
13323 309092 : assoc_assign = is_assoc_assign (expr1, expr2);
13324 :
13325 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13326 : mode. Avoid false-positive uninitialized diagnostics with initializing
13327 : the codimension flag unconditionally. */
13328 309092 : lhs_caf_attr.codimension = false;
13329 309092 : rhs_caf_attr.codimension = false;
13330 309092 : if (flag_coarray == GFC_FCOARRAY_LIB)
13331 : {
13332 6687 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13333 6687 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13334 : }
13335 :
13336 309092 : tree reallocation = NULL_TREE;
13337 309092 : if (lss != gfc_ss_terminator)
13338 : {
13339 : /* The assignment needs scalarization. */
13340 : lss_section = lss;
13341 :
13342 : /* Find a non-scalar SS from the lhs. */
13343 : while (lss_section != gfc_ss_terminator
13344 40120 : && lss_section->info->type != GFC_SS_SECTION)
13345 0 : lss_section = lss_section->next;
13346 :
13347 40120 : gcc_assert (lss_section != gfc_ss_terminator);
13348 :
13349 : /* Initialize the scalarizer. */
13350 40120 : gfc_init_loopinfo (&loop);
13351 :
13352 : /* Walk the rhs. */
13353 40120 : rss = gfc_walk_expr (expr2);
13354 40120 : if (rss == gfc_ss_terminator)
13355 : {
13356 : /* The rhs is scalar. Add a ss for the expression. */
13357 15026 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13358 15026 : lss->is_alloc_lhs = 0;
13359 : }
13360 :
13361 : /* When doing a class assign, then the handle to the rhs needs to be a
13362 : pointer to allow for polymorphism. */
13363 40120 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13364 509 : rss->info->type = GFC_SS_REFERENCE;
13365 :
13366 40120 : rss->no_bounds_check = expr2->no_bounds_check;
13367 : /* Associate the SS with the loop. */
13368 40120 : gfc_add_ss_to_loop (&loop, lss);
13369 40120 : gfc_add_ss_to_loop (&loop, rss);
13370 :
13371 : /* Calculate the bounds of the scalarization. */
13372 40120 : gfc_conv_ss_startstride (&loop);
13373 : /* Enable loop reversal. */
13374 682040 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13375 601800 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13376 : /* Resolve any data dependencies in the statement. */
13377 40120 : if (may_alias)
13378 37835 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13379 : /* Setup the scalarizing loops. */
13380 40120 : gfc_conv_loop_setup (&loop, &expr2->where);
13381 :
13382 : /* Setup the gfc_se structures. */
13383 40120 : gfc_copy_loopinfo_to_se (&lse, &loop);
13384 40120 : gfc_copy_loopinfo_to_se (&rse, &loop);
13385 :
13386 40120 : rse.ss = rss;
13387 40120 : gfc_mark_ss_chain_used (rss, 1);
13388 40120 : if (loop.temp_ss == NULL)
13389 : {
13390 39013 : lse.ss = lss;
13391 39013 : gfc_mark_ss_chain_used (lss, 1);
13392 : }
13393 : else
13394 : {
13395 1107 : lse.ss = loop.temp_ss;
13396 1107 : gfc_mark_ss_chain_used (lss, 3);
13397 1107 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13398 : }
13399 :
13400 : /* Allow the scalarizer to workshare array assignments. */
13401 40120 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13402 : == OMPWS_WORKSHARE_FLAG
13403 85 : && loop.temp_ss == NULL)
13404 : {
13405 73 : maybe_workshare = true;
13406 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13407 : }
13408 :
13409 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13410 40120 : if (realloc_flag)
13411 : {
13412 6443 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13413 6443 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13414 6443 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13415 : expr2);
13416 : }
13417 :
13418 : /* Start the scalarized loop body. */
13419 40120 : gfc_start_scalarized_body (&loop, &body);
13420 : }
13421 : else
13422 268972 : gfc_init_block (&body);
13423 :
13424 309092 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13425 :
13426 : /* Translate the expression. */
13427 618184 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13428 309092 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13429 309092 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13430 309092 : gfc_conv_expr (&rse, expr2);
13431 :
13432 : /* Deal with the case of a scalar class function assigned to a derived type.
13433 : */
13434 309092 : if (gfc_is_alloc_class_scalar_function (expr2)
13435 309092 : && expr1->ts.type == BT_DERIVED)
13436 : {
13437 60 : rse.expr = gfc_class_data_get (rse.expr);
13438 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13439 : }
13440 :
13441 : /* Stabilize a string length for temporaries. */
13442 309092 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13443 24639 : && !(VAR_P (rse.string_length)
13444 : || TREE_CODE (rse.string_length) == PARM_DECL
13445 : || INDIRECT_REF_P (rse.string_length)))
13446 23775 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13447 285317 : else if (expr2->ts.type == BT_CHARACTER)
13448 : {
13449 4376 : if (expr1->ts.deferred
13450 6797 : && gfc_expr_attr (expr1).allocatable
13451 6917 : && gfc_check_dependency (expr1, expr2, true))
13452 120 : rse.string_length =
13453 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13454 4376 : string_length = rse.string_length;
13455 : }
13456 : else
13457 : string_length = NULL_TREE;
13458 :
13459 309092 : if (l_is_temp)
13460 : {
13461 1107 : gfc_conv_tmp_array_ref (&lse);
13462 1107 : if (expr2->ts.type == BT_CHARACTER)
13463 123 : lse.string_length = string_length;
13464 : }
13465 : else
13466 : {
13467 307985 : gfc_conv_expr (&lse, expr1);
13468 : /* For some expression (e.g. complex numbers) fold_convert uses a
13469 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13470 : not updated when assigned to. */
13471 307985 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13472 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13473 :
13474 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13475 314138 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13476 : {
13477 36 : tree cond;
13478 36 : const char* msg;
13479 :
13480 36 : tmp = INDIRECT_REF_P (lse.expr)
13481 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13482 36 : STRIP_NOPS (tmp);
13483 :
13484 : /* We should only get array references here. */
13485 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13486 : || TREE_CODE (tmp) == ARRAY_REF);
13487 :
13488 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13489 : or the array itself(ARRAY_REF). */
13490 36 : tmp = TREE_OPERAND (tmp, 0);
13491 :
13492 : /* Provide the address of the array. */
13493 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13494 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13495 :
13496 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13497 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13498 36 : msg = _("Assignment of scalar to unallocated array");
13499 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13500 : &expr1->where, msg);
13501 : }
13502 :
13503 : /* Deallocate the lhs parameterized components if required. */
13504 307985 : if (dealloc
13505 289524 : && !expr1->symtree->n.sym->attr.associate_var
13506 287543 : && expr2->expr_type != EXPR_ARRAY
13507 281531 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
13508 : {
13509 295 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
13510 :
13511 295 : tmp = lse.expr;
13512 295 : if (pdt_dep)
13513 : {
13514 : /* Create a temporary for deallocation after assignment. */
13515 126 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
13516 126 : gfc_add_modify (&lse.pre, tmp, lse.expr);
13517 : }
13518 :
13519 295 : if (expr1->ts.type == BT_DERIVED)
13520 295 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
13521 : expr1->rank);
13522 0 : else if (expr1->ts.type == BT_CLASS)
13523 : {
13524 0 : tmp = gfc_class_data_get (tmp);
13525 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
13526 : tmp, expr1->rank);
13527 : }
13528 :
13529 295 : if (tmp && pdt_dep)
13530 68 : gfc_add_expr_to_block (&rse.post, tmp);
13531 227 : else if (tmp)
13532 43 : gfc_add_expr_to_block (&lse.pre, tmp);
13533 : }
13534 : }
13535 :
13536 : /* Assignments of scalar derived types with allocatable components
13537 : to arrays must be done with a deep copy and the rhs temporary
13538 : must have its components deallocated afterwards. */
13539 618184 : scalar_to_array = (expr2->ts.type == BT_DERIVED
13540 19442 : && expr2->ts.u.derived->attr.alloc_comp
13541 6678 : && !gfc_expr_is_variable (expr2)
13542 312756 : && expr1->rank && !expr2->rank);
13543 618184 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
13544 19725 : && expr1->rank
13545 3822 : && expr1->ts.u.derived->attr.alloc_comp
13546 310483 : && gfc_is_alloc_class_scalar_function (expr2));
13547 309092 : if (scalar_to_array && dealloc)
13548 : {
13549 59 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
13550 59 : gfc_prepend_expr_to_block (&loop.post, tmp);
13551 : }
13552 :
13553 : /* When assigning a character function result to a deferred-length variable,
13554 : the function call must happen before the (re)allocation of the lhs -
13555 : otherwise the character length of the result is not known.
13556 : NOTE 1: This relies on having the exact dependence of the length type
13557 : parameter available to the caller; gfortran saves it in the .mod files.
13558 : NOTE 2: Vector array references generate an index temporary that must
13559 : not go outside the loop. Otherwise, variables should not generate
13560 : a pre block.
13561 : NOTE 3: The concatenation operation generates a temporary pointer,
13562 : whose allocation must go to the innermost loop.
13563 : NOTE 4: Elemental functions may generate a temporary, too. */
13564 309092 : if (flag_realloc_lhs
13565 303012 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
13566 2984 : && !(lss != gfc_ss_terminator
13567 928 : && rss != gfc_ss_terminator
13568 928 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
13569 741 : || (expr2->expr_type == EXPR_FUNCTION
13570 160 : && expr2->value.function.esym != NULL
13571 26 : && expr2->value.function.esym->attr.elemental)
13572 728 : || (expr2->expr_type == EXPR_FUNCTION
13573 147 : && expr2->value.function.isym != NULL
13574 134 : && expr2->value.function.isym->elemental)
13575 672 : || (expr2->expr_type == EXPR_OP
13576 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
13577 2703 : gfc_add_block_to_block (&block, &rse.pre);
13578 :
13579 : /* Nullify the allocatable components corresponding to those of the lhs
13580 : derived type, so that the finalization of the function result does not
13581 : affect the lhs of the assignment. Prepend is used to ensure that the
13582 : nullification occurs before the call to the finalizer. In the case of
13583 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
13584 : as part of the deep copy. */
13585 308265 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
13586 327990 : && (gfc_is_class_array_function (expr2)
13587 18874 : || gfc_is_alloc_class_scalar_function (expr2)))
13588 : {
13589 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
13590 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
13591 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
13592 0 : gfc_add_block_to_block (&loop.post, &rse.post);
13593 : }
13594 :
13595 309092 : tmp = NULL_TREE;
13596 :
13597 309092 : if (is_poly_assign)
13598 : {
13599 3319 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
13600 3319 : use_vptr_copy || (lhs_attr.allocatable
13601 283 : && !lhs_attr.dimension),
13602 3063 : !realloc_flag && flag_realloc_lhs
13603 3870 : && !lhs_attr.pointer);
13604 3319 : if (expr2->expr_type == EXPR_FUNCTION
13605 220 : && expr2->ts.type == BT_DERIVED
13606 18 : && expr2->ts.u.derived->attr.alloc_comp)
13607 : {
13608 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
13609 : rse.expr, expr2->rank);
13610 18 : if (lss == gfc_ss_terminator)
13611 18 : gfc_add_expr_to_block (&rse.post, tmp2);
13612 : else
13613 0 : gfc_add_expr_to_block (&loop.post, tmp2);
13614 : }
13615 :
13616 3319 : expr1->must_finalize = 0;
13617 : }
13618 305773 : else if (!is_poly_assign
13619 305773 : && expr1->ts.type == BT_CLASS
13620 442 : && expr2->ts.type == BT_CLASS
13621 255 : && (expr2->must_finalize || dummy_class_array_copy))
13622 : {
13623 : /* This case comes about when the scalarizer provides array element
13624 : references to class temporaries or nonpointer dummy arrays. Use the
13625 : vptr copy function, since this does a deep copy of allocatable
13626 : components. */
13627 132 : tmp = gfc_get_vptr_from_expr (rse.expr);
13628 132 : if (tmp == NULL_TREE && dummy_class_array_copy)
13629 12 : tmp = gfc_get_vptr_from_expr (gfc_get_class_from_gfc_expr (expr2));
13630 132 : if (tmp != NULL_TREE)
13631 : {
13632 132 : tree fcn = gfc_vptr_copy_get (tmp);
13633 132 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
13634 132 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
13635 132 : tmp = build_call_expr_loc (input_location,
13636 : fcn, 2,
13637 : gfc_build_addr_expr (NULL, rse.expr),
13638 : gfc_build_addr_expr (NULL, lse.expr));
13639 : }
13640 : }
13641 :
13642 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
13643 : after evaluation of the rhs and before reallocation.
13644 : Skip finalization for self-assignment to avoid use-after-free.
13645 : Strip parentheses from both sides to handle cases like a = (a). */
13646 309092 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
13647 309092 : if (final_expr
13648 660 : && gfc_dep_compare_expr (strip_parentheses (expr1),
13649 : strip_parentheses (expr2)) != 0
13650 309728 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
13651 211 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
13652 : {
13653 636 : if (lss == gfc_ss_terminator)
13654 : {
13655 177 : gfc_add_block_to_block (&block, &rse.pre);
13656 177 : gfc_add_block_to_block (&block, &lse.finalblock);
13657 : }
13658 : else
13659 : {
13660 459 : gfc_add_block_to_block (&body, &rse.pre);
13661 459 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
13662 : &lse.finalblock);
13663 : }
13664 : }
13665 : else
13666 308456 : gfc_add_block_to_block (&body, &rse.pre);
13667 :
13668 309092 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
13669 2994 : && assoc_assign)
13670 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
13671 :
13672 : /* If nothing else works, do it the old fashioned way! */
13673 309092 : if (tmp == NULL_TREE)
13674 : {
13675 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
13676 305641 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
13677 305641 : tmp
13678 305641 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13679 305641 : gfc_expr_is_variable (expr2_stripped)
13680 275523 : || scalar_to_array
13681 580427 : || expr2->expr_type == EXPR_ARRAY,
13682 305641 : !(l_is_temp || init_flag) && dealloc,
13683 305641 : expr1->symtree->n.sym->attr.codimension,
13684 : assoc_assign);
13685 : }
13686 :
13687 : /* Add the lse pre block to the body */
13688 309092 : gfc_add_block_to_block (&body, &lse.pre);
13689 309092 : gfc_add_expr_to_block (&body, tmp);
13690 :
13691 : /* Add the post blocks to the body. Scalar finalization must appear before
13692 : the post block in case any dellocations are done. */
13693 309092 : if (rse.finalblock.head
13694 309092 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
13695 14 : && gfc_expr_attr (expr2).elemental)))
13696 : {
13697 136 : gfc_add_block_to_block (&body, &rse.finalblock);
13698 136 : gfc_add_block_to_block (&body, &rse.post);
13699 : }
13700 : else
13701 308956 : gfc_add_block_to_block (&body, &rse.post);
13702 :
13703 309092 : gfc_add_block_to_block (&body, &lse.post);
13704 :
13705 309092 : if (lss == gfc_ss_terminator)
13706 : {
13707 : /* F2003: Add the code for reallocation on assignment. */
13708 266234 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
13709 272603 : && !is_poly_assign)
13710 3631 : alloc_scalar_allocatable_for_assignment (&block, string_length,
13711 : expr1, expr2);
13712 :
13713 : /* Use the scalar assignment as is. */
13714 268972 : gfc_add_block_to_block (&block, &body);
13715 : }
13716 : else
13717 : {
13718 40120 : gcc_assert (lse.ss == gfc_ss_terminator
13719 : && rse.ss == gfc_ss_terminator);
13720 :
13721 40120 : if (l_is_temp)
13722 : {
13723 1107 : gfc_trans_scalarized_loop_boundary (&loop, &body);
13724 :
13725 : /* We need to copy the temporary to the actual lhs. */
13726 1107 : gfc_init_se (&lse, NULL);
13727 1107 : gfc_init_se (&rse, NULL);
13728 1107 : gfc_copy_loopinfo_to_se (&lse, &loop);
13729 1107 : gfc_copy_loopinfo_to_se (&rse, &loop);
13730 :
13731 1107 : rse.ss = loop.temp_ss;
13732 1107 : lse.ss = lss;
13733 :
13734 1107 : gfc_conv_tmp_array_ref (&rse);
13735 1107 : gfc_conv_expr (&lse, expr1);
13736 :
13737 1107 : gcc_assert (lse.ss == gfc_ss_terminator
13738 : && rse.ss == gfc_ss_terminator);
13739 :
13740 1107 : if (expr2->ts.type == BT_CHARACTER)
13741 123 : rse.string_length = string_length;
13742 :
13743 1107 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13744 : false, dealloc);
13745 1107 : gfc_add_expr_to_block (&body, tmp);
13746 : }
13747 :
13748 40120 : if (reallocation != NULL_TREE)
13749 6443 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
13750 :
13751 40120 : if (maybe_workshare)
13752 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
13753 :
13754 : /* Generate the copying loops. */
13755 40120 : gfc_trans_scalarizing_loops (&loop, &body);
13756 :
13757 : /* Wrap the whole thing up. */
13758 40120 : gfc_add_block_to_block (&block, &loop.pre);
13759 40120 : gfc_add_block_to_block (&block, &loop.post);
13760 :
13761 40120 : gfc_cleanup_loop (&loop);
13762 : }
13763 :
13764 : /* Since parameterized components cannot have default initializers,
13765 : the default PDT constructor leaves them unallocated. Do the
13766 : allocation now. */
13767 309092 : if (init_flag && IS_PDT (expr1)
13768 329 : && !expr1->symtree->n.sym->attr.allocatable
13769 329 : && !expr1->symtree->n.sym->attr.dummy)
13770 : {
13771 67 : gfc_symbol *sym = expr1->symtree->n.sym;
13772 67 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
13773 : sym->backend_decl,
13774 67 : sym->as ? sym->as->rank : 0,
13775 67 : sym->param_list);
13776 67 : gfc_add_expr_to_block (&block, tmp);
13777 : }
13778 :
13779 309092 : return gfc_finish_block (&block);
13780 : }
13781 :
13782 :
13783 : /* Check whether EXPR is a copyable array. */
13784 :
13785 : static bool
13786 979529 : copyable_array_p (gfc_expr * expr)
13787 : {
13788 979529 : if (expr->expr_type != EXPR_VARIABLE)
13789 : return false;
13790 :
13791 : /* First check it's an array. */
13792 955762 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
13793 : return false;
13794 :
13795 147399 : if (!gfc_full_array_ref_p (expr->ref, NULL))
13796 : return false;
13797 :
13798 : /* Next check that it's of a simple enough type. */
13799 116332 : switch (expr->ts.type)
13800 : {
13801 : case BT_INTEGER:
13802 : case BT_REAL:
13803 : case BT_COMPLEX:
13804 : case BT_LOGICAL:
13805 : return true;
13806 :
13807 : case BT_CHARACTER:
13808 : return false;
13809 :
13810 6668 : case_bt_struct:
13811 6668 : return (!expr->ts.u.derived->attr.alloc_comp
13812 6668 : && !expr->ts.u.derived->attr.pdt_type);
13813 :
13814 : default:
13815 : break;
13816 : }
13817 :
13818 : return false;
13819 : }
13820 :
13821 : /* Translate an assignment. */
13822 :
13823 : tree
13824 326956 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13825 : bool dealloc, bool use_vptr_copy, bool may_alias)
13826 : {
13827 326956 : tree tmp;
13828 :
13829 : /* Special case a single function returning an array. */
13830 326956 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
13831 : {
13832 14488 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
13833 14488 : if (tmp)
13834 : return tmp;
13835 : }
13836 :
13837 : /* Special case assigning an array to zero. */
13838 320083 : if (copyable_array_p (expr1)
13839 320083 : && is_zero_initializer_p (expr2))
13840 : {
13841 3957 : tmp = gfc_trans_zero_assign (expr1);
13842 3957 : if (tmp)
13843 : return tmp;
13844 : }
13845 :
13846 : /* Special case copying one array to another. */
13847 316405 : if (copyable_array_p (expr1)
13848 28122 : && copyable_array_p (expr2)
13849 2699 : && gfc_compare_types (&expr1->ts, &expr2->ts)
13850 319104 : && !gfc_check_dependency (expr1, expr2, 0))
13851 : {
13852 2603 : tmp = gfc_trans_array_copy (expr1, expr2);
13853 2603 : if (tmp)
13854 : return tmp;
13855 : }
13856 :
13857 : /* Special case initializing an array from a constant array constructor. */
13858 314919 : if (copyable_array_p (expr1)
13859 26636 : && expr2->expr_type == EXPR_ARRAY
13860 323088 : && gfc_compare_types (&expr1->ts, &expr2->ts))
13861 : {
13862 8169 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
13863 8169 : if (tmp)
13864 : return tmp;
13865 : }
13866 :
13867 309092 : if (UNLIMITED_POLY (expr1) && expr1->rank)
13868 309092 : use_vptr_copy = true;
13869 :
13870 : /* Fallback to the scalarizer to generate explicit loops. */
13871 309092 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
13872 309092 : use_vptr_copy, may_alias);
13873 : }
13874 :
13875 : tree
13876 13069 : gfc_trans_init_assign (gfc_code * code)
13877 : {
13878 13069 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
13879 : }
13880 :
13881 : tree
13882 305506 : gfc_trans_assign (gfc_code * code)
13883 : {
13884 305506 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
13885 : }
13886 :
13887 : /* Generate a simple loop for internal use of the form
13888 : for (var = begin; var <cond> end; var += step)
13889 : body; */
13890 : void
13891 12171 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
13892 : enum tree_code cond, tree step, tree body)
13893 : {
13894 12171 : tree tmp;
13895 :
13896 : /* var = begin. */
13897 12171 : gfc_add_modify (block, var, begin);
13898 :
13899 : /* Loop: for (var = begin; var <cond> end; var += step). */
13900 12171 : tree label_loop = gfc_build_label_decl (NULL_TREE);
13901 12171 : tree label_cond = gfc_build_label_decl (NULL_TREE);
13902 12171 : TREE_USED (label_loop) = 1;
13903 12171 : TREE_USED (label_cond) = 1;
13904 :
13905 12171 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
13906 12171 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
13907 :
13908 : /* Loop body. */
13909 12171 : gfc_add_expr_to_block (block, body);
13910 :
13911 : /* End of loop body. */
13912 12171 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
13913 12171 : gfc_add_modify (block, var, tmp);
13914 12171 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
13915 12171 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
13916 12171 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
13917 : build_empty_stmt (input_location));
13918 12171 : gfc_add_expr_to_block (block, tmp);
13919 12171 : }
|
