Line data Source code
1 : /* Expression translation
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Paul Brook <paul@nowt.org>
4 : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 :
6 : This file is part of GCC.
7 :
8 : GCC is free software; you can redistribute it and/or modify it under
9 : the terms of the GNU General Public License as published by the Free
10 : Software Foundation; either version 3, or (at your option) any later
11 : version.
12 :
13 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : for more details.
17 :
18 : You should have received a copy of the GNU General Public License
19 : along with GCC; see the file COPYING3. If not see
20 : <http://www.gnu.org/licenses/>. */
21 :
22 : /* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
23 :
24 : #define INCLUDE_MEMORY
25 : #include "config.h"
26 : #include "system.h"
27 : #include "coretypes.h"
28 : #include "options.h"
29 : #include "tree.h"
30 : #include "gfortran.h"
31 : #include "trans.h"
32 : #include "stringpool.h"
33 : #include "diagnostic-core.h" /* For fatal_error. */
34 : #include "fold-const.h"
35 : #include "langhooks.h"
36 : #include "arith.h"
37 : #include "constructor.h"
38 : #include "trans-const.h"
39 : #include "trans-types.h"
40 : #include "trans-array.h"
41 : #include "trans-descriptor.h"
42 : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 : #include "trans-stmt.h"
44 : #include "dependency.h"
45 : #include "gimplify.h"
46 : #include "tm.h" /* For CHAR_TYPE_SIZE. */
47 :
48 :
49 : /* Calculate the number of characters in a string. */
50 :
51 : static tree
52 36288 : gfc_get_character_len (tree type)
53 : {
54 36288 : tree len;
55 :
56 36288 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
57 : && TYPE_STRING_FLAG (type));
58 :
59 36288 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
60 36288 : len = (len) ? (len) : (integer_zero_node);
61 36288 : return fold_convert (gfc_charlen_type_node, len);
62 : }
63 :
64 :
65 :
66 : /* Calculate the number of bytes in a string. */
67 :
68 : tree
69 36288 : gfc_get_character_len_in_bytes (tree type)
70 : {
71 36288 : tree tmp, len;
72 :
73 36288 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
74 : && TYPE_STRING_FLAG (type));
75 :
76 36288 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
77 72576 : tmp = (tmp && !integer_zerop (tmp))
78 72576 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
79 36288 : len = gfc_get_character_len (type);
80 36288 : if (tmp && len && !integer_zerop (len))
81 35528 : len = fold_build2_loc (input_location, MULT_EXPR,
82 : gfc_charlen_type_node, len, tmp);
83 36288 : return len;
84 : }
85 :
86 :
87 : /* Convert a scalar to an array descriptor. To be used for assumed-rank
88 : arrays. */
89 :
90 : static tree
91 7012 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
92 : {
93 7012 : enum gfc_array_kind akind;
94 7012 : tree *lbound = NULL, *ubound = NULL;
95 7012 : int codim = 0;
96 :
97 7012 : if (attr.pointer)
98 : akind = GFC_ARRAY_POINTER_CONT;
99 6750 : else if (attr.allocatable)
100 : akind = GFC_ARRAY_ALLOCATABLE;
101 : else
102 5289 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
103 :
104 7012 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
105 6041 : scalar = TREE_TYPE (scalar);
106 7012 : if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
107 : {
108 5728 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
109 5728 : codim = lang_specific->corank;
110 5728 : lbound = lang_specific->lbound;
111 5728 : ubound = lang_specific->ubound;
112 : }
113 7367 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
114 : ubound, 1, akind,
115 7012 : !(attr.pointer || attr.target));
116 : }
117 :
118 : tree
119 6322 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
120 : {
121 6322 : tree desc, type, etype;
122 :
123 6322 : type = get_scalar_to_descriptor_type (scalar, attr);
124 6322 : etype = TREE_TYPE (scalar);
125 6322 : desc = gfc_create_var (type, "desc");
126 6322 : DECL_ARTIFICIAL (desc) = 1;
127 :
128 6322 : if (CONSTANT_CLASS_P (scalar))
129 : {
130 0 : tree tmp;
131 0 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
132 0 : gfc_add_modify (&se->pre, tmp, scalar);
133 0 : scalar = tmp;
134 : }
135 6322 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
136 971 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
137 5351 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
138 158 : etype = TREE_TYPE (etype);
139 6322 : gfc_conv_descriptor_dtype_set (&se->pre, desc,
140 : gfc_get_dtype_rank_type (0, etype));
141 6322 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
142 6322 : gfc_conv_descriptor_span_set (&se->pre, desc,
143 : gfc_conv_descriptor_elem_len_get (desc));
144 :
145 : /* Copy pointer address back - but only if it could have changed and
146 : if the actual argument is a pointer and not, e.g., NULL(). */
147 6322 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
148 2302 : gfc_add_modify (&se->post, scalar,
149 1151 : fold_convert (TREE_TYPE (scalar),
150 : gfc_conv_descriptor_data_get (desc)));
151 6322 : return desc;
152 : }
153 :
154 :
155 : /* Get the coarray token from the ultimate array or component ref.
156 : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
157 :
158 : tree
159 542 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
160 : {
161 542 : gfc_symbol *sym = expr->symtree->n.sym;
162 1084 : bool is_coarray = sym->ts.type == BT_CLASS
163 542 : ? CLASS_DATA (sym)->attr.codimension
164 497 : : sym->attr.codimension;
165 542 : gfc_expr *caf_expr = gfc_copy_expr (expr);
166 542 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
167 :
168 1696 : while (ref)
169 : {
170 1154 : if (ref->type == REF_COMPONENT
171 431 : && (ref->u.c.component->attr.allocatable
172 104 : || ref->u.c.component->attr.pointer)
173 429 : && (is_coarray || ref->u.c.component->attr.codimension))
174 1154 : last_caf_ref = ref;
175 1154 : ref = ref->next;
176 : }
177 :
178 542 : if (last_caf_ref == NULL)
179 : {
180 196 : gfc_free_expr (caf_expr);
181 196 : return NULL_TREE;
182 : }
183 :
184 143 : tree comp = last_caf_ref->u.c.component->caf_token
185 346 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
186 : : NULL_TREE,
187 : caf;
188 346 : gfc_se se;
189 346 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
190 346 : if (comp == NULL_TREE && comp_ref)
191 : {
192 60 : gfc_free_expr (caf_expr);
193 60 : return NULL_TREE;
194 : }
195 286 : gfc_init_se (&se, outerse);
196 286 : gfc_free_ref_list (last_caf_ref->next);
197 286 : last_caf_ref->next = NULL;
198 286 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
199 572 : caf_expr->corank = last_caf_ref->u.c.component->as
200 286 : ? last_caf_ref->u.c.component->as->corank
201 : : expr->corank;
202 286 : se.want_pointer = comp_ref;
203 286 : gfc_conv_expr (&se, caf_expr);
204 286 : gfc_add_block_to_block (&outerse->pre, &se.pre);
205 :
206 286 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
207 143 : se.expr = TREE_OPERAND (se.expr, 0);
208 286 : gfc_free_expr (caf_expr);
209 :
210 286 : if (comp_ref)
211 143 : caf = fold_build3_loc (input_location, COMPONENT_REF,
212 143 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
213 : else
214 143 : caf = gfc_conv_descriptor_token (se.expr);
215 286 : return gfc_build_addr_expr (NULL_TREE, caf);
216 : }
217 :
218 :
219 : /* This is the seed for an eventual trans-class.c
220 :
221 : The following parameters should not be used directly since they might
222 : in future implementations. Use the corresponding APIs. */
223 : #define CLASS_DATA_FIELD 0
224 : #define CLASS_VPTR_FIELD 1
225 : #define CLASS_LEN_FIELD 2
226 : #define VTABLE_HASH_FIELD 0
227 : #define VTABLE_SIZE_FIELD 1
228 : #define VTABLE_EXTENDS_FIELD 2
229 : #define VTABLE_DEF_INIT_FIELD 3
230 : #define VTABLE_COPY_FIELD 4
231 : #define VTABLE_FINAL_FIELD 5
232 : #define VTABLE_DEALLOCATE_FIELD 6
233 :
234 :
235 : tree
236 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
237 : {
238 40 : tree tmp;
239 40 : tree field;
240 40 : vec<constructor_elt, va_gc> *init = NULL;
241 :
242 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
243 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
244 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
245 :
246 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
247 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
248 :
249 40 : return build_constructor (TREE_TYPE (decl), init);
250 : }
251 :
252 :
253 : tree
254 33416 : gfc_class_data_get (tree decl)
255 : {
256 33416 : tree data;
257 33416 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
258 5591 : decl = build_fold_indirect_ref_loc (input_location, decl);
259 33416 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
260 : CLASS_DATA_FIELD);
261 33416 : return fold_build3_loc (input_location, COMPONENT_REF,
262 33416 : TREE_TYPE (data), decl, data,
263 33416 : NULL_TREE);
264 : }
265 :
266 :
267 : tree
268 47459 : gfc_class_vptr_get (tree decl)
269 : {
270 47459 : tree vptr;
271 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
272 : then available through the saved descriptor. */
273 29060 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
274 49481 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
275 1351 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
276 47459 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
277 2417 : decl = build_fold_indirect_ref_loc (input_location, decl);
278 47459 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
279 : CLASS_VPTR_FIELD);
280 47459 : return fold_build3_loc (input_location, COMPONENT_REF,
281 47459 : TREE_TYPE (vptr), decl, vptr,
282 47459 : NULL_TREE);
283 : }
284 :
285 :
286 : tree
287 7123 : gfc_class_len_get (tree decl)
288 : {
289 7123 : tree len;
290 : /* For class arrays decl may be a temporary descriptor handle, the len is
291 : then available through the saved descriptor. */
292 5051 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
293 7414 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
294 127 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
295 7123 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
296 704 : decl = build_fold_indirect_ref_loc (input_location, decl);
297 7123 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
298 : CLASS_LEN_FIELD);
299 7123 : return fold_build3_loc (input_location, COMPONENT_REF,
300 7123 : TREE_TYPE (len), decl, len,
301 7123 : NULL_TREE);
302 : }
303 :
304 :
305 : /* Try to get the _len component of a class. When the class is not unlimited
306 : poly, i.e. no _len field exists, then return a zero node. */
307 :
308 : static tree
309 8680 : gfc_class_len_or_zero_get (tree decl)
310 : {
311 8680 : tree len;
312 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
313 : then available through the saved descriptor. */
314 4282 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
315 8854 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
316 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
317 8680 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
318 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
319 8680 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
320 : CLASS_LEN_FIELD);
321 11160 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
322 2480 : TREE_TYPE (len), decl, len,
323 : NULL_TREE)
324 6200 : : build_zero_cst (gfc_charlen_type_node);
325 : }
326 :
327 :
328 : tree
329 8498 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
330 : {
331 8498 : tree tmp;
332 8498 : tree tmp2;
333 8498 : tree type;
334 :
335 8498 : tmp = gfc_class_len_or_zero_get (class_expr);
336 :
337 : /* Include the len value in the element size if present. */
338 8498 : if (!integer_zerop (tmp))
339 : {
340 2298 : type = TREE_TYPE (size);
341 2298 : if (block)
342 : {
343 1080 : size = gfc_evaluate_now (size, block);
344 1080 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
345 : }
346 : else
347 1218 : tmp = fold_convert (type , tmp);
348 2298 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
349 : type, size, tmp);
350 2298 : tmp = fold_build2_loc (input_location, GT_EXPR,
351 : logical_type_node, tmp,
352 : build_zero_cst (type));
353 2298 : size = fold_build3_loc (input_location, COND_EXPR,
354 : type, tmp, tmp2, size);
355 : }
356 : else
357 : return size;
358 :
359 2298 : if (block)
360 1080 : size = gfc_evaluate_now (size, block);
361 :
362 : return size;
363 : }
364 :
365 :
366 : /* Get the specified FIELD from the VPTR. */
367 :
368 : static tree
369 22270 : vptr_field_get (tree vptr, int fieldno)
370 : {
371 22270 : tree field;
372 22270 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
373 22270 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
374 : fieldno);
375 22270 : field = fold_build3_loc (input_location, COMPONENT_REF,
376 22270 : TREE_TYPE (field), vptr, field,
377 : NULL_TREE);
378 22270 : gcc_assert (field);
379 22270 : return field;
380 : }
381 :
382 :
383 : /* Get the field from the class' vptr. */
384 :
385 : static tree
386 10362 : class_vtab_field_get (tree decl, int fieldno)
387 : {
388 10362 : tree vptr;
389 10362 : vptr = gfc_class_vptr_get (decl);
390 10362 : return vptr_field_get (vptr, fieldno);
391 : }
392 :
393 :
394 : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
395 : unison. */
396 : #define VTAB_GET_FIELD_GEN(name, field) tree \
397 : gfc_class_vtab_## name ##_get (tree cl) \
398 : { \
399 : return class_vtab_field_get (cl, field); \
400 : } \
401 : \
402 : tree \
403 : gfc_vptr_## name ##_get (tree vptr) \
404 : { \
405 : return vptr_field_get (vptr, field); \
406 : }
407 :
408 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
409 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
410 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
411 4527 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
412 1914 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
413 1167 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
414 : #undef VTAB_GET_FIELD_GEN
415 :
416 : /* The size field is returned as an array index type. Therefore treat
417 : it and only it specially. */
418 :
419 : tree
420 8246 : gfc_class_vtab_size_get (tree cl)
421 : {
422 8246 : tree size;
423 8246 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
424 : /* Always return size as an array index type. */
425 8246 : size = fold_convert (gfc_array_index_type, size);
426 8246 : gcc_assert (size);
427 8246 : return size;
428 : }
429 :
430 : tree
431 6233 : gfc_vptr_size_get (tree vptr)
432 : {
433 6233 : tree size;
434 6233 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
435 : /* Always return size as an array index type. */
436 6233 : size = fold_convert (gfc_array_index_type, size);
437 6233 : gcc_assert (size);
438 6233 : return size;
439 : }
440 :
441 :
442 : #undef CLASS_DATA_FIELD
443 : #undef CLASS_VPTR_FIELD
444 : #undef CLASS_LEN_FIELD
445 : #undef VTABLE_HASH_FIELD
446 : #undef VTABLE_SIZE_FIELD
447 : #undef VTABLE_EXTENDS_FIELD
448 : #undef VTABLE_DEF_INIT_FIELD
449 : #undef VTABLE_COPY_FIELD
450 : #undef VTABLE_FINAL_FIELD
451 :
452 :
453 : /* IF ts is null (default), search for the last _class ref in the chain
454 : of references of the expression and cut the chain there. Although
455 : this routine is similar to class.cc:gfc_add_component_ref (), there
456 : is a significant difference: gfc_add_component_ref () concentrates
457 : on an array ref that is the last ref in the chain and is oblivious
458 : to the kind of refs following.
459 : ELSE IF ts is non-null the cut is at the class entity or component
460 : that is followed by an array reference, which is not an element.
461 : These calls come from trans-array.cc:build_class_array_ref, which
462 : handles scalarized class array references.*/
463 :
464 : gfc_expr *
465 9865 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
466 : gfc_typespec **ts)
467 : {
468 9865 : gfc_expr *base_expr;
469 9865 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
470 :
471 : /* Find the last class reference. */
472 9865 : class_ref = NULL;
473 9865 : array_ref = NULL;
474 :
475 9865 : if (ts)
476 : {
477 477 : if (e->symtree
478 452 : && e->symtree->n.sym->ts.type == BT_CLASS)
479 452 : *ts = &e->symtree->n.sym->ts;
480 : else
481 25 : *ts = NULL;
482 : }
483 :
484 24799 : for (ref = e->ref; ref; ref = ref->next)
485 : {
486 15396 : if (ts)
487 : {
488 1128 : if (ref->type == REF_COMPONENT
489 538 : && ref->u.c.component->ts.type == BT_CLASS
490 0 : && ref->next && ref->next->type == REF_COMPONENT
491 0 : && !strcmp (ref->next->u.c.component->name, "_data")
492 0 : && ref->next->next
493 0 : && ref->next->next->type == REF_ARRAY
494 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
495 : {
496 0 : *ts = &ref->u.c.component->ts;
497 0 : class_ref = ref;
498 0 : break;
499 : }
500 :
501 1128 : if (ref->next == NULL)
502 : break;
503 : }
504 : else
505 : {
506 14268 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
507 14268 : array_ref = ref;
508 :
509 14268 : if (ref->type == REF_COMPONENT
510 8589 : && ref->u.c.component->ts.type == BT_CLASS)
511 : {
512 : /* Component to the right of a part reference with nonzero
513 : rank must not have the ALLOCATABLE attribute. If attempts
514 : are made to reference such a component reference, an error
515 : results followed by an ICE. */
516 1690 : if (array_ref
517 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
518 : return NULL;
519 : class_ref = ref;
520 : }
521 : }
522 : }
523 :
524 9855 : if (ts && *ts == NULL)
525 : return NULL;
526 :
527 : /* Remove and store all subsequent references after the
528 : CLASS reference. */
529 9830 : if (class_ref)
530 : {
531 1488 : tail = class_ref->next;
532 1488 : class_ref->next = NULL;
533 : }
534 8342 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
535 : {
536 8342 : tail = e->ref;
537 8342 : e->ref = NULL;
538 : }
539 :
540 9830 : if (is_mold)
541 61 : base_expr = gfc_expr_to_initialize (e);
542 : else
543 9769 : base_expr = gfc_copy_expr (e);
544 :
545 : /* Restore the original tail expression. */
546 9830 : if (class_ref)
547 : {
548 1488 : gfc_free_ref_list (class_ref->next);
549 1488 : class_ref->next = tail;
550 : }
551 8342 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
552 : {
553 8342 : gfc_free_ref_list (e->ref);
554 8342 : e->ref = tail;
555 : }
556 : return base_expr;
557 : }
558 :
559 : /* Reset the vptr to the declared type, e.g. after deallocation.
560 : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
561 : one with e or class_type. At least one of the two has to be set. The
562 : generated assignment code is added at the end of BLOCK. */
563 :
564 : void
565 11578 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
566 : gfc_symbol *class_type)
567 : {
568 11578 : tree vptr = NULL_TREE;
569 :
570 11578 : if (class_container != NULL_TREE)
571 6890 : vptr = gfc_get_vptr_from_expr (class_container);
572 :
573 6890 : if (vptr == NULL_TREE)
574 : {
575 4695 : gfc_se se;
576 4695 : gcc_assert (e);
577 :
578 : /* Evaluate the expression and obtain the vptr from it. */
579 4695 : gfc_init_se (&se, NULL);
580 4695 : if (e->rank)
581 2333 : gfc_conv_expr_descriptor (&se, e);
582 : else
583 2362 : gfc_conv_expr (&se, e);
584 4695 : gfc_add_block_to_block (block, &se.pre);
585 :
586 4695 : vptr = gfc_get_vptr_from_expr (se.expr);
587 : }
588 :
589 : /* If a vptr is not found, we can do nothing more. */
590 4695 : if (vptr == NULL_TREE)
591 : return;
592 :
593 11568 : if (UNLIMITED_POLY (e)
594 10496 : || UNLIMITED_POLY (class_type)
595 : /* When the class_type's source is not a symbol (e.g. a component's ts),
596 : then look at the _data-components type. */
597 1583 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
598 1583 : && class_type->components && class_type->components->ts.u.derived
599 1577 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
600 1252 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
601 : else
602 : {
603 10316 : gfc_symbol *vtab, *type = nullptr;
604 10316 : tree vtable;
605 :
606 10316 : if (e)
607 8913 : type = e->ts.u.derived;
608 1403 : else if (class_type)
609 : {
610 1403 : if (class_type->ts.type == BT_CLASS)
611 0 : type = CLASS_DATA (class_type)->ts.u.derived;
612 : else
613 : type = class_type;
614 : }
615 8913 : gcc_assert (type);
616 : /* Return the vptr to the address of the declared type. */
617 10316 : vtab = gfc_find_derived_vtab (type);
618 10316 : vtable = vtab->backend_decl;
619 10316 : if (vtable == NULL_TREE)
620 100 : vtable = gfc_get_symbol_decl (vtab);
621 10316 : vtable = gfc_build_addr_expr (NULL, vtable);
622 10316 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
623 10316 : gfc_add_modify (block, vptr, vtable);
624 : }
625 : }
626 :
627 : /* Set the vptr of a class in to from the type given in from. If from is NULL,
628 : then reset the vptr to the default or to. */
629 :
630 : void
631 234 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
632 : {
633 234 : tree tmp, vptr_ref;
634 234 : gfc_symbol *type;
635 :
636 234 : vptr_ref = gfc_get_vptr_from_expr (to);
637 276 : if (POINTER_TYPE_P (TREE_TYPE (from))
638 234 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
639 : {
640 44 : gfc_add_modify (block, vptr_ref,
641 22 : fold_convert (TREE_TYPE (vptr_ref),
642 : gfc_get_vptr_from_expr (from)));
643 256 : return;
644 : }
645 212 : tmp = gfc_get_vptr_from_expr (from);
646 212 : if (tmp)
647 : {
648 170 : gfc_add_modify (block, vptr_ref,
649 170 : fold_convert (TREE_TYPE (vptr_ref), tmp));
650 170 : return;
651 : }
652 42 : if (VAR_P (from)
653 42 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
654 : {
655 42 : gfc_add_modify (block, vptr_ref,
656 42 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
657 42 : return;
658 : }
659 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
660 0 : && GFC_CLASS_TYPE_P (
661 : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
662 : {
663 0 : gfc_add_modify (block, vptr_ref,
664 0 : fold_convert (TREE_TYPE (vptr_ref),
665 : gfc_get_vptr_from_expr (TREE_OPERAND (
666 : TREE_OPERAND (from, 0), 0))));
667 0 : return;
668 : }
669 :
670 : /* If nothing of the above matches, set the vtype according to the type. */
671 0 : tmp = TREE_TYPE (from);
672 0 : if (POINTER_TYPE_P (tmp))
673 0 : tmp = TREE_TYPE (tmp);
674 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
675 : &type);
676 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
677 0 : gcc_assert (tmp);
678 0 : gfc_add_modify (block, vptr_ref,
679 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
680 : }
681 :
682 : /* Reset the len for unlimited polymorphic objects. */
683 :
684 : void
685 657 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
686 : {
687 657 : gfc_expr *e;
688 657 : gfc_se se_len;
689 657 : e = gfc_find_and_cut_at_last_class_ref (expr);
690 657 : if (e == NULL)
691 : return;
692 657 : gfc_add_len_component (e);
693 657 : gfc_init_se (&se_len, NULL);
694 657 : gfc_conv_expr (&se_len, e);
695 657 : gfc_add_modify (block, se_len.expr,
696 657 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
697 657 : gfc_free_expr (e);
698 : }
699 :
700 :
701 : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
702 : reference is found. Note that it is up to the caller to avoid using this
703 : for expressions other than variables. */
704 :
705 : tree
706 1559 : gfc_get_class_from_gfc_expr (gfc_expr *e)
707 : {
708 1559 : gfc_expr *class_expr;
709 1559 : gfc_se cse;
710 1559 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
711 1559 : if (class_expr == NULL)
712 : return NULL_TREE;
713 1559 : gfc_init_se (&cse, NULL);
714 1559 : gfc_conv_expr (&cse, class_expr);
715 1559 : gfc_free_expr (class_expr);
716 1559 : return cse.expr;
717 : }
718 :
719 :
720 : /* Obtain the last class reference in an expression.
721 : Return NULL_TREE if no class reference is found. */
722 :
723 : tree
724 110191 : gfc_get_class_from_expr (tree expr)
725 : {
726 110191 : tree tmp;
727 110191 : tree type;
728 110191 : bool array_descr_found = false;
729 110191 : bool comp_after_descr_found = false;
730 :
731 283885 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
732 : {
733 283885 : if (CONSTANT_CLASS_P (tmp))
734 : return NULL_TREE;
735 :
736 283848 : type = TREE_TYPE (tmp);
737 329028 : while (type)
738 : {
739 321144 : if (GFC_CLASS_TYPE_P (type))
740 : return tmp;
741 300644 : if (GFC_DESCRIPTOR_TYPE_P (type))
742 35963 : array_descr_found = true;
743 300644 : if (type != TYPE_CANONICAL (type))
744 45180 : type = TYPE_CANONICAL (type);
745 : else
746 : type = NULL_TREE;
747 : }
748 263348 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
749 : break;
750 :
751 : /* Avoid walking up the reference chain too far. For class arrays, the
752 : array descriptor is a direct component (through a pointer) of the class
753 : container. So there is exactly one COMPONENT_REF between a class
754 : container and its child array descriptor. After seeing an array
755 : descriptor, we can give up on the second COMPONENT_REF we see, if no
756 : class container was found until that point. */
757 173694 : if (array_descr_found)
758 : {
759 7641 : if (comp_after_descr_found)
760 : {
761 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
762 : return NULL_TREE;
763 : }
764 7629 : else if (TREE_CODE (tmp) == COMPONENT_REF)
765 7641 : comp_after_descr_found = true;
766 : }
767 : }
768 :
769 89654 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
770 60163 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
771 :
772 89654 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
773 20 : return tmp;
774 :
775 : return NULL_TREE;
776 : }
777 :
778 :
779 : /* Obtain the vptr of the last class reference in an expression.
780 : Return NULL_TREE if no class reference is found. */
781 :
782 : tree
783 12245 : gfc_get_vptr_from_expr (tree expr)
784 : {
785 12245 : tree tmp;
786 :
787 12245 : tmp = gfc_get_class_from_expr (expr);
788 :
789 12245 : if (tmp != NULL_TREE)
790 12174 : return gfc_class_vptr_get (tmp);
791 :
792 : return NULL_TREE;
793 : }
794 :
795 : static void
796 2305 : copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
797 : {
798 2305 : tree src_type = TREE_TYPE (src);
799 2305 : if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
800 : {
801 135 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
802 270 : for (int c = 0; c < lang_specific->corank; ++c)
803 : {
804 135 : int dim = lang_specific->rank + c;
805 135 : tree codim = gfc_rank_cst[dim];
806 :
807 135 : if (lang_specific->lbound[dim])
808 54 : gfc_conv_descriptor_lbound_set (block, dest, codim,
809 : lang_specific->lbound[dim]);
810 : else
811 81 : gfc_conv_descriptor_lbound_set (
812 : block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
813 135 : if (dim + 1 < lang_specific->corank)
814 : {
815 0 : if (lang_specific->ubound[dim])
816 0 : gfc_conv_descriptor_ubound_set (block, dest, codim,
817 : lang_specific->ubound[dim]);
818 : else
819 0 : gfc_conv_descriptor_ubound_set (
820 : block, dest, codim,
821 : gfc_conv_descriptor_ubound_get (src, codim));
822 : }
823 : }
824 : }
825 2305 : }
826 :
827 : void
828 1971 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
829 : bool lhs_type)
830 : {
831 1971 : tree lhs_dim, rhs_dim, type;
832 :
833 1971 : gfc_conv_descriptor_data_set (block, lhs_desc,
834 : gfc_conv_descriptor_data_get (rhs_desc));
835 1971 : gfc_conv_descriptor_offset_set (block, lhs_desc,
836 : gfc_conv_descriptor_offset_get (rhs_desc));
837 :
838 1971 : gfc_conv_descriptor_dtype_set (block, lhs_desc,
839 : gfc_conv_descriptor_dtype_get (rhs_desc));
840 1971 : gfc_conv_descriptor_span_set (block, lhs_desc,
841 : gfc_conv_descriptor_span_get (rhs_desc));
842 :
843 : /* Assign the dimension as range-ref. */
844 1971 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
845 1971 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
846 :
847 1971 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
848 1971 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
849 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
850 1971 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
851 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
852 1971 : gfc_add_modify (block, lhs_dim, rhs_dim);
853 :
854 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
855 1971 : copy_coarray_desc_part (block, lhs_desc, rhs_desc);
856 1971 : }
857 :
858 : /* Takes a derived type expression and returns the address of a temporary
859 : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
860 : used for the temporary class object.
861 : optional_alloc_ptr is false when the dummy is neither allocatable
862 : nor a pointer; that's only relevant for the optional handling.
863 : The optional argument 'derived_array' is used to preserve the parmse
864 : expression for deallocation of allocatable components. Assumed rank
865 : formal arguments made this necessary. */
866 : void
867 5313 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
868 : tree opt_vptr_src, bool optional,
869 : bool optional_alloc_ptr, const char *proc_name,
870 : tree *derived_array)
871 : {
872 5313 : tree cond_optional = NULL_TREE;
873 5313 : gfc_ss *ss;
874 5313 : tree ctree;
875 5313 : tree var;
876 5313 : tree tmp;
877 5313 : tree packed = NULL_TREE;
878 :
879 : /* The derived type needs to be converted to a temporary CLASS object. */
880 5313 : tmp = gfc_typenode_for_spec (&fsym->ts);
881 5313 : var = gfc_create_var (tmp, "class");
882 :
883 : /* Set the vptr. */
884 5313 : if (opt_vptr_src)
885 128 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
886 : else
887 5185 : gfc_reset_vptr (&parmse->pre, e, var);
888 :
889 : /* Now set the data field. */
890 5313 : ctree = gfc_class_data_get (var);
891 :
892 5313 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
893 : {
894 4 : tree token;
895 4 : tmp = gfc_get_tree_for_caf_expr (e);
896 4 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
897 2 : tmp = build_fold_indirect_ref (tmp);
898 4 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
899 4 : gfc_conv_descriptor_token_set (&parmse->pre, ctree, token);
900 : }
901 :
902 5313 : if (optional)
903 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
904 :
905 : /* Set the _len as early as possible. */
906 5313 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
907 5313 : && fsym->ts.u.derived->components->ts.u.derived->attr
908 5313 : .unlimited_polymorphic)
909 : {
910 : /* Take care about initializing the _len component correctly. */
911 386 : tree len_tree = gfc_class_len_get (var);
912 386 : if (UNLIMITED_POLY (e))
913 : {
914 12 : gfc_expr *len;
915 12 : gfc_se se;
916 :
917 12 : len = gfc_find_and_cut_at_last_class_ref (e);
918 12 : gfc_add_len_component (len);
919 12 : gfc_init_se (&se, NULL);
920 12 : gfc_conv_expr (&se, len);
921 12 : if (optional)
922 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
923 : cond_optional, se.expr,
924 0 : fold_convert (TREE_TYPE (se.expr),
925 : integer_zero_node));
926 : else
927 12 : tmp = se.expr;
928 12 : gfc_free_expr (len);
929 12 : }
930 : else
931 374 : tmp = integer_zero_node;
932 386 : gfc_add_modify (&parmse->pre, len_tree,
933 386 : fold_convert (TREE_TYPE (len_tree), tmp));
934 : }
935 :
936 5313 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
937 : {
938 : /* If there is a ready made pointer to a derived type, use it
939 : rather than evaluating the expression again. */
940 535 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
941 535 : gfc_add_modify (&parmse->pre, ctree, tmp);
942 : }
943 4778 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
944 : {
945 : /* For an array reference in an elemental procedure call we need
946 : to retain the ss to provide the scalarized array reference. */
947 445 : gfc_conv_expr_reference (parmse, e);
948 445 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
949 445 : if (optional)
950 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
951 : cond_optional, tmp,
952 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
953 445 : gfc_add_modify (&parmse->pre, ctree, tmp);
954 : }
955 : else
956 : {
957 4333 : ss = gfc_walk_expr (e);
958 4333 : if (ss == gfc_ss_terminator)
959 : {
960 3073 : parmse->ss = NULL;
961 3073 : gfc_conv_expr_reference (parmse, e);
962 :
963 : /* Scalar to an assumed-rank array. */
964 3073 : if (fsym->ts.u.derived->components->as)
965 : {
966 334 : tree type;
967 334 : type = get_scalar_to_descriptor_type (parmse->expr,
968 : gfc_expr_attr (e));
969 334 : gfc_conv_descriptor_dtype_set (&parmse->pre, ctree,
970 : gfc_get_dtype (type));
971 334 : copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
972 334 : if (optional)
973 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
974 96 : TREE_TYPE (parmse->expr),
975 : cond_optional, parmse->expr,
976 96 : fold_convert (TREE_TYPE (parmse->expr),
977 : null_pointer_node));
978 334 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
979 : }
980 : else
981 : {
982 2739 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
983 2739 : if (optional)
984 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
985 : cond_optional, tmp,
986 132 : fold_convert (TREE_TYPE (tmp),
987 : null_pointer_node));
988 2739 : gfc_add_modify (&parmse->pre, ctree, tmp);
989 : }
990 : }
991 : else
992 : {
993 1260 : stmtblock_t block;
994 1260 : gfc_init_block (&block);
995 1260 : gfc_ref *ref;
996 1260 : int dim;
997 1260 : tree lbshift = NULL_TREE;
998 :
999 : /* Array refs with sections indicate, that a for a formal argument
1000 : expecting contiguous repacking needs to be done. */
1001 2369 : for (ref = e->ref; ref; ref = ref->next)
1002 1259 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1003 : break;
1004 1260 : if (IS_CLASS_ARRAY (fsym)
1005 1152 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
1006 894 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
1007 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
1008 144 : fsym->attr.contiguous = 1;
1009 :
1010 : /* Detect any array references with vector subscripts. */
1011 2513 : for (ref = e->ref; ref; ref = ref->next)
1012 1259 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
1013 1217 : && ref->u.ar.type != AR_FULL)
1014 : {
1015 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
1016 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
1017 : break;
1018 150 : if (dim < ref->u.ar.dimen)
1019 : break;
1020 : }
1021 : /* Array references with vector subscripts and non-variable
1022 : expressions need be converted to a one-based descriptor. */
1023 1260 : if (ref || e->expr_type != EXPR_VARIABLE)
1024 49 : lbshift = gfc_index_one_node;
1025 :
1026 1260 : parmse->expr = var;
1027 1260 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
1028 : &lbshift, &packed);
1029 :
1030 1260 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
1031 : {
1032 1164 : *derived_array
1033 1164 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
1034 1164 : if (e->rank == -1)
1035 : {
1036 : /* Assumed-rank actual: parmse->expr physically holds only
1037 : dtype.rank dims; a full struct assign reads past the end.
1038 : Copy field-by-field with a runtime-sized dim[] memcpy.
1039 : PR fortran/60576. */
1040 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
1041 :
1042 78 : gfc_conv_descriptor_data_set
1043 78 : (&block, *derived_array,
1044 : gfc_conv_descriptor_data_get (parmse->expr));
1045 78 : gfc_conv_descriptor_offset_set
1046 78 : (&block, *derived_array,
1047 : gfc_conv_descriptor_offset_get (parmse->expr));
1048 78 : tree dtype_val = gfc_conv_descriptor_dtype_get (parmse->expr);
1049 78 : gfc_conv_descriptor_dtype_set (&block, *derived_array,
1050 : dtype_val);
1051 78 : rank = gfc_conv_descriptor_rank_get (parmse->expr);
1052 78 : rank = fold_convert (size_type_node, rank);
1053 78 : dim_field = gfc_get_descriptor_dimension (parmse->expr);
1054 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
1055 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
1056 : size_type_node, rank, dim_size);
1057 78 : dst_ptr = gfc_build_addr_expr
1058 78 : (pvoid_type_node, gfc_get_descriptor_dimension (*derived_array));
1059 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
1060 78 : gfc_add_expr_to_block (&block,
1061 : build_call_expr_loc (input_location,
1062 : builtin_decl_explicit (BUILT_IN_MEMCPY),
1063 : 3, dst_ptr, src_ptr, copy_size));
1064 : }
1065 : else
1066 1086 : gfc_add_modify (&block, *derived_array, parmse->expr);
1067 : }
1068 :
1069 1260 : if (optional)
1070 : {
1071 348 : tmp = gfc_finish_block (&block);
1072 :
1073 348 : gfc_init_block (&block);
1074 348 : gfc_init_absent_descriptor (&block, ctree);
1075 348 : if (derived_array && *derived_array != NULL_TREE)
1076 348 : gfc_init_absent_descriptor (&block, *derived_array);
1077 :
1078 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
1079 : gfc_finish_block (&block));
1080 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
1081 : }
1082 : else
1083 912 : gfc_add_block_to_block (&parmse->pre, &block);
1084 : }
1085 : }
1086 :
1087 : /* Pass the address of the class object. */
1088 5313 : if (packed)
1089 : parmse->expr = packed;
1090 : else
1091 5217 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1092 :
1093 5313 : if (optional && optional_alloc_ptr)
1094 84 : parmse->expr
1095 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1096 : cond_optional, parmse->expr,
1097 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1098 5313 : }
1099 :
1100 : /* Create a new class container, which is required as scalar coarrays
1101 : have an array descriptor while normal scalars haven't. Optionally,
1102 : NULL pointer checks are added if the argument is OPTIONAL. */
1103 :
1104 : static void
1105 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1106 : gfc_typespec class_ts, bool optional)
1107 : {
1108 48 : tree var, ctree, tmp;
1109 48 : stmtblock_t block;
1110 48 : gfc_ref *ref;
1111 48 : gfc_ref *class_ref;
1112 :
1113 48 : gfc_init_block (&block);
1114 :
1115 48 : class_ref = NULL;
1116 144 : for (ref = e->ref; ref; ref = ref->next)
1117 : {
1118 96 : if (ref->type == REF_COMPONENT
1119 48 : && ref->u.c.component->ts.type == BT_CLASS)
1120 96 : class_ref = ref;
1121 : }
1122 :
1123 48 : if (class_ref == NULL
1124 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1125 48 : tmp = e->symtree->n.sym->backend_decl;
1126 : else
1127 : {
1128 : /* Remove everything after the last class reference, convert the
1129 : expression and then recover its tailend once more. */
1130 0 : gfc_se tmpse;
1131 0 : ref = class_ref->next;
1132 0 : class_ref->next = NULL;
1133 0 : gfc_init_se (&tmpse, NULL);
1134 0 : gfc_conv_expr (&tmpse, e);
1135 0 : class_ref->next = ref;
1136 0 : tmp = tmpse.expr;
1137 : }
1138 :
1139 48 : var = gfc_typenode_for_spec (&class_ts);
1140 48 : var = gfc_create_var (var, "class");
1141 :
1142 48 : ctree = gfc_class_vptr_get (var);
1143 96 : gfc_add_modify (&block, ctree,
1144 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1145 :
1146 48 : ctree = gfc_class_data_get (var);
1147 48 : tmp = gfc_conv_descriptor_data_get (
1148 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1149 : ? tmp
1150 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1151 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1152 :
1153 : /* Pass the address of the class object. */
1154 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1155 :
1156 48 : if (optional)
1157 : {
1158 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1159 48 : tree tmp2;
1160 :
1161 48 : tmp = gfc_finish_block (&block);
1162 :
1163 48 : gfc_init_block (&block);
1164 48 : tmp2 = gfc_class_data_get (var);
1165 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1166 : null_pointer_node));
1167 48 : tmp2 = gfc_finish_block (&block);
1168 :
1169 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1170 : cond, tmp, tmp2);
1171 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1172 : }
1173 : else
1174 0 : gfc_add_block_to_block (&parmse->pre, &block);
1175 48 : }
1176 :
1177 :
1178 : /* Takes an intrinsic type expression and returns the address of a temporary
1179 : class object of the 'declared' type. */
1180 : void
1181 930 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1182 : gfc_typespec class_ts)
1183 : {
1184 930 : gfc_symbol *vtab;
1185 930 : gfc_ss *ss;
1186 930 : tree ctree;
1187 930 : tree var;
1188 930 : tree tmp;
1189 930 : int dim;
1190 930 : bool unlimited_poly;
1191 :
1192 1860 : unlimited_poly = class_ts.type == BT_CLASS
1193 930 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1194 930 : && class_ts.u.derived->components->ts.u.derived
1195 930 : ->attr.unlimited_polymorphic;
1196 :
1197 : /* The intrinsic type needs to be converted to a temporary
1198 : CLASS object. */
1199 930 : tmp = gfc_typenode_for_spec (&class_ts);
1200 930 : var = gfc_create_var (tmp, "class");
1201 :
1202 : /* Force a temporary for component or substring references. */
1203 930 : if (unlimited_poly
1204 930 : && class_ts.u.derived->components->attr.dimension
1205 671 : && !class_ts.u.derived->components->attr.allocatable
1206 671 : && !class_ts.u.derived->components->attr.class_pointer
1207 1601 : && is_subref_array (e))
1208 17 : parmse->force_tmp = 1;
1209 :
1210 : /* Set the vptr. */
1211 930 : ctree = gfc_class_vptr_get (var);
1212 :
1213 930 : vtab = gfc_find_vtab (&e->ts);
1214 930 : gcc_assert (vtab);
1215 930 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1216 930 : gfc_add_modify (&parmse->pre, ctree,
1217 930 : fold_convert (TREE_TYPE (ctree), tmp));
1218 :
1219 : /* Now set the data field. */
1220 930 : ctree = gfc_class_data_get (var);
1221 930 : if (parmse->ss && parmse->ss->info->useflags)
1222 : {
1223 : /* For an array reference in an elemental procedure call we need
1224 : to retain the ss to provide the scalarized array reference. */
1225 36 : gfc_conv_expr_reference (parmse, e);
1226 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1227 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1228 : }
1229 : else
1230 : {
1231 894 : ss = gfc_walk_expr (e);
1232 894 : if (ss == gfc_ss_terminator)
1233 : {
1234 247 : parmse->ss = NULL;
1235 247 : gfc_conv_expr_reference (parmse, e);
1236 247 : if (class_ts.u.derived->components->as
1237 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1238 : {
1239 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1240 : gfc_expr_attr (e));
1241 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1242 24 : TREE_TYPE (ctree), tmp);
1243 : }
1244 : else
1245 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1246 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1247 : }
1248 : else
1249 : {
1250 647 : parmse->ss = ss;
1251 647 : gfc_conv_expr_descriptor (parmse, e);
1252 :
1253 : /* Array references with vector subscripts and non-variable expressions
1254 : need be converted to a one-based descriptor. */
1255 647 : if (e->expr_type != EXPR_VARIABLE)
1256 : {
1257 416 : for (dim = 0; dim < e->rank; ++dim)
1258 217 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1259 : dim, gfc_index_one_node);
1260 : }
1261 :
1262 647 : if (class_ts.u.derived->components->as->rank != e->rank)
1263 : {
1264 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1265 49 : TREE_TYPE (ctree), parmse->expr);
1266 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1267 : }
1268 : else
1269 598 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1270 : }
1271 : }
1272 :
1273 930 : gcc_assert (class_ts.type == BT_CLASS);
1274 930 : if (unlimited_poly)
1275 : {
1276 930 : ctree = gfc_class_len_get (var);
1277 : /* When the actual arg is a char array, then set the _len component of the
1278 : unlimited polymorphic entity to the length of the string. */
1279 930 : if (e->ts.type == BT_CHARACTER)
1280 : {
1281 : /* Start with parmse->string_length because this seems to be set to a
1282 : correct value more often. */
1283 175 : if (parmse->string_length)
1284 : tmp = parmse->string_length;
1285 : /* When the string_length is not yet set, then try the backend_decl of
1286 : the cl. */
1287 0 : else if (e->ts.u.cl->backend_decl)
1288 : tmp = e->ts.u.cl->backend_decl;
1289 : /* If both of the above approaches fail, then try to generate an
1290 : expression from the input, which is only feasible currently, when the
1291 : expression can be evaluated to a constant one. */
1292 : else
1293 : {
1294 : /* Try to simplify the expression. */
1295 0 : gfc_simplify_expr (e, 0);
1296 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1297 : {
1298 : /* Amazingly all data is present to compute the length of a
1299 : constant string, but the expression is not yet there. */
1300 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1301 : gfc_charlen_int_kind,
1302 : &e->where);
1303 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1304 0 : e->value.character.length);
1305 0 : gfc_conv_const_charlen (e->ts.u.cl);
1306 0 : e->ts.u.cl->resolved = 1;
1307 0 : tmp = e->ts.u.cl->backend_decl;
1308 : }
1309 : else
1310 : {
1311 0 : gfc_error ("Cannot compute the length of the char array "
1312 : "at %L.", &e->where);
1313 : }
1314 : }
1315 : }
1316 : else
1317 755 : tmp = integer_zero_node;
1318 :
1319 930 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1320 : }
1321 :
1322 : /* Pass the address of the class object. */
1323 930 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1324 930 : }
1325 :
1326 :
1327 : /* Takes a scalarized class array expression and returns the
1328 : address of a temporary scalar class object of the 'declared'
1329 : type.
1330 : OOP-TODO: This could be improved by adding code that branched on
1331 : the dynamic type being the same as the declared type. In this case
1332 : the original class expression can be passed directly.
1333 : optional_alloc_ptr is false when the dummy is neither allocatable
1334 : nor a pointer; that's relevant for the optional handling.
1335 : Set copyback to true if class container's _data and _vtab pointers
1336 : might get modified. */
1337 :
1338 : void
1339 3714 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1340 : bool elemental, bool copyback, bool optional,
1341 : bool optional_alloc_ptr)
1342 : {
1343 3714 : tree ctree;
1344 3714 : tree var;
1345 3714 : tree tmp;
1346 3714 : tree vptr;
1347 3714 : tree cond = NULL_TREE;
1348 3714 : tree slen = NULL_TREE;
1349 3714 : gfc_ref *ref;
1350 3714 : gfc_ref *class_ref;
1351 3714 : stmtblock_t block;
1352 3714 : bool full_array = false;
1353 :
1354 : /* If this is the data field of a class temporary, the class expression
1355 : can be obtained and returned directly. */
1356 3714 : if (e->expr_type != EXPR_VARIABLE
1357 180 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1358 36 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))
1359 3750 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse->expr, 0))))
1360 : {
1361 36 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1362 36 : if (!VAR_P (parmse->expr))
1363 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1364 36 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1365 174 : return;
1366 : }
1367 :
1368 3678 : gfc_init_block (&block);
1369 :
1370 3678 : class_ref = NULL;
1371 7429 : for (ref = e->ref; ref; ref = ref->next)
1372 : {
1373 7053 : if (ref->type == REF_COMPONENT
1374 3784 : && ref->u.c.component->ts.type == BT_CLASS)
1375 7053 : class_ref = ref;
1376 :
1377 7053 : if (ref->next == NULL)
1378 : break;
1379 : }
1380 :
1381 3678 : if ((ref == NULL || class_ref == ref)
1382 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1383 4148 : && (!class_ts.u.derived->components->as
1384 379 : || class_ts.u.derived->components->as->rank != -1))
1385 : return;
1386 :
1387 : /* Test for FULL_ARRAY. */
1388 3540 : if (e->rank == 0
1389 3896 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1390 494 : || (class_ts.u.derived->components->as
1391 366 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1392 411 : full_array = true;
1393 : else
1394 3129 : gfc_is_class_array_ref (e, &full_array);
1395 :
1396 : /* The derived type needs to be converted to a temporary
1397 : CLASS object. */
1398 3540 : tmp = gfc_typenode_for_spec (&class_ts);
1399 3540 : var = gfc_create_var (tmp, "class");
1400 :
1401 : /* Set the data. */
1402 3540 : ctree = gfc_class_data_get (var);
1403 3540 : if (class_ts.u.derived->components->as
1404 3256 : && e->rank != class_ts.u.derived->components->as->rank)
1405 : {
1406 977 : if (e->rank == 0)
1407 : {
1408 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1409 : gfc_expr_attr (e));
1410 356 : gfc_conv_descriptor_dtype_set (&block, ctree,
1411 : gfc_get_dtype (type));
1412 :
1413 356 : tmp = gfc_class_data_get (parmse->expr);
1414 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1415 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1416 :
1417 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1418 : }
1419 : else
1420 621 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1421 : }
1422 : else
1423 : {
1424 2563 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1425 1499 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1426 1499 : TREE_TYPE (ctree), parmse->expr);
1427 2563 : gfc_add_modify (&block, ctree, parmse->expr);
1428 : }
1429 :
1430 : /* Return the data component, except in the case of scalarized array
1431 : references, where nullification of the cannot occur and so there
1432 : is no need. */
1433 3540 : if (!elemental && full_array && copyback)
1434 : {
1435 1188 : if (class_ts.u.derived->components->as
1436 1188 : && e->rank != class_ts.u.derived->components->as->rank)
1437 : {
1438 270 : if (e->rank == 0)
1439 : {
1440 102 : tmp = gfc_class_data_get (parmse->expr);
1441 204 : gfc_add_modify (&parmse->post, tmp,
1442 102 : fold_convert (TREE_TYPE (tmp),
1443 : gfc_conv_descriptor_data_get (ctree)));
1444 : }
1445 : else
1446 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1447 : true);
1448 : }
1449 : else
1450 918 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1451 : }
1452 :
1453 : /* Set the vptr. */
1454 3540 : ctree = gfc_class_vptr_get (var);
1455 :
1456 : /* The vptr is the second field of the actual argument.
1457 : First we have to find the corresponding class reference. */
1458 :
1459 3540 : tmp = NULL_TREE;
1460 3540 : if (gfc_is_class_array_function (e)
1461 3540 : && parmse->class_vptr != NULL_TREE)
1462 : tmp = parmse->class_vptr;
1463 3522 : else if (class_ref == NULL
1464 3023 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1465 : {
1466 3023 : tmp = e->symtree->n.sym->backend_decl;
1467 :
1468 3023 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1469 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1470 :
1471 3023 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1472 397 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1473 :
1474 3023 : slen = build_zero_cst (size_type_node);
1475 : }
1476 499 : else if (parmse->class_container != NULL_TREE)
1477 : /* Don't redundantly evaluate the expression if the required information
1478 : is already available. */
1479 : tmp = parmse->class_container;
1480 : else
1481 : {
1482 : /* Remove everything after the last class reference, convert the
1483 : expression and then recover its tailend once more. */
1484 18 : gfc_se tmpse;
1485 18 : ref = class_ref->next;
1486 18 : class_ref->next = NULL;
1487 18 : gfc_init_se (&tmpse, NULL);
1488 18 : gfc_conv_expr (&tmpse, e);
1489 18 : class_ref->next = ref;
1490 18 : tmp = tmpse.expr;
1491 18 : slen = tmpse.string_length;
1492 : }
1493 :
1494 3540 : gcc_assert (tmp != NULL_TREE);
1495 :
1496 : /* Dereference if needs be. */
1497 3540 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1498 345 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1499 :
1500 3540 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1501 3522 : vptr = gfc_class_vptr_get (tmp);
1502 : else
1503 : vptr = tmp;
1504 :
1505 3540 : gfc_add_modify (&block, ctree,
1506 3540 : fold_convert (TREE_TYPE (ctree), vptr));
1507 :
1508 : /* Return the vptr component, except in the case of scalarized array
1509 : references, where the dynamic type cannot change. */
1510 3540 : if (!elemental && full_array && copyback)
1511 1188 : gfc_add_modify (&parmse->post, vptr,
1512 1188 : fold_convert (TREE_TYPE (vptr), ctree));
1513 :
1514 : /* For unlimited polymorphic objects also set the _len component. */
1515 3540 : if (class_ts.type == BT_CLASS
1516 3540 : && class_ts.u.derived->components
1517 3540 : && class_ts.u.derived->components->ts.u
1518 3540 : .derived->attr.unlimited_polymorphic)
1519 : {
1520 1206 : ctree = gfc_class_len_get (var);
1521 1206 : if (UNLIMITED_POLY (e))
1522 1003 : tmp = gfc_class_len_get (tmp);
1523 203 : else if (e->ts.type == BT_CHARACTER)
1524 : {
1525 0 : gcc_assert (slen != NULL_TREE);
1526 : tmp = slen;
1527 : }
1528 : else
1529 203 : tmp = build_zero_cst (size_type_node);
1530 1206 : gfc_add_modify (&parmse->pre, ctree,
1531 1206 : fold_convert (TREE_TYPE (ctree), tmp));
1532 :
1533 : /* Return the len component, except in the case of scalarized array
1534 : references, where the dynamic type cannot change. */
1535 1206 : if (!elemental && full_array && copyback
1536 471 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1537 458 : gfc_add_modify (&parmse->post, tmp,
1538 458 : fold_convert (TREE_TYPE (tmp), ctree));
1539 : }
1540 :
1541 3540 : if (optional)
1542 : {
1543 510 : tree tmp2;
1544 :
1545 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1546 : /* parmse->pre may contain some preparatory instructions for the
1547 : temporary array descriptor. Those may only be executed when the
1548 : optional argument is set, therefore add parmse->pre's instructions
1549 : to block, which is later guarded by an if (optional_arg_given). */
1550 510 : gfc_add_block_to_block (&parmse->pre, &block);
1551 510 : block.head = parmse->pre.head;
1552 510 : parmse->pre.head = NULL_TREE;
1553 510 : tmp = gfc_finish_block (&block);
1554 :
1555 510 : if (optional_alloc_ptr)
1556 102 : tmp2 = build_empty_stmt (input_location);
1557 : else
1558 : {
1559 408 : gfc_init_block (&block);
1560 408 : gfc_conv_descriptor_data_set (&block, gfc_class_data_get (var),
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 3030 : gfc_add_block_to_block (&parmse->pre, &block);
1580 :
1581 : /* Pass the address of the class object. */
1582 3540 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1583 :
1584 3540 : 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 768 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1598 : bool unlimited)
1599 : {
1600 768 : tree data, size, tmp, ctmp, offset, ptr;
1601 :
1602 768 : data = data_comp != NULL_TREE ? data_comp :
1603 0 : gfc_class_data_get (class_decl);
1604 768 : size = gfc_class_vtab_size_get (class_decl);
1605 :
1606 768 : if (unlimited)
1607 : {
1608 244 : tmp = fold_convert (gfc_array_index_type,
1609 : gfc_class_len_get (class_decl));
1610 244 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1611 : gfc_array_index_type, size, tmp);
1612 244 : tmp = fold_build2_loc (input_location, GT_EXPR,
1613 : logical_type_node, tmp,
1614 244 : build_zero_cst (TREE_TYPE (tmp)));
1615 244 : size = fold_build3_loc (input_location, COND_EXPR,
1616 : gfc_array_index_type, tmp, ctmp, size);
1617 : }
1618 :
1619 768 : offset = fold_build2_loc (input_location, MULT_EXPR,
1620 : gfc_array_index_type,
1621 : index, size);
1622 :
1623 768 : data = gfc_conv_descriptor_data_get (data);
1624 768 : ptr = fold_convert (pvoid_type_node, data);
1625 768 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1626 768 : 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 816 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1637 : {
1638 816 : tree fcn;
1639 816 : tree fcn_type;
1640 816 : tree from_data;
1641 816 : tree from_len;
1642 816 : tree to_data;
1643 816 : tree to_len;
1644 816 : tree to_ref;
1645 816 : tree from_ref;
1646 816 : vec<tree, va_gc> *args;
1647 816 : tree tmp;
1648 816 : tree stdcopy;
1649 816 : tree extcopy;
1650 816 : tree index;
1651 816 : bool is_from_desc = false, is_to_class = false;
1652 :
1653 816 : args = NULL;
1654 : /* To prevent warnings on uninitialized variables. */
1655 816 : from_len = to_len = NULL_TREE;
1656 :
1657 816 : if (from != NULL_TREE)
1658 816 : fcn = gfc_class_vtab_copy_get (from);
1659 : else
1660 0 : fcn = gfc_class_vtab_copy_get (to);
1661 :
1662 816 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1663 :
1664 816 : if (from != NULL_TREE)
1665 : {
1666 816 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1667 816 : 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 1632 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1677 816 : ? build_fold_indirect_ref (from) : from;
1678 1632 : from_data =
1679 816 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1680 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1681 816 : ? gfc_class_data_get (from) : from;
1682 816 : 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 816 : if (unlimited)
1689 : {
1690 182 : if (from != NULL_TREE && unlimited)
1691 182 : from_len = gfc_class_len_or_zero_get (from);
1692 : else
1693 0 : from_len = build_zero_cst (size_type_node);
1694 : }
1695 :
1696 816 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1697 : {
1698 816 : is_to_class = true;
1699 816 : to_data = gfc_class_data_get (to);
1700 816 : if (unlimited)
1701 182 : 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 816 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1708 : {
1709 384 : stmtblock_t loopbody;
1710 384 : stmtblock_t body;
1711 384 : stmtblock_t ifbody;
1712 384 : gfc_loopinfo loop;
1713 :
1714 384 : gfc_init_block (&body);
1715 384 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1716 : gfc_array_index_type, nelems,
1717 : gfc_index_one_node);
1718 384 : nelems = gfc_evaluate_now (tmp, &body);
1719 384 : index = gfc_create_var (gfc_array_index_type, "S");
1720 :
1721 384 : if (is_from_desc)
1722 : {
1723 384 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1724 : unlimited);
1725 384 : vec_safe_push (args, from_ref);
1726 : }
1727 : else
1728 0 : vec_safe_push (args, from_data);
1729 :
1730 384 : if (is_to_class)
1731 384 : 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 384 : vec_safe_push (args, to_ref);
1740 :
1741 : /* Add bounds check. */
1742 384 : 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 384 : tmp = build_call_vec (fcn_type, fcn, args);
1772 :
1773 : /* Build the body of the loop. */
1774 384 : gfc_init_block (&loopbody);
1775 384 : gfc_add_expr_to_block (&loopbody, tmp);
1776 :
1777 : /* Build the loop and return. */
1778 384 : gfc_init_loopinfo (&loop);
1779 384 : loop.dimen = 1;
1780 384 : loop.from[0] = gfc_index_zero_node;
1781 384 : loop.loopvar[0] = index;
1782 384 : loop.to[0] = nelems;
1783 384 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1784 384 : gfc_init_block (&ifbody);
1785 384 : gfc_add_block_to_block (&ifbody, &loop.pre);
1786 384 : stdcopy = gfc_finish_block (&ifbody);
1787 : /* In initialization mode from_len is a constant zero. */
1788 384 : if (unlimited && !integer_zerop (from_len))
1789 : {
1790 122 : vec_safe_push (args, from_len);
1791 122 : vec_safe_push (args, to_len);
1792 122 : tmp = build_call_vec (fcn_type, fcn, args);
1793 : /* Build the body of the loop. */
1794 122 : gfc_init_block (&loopbody);
1795 122 : gfc_add_expr_to_block (&loopbody, tmp);
1796 :
1797 : /* Build the loop and return. */
1798 122 : gfc_init_loopinfo (&loop);
1799 122 : loop.dimen = 1;
1800 122 : loop.from[0] = gfc_index_zero_node;
1801 122 : loop.loopvar[0] = index;
1802 122 : loop.to[0] = nelems;
1803 122 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1804 122 : gfc_init_block (&ifbody);
1805 122 : gfc_add_block_to_block (&ifbody, &loop.pre);
1806 122 : extcopy = gfc_finish_block (&ifbody);
1807 :
1808 122 : tmp = fold_build2_loc (input_location, GT_EXPR,
1809 : logical_type_node, from_len,
1810 122 : build_zero_cst (TREE_TYPE (from_len)));
1811 122 : tmp = fold_build3_loc (input_location, COND_EXPR,
1812 : void_type_node, tmp, extcopy, stdcopy);
1813 122 : gfc_add_expr_to_block (&body, tmp);
1814 122 : tmp = gfc_finish_block (&body);
1815 : }
1816 : else
1817 : {
1818 262 : gfc_add_expr_to_block (&body, stdcopy);
1819 262 : tmp = gfc_finish_block (&body);
1820 : }
1821 384 : gfc_cleanup_loop (&loop);
1822 : }
1823 : else
1824 : {
1825 432 : gcc_assert (!is_from_desc);
1826 432 : vec_safe_push (args, from_data);
1827 432 : vec_safe_push (args, to_data);
1828 432 : stdcopy = build_call_vec (fcn_type, fcn, args);
1829 :
1830 : /* In initialization mode from_len is a constant zero. */
1831 432 : 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 816 : 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 816 : 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 491 : gfc_trans_class_init_assign (gfc_code *code)
1912 : {
1913 491 : stmtblock_t block;
1914 491 : tree tmp;
1915 491 : bool cmp_flag = true;
1916 491 : gfc_se dst,src,memsz;
1917 491 : gfc_expr *lhs, *rhs, *sz;
1918 491 : gfc_component *cmp;
1919 491 : gfc_symbol *sym;
1920 491 : gfc_ref *ref;
1921 :
1922 491 : gfc_start_block (&block);
1923 :
1924 491 : lhs = gfc_copy_expr (code->expr1);
1925 :
1926 491 : rhs = gfc_copy_expr (code->expr1);
1927 491 : 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 491 : gfc_get_derived_type (rhs->ts.u.derived);
1933 491 : gfc_add_def_init_component (rhs);
1934 : /* The _def_init is always scalar. */
1935 491 : 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 491 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1942 : : NULL;
1943 491 : if (code->op != EXEC_ALLOCATE
1944 430 : && sym && sym->attr.dummy
1945 430 : && sym->attr.intent == INTENT_OUT)
1946 : {
1947 430 : ref = rhs->ref;
1948 860 : while (ref && ref->next)
1949 : ref = ref->next;
1950 430 : cmp = ref->u.c.component->ts.u.derived->components;
1951 665 : for (; cmp; cmp = cmp->next)
1952 : {
1953 458 : if (cmp->initializer)
1954 : break;
1955 235 : else if (!cmp->next)
1956 170 : cmp_flag = false;
1957 : }
1958 : }
1959 :
1960 491 : if (code->expr1->ts.type == BT_CLASS
1961 468 : && 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 385 : else if (cmp_flag)
1971 : {
1972 : /* Scalar initialization needs the _data component. */
1973 228 : gfc_add_data_component (lhs);
1974 228 : sz = gfc_copy_expr (code->expr1);
1975 228 : gfc_add_vptr_component (sz);
1976 228 : gfc_add_size_component (sz);
1977 :
1978 228 : gfc_init_se (&dst, NULL);
1979 228 : gfc_init_se (&src, NULL);
1980 228 : gfc_init_se (&memsz, NULL);
1981 228 : gfc_conv_expr (&dst, lhs);
1982 228 : gfc_conv_expr (&src, rhs);
1983 228 : gfc_conv_expr (&memsz, sz);
1984 228 : gfc_add_block_to_block (&block, &src.pre);
1985 228 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1986 :
1987 228 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1988 :
1989 228 : 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 157 : tmp = build_empty_stmt (input_location);
2002 :
2003 491 : if (code->expr1->symtree->n.sym->attr.dummy
2004 440 : && (code->expr1->symtree->n.sym->attr.optional
2005 434 : || 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 491 : gfc_add_expr_to_block (&block, tmp);
2014 491 : gfc_free_expr (lhs);
2015 491 : gfc_free_expr (rhs);
2016 :
2017 491 : 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 800 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
2027 : {
2028 800 : tree fcn;
2029 800 : tree rse_expr;
2030 800 : tree class_data;
2031 800 : tree tmp;
2032 800 : tree zero;
2033 800 : tree cond;
2034 800 : tree final_cond;
2035 800 : stmtblock_t inner_block;
2036 800 : bool is_descriptor;
2037 800 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
2038 800 : 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 800 : tmp = TREE_TYPE (lse->expr);
2044 800 : 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 752 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
2050 1079 : && 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 521 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
2057 521 : && 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 466 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
2062 466 : || not_call_expr)
2063 : {
2064 466 : tmp = gfc_get_class_from_expr (rse->expr);
2065 466 : 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 13026 : realloc_lhs_warning (bt type, bool array, locus *where)
2131 : {
2132 13026 : 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 13001 : 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 13026 : }
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 1296361 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2150 : {
2151 1296361 : dest->ss = src->ss;
2152 1296361 : dest->loop = src->loop;
2153 0 : }
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 4708774 : gfc_init_se (gfc_se * se, gfc_se * parent)
2164 : {
2165 4708774 : memset (se, 0, sizeof (gfc_se));
2166 4708774 : gfc_init_block (&se->pre);
2167 4708774 : gfc_init_block (&se->finalblock);
2168 4708774 : gfc_init_block (&se->post);
2169 :
2170 4708774 : se->parent = parent;
2171 :
2172 4708774 : if (parent)
2173 1296361 : gfc_copy_se_loopvars (se, parent);
2174 4708774 : }
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 246381 : gfc_advance_se_ss_chain (gfc_se * se)
2183 : {
2184 246381 : gfc_se *p;
2185 :
2186 246381 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2187 :
2188 : p = se;
2189 : /* Walk down the parent chain. */
2190 646444 : while (p != NULL)
2191 : {
2192 : /* Simple consistency check. */
2193 400063 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2194 : || p->parent->ss->nested_ss == p->ss);
2195 :
2196 400063 : p->ss = p->ss->next;
2197 :
2198 400063 : p = p->parent;
2199 : }
2200 246381 : }
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 8244 : gfc_make_safe_expr (gfc_se * se)
2208 : {
2209 8244 : tree var;
2210 :
2211 8244 : 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 11886 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2226 : {
2227 11886 : tree decl, orig_decl, cond;
2228 :
2229 11886 : gcc_assert (sym->attr.dummy);
2230 11886 : 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 11886 : if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
2235 : {
2236 1082 : char name[GFC_MAX_SYMBOL_LEN + 2];
2237 1082 : tree tree_name;
2238 :
2239 1082 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2240 1082 : name[0] = '.';
2241 1082 : strcpy (&name[1], sym->name);
2242 1082 : tree_name = get_identifier (name);
2243 :
2244 : /* Walk function argument list to find hidden arg. */
2245 1082 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2246 5428 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2247 5428 : if (DECL_NAME (cond) == tree_name
2248 5428 : && DECL_ARTIFICIAL (cond))
2249 : break;
2250 :
2251 1082 : gcc_assert (cond);
2252 1082 : 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 10804 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2261 : {
2262 876 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2263 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2264 876 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2265 : }
2266 :
2267 10804 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2268 10804 : 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 10804 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2280 7667 : && !sym->attr.allocatable
2281 6455 : && ((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 4366 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2286 6 : || sym->ts.type == BT_CLASS))
2287 : {
2288 4360 : tree tmp;
2289 :
2290 4360 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2291 1525 : || sym->as->type == AS_ASSUMED_RANK
2292 1437 : || sym->attr.codimension))
2293 3438 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2294 : {
2295 1093 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2296 1093 : if (sym->ts.type == BT_CLASS)
2297 171 : tmp = gfc_class_data_get (tmp);
2298 1093 : tmp = gfc_conv_array_data (tmp);
2299 : }
2300 3267 : else if (sym->ts.type == BT_CLASS)
2301 36 : tmp = gfc_class_data_get (decl);
2302 : else
2303 : tmp = NULL_TREE;
2304 :
2305 1129 : if (tmp != NULL_TREE)
2306 : {
2307 1129 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2308 1129 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2309 1129 : 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 880 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2322 : {
2323 880 : tree present;
2324 880 : tree tmp;
2325 :
2326 880 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2327 :
2328 880 : 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 826 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2344 : present, se->expr,
2345 826 : build_zero_cst (TREE_TYPE (se->expr)));
2346 826 : tmp = gfc_evaluate_now (tmp, &se->pre);
2347 826 : se->expr = tmp;
2348 : }
2349 :
2350 880 : 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 262 : 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 244 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2365 244 : tmp = fold_build3_loc (input_location, COND_EXPR,
2366 : gfc_charlen_type_node,
2367 : present, se->string_length, tmp);
2368 244 : tmp = gfc_evaluate_now (tmp, &se->pre);
2369 : }
2370 262 : se->string_length = tmp;
2371 : }
2372 880 : return;
2373 : }
2374 :
2375 :
2376 : /* Get the character length of an expression, looking through gfc_refs
2377 : if necessary. */
2378 :
2379 : tree
2380 20182 : gfc_get_expr_charlen (gfc_expr *e)
2381 : {
2382 20182 : gfc_ref *r;
2383 20182 : tree length;
2384 20182 : tree previous = NULL_TREE;
2385 20182 : gfc_se se;
2386 :
2387 20182 : gcc_assert (e->expr_type == EXPR_VARIABLE
2388 : && e->ts.type == BT_CHARACTER);
2389 :
2390 20182 : length = NULL; /* To silence compiler warning. */
2391 :
2392 20182 : if (is_subref_array (e) && e->ts.u.cl->length)
2393 : {
2394 773 : gfc_se tmpse;
2395 773 : gfc_init_se (&tmpse, NULL);
2396 773 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2397 773 : e->ts.u.cl->backend_decl = tmpse.expr;
2398 773 : 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 19409 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2405 19103 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2406 :
2407 : /* Look through the reference chain for component references. */
2408 38967 : for (r = e->ref; r; r = r->next)
2409 : {
2410 19558 : previous = length;
2411 19558 : switch (r->type)
2412 : {
2413 306 : case REF_COMPONENT:
2414 306 : if (r->u.c.component->ts.type == BT_CHARACTER)
2415 306 : 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 19558 : break;
2441 : }
2442 : }
2443 :
2444 19409 : 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 2124 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2453 : {
2454 2124 : tree caf_decl;
2455 2124 : bool found = false;
2456 2124 : gfc_ref *ref;
2457 :
2458 2124 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2459 :
2460 : /* Not-implemented diagnostic. */
2461 2124 : 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 4509 : for (ref = expr->ref; ref; ref = ref->next)
2468 2385 : if (ref->type == REF_COMPONENT)
2469 : {
2470 225 : 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 2124 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2479 2124 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2480 : : expr->symtree->n.sym->backend_decl;
2481 :
2482 2124 : 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 2094 : 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 76 : for (ref = expr->ref; ref; ref = ref->next)
2520 76 : if (ref->type == REF_COMPONENT)
2521 : {
2522 76 : gfc_component *comp = ref->u.c.component;
2523 :
2524 76 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2525 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2526 76 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2527 76 : TREE_TYPE (comp->backend_decl), caf_decl,
2528 : comp->backend_decl, NULL_TREE);
2529 76 : 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 76 : if (comp->attr.codimension)
2539 : {
2540 : found = true;
2541 : break;
2542 : }
2543 : }
2544 76 : 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 1995 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2553 : tree se_expr, gfc_expr *expr)
2554 : {
2555 1995 : tree tmp;
2556 :
2557 1995 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2558 :
2559 : /* Coarray token. */
2560 1995 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2561 620 : *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 1995 : 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 1706 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2667 : {
2668 1706 : gfc_ref *ref;
2669 1706 : tree lbound, ubound, extent, tmp, img_idx;
2670 1706 : gfc_se se;
2671 1706 : int i;
2672 :
2673 1767 : for (ref = e->ref; ref; ref = ref->next)
2674 1767 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2675 : break;
2676 1706 : gcc_assert (ref != NULL);
2677 :
2678 1706 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2679 167 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2680 167 : 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 3891 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2806 : {
2807 3891 : gfc_se se;
2808 :
2809 3891 : gfc_init_se (&se, NULL);
2810 :
2811 3891 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2812 1367 : 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 2617 : 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 2441 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2839 2441 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2840 : gfc_charlen_type_node, se.expr,
2841 2441 : build_zero_cst (TREE_TYPE (se.expr)));
2842 2441 : gfc_add_block_to_block (pblock, &se.pre);
2843 : }
2844 :
2845 2524 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2846 1606 : 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 7333 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2854 : const char *name, locus *where)
2855 : {
2856 7333 : tree tmp;
2857 7333 : tree type;
2858 7333 : tree fault;
2859 7333 : gfc_se start;
2860 7333 : gfc_se end;
2861 7333 : char *msg;
2862 7333 : mpz_t length;
2863 :
2864 7333 : type = gfc_get_character_type (kind, ref->u.ss.length);
2865 7333 : type = build_pointer_type (type);
2866 :
2867 7333 : gfc_init_se (&start, se);
2868 7333 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2869 7333 : gfc_add_block_to_block (&se->pre, &start.pre);
2870 :
2871 7333 : if (integer_onep (start.expr))
2872 2798 : gfc_conv_string_parameter (se);
2873 : else
2874 : {
2875 4535 : tmp = start.expr;
2876 4535 : STRIP_NOPS (tmp);
2877 : /* Avoid multiple evaluation of substring start. */
2878 4535 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2879 1700 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2880 :
2881 : /* Change the start of the string. */
2882 4535 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2883 1197 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2884 3458 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2885 5612 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2886 1077 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2887 : tmp = se->expr;
2888 : else
2889 1069 : tmp = build_fold_indirect_ref_loc (input_location,
2890 : se->expr);
2891 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2892 4535 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2893 : {
2894 4407 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2895 4407 : 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 7333 : gfc_init_se (&end, se);
2910 7333 : if (ref->u.ss.end == NULL)
2911 202 : end.expr = se->string_length;
2912 : else
2913 : {
2914 7131 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2915 7131 : gfc_add_block_to_block (&se->pre, &end.pre);
2916 : }
2917 7333 : tmp = end.expr;
2918 7333 : STRIP_NOPS (tmp);
2919 7333 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2920 2304 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2921 :
2922 7333 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2923 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2924 7788 : && !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 7333 : if (ref->u.ss.end
2967 7333 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2968 : {
2969 6111 : HOST_WIDE_INT i_len;
2970 :
2971 6111 : i_len = gfc_mpz_get_hwi (length) + 1;
2972 6111 : if (i_len < 0)
2973 : i_len = 0;
2974 :
2975 6111 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2976 6111 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2977 : }
2978 : else
2979 : {
2980 1222 : 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 1222 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2984 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2985 1222 : 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 7333 : se->string_length = tmp;
2990 7333 : }
2991 :
2992 :
2993 : /* Convert a derived type component reference. */
2994 :
2995 : void
2996 182585 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2997 : {
2998 182585 : gfc_component *c;
2999 182585 : tree tmp;
3000 182585 : tree decl;
3001 182585 : tree field;
3002 182585 : tree context;
3003 :
3004 182585 : c = ref->u.c.component;
3005 :
3006 182585 : 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 182585 : field = c->backend_decl;
3011 182585 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
3012 182585 : decl = se->expr;
3013 182585 : 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 182585 : if (context != TREE_TYPE (decl)
3025 182585 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
3026 14146 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
3027 : {
3028 14146 : tree f2 = c->norestrict_decl;
3029 24006 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
3030 8569 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
3031 8569 : if (TREE_CODE (f2) == FIELD_DECL
3032 8569 : && DECL_NAME (f2) == DECL_NAME (field))
3033 : break;
3034 14146 : gcc_assert (f2);
3035 14146 : c->norestrict_decl = f2;
3036 14146 : field = f2;
3037 : }
3038 :
3039 182585 : 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 182585 : se->class_vptr = NULL_TREE;
3048 :
3049 182585 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
3050 : decl, field, NULL_TREE);
3051 :
3052 182585 : se->expr = tmp;
3053 :
3054 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
3055 : strlen () conditional below. */
3056 182585 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
3057 8922 : && !c->ts.deferred
3058 5710 : && !c->attr.pdt_string)
3059 : {
3060 5536 : tmp = c->ts.u.cl->backend_decl;
3061 : /* Components must always be constant length. */
3062 5536 : gcc_assert (tmp && INTEGER_CST_P (tmp));
3063 5536 : se->string_length = tmp;
3064 : }
3065 :
3066 182585 : if (gfc_deferred_strlen (c, &field))
3067 : {
3068 3386 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
3069 3386 : TREE_TYPE (field),
3070 : decl, field, NULL_TREE);
3071 3386 : se->string_length = tmp;
3072 : }
3073 :
3074 182585 : if (((c->attr.pointer || c->attr.allocatable)
3075 106720 : && (!c->attr.dimension && !c->attr.codimension)
3076 57460 : && c->ts.type != BT_CHARACTER)
3077 127402 : || c->attr.proc_pointer)
3078 61747 : se->expr = build_fold_indirect_ref_loc (input_location,
3079 : se->expr);
3080 182585 : }
3081 :
3082 :
3083 : /* This function deals with component references to components of the
3084 : parent type for derived type extensions. */
3085 : void
3086 66891 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
3087 : {
3088 66891 : gfc_component *c;
3089 66891 : gfc_component *cmp;
3090 66891 : gfc_symbol *dt;
3091 66891 : gfc_ref parent;
3092 :
3093 66891 : dt = ref->u.c.sym;
3094 66891 : c = ref->u.c.component;
3095 :
3096 : /* Return if the component is in this type, i.e. not in the parent type. */
3097 117408 : for (cmp = dt->components; cmp; cmp = cmp->next)
3098 106374 : if (c == cmp)
3099 55857 : return;
3100 :
3101 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3102 11034 : parent.type = REF_COMPONENT;
3103 11034 : parent.next = NULL;
3104 11034 : parent.u.c.sym = dt;
3105 11034 : parent.u.c.component = dt->components;
3106 :
3107 11034 : if (dt->backend_decl == NULL)
3108 0 : gfc_get_derived_type (dt);
3109 :
3110 : /* Build the reference and call self. */
3111 11034 : gfc_conv_component_ref (se, &parent);
3112 11034 : parent.u.c.sym = dt->components->ts.u.derived;
3113 11034 : parent.u.c.component = c;
3114 11034 : 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 1471512 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3158 : bool is_classarray)
3159 : {
3160 1471512 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3161 : return var;
3162 299591 : 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 287699 : if (sym->ts.type == BT_CHARACTER)
3168 : {
3169 : /* Dereference character pointer dummy arguments
3170 : or results. */
3171 33136 : if ((sym->attr.pointer || sym->attr.allocatable
3172 19196 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3173 14276 : && (sym->attr.dummy
3174 10960 : || sym->attr.function
3175 10562 : || sym->attr.result))
3176 4399 : var = build_fold_indirect_ref_loc (input_location, var);
3177 : }
3178 254563 : else if (!sym->attr.value)
3179 : {
3180 : /* Dereference temporaries for class array dummy arguments. */
3181 175648 : if (sym->attr.dummy && is_classarray
3182 261554 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3183 : {
3184 5649 : if (!descriptor_only_p)
3185 2926 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3186 :
3187 5649 : var = build_fold_indirect_ref_loc (input_location, var);
3188 : }
3189 :
3190 : /* Dereference non-character scalar dummy arguments. */
3191 253465 : if (sym->attr.dummy && !sym->attr.dimension
3192 106423 : && !(sym->attr.codimension && sym->attr.allocatable)
3193 106357 : && (sym->ts.type != BT_CLASS
3194 20351 : || (!CLASS_DATA (sym)->attr.dimension
3195 11780 : && !(CLASS_DATA (sym)->attr.codimension
3196 283 : && CLASS_DATA (sym)->attr.allocatable))))
3197 97645 : var = build_fold_indirect_ref_loc (input_location, var);
3198 :
3199 : /* Dereference scalar hidden result. */
3200 253465 : 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 253465 : if (!is_classarray
3209 244930 : && (sym->attr.pointer || sym->attr.allocatable
3210 194863 : || gfc_is_associate_pointer (sym)
3211 190019 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3212 331920 : && (sym->attr.dummy
3213 36967 : || sym->attr.function
3214 36037 : || sym->attr.result
3215 34931 : || (!sym->attr.dimension
3216 34926 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3217 78450 : var = build_fold_indirect_ref_loc (input_location, var);
3218 : /* Now treat the class array pointer variables accordingly. */
3219 175015 : else if (sym->ts.type == BT_CLASS
3220 20797 : && sym->attr.dummy
3221 20351 : && (CLASS_DATA (sym)->attr.dimension
3222 11780 : || CLASS_DATA (sym)->attr.codimension)
3223 8854 : && ((CLASS_DATA (sym)->as
3224 8854 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3225 7791 : || CLASS_DATA (sym)->attr.allocatable
3226 6382 : || CLASS_DATA (sym)->attr.class_pointer))
3227 3063 : 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 171952 : else if (sym->ts.type == BT_CLASS
3234 17734 : && !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 1626462 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3253 : {
3254 1626462 : gfc_ss *ss;
3255 1626462 : gfc_ref *ref;
3256 1626462 : gfc_symbol *sym;
3257 1626462 : tree parent_decl = NULL_TREE;
3258 1626462 : int parent_flag;
3259 1626462 : bool return_value;
3260 1626462 : bool alternate_entry;
3261 1626462 : bool entry_master;
3262 1626462 : bool is_classarray;
3263 1626462 : bool first_time = true;
3264 :
3265 1626462 : sym = expr->symtree->n.sym;
3266 1626462 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3267 1626462 : ss = se->ss;
3268 1626462 : if (ss != NULL)
3269 : {
3270 134908 : gfc_ss_info *ss_info = ss->info;
3271 :
3272 : /* Check that something hasn't gone horribly wrong. */
3273 134908 : gcc_assert (ss != gfc_ss_terminator);
3274 134908 : gcc_assert (ss_info->expr == expr);
3275 :
3276 : /* A scalarized term. We already know the descriptor. */
3277 134908 : se->expr = ss_info->data.array.descriptor;
3278 134908 : se->string_length = ss_info->string_length;
3279 134908 : ref = ss_info->data.array.ref;
3280 134908 : if (ref)
3281 134554 : 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 1491554 : tree se_expr = NULL_TREE;
3289 :
3290 1491554 : 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 1491554 : return_value = sym->attr.function && sym->result == sym;
3295 19442 : alternate_entry = sym->attr.function && sym->attr.entry
3296 1492693 : && sym->result == sym;
3297 2983108 : entry_master = sym->attr.result
3298 14968 : && sym->ns->proc_name->attr.entry_master
3299 1491935 : && !gfc_return_by_reference (sym->ns->proc_name);
3300 1491554 : if (current_function_decl)
3301 1472893 : parent_decl = DECL_CONTEXT (current_function_decl);
3302 :
3303 1491554 : if ((se->expr == parent_decl && return_value)
3304 1491437 : || (sym->ns && sym->ns->proc_name
3305 1486443 : && parent_decl
3306 1467782 : && sym->ns->proc_name->backend_decl == parent_decl
3307 38644 : && (alternate_entry || entry_master)))
3308 : parent_flag = 1;
3309 : else
3310 1491404 : 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 1491554 : if (return_value && (se->expr == current_function_decl || parent_flag))
3315 10467 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3316 :
3317 : /* Similarly for alternate entry points. */
3318 1481087 : 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 1479981 : 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 11868 : if (se_expr)
3338 11868 : se->expr = se_expr;
3339 :
3340 : /* Procedure actual arguments. Look out for temporary variables
3341 : with the same attributes as function values. */
3342 1479686 : else if (!sym->attr.temporary
3343 1479618 : && sym->attr.flavor == FL_PROCEDURE
3344 22187 : && se->expr != current_function_decl)
3345 : {
3346 22120 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3347 : {
3348 20408 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3349 20408 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3350 : }
3351 : return;
3352 : }
3353 :
3354 1469434 : if (sym->ts.type == BT_CLASS
3355 74724 : && sym->attr.class_ok
3356 74482 : && sym->ts.u.derived->attr.is_class)
3357 : {
3358 28957 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3359 82586 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3360 5791 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3361 : else
3362 68691 : se->class_container = se->expr;
3363 : }
3364 :
3365 : /* Dereference the expression, where needed. */
3366 1469434 : 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 1468557 : se->expr
3373 1468557 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3374 : is_classarray);
3375 :
3376 1469434 : ref = expr->ref;
3377 : }
3378 :
3379 : /* For character variables, also get the length. */
3380 1604342 : 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 167304 : 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 167304 : se->string_length = sym->ts.u.cl->backend_decl;
3388 167304 : 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 167310 : && 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 1604342 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3401 90708 : && (gfc_option.allow_std & GFC_STD_F202Y)
3402 1604576 : && 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 (gfc_array_dim_rank_type,
3408 : gfc_conv_descriptor_rank_get (se->expr));
3409 60 : dim = fold_build2_loc (input_location, MINUS_EXPR,
3410 : gfc_array_dim_rank_type, dim, gfc_rank_cst[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 1604342 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3425 418 : gfc_fixup_inferred_type_refs (expr);
3426 :
3427 1604342 : gfc_typespec *ts = &sym->ts;
3428 2048940 : while (ref)
3429 : {
3430 799590 : switch (ref->type)
3431 : {
3432 620511 : case REF_ARRAY:
3433 : /* Return the descriptor if that's what we want and this is an array
3434 : section reference. */
3435 620511 : 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 275107 : if (se->want_pointer
3440 24483 : && ref->next == NULL && (se->descriptor_only))
3441 : return;
3442 :
3443 265519 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3444 : /* Return a pointer to an element. */
3445 265519 : break;
3446 :
3447 171455 : case REF_COMPONENT:
3448 171455 : ts = &ref->u.c.component->ts;
3449 171455 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3450 6129 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3451 3244 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3452 3244 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3453 2723 : && 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 168732 : if (ref->u.c.sym->attr.extension)
3460 55766 : conv_parent_component_references (se, ref);
3461 :
3462 168732 : gfc_conv_component_ref (se, ref);
3463 :
3464 168732 : if (ref->u.c.component->ts.type == BT_CLASS
3465 12497 : && ref->u.c.component->attr.class_ok
3466 12497 : && ref->u.c.component->ts.u.derived->attr.is_class)
3467 12497 : se->class_container = se->expr;
3468 156235 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3469 153741 : && ref->u.c.sym->attr.is_class))
3470 86160 : se->class_container = NULL_TREE;
3471 :
3472 168732 : if (!ref->next && ref->u.c.sym->attr.codimension
3473 0 : && se->want_pointer && se->descriptor_only)
3474 : return;
3475 :
3476 : break;
3477 :
3478 7075 : case REF_SUBSTRING:
3479 7075 : gfc_conv_substring (se, ref, expr->ts.kind,
3480 7075 : expr->symtree->name, &expr->where);
3481 7075 : 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 444598 : break;
3490 : }
3491 444598 : first_time = false;
3492 444598 : ref = ref->next;
3493 : }
3494 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3495 : separately. */
3496 1249350 : if (se->want_pointer)
3497 : {
3498 135583 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3499 8090 : gfc_conv_string_parameter (se);
3500 : else
3501 127493 : 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 28941 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3510 : {
3511 28941 : gfc_se operand;
3512 28941 : tree type;
3513 :
3514 28941 : gcc_assert (expr->ts.type != BT_CHARACTER);
3515 : /* Initialize the operand. */
3516 28941 : gfc_init_se (&operand, se);
3517 28941 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3518 28941 : gfc_add_block_to_block (&se->pre, &operand.pre);
3519 :
3520 28941 : 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 28941 : if (code == TRUTH_NOT_EXPR)
3526 20320 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3527 : build_int_cst (type, 0));
3528 : else
3529 8621 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3530 :
3531 28941 : }
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 49183 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3797 : {
3798 49183 : tree gfc_int4_type_node;
3799 49183 : int kind;
3800 49183 : int ikind;
3801 49183 : int res_ikind_1, res_ikind_2;
3802 49183 : gfc_se lse;
3803 49183 : gfc_se rse;
3804 49183 : tree fndecl = NULL;
3805 :
3806 49183 : gfc_init_se (&lse, se);
3807 49183 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3808 49183 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3809 49183 : gfc_add_block_to_block (&se->pre, &lse.pre);
3810 :
3811 49183 : gfc_init_se (&rse, se);
3812 49183 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3813 49183 : gfc_add_block_to_block (&se->pre, &rse.pre);
3814 :
3815 49183 : 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 20483 : 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 32784 : if ((expr->value.op.op2->ts.type == BT_INTEGER
3830 31468 : || expr->value.op.op2->ts.type == BT_UNSIGNED)
3831 31916 : && 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 32784 : if (INTEGER_CST_P (lse.expr)
3836 15377 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE
3837 48161 : && expr->value.op.op2->ts.type == BT_INTEGER)
3838 : {
3839 257 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3840 257 : HOST_WIDE_INT v;
3841 257 : unsigned HOST_WIDE_INT w;
3842 257 : int kind, ikind, bit_size;
3843 :
3844 257 : v = wlhs.to_shwi ();
3845 257 : w = absu_hwi (v);
3846 :
3847 257 : kind = expr->value.op.op1->ts.kind;
3848 257 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3849 257 : bit_size = gfc_integer_kinds[ikind].bit_size;
3850 :
3851 257 : if (v == 1)
3852 : {
3853 : /* 1**something is always 1. */
3854 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3855 245 : return;
3856 : }
3857 222 : 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 188 : 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 176 : tree lshift;
3880 176 : tree type;
3881 176 : tree shift;
3882 176 : tree ge;
3883 176 : tree cond;
3884 176 : tree num_bits;
3885 176 : tree cond2;
3886 176 : tree tmp1;
3887 :
3888 176 : type = TREE_TYPE (lse.expr);
3889 :
3890 176 : if (w == 2)
3891 116 : 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 176 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3907 : build_int_cst (type, 1), shift);
3908 176 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3909 : rse.expr, build_int_cst (type, 0));
3910 176 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3911 : build_int_cst (type, 0));
3912 176 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3913 176 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3914 : rse.expr, num_bits);
3915 176 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3916 : build_int_cst (type, 0), cond);
3917 176 : if (v > 0)
3918 : {
3919 : 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 176 : return;
3935 : }
3936 : }
3937 : /* Handle unsigned separate from signed above, things would be too
3938 : complicated otherwise. */
3939 :
3940 32539 : 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 28759 : 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 28759 : res_ikind_1 = -1;
3988 28759 : res_ikind_2 = -1;
3989 :
3990 28759 : kind = expr->value.op.op1->ts.kind;
3991 28759 : switch (expr->value.op.op2->ts.type)
3992 : {
3993 1071 : case BT_INTEGER:
3994 1071 : ikind = expr->value.op.op2->ts.kind;
3995 1071 : switch (ikind)
3996 : {
3997 168 : case 1:
3998 168 : case 2:
3999 168 : rse.expr = convert (gfc_int4_type_node, rse.expr);
4000 168 : res_ikind_2 = ikind;
4001 : /* Fall through. */
4002 :
4003 : case 4:
4004 : ikind = 0;
4005 : break;
4006 :
4007 182 : case 8:
4008 182 : ikind = 1;
4009 182 : break;
4010 :
4011 6 : case 16:
4012 6 : ikind = 2;
4013 6 : break;
4014 :
4015 0 : default:
4016 0 : gcc_unreachable ();
4017 : }
4018 1071 : 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 212 : case 8:
4036 212 : kind = 1;
4037 212 : 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 1071 : 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 710 : case BT_REAL:
4060 : /* Use builtins for real ** int4. */
4061 :
4062 710 : if (real_minus_onep (lse.expr))
4063 : {
4064 : /* (-1.0)**n is (real) (1 - ((n & 1) << 1)), see the integer case
4065 : above. */
4066 :
4067 59 : tree lhs_type, rhs_type;
4068 59 : tree tmp;
4069 59 : lhs_type = TREE_TYPE (lse.expr);
4070 59 : rhs_type = TREE_TYPE (rse.expr);
4071 59 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, rhs_type,
4072 : rse.expr, build_int_cst (rhs_type, 1));
4073 59 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, rhs_type,
4074 : tmp, build_int_cst (rhs_type, 1));
4075 59 : tmp = fold_build2_loc (input_location, MINUS_EXPR, rhs_type,
4076 : build_int_cst (rhs_type, 1), tmp);
4077 59 : se->expr = fold_convert (lhs_type, tmp);
4078 59 : return;
4079 : }
4080 :
4081 651 : if (ikind == 0)
4082 : {
4083 555 : switch (kind)
4084 : {
4085 391 : case 0:
4086 391 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
4087 391 : break;
4088 :
4089 146 : case 1:
4090 146 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
4091 146 : break;
4092 :
4093 6 : case 2:
4094 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4095 6 : break;
4096 :
4097 12 : case 3:
4098 : /* Use the __builtin_powil() only if real(kind=16) is
4099 : actually the C long double type. */
4100 12 : if (!gfc_real16_is_float128)
4101 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4102 : break;
4103 :
4104 : default:
4105 : gcc_unreachable ();
4106 : }
4107 : }
4108 :
4109 : /* If we don't have a good builtin for this, go for the
4110 : library function. */
4111 543 : if (!fndecl)
4112 108 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
4113 : break;
4114 :
4115 232 : case BT_COMPLEX:
4116 232 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
4117 232 : break;
4118 :
4119 0 : default:
4120 0 : gcc_unreachable ();
4121 : }
4122 : break;
4123 :
4124 139 : case BT_REAL:
4125 139 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
4126 139 : break;
4127 :
4128 729 : case BT_COMPLEX:
4129 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
4130 729 : break;
4131 :
4132 26820 : case BT_UNSIGNED:
4133 26820 : {
4134 : /* Valid kinds for unsigned are 1, 2, 4, 8, 16. Instead of using a
4135 : large switch statement, let's just use __builtin_ctz. */
4136 26820 : int base = __builtin_ctz (expr->value.op.op1->ts.kind);
4137 26820 : int expon = __builtin_ctz (expr->value.op.op2->ts.kind);
4138 26820 : fndecl = gfor_fndecl_unsigned_pow_list[base][expon];
4139 : }
4140 26820 : break;
4141 :
4142 0 : default:
4143 0 : gcc_unreachable ();
4144 28700 : break;
4145 : }
4146 :
4147 28700 : se->expr = build_call_expr_loc (input_location,
4148 : fndecl, 2, lse.expr, rse.expr);
4149 :
4150 : /* Convert the result back if it is of wrong integer kind. */
4151 28700 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
4152 : {
4153 : /* We want the maximum of both operand kinds as result. */
4154 0 : if (res_ikind_1 < res_ikind_2)
4155 0 : res_ikind_1 = res_ikind_2;
4156 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
4157 : }
4158 : }
4159 :
4160 :
4161 : /* Generate code to allocate a string temporary. */
4162 :
4163 : tree
4164 4910 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4165 : {
4166 4910 : tree var;
4167 4910 : tree tmp;
4168 :
4169 4910 : if (gfc_can_put_var_on_stack (len))
4170 : {
4171 : /* Create a temporary variable to hold the result. */
4172 4622 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4173 2311 : TREE_TYPE (len), len,
4174 2311 : build_int_cst (TREE_TYPE (len), 1));
4175 2311 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4176 :
4177 2311 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4178 2311 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4179 : else
4180 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
4181 :
4182 2311 : var = gfc_create_var (tmp, "str");
4183 2311 : var = gfc_build_addr_expr (type, var);
4184 : }
4185 : else
4186 : {
4187 : /* Allocate a temporary to hold the result. */
4188 2599 : var = gfc_create_var (type, "pstr");
4189 2599 : gcc_assert (POINTER_TYPE_P (type));
4190 2599 : tmp = TREE_TYPE (type);
4191 2599 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4192 2599 : tmp = TREE_TYPE (tmp);
4193 2599 : tmp = TYPE_SIZE_UNIT (tmp);
4194 2599 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4195 : fold_convert (size_type_node, len),
4196 : fold_convert (size_type_node, tmp));
4197 2599 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4198 2599 : gfc_add_modify (&se->pre, var, tmp);
4199 :
4200 : /* Free the temporary afterwards. */
4201 2599 : tmp = gfc_call_free (var);
4202 2599 : gfc_add_expr_to_block (&se->post, tmp);
4203 : }
4204 :
4205 4910 : return var;
4206 : }
4207 :
4208 :
4209 : /* Handle a string concatenation operation. A temporary will be allocated to
4210 : hold the result. */
4211 :
4212 : static void
4213 1294 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4214 : {
4215 1294 : gfc_se lse, rse;
4216 1294 : tree len, type, var, tmp, fndecl;
4217 :
4218 1294 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4219 : && expr->value.op.op2->ts.type == BT_CHARACTER);
4220 1294 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4221 :
4222 1294 : gfc_init_se (&lse, se);
4223 1294 : gfc_conv_expr (&lse, expr->value.op.op1);
4224 1294 : gfc_conv_string_parameter (&lse);
4225 1294 : gfc_init_se (&rse, se);
4226 1294 : gfc_conv_expr (&rse, expr->value.op.op2);
4227 1294 : gfc_conv_string_parameter (&rse);
4228 :
4229 1294 : gfc_add_block_to_block (&se->pre, &lse.pre);
4230 1294 : gfc_add_block_to_block (&se->pre, &rse.pre);
4231 :
4232 1294 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4233 1294 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4234 1294 : if (len == NULL_TREE)
4235 : {
4236 1075 : len = fold_build2_loc (input_location, PLUS_EXPR,
4237 : gfc_charlen_type_node,
4238 : fold_convert (gfc_charlen_type_node,
4239 : lse.string_length),
4240 : fold_convert (gfc_charlen_type_node,
4241 : rse.string_length));
4242 : }
4243 :
4244 1294 : type = build_pointer_type (type);
4245 :
4246 1294 : var = gfc_conv_string_tmp (se, type, len);
4247 :
4248 : /* Do the actual concatenation. */
4249 1294 : if (expr->ts.kind == 1)
4250 1203 : fndecl = gfor_fndecl_concat_string;
4251 91 : else if (expr->ts.kind == 4)
4252 91 : fndecl = gfor_fndecl_concat_string_char4;
4253 : else
4254 0 : gcc_unreachable ();
4255 :
4256 1294 : tmp = build_call_expr_loc (input_location,
4257 : fndecl, 6, len, var, lse.string_length, lse.expr,
4258 : rse.string_length, rse.expr);
4259 1294 : gfc_add_expr_to_block (&se->pre, tmp);
4260 :
4261 : /* Add the cleanup for the operands. */
4262 1294 : gfc_add_block_to_block (&se->pre, &rse.post);
4263 1294 : gfc_add_block_to_block (&se->pre, &lse.post);
4264 :
4265 1294 : se->expr = var;
4266 1294 : se->string_length = len;
4267 1294 : }
4268 :
4269 : /* Translates an op expression. Common (binary) cases are handled by this
4270 : function, others are passed on. Recursion is used in either case.
4271 : We use the fact that (op1.ts == op2.ts) (except for the power
4272 : operator **).
4273 : Operators need no special handling for scalarized expressions as long as
4274 : they call gfc_conv_simple_val to get their operands.
4275 : Character strings get special handling. */
4276 :
4277 : static void
4278 511917 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4279 : {
4280 511917 : enum tree_code code;
4281 511917 : gfc_se lse;
4282 511917 : gfc_se rse;
4283 511917 : tree tmp, type;
4284 511917 : int lop;
4285 511917 : int checkstring;
4286 :
4287 511917 : checkstring = 0;
4288 511917 : lop = 0;
4289 511917 : switch (expr->value.op.op)
4290 : {
4291 15591 : case INTRINSIC_PARENTHESES:
4292 15591 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4293 3802 : && flag_protect_parens)
4294 : {
4295 3668 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
4296 3668 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
4297 91347 : return;
4298 : }
4299 :
4300 : /* Fallthrough. */
4301 11929 : case INTRINSIC_UPLUS:
4302 11929 : gfc_conv_expr (se, expr->value.op.op1);
4303 11929 : return;
4304 :
4305 4953 : case INTRINSIC_UMINUS:
4306 4953 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4307 4953 : return;
4308 :
4309 20320 : case INTRINSIC_NOT:
4310 20320 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4311 20320 : return;
4312 :
4313 : case INTRINSIC_PLUS:
4314 : code = PLUS_EXPR;
4315 : break;
4316 :
4317 29727 : case INTRINSIC_MINUS:
4318 29727 : code = MINUS_EXPR;
4319 29727 : break;
4320 :
4321 33385 : case INTRINSIC_TIMES:
4322 33385 : code = MULT_EXPR;
4323 33385 : break;
4324 :
4325 7089 : case INTRINSIC_DIVIDE:
4326 : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
4327 : an integer or unsigned, we must round towards zero, so we use a
4328 : TRUNC_DIV_EXPR. */
4329 7089 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4330 : code = TRUNC_DIV_EXPR;
4331 : else
4332 420570 : code = RDIV_EXPR;
4333 : break;
4334 :
4335 49183 : case INTRINSIC_POWER:
4336 49183 : gfc_conv_power_op (se, expr);
4337 49183 : return;
4338 :
4339 1294 : case INTRINSIC_CONCAT:
4340 1294 : gfc_conv_concat_op (se, expr);
4341 1294 : return;
4342 :
4343 4834 : case INTRINSIC_AND:
4344 4834 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4345 : lop = 1;
4346 : break;
4347 :
4348 56065 : case INTRINSIC_OR:
4349 56065 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
4350 : lop = 1;
4351 : break;
4352 :
4353 : /* EQV and NEQV only work on logicals, but since we represent them
4354 : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4355 12690 : case INTRINSIC_EQ:
4356 12690 : case INTRINSIC_EQ_OS:
4357 12690 : case INTRINSIC_EQV:
4358 12690 : code = EQ_EXPR;
4359 12690 : checkstring = 1;
4360 12690 : lop = 1;
4361 12690 : break;
4362 :
4363 209019 : case INTRINSIC_NE:
4364 209019 : case INTRINSIC_NE_OS:
4365 209019 : case INTRINSIC_NEQV:
4366 209019 : code = NE_EXPR;
4367 209019 : checkstring = 1;
4368 209019 : lop = 1;
4369 209019 : break;
4370 :
4371 12156 : case INTRINSIC_GT:
4372 12156 : case INTRINSIC_GT_OS:
4373 12156 : code = GT_EXPR;
4374 12156 : checkstring = 1;
4375 12156 : lop = 1;
4376 12156 : break;
4377 :
4378 1677 : case INTRINSIC_GE:
4379 1677 : case INTRINSIC_GE_OS:
4380 1677 : code = GE_EXPR;
4381 1677 : checkstring = 1;
4382 1677 : lop = 1;
4383 1677 : break;
4384 :
4385 4381 : case INTRINSIC_LT:
4386 4381 : case INTRINSIC_LT_OS:
4387 4381 : code = LT_EXPR;
4388 4381 : checkstring = 1;
4389 4381 : lop = 1;
4390 4381 : break;
4391 :
4392 2610 : case INTRINSIC_LE:
4393 2610 : case INTRINSIC_LE_OS:
4394 2610 : code = LE_EXPR;
4395 2610 : checkstring = 1;
4396 2610 : lop = 1;
4397 2610 : break;
4398 :
4399 0 : case INTRINSIC_USER:
4400 0 : case INTRINSIC_ASSIGN:
4401 : /* These should be converted into function calls by the frontend. */
4402 0 : gcc_unreachable ();
4403 :
4404 0 : default:
4405 0 : fatal_error (input_location, "Unknown intrinsic op");
4406 420570 : return;
4407 : }
4408 :
4409 : /* The only exception to this is **, which is handled separately anyway. */
4410 420570 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4411 :
4412 420570 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4413 386306 : checkstring = 0;
4414 :
4415 : /* lhs */
4416 420570 : gfc_init_se (&lse, se);
4417 420570 : gfc_conv_expr (&lse, expr->value.op.op1);
4418 420570 : gfc_add_block_to_block (&se->pre, &lse.pre);
4419 :
4420 : /* rhs */
4421 420570 : gfc_init_se (&rse, se);
4422 420570 : gfc_conv_expr (&rse, expr->value.op.op2);
4423 420570 : gfc_add_block_to_block (&se->pre, &rse.pre);
4424 :
4425 420570 : if (checkstring)
4426 : {
4427 34264 : gfc_conv_string_parameter (&lse);
4428 34264 : gfc_conv_string_parameter (&rse);
4429 :
4430 68528 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4431 : rse.string_length, rse.expr,
4432 34264 : expr->value.op.op1->ts.kind,
4433 : code);
4434 34264 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4435 34264 : gfc_add_block_to_block (&lse.post, &rse.post);
4436 : }
4437 :
4438 420570 : type = gfc_typenode_for_spec (&expr->ts);
4439 :
4440 420570 : if (lop)
4441 : {
4442 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4443 303432 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4444 171443 : && expr->value.op.op1->ts.type == BT_INTEGER
4445 74212 : && expr->value.op.op1->symtree
4446 74212 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4447 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4448 :
4449 303432 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4450 72616 : && expr->value.op.op2->ts.type == BT_INTEGER
4451 13159 : && expr->value.op.op2->symtree
4452 13159 : && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
4453 12 : TREE_THIS_VOLATILE (rse.expr) = 1;
4454 :
4455 : /* The result of logical ops is always logical_type_node. */
4456 303432 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4457 : lse.expr, rse.expr);
4458 303432 : se->expr = convert (type, tmp);
4459 : }
4460 : else
4461 117138 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4462 :
4463 : /* Add the post blocks. */
4464 420570 : gfc_add_block_to_block (&se->post, &rse.post);
4465 420570 : gfc_add_block_to_block (&se->post, &lse.post);
4466 : }
4467 :
4468 : static void
4469 159 : gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
4470 : {
4471 159 : gfc_se cond_se, true_se, false_se;
4472 159 : tree condition, true_val, false_val;
4473 159 : tree type;
4474 :
4475 159 : gfc_init_se (&cond_se, se);
4476 159 : gfc_init_se (&true_se, se);
4477 159 : gfc_init_se (&false_se, se);
4478 :
4479 159 : gfc_conv_expr (&cond_se, expr->value.conditional.condition);
4480 159 : gfc_add_block_to_block (&se->pre, &cond_se.pre);
4481 159 : condition = gfc_evaluate_now (cond_se.expr, &se->pre);
4482 :
4483 159 : true_se.want_pointer = se->want_pointer;
4484 159 : gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
4485 159 : true_val = true_se.expr;
4486 159 : false_se.want_pointer = se->want_pointer;
4487 159 : gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
4488 159 : false_val = false_se.expr;
4489 :
4490 159 : if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
4491 24 : gfc_add_expr_to_block (
4492 : &se->pre,
4493 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4494 24 : true_se.pre.head != NULL_TREE
4495 6 : ? gfc_finish_block (&true_se.pre)
4496 18 : : build_empty_stmt (input_location),
4497 24 : false_se.pre.head != NULL_TREE
4498 24 : ? gfc_finish_block (&false_se.pre)
4499 0 : : build_empty_stmt (input_location)));
4500 :
4501 159 : if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
4502 6 : gfc_add_expr_to_block (
4503 : &se->post,
4504 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4505 6 : true_se.post.head != NULL_TREE
4506 0 : ? gfc_finish_block (&true_se.post)
4507 6 : : build_empty_stmt (input_location),
4508 6 : false_se.post.head != NULL_TREE
4509 6 : ? gfc_finish_block (&false_se.post)
4510 0 : : build_empty_stmt (input_location)));
4511 :
4512 159 : type = gfc_typenode_for_spec (&expr->ts);
4513 159 : if (se->want_pointer)
4514 18 : type = build_pointer_type (type);
4515 :
4516 159 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
4517 : true_val, false_val);
4518 159 : if (expr->ts.type == BT_CHARACTER)
4519 66 : se->string_length
4520 66 : = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
4521 : condition, true_se.string_length,
4522 : false_se.string_length);
4523 159 : }
4524 :
4525 : /* If a string's length is one, we convert it to a single character. */
4526 :
4527 : tree
4528 141638 : gfc_string_to_single_character (tree len, tree str, int kind)
4529 : {
4530 :
4531 141638 : if (len == NULL
4532 141638 : || !tree_fits_uhwi_p (len)
4533 260269 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4534 : return NULL_TREE;
4535 :
4536 118579 : if (TREE_INT_CST_LOW (len) == 1)
4537 : {
4538 22737 : str = fold_convert (gfc_get_pchar_type (kind), str);
4539 22737 : return build_fold_indirect_ref_loc (input_location, str);
4540 : }
4541 :
4542 95842 : if (kind == 1
4543 78436 : && TREE_CODE (str) == ADDR_EXPR
4544 67633 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4545 48333 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4546 29789 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4547 29789 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4548 29789 : && TREE_INT_CST_LOW (len) > 1
4549 123791 : && TREE_INT_CST_LOW (len)
4550 : == (unsigned HOST_WIDE_INT)
4551 27949 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4552 : {
4553 27949 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4554 27949 : ret = build_fold_indirect_ref_loc (input_location, ret);
4555 27949 : if (TREE_CODE (ret) == INTEGER_CST)
4556 : {
4557 27949 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4558 27949 : int i, length = TREE_STRING_LENGTH (string_cst);
4559 27949 : const char *ptr = TREE_STRING_POINTER (string_cst);
4560 :
4561 42077 : for (i = 1; i < length; i++)
4562 41385 : if (ptr[i] != ' ')
4563 : return NULL_TREE;
4564 :
4565 : return ret;
4566 : }
4567 : }
4568 :
4569 : return NULL_TREE;
4570 : }
4571 :
4572 :
4573 : static void
4574 172 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4575 : {
4576 172 : gcc_assert (expr);
4577 :
4578 : /* We used to modify the tree here. Now it is done earlier in
4579 : the front-end, so we only check it here to avoid regressions. */
4580 172 : if (sym->backend_decl)
4581 : {
4582 67 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4583 67 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4584 67 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4585 67 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4586 : }
4587 :
4588 : /* If we have a constant character expression, make it into an
4589 : integer of type C char. */
4590 172 : if ((*expr)->expr_type == EXPR_CONSTANT)
4591 : {
4592 166 : gfc_typespec ts;
4593 166 : gfc_clear_ts (&ts);
4594 :
4595 332 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4596 166 : (*expr)->value.character.string[0]);
4597 166 : gfc_replace_expr (*expr, tmp);
4598 : }
4599 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4600 : {
4601 6 : if ((*expr)->ref == NULL)
4602 : {
4603 6 : se->expr = gfc_string_to_single_character
4604 6 : (integer_one_node,
4605 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4606 : gfc_get_symbol_decl
4607 6 : ((*expr)->symtree->n.sym)),
4608 : (*expr)->ts.kind);
4609 : }
4610 : else
4611 : {
4612 0 : gfc_conv_variable (se, *expr);
4613 0 : se->expr = gfc_string_to_single_character
4614 0 : (integer_one_node,
4615 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4616 : se->expr),
4617 0 : (*expr)->ts.kind);
4618 : }
4619 : }
4620 172 : }
4621 :
4622 : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4623 : if STR is a string literal, otherwise return -1. */
4624 :
4625 : static int
4626 32546 : gfc_optimize_len_trim (tree len, tree str, int kind)
4627 : {
4628 32546 : if (kind == 1
4629 27494 : && TREE_CODE (str) == ADDR_EXPR
4630 24141 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4631 15415 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4632 9929 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4633 9929 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4634 9929 : && tree_fits_uhwi_p (len)
4635 9929 : && tree_to_uhwi (len) >= 1
4636 32546 : && tree_to_uhwi (len)
4637 9885 : == (unsigned HOST_WIDE_INT)
4638 9885 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4639 : {
4640 9885 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4641 9885 : folded = build_fold_indirect_ref_loc (input_location, folded);
4642 9885 : if (TREE_CODE (folded) == INTEGER_CST)
4643 : {
4644 9885 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4645 9885 : int length = TREE_STRING_LENGTH (string_cst);
4646 9885 : const char *ptr = TREE_STRING_POINTER (string_cst);
4647 :
4648 14804 : for (; length > 0; length--)
4649 14804 : if (ptr[length - 1] != ' ')
4650 : break;
4651 :
4652 : return length;
4653 : }
4654 : }
4655 : return -1;
4656 : }
4657 :
4658 : /* Helper to build a call to memcmp. */
4659 :
4660 : static tree
4661 13237 : build_memcmp_call (tree s1, tree s2, tree n)
4662 : {
4663 13237 : tree tmp;
4664 :
4665 13237 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4666 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4667 : else
4668 13237 : s1 = fold_convert (pvoid_type_node, s1);
4669 :
4670 13237 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4671 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4672 : else
4673 13237 : s2 = fold_convert (pvoid_type_node, s2);
4674 :
4675 13237 : n = fold_convert (size_type_node, n);
4676 :
4677 13237 : tmp = build_call_expr_loc (input_location,
4678 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4679 : 3, s1, s2, n);
4680 :
4681 13237 : return fold_convert (integer_type_node, tmp);
4682 : }
4683 :
4684 : /* Compare two strings. If they are all single characters, the result is the
4685 : subtraction of them. Otherwise, we build a library call. */
4686 :
4687 : tree
4688 34363 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4689 : enum tree_code code)
4690 : {
4691 34363 : tree sc1;
4692 34363 : tree sc2;
4693 34363 : tree fndecl;
4694 :
4695 34363 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4696 34363 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4697 :
4698 34363 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4699 34363 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4700 :
4701 34363 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4702 : {
4703 : /* Deal with single character specially. */
4704 4851 : sc1 = fold_convert (integer_type_node, sc1);
4705 4851 : sc2 = fold_convert (integer_type_node, sc2);
4706 4851 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4707 4851 : sc1, sc2);
4708 : }
4709 :
4710 29512 : if ((code == EQ_EXPR || code == NE_EXPR)
4711 28950 : && optimize
4712 24249 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4713 : {
4714 : /* If one string is a string literal with LEN_TRIM longer
4715 : than the length of the second string, the strings
4716 : compare unequal. */
4717 16273 : int len = gfc_optimize_len_trim (len1, str1, kind);
4718 16273 : if (len > 0 && compare_tree_int (len2, len) < 0)
4719 0 : return integer_one_node;
4720 16273 : len = gfc_optimize_len_trim (len2, str2, kind);
4721 16273 : if (len > 0 && compare_tree_int (len1, len) < 0)
4722 0 : return integer_one_node;
4723 : }
4724 :
4725 : /* We can compare via memcpy if the strings are known to be equal
4726 : in length and they are
4727 : - kind=1
4728 : - kind=4 and the comparison is for (in)equality. */
4729 :
4730 19832 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4731 19494 : && tree_int_cst_equal (len1, len2)
4732 42809 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4733 : {
4734 13237 : tree tmp;
4735 13237 : tree chartype;
4736 :
4737 13237 : chartype = gfc_get_char_type (kind);
4738 13237 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4739 13237 : fold_convert (TREE_TYPE(len1),
4740 : TYPE_SIZE_UNIT(chartype)),
4741 : len1);
4742 13237 : return build_memcmp_call (str1, str2, tmp);
4743 : }
4744 :
4745 : /* Build a call for the comparison. */
4746 16275 : if (kind == 1)
4747 13426 : fndecl = gfor_fndecl_compare_string;
4748 2849 : else if (kind == 4)
4749 2849 : fndecl = gfor_fndecl_compare_string_char4;
4750 : else
4751 0 : gcc_unreachable ();
4752 :
4753 16275 : return build_call_expr_loc (input_location, fndecl, 4,
4754 16275 : len1, str1, len2, str2);
4755 : }
4756 :
4757 :
4758 : /* Return the backend_decl for a procedure pointer component. */
4759 :
4760 : static tree
4761 1920 : get_proc_ptr_comp (gfc_expr *e)
4762 : {
4763 1920 : gfc_se comp_se;
4764 1920 : gfc_expr *e2;
4765 1920 : expr_t old_type;
4766 :
4767 1920 : gfc_init_se (&comp_se, NULL);
4768 1920 : e2 = gfc_copy_expr (e);
4769 : /* We have to restore the expr type later so that gfc_free_expr frees
4770 : the exact same thing that was allocated.
4771 : TODO: This is ugly. */
4772 1920 : old_type = e2->expr_type;
4773 1920 : e2->expr_type = EXPR_VARIABLE;
4774 1920 : gfc_conv_expr (&comp_se, e2);
4775 1920 : e2->expr_type = old_type;
4776 1920 : gfc_free_expr (e2);
4777 1920 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4778 : }
4779 :
4780 :
4781 : /* Convert a typebound function reference from a class object. */
4782 : static void
4783 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4784 : {
4785 80 : gfc_ref *ref;
4786 80 : tree var;
4787 :
4788 80 : if (!VAR_P (base_object))
4789 : {
4790 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4791 0 : gfc_add_modify (&se->pre, var, base_object);
4792 : }
4793 80 : se->expr = gfc_class_vptr_get (base_object);
4794 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4795 80 : ref = expr->ref;
4796 308 : while (ref && ref->next)
4797 : ref = ref->next;
4798 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4799 80 : if (ref->u.c.sym->attr.extension)
4800 0 : conv_parent_component_references (se, ref);
4801 80 : gfc_conv_component_ref (se, ref);
4802 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4803 80 : }
4804 :
4805 : static tree
4806 129624 : get_builtin_fn (gfc_symbol * sym)
4807 : {
4808 129624 : if (!gfc_option.disable_omp_is_initial_device
4809 129620 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4810 631 : && !strcmp (sym->name, "omp_is_initial_device"))
4811 41 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4812 :
4813 129583 : if (!gfc_option.disable_omp_get_initial_device
4814 129576 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4815 4288 : && !strcmp (sym->name, "omp_get_initial_device"))
4816 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4817 :
4818 129554 : if (!gfc_option.disable_omp_get_num_devices
4819 129547 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4820 4259 : && !strcmp (sym->name, "omp_get_num_devices"))
4821 107 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4822 :
4823 129447 : if (!gfc_option.disable_acc_on_device
4824 129267 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4825 1169 : && !strcmp (sym->name, "acc_on_device_h"))
4826 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4827 :
4828 : return NULL_TREE;
4829 : }
4830 :
4831 : static tree
4832 567 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4833 : {
4834 567 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4835 :
4836 567 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4837 : /* In Fortran omp_is_initial_device returns logical(4)
4838 : but the builtin uses 'int'. */
4839 41 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4840 :
4841 526 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4842 : {
4843 : /* Likewise for the return type; additionally, the argument it a
4844 : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4845 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4846 390 : CALL_EXPR_ARG (fn_call, 0));
4847 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4848 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4849 : }
4850 : return fn_call;
4851 : }
4852 :
4853 : static void
4854 132370 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4855 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4856 : {
4857 132370 : tree tmp;
4858 :
4859 132370 : if (gfc_is_proc_ptr_comp (expr))
4860 1920 : tmp = get_proc_ptr_comp (expr);
4861 130450 : else if (sym->attr.dummy)
4862 : {
4863 826 : tmp = gfc_get_symbol_decl (sym);
4864 826 : if (sym->attr.proc_pointer)
4865 89 : tmp = build_fold_indirect_ref_loc (input_location,
4866 : tmp);
4867 826 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4868 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4869 : }
4870 : else
4871 : {
4872 129624 : if (!sym->backend_decl)
4873 32644 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4874 :
4875 129624 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4876 567 : *is_builtin = true;
4877 : else
4878 : {
4879 129057 : TREE_USED (sym->backend_decl) = 1;
4880 129057 : tmp = sym->backend_decl;
4881 : }
4882 :
4883 129624 : if (sym->attr.cray_pointee)
4884 : {
4885 : /* TODO - make the cray pointee a pointer to a procedure,
4886 : assign the pointer to it and use it for the call. This
4887 : will do for now! */
4888 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4889 19 : gfc_get_symbol_decl (sym->cp_pointer));
4890 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4891 : }
4892 :
4893 129624 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4894 : {
4895 128996 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4896 128996 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4897 : }
4898 : }
4899 132370 : se->expr = tmp;
4900 132370 : }
4901 :
4902 :
4903 : /* Initialize MAPPING. */
4904 :
4905 : void
4906 132487 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4907 : {
4908 132487 : mapping->syms = NULL;
4909 132487 : mapping->charlens = NULL;
4910 132487 : }
4911 :
4912 :
4913 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4914 :
4915 : void
4916 132487 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4917 : {
4918 132487 : gfc_interface_sym_mapping *sym;
4919 132487 : gfc_interface_sym_mapping *nextsym;
4920 132487 : gfc_charlen *cl;
4921 132487 : gfc_charlen *nextcl;
4922 :
4923 173233 : for (sym = mapping->syms; sym; sym = nextsym)
4924 : {
4925 40746 : nextsym = sym->next;
4926 40746 : sym->new_sym->n.sym->formal = NULL;
4927 40746 : gfc_free_symbol (sym->new_sym->n.sym);
4928 40746 : gfc_free_expr (sym->expr);
4929 40746 : free (sym->new_sym);
4930 40746 : free (sym);
4931 : }
4932 137175 : for (cl = mapping->charlens; cl; cl = nextcl)
4933 : {
4934 4688 : nextcl = cl->next;
4935 4688 : gfc_free_expr (cl->length);
4936 4688 : free (cl);
4937 : }
4938 132487 : }
4939 :
4940 :
4941 : /* Return a copy of gfc_charlen CL. Add the returned structure to
4942 : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4943 :
4944 : static gfc_charlen *
4945 4688 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4946 : gfc_charlen * cl)
4947 : {
4948 4688 : gfc_charlen *new_charlen;
4949 :
4950 4688 : new_charlen = gfc_get_charlen ();
4951 4688 : new_charlen->next = mapping->charlens;
4952 4688 : new_charlen->length = gfc_copy_expr (cl->length);
4953 :
4954 4688 : mapping->charlens = new_charlen;
4955 4688 : return new_charlen;
4956 : }
4957 :
4958 :
4959 : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4960 : array variable that can be used as the actual argument for dummy
4961 : argument SYM, except in the case of assumed rank dummies of
4962 : non-intrinsic functions where the descriptor must be passed. Add any
4963 : initialization code to BLOCK. PACKED is as for gfc_get_nodesc_array_type
4964 : and DATA points to the first element in the passed array. */
4965 :
4966 : static tree
4967 8454 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4968 : gfc_packed packed, tree data, tree len,
4969 : bool assumed_rank_formal)
4970 : {
4971 8454 : tree type;
4972 8454 : tree var;
4973 :
4974 8454 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4975 70 : type = gfc_get_character_type_len (sym->ts.kind, len);
4976 : else
4977 8384 : type = gfc_typenode_for_spec (&sym->ts);
4978 :
4979 8454 : if (assumed_rank_formal)
4980 13 : type = TREE_TYPE (data);
4981 : else
4982 8441 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4983 8441 : !sym->attr.target && !sym->attr.pointer
4984 8417 : && !sym->attr.proc_pointer);
4985 :
4986 8454 : var = gfc_create_var (type, "ifm");
4987 8454 : gfc_add_modify (block, var, fold_convert (type, data));
4988 :
4989 8454 : return var;
4990 : }
4991 :
4992 :
4993 : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4994 : and offset of descriptorless array type TYPE given that it has the same
4995 : size as DESC. Add any set-up code to BLOCK. */
4996 :
4997 : static void
4998 8124 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4999 : {
5000 8124 : int n;
5001 8124 : tree dim;
5002 8124 : tree offset;
5003 8124 : tree tmp;
5004 :
5005 8124 : offset = gfc_index_zero_node;
5006 9238 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
5007 : {
5008 1114 : dim = gfc_rank_cst[n];
5009 1114 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
5010 1114 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
5011 : {
5012 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
5013 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
5014 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
5015 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
5016 : }
5017 1113 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
5018 : {
5019 1087 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5020 : gfc_array_index_type,
5021 : gfc_conv_descriptor_ubound_get (desc, dim),
5022 : gfc_conv_descriptor_lbound_get (desc, dim));
5023 3261 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5024 : gfc_array_index_type,
5025 1087 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
5026 1087 : tmp = gfc_evaluate_now (tmp, block);
5027 1087 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
5028 : }
5029 4456 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5030 1114 : GFC_TYPE_ARRAY_LBOUND (type, n),
5031 1114 : GFC_TYPE_ARRAY_STRIDE (type, n));
5032 1114 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5033 : gfc_array_index_type, offset, tmp);
5034 : }
5035 8124 : offset = gfc_evaluate_now (offset, block);
5036 8124 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
5037 8124 : }
5038 :
5039 :
5040 : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
5041 : in SE. The caller may still use se->expr and se->string_length after
5042 : calling this function. */
5043 :
5044 : void
5045 40746 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
5046 : gfc_symbol * sym, gfc_se * se,
5047 : gfc_expr *expr)
5048 : {
5049 40746 : gfc_interface_sym_mapping *sm;
5050 40746 : tree desc;
5051 40746 : tree tmp;
5052 40746 : tree value;
5053 40746 : gfc_symbol *new_sym;
5054 40746 : gfc_symtree *root;
5055 40746 : gfc_symtree *new_symtree;
5056 :
5057 : /* Create a new symbol to represent the actual argument. */
5058 40746 : new_sym = gfc_new_symbol (sym->name, NULL);
5059 40746 : new_sym->ts = sym->ts;
5060 40746 : new_sym->as = gfc_copy_array_spec (sym->as);
5061 40746 : new_sym->attr.referenced = 1;
5062 40746 : new_sym->attr.dimension = sym->attr.dimension;
5063 40746 : new_sym->attr.contiguous = sym->attr.contiguous;
5064 40746 : new_sym->attr.codimension = sym->attr.codimension;
5065 40746 : new_sym->attr.pointer = sym->attr.pointer;
5066 40746 : new_sym->attr.allocatable = sym->attr.allocatable;
5067 40746 : new_sym->attr.flavor = sym->attr.flavor;
5068 40746 : new_sym->attr.function = sym->attr.function;
5069 40746 : new_sym->attr.dummy = 0;
5070 :
5071 : /* Ensure that the interface is available and that
5072 : descriptors are passed for array actual arguments. */
5073 40746 : if (sym->attr.flavor == FL_PROCEDURE)
5074 : {
5075 36 : new_sym->formal = expr->symtree->n.sym->formal;
5076 36 : new_sym->attr.always_explicit
5077 36 : = expr->symtree->n.sym->attr.always_explicit;
5078 : }
5079 :
5080 : /* Create a fake symtree for it. */
5081 40746 : root = NULL;
5082 40746 : new_symtree = gfc_new_symtree (&root, sym->name);
5083 40746 : new_symtree->n.sym = new_sym;
5084 40746 : gcc_assert (new_symtree == root);
5085 :
5086 : /* Create a dummy->actual mapping. */
5087 40746 : sm = XCNEW (gfc_interface_sym_mapping);
5088 40746 : sm->next = mapping->syms;
5089 40746 : sm->old = sym;
5090 40746 : sm->new_sym = new_symtree;
5091 40746 : sm->expr = gfc_copy_expr (expr);
5092 40746 : mapping->syms = sm;
5093 :
5094 : /* Stabilize the argument's value. */
5095 40746 : if (!sym->attr.function && se)
5096 40648 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5097 :
5098 40746 : if (sym->ts.type == BT_CHARACTER)
5099 : {
5100 : /* Create a copy of the dummy argument's length. */
5101 2886 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
5102 2886 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
5103 :
5104 : /* If the length is specified as "*", record the length that
5105 : the caller is passing. We should use the callee's length
5106 : in all other cases. */
5107 2886 : if (!new_sym->ts.u.cl->length && se)
5108 : {
5109 2646 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5110 2646 : new_sym->ts.u.cl->backend_decl = se->string_length;
5111 : }
5112 : }
5113 :
5114 40732 : if (!se)
5115 62 : return;
5116 :
5117 : /* Use the passed value as-is if the argument is a function. */
5118 40684 : if (sym->attr.flavor == FL_PROCEDURE)
5119 36 : value = se->expr;
5120 :
5121 : /* If the argument is a pass-by-value scalar, use the value as is. */
5122 40648 : else if (!sym->attr.dimension && sym->attr.value)
5123 78 : value = se->expr;
5124 :
5125 : /* If the argument is either a string or a pointer to a string,
5126 : convert it to a boundless character type. */
5127 40570 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5128 : {
5129 1305 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5130 1305 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5131 1305 : tmp = build_pointer_type (tmp);
5132 1305 : if (sym->attr.pointer)
5133 126 : value = build_fold_indirect_ref_loc (input_location,
5134 : se->expr);
5135 : else
5136 1179 : value = se->expr;
5137 1305 : value = fold_convert (tmp, value);
5138 : }
5139 :
5140 : /* If the argument is a scalar, a pointer to an array or an allocatable,
5141 : dereference it. */
5142 39265 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5143 29314 : value = build_fold_indirect_ref_loc (input_location,
5144 : se->expr);
5145 :
5146 : /* For character(*), use the actual argument's descriptor. */
5147 9951 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5148 1497 : value = build_fold_indirect_ref_loc (input_location,
5149 : se->expr);
5150 :
5151 : /* If the argument is an array descriptor, use it to determine
5152 : information about the actual argument's shape. */
5153 8454 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5154 8454 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5155 : {
5156 8124 : bool assumed_rank_formal = false;
5157 :
5158 : /* Get the actual argument's descriptor. */
5159 8124 : desc = build_fold_indirect_ref_loc (input_location,
5160 : se->expr);
5161 :
5162 : /* Create the replacement variable. */
5163 8124 : if (sym->as && sym->as->type == AS_ASSUMED_RANK
5164 7334 : && !(sym->ns && sym->ns->proc_name
5165 7334 : && sym->ns->proc_name->attr.proc == PROC_INTRINSIC))
5166 : {
5167 : assumed_rank_formal = true;
5168 : tmp = desc;
5169 : }
5170 : else
5171 8111 : tmp = gfc_conv_descriptor_data_get (desc);
5172 :
5173 8124 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5174 : PACKED_NO, tmp,
5175 : se->string_length,
5176 : assumed_rank_formal);
5177 :
5178 : /* Use DESC to work out the upper bounds, strides and offset. */
5179 8124 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5180 : }
5181 : else
5182 : /* Otherwise we have a packed array. */
5183 330 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5184 : PACKED_FULL, se->expr,
5185 : se->string_length,
5186 : false);
5187 :
5188 40684 : new_sym->backend_decl = value;
5189 : }
5190 :
5191 :
5192 : /* Called once all dummy argument mappings have been added to MAPPING,
5193 : but before the mapping is used to evaluate expressions. Pre-evaluate
5194 : the length of each argument, adding any initialization code to PRE and
5195 : any finalization code to POST. */
5196 :
5197 : static void
5198 132450 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5199 : stmtblock_t * pre, stmtblock_t * post)
5200 : {
5201 132450 : gfc_interface_sym_mapping *sym;
5202 132450 : gfc_expr *expr;
5203 132450 : gfc_se se;
5204 :
5205 173134 : for (sym = mapping->syms; sym; sym = sym->next)
5206 40684 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5207 2872 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5208 : {
5209 226 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5210 226 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5211 226 : gfc_init_se (&se, NULL);
5212 226 : gfc_conv_expr (&se, expr);
5213 226 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5214 226 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5215 226 : gfc_add_block_to_block (pre, &se.pre);
5216 226 : gfc_add_block_to_block (post, &se.post);
5217 :
5218 226 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5219 : }
5220 132450 : }
5221 :
5222 :
5223 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5224 : constructor C. */
5225 :
5226 : static void
5227 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5228 : gfc_constructor_base base)
5229 : {
5230 47 : gfc_constructor *c;
5231 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5232 : {
5233 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5234 381 : if (c->iterator)
5235 : {
5236 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5237 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5238 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5239 : }
5240 : }
5241 47 : }
5242 :
5243 :
5244 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5245 : reference REF. */
5246 :
5247 : static void
5248 12729 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5249 : gfc_ref * ref)
5250 : {
5251 12729 : int n;
5252 :
5253 14214 : for (; ref; ref = ref->next)
5254 1485 : switch (ref->type)
5255 : {
5256 : case REF_ARRAY:
5257 2915 : for (n = 0; n < ref->u.ar.dimen; n++)
5258 : {
5259 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5260 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5261 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5262 : }
5263 : break;
5264 :
5265 : case REF_COMPONENT:
5266 : case REF_INQUIRY:
5267 : break;
5268 :
5269 43 : case REF_SUBSTRING:
5270 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5271 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5272 43 : break;
5273 : }
5274 12729 : }
5275 :
5276 :
5277 : /* Convert intrinsic function calls into result expressions. */
5278 :
5279 : static bool
5280 2232 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5281 : {
5282 2232 : gfc_symbol *sym;
5283 2232 : gfc_expr *new_expr;
5284 2232 : gfc_expr *arg1;
5285 2232 : gfc_expr *arg2;
5286 2232 : int d, dup;
5287 :
5288 2232 : arg1 = expr->value.function.actual->expr;
5289 2232 : if (expr->value.function.actual->next)
5290 2111 : arg2 = expr->value.function.actual->next->expr;
5291 : else
5292 : arg2 = NULL;
5293 :
5294 2232 : sym = arg1->symtree->n.sym;
5295 :
5296 2232 : if (sym->attr.dummy)
5297 : return false;
5298 :
5299 2208 : new_expr = NULL;
5300 :
5301 2208 : switch (expr->value.function.isym->id)
5302 : {
5303 947 : case GFC_ISYM_LEN:
5304 : /* TODO figure out why this condition is necessary. */
5305 947 : if (sym->attr.function
5306 43 : && (arg1->ts.u.cl->length == NULL
5307 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5308 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5309 : return false;
5310 :
5311 904 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5312 904 : break;
5313 :
5314 228 : case GFC_ISYM_LEN_TRIM:
5315 228 : new_expr = gfc_copy_expr (arg1);
5316 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5317 :
5318 228 : if (!new_expr)
5319 : return false;
5320 :
5321 228 : gfc_replace_expr (arg1, new_expr);
5322 228 : return true;
5323 :
5324 606 : case GFC_ISYM_SIZE:
5325 606 : if (!sym->as || sym->as->rank == 0)
5326 : return false;
5327 :
5328 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5329 : {
5330 360 : dup = mpz_get_si (arg2->value.integer);
5331 360 : d = dup - 1;
5332 : }
5333 : else
5334 : {
5335 530 : dup = sym->as->rank;
5336 530 : d = 0;
5337 : }
5338 :
5339 542 : for (; d < dup; d++)
5340 : {
5341 530 : gfc_expr *tmp;
5342 :
5343 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5344 : {
5345 518 : gfc_free_expr (new_expr);
5346 518 : return false;
5347 : }
5348 :
5349 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5350 : gfc_get_int_expr (gfc_default_integer_kind,
5351 : NULL, 1));
5352 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5353 12 : if (new_expr)
5354 0 : new_expr = gfc_multiply (new_expr, tmp);
5355 : else
5356 : new_expr = tmp;
5357 : }
5358 : break;
5359 :
5360 44 : case GFC_ISYM_LBOUND:
5361 44 : case GFC_ISYM_UBOUND:
5362 : /* TODO These implementations of lbound and ubound do not limit if
5363 : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5364 :
5365 44 : if (!sym->as || sym->as->rank == 0)
5366 : return false;
5367 :
5368 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5369 38 : d = mpz_get_si (arg2->value.integer) - 1;
5370 : else
5371 : return false;
5372 :
5373 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5374 : {
5375 23 : if (sym->as->lower[d])
5376 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5377 : }
5378 : else
5379 : {
5380 15 : if (sym->as->upper[d])
5381 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5382 : }
5383 : break;
5384 :
5385 : default:
5386 : break;
5387 : }
5388 :
5389 1337 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5390 1337 : if (!new_expr)
5391 : return false;
5392 :
5393 113 : gfc_replace_expr (expr, new_expr);
5394 113 : return true;
5395 : }
5396 :
5397 :
5398 : static void
5399 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5400 : gfc_interface_mapping * mapping)
5401 : {
5402 24 : gfc_formal_arglist *f;
5403 24 : gfc_actual_arglist *actual;
5404 :
5405 24 : actual = expr->value.function.actual;
5406 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5407 :
5408 72 : for (; f && actual; f = f->next, actual = actual->next)
5409 : {
5410 24 : if (!actual->expr)
5411 0 : continue;
5412 :
5413 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5414 : }
5415 :
5416 24 : if (map_expr->symtree->n.sym->attr.dimension)
5417 : {
5418 6 : int d;
5419 6 : gfc_array_spec *as;
5420 :
5421 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5422 :
5423 18 : for (d = 0; d < as->rank; d++)
5424 : {
5425 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5426 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5427 : }
5428 :
5429 6 : expr->value.function.esym->as = as;
5430 : }
5431 :
5432 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5433 : {
5434 0 : expr->value.function.esym->ts.u.cl->length
5435 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5436 :
5437 0 : gfc_apply_interface_mapping_to_expr (mapping,
5438 0 : expr->value.function.esym->ts.u.cl->length);
5439 : }
5440 24 : }
5441 :
5442 :
5443 : /* EXPR is a copy of an expression that appeared in the interface
5444 : associated with MAPPING. Walk it recursively looking for references to
5445 : dummy arguments that MAPPING maps to actual arguments. Replace each such
5446 : reference with a reference to the associated actual argument. */
5447 :
5448 : static void
5449 21316 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5450 : gfc_expr * expr)
5451 : {
5452 22881 : gfc_interface_sym_mapping *sym;
5453 22881 : gfc_actual_arglist *actual;
5454 :
5455 22881 : if (!expr)
5456 : return;
5457 :
5458 : /* Copying an expression does not copy its length, so do that here. */
5459 12729 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5460 : {
5461 1802 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5462 1802 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5463 : }
5464 :
5465 : /* Apply the mapping to any references. */
5466 12729 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5467 :
5468 : /* ...and to the expression's symbol, if it has one. */
5469 : /* TODO Find out why the condition on expr->symtree had to be moved into
5470 : the loop rather than being outside it, as originally. */
5471 30170 : for (sym = mapping->syms; sym; sym = sym->next)
5472 17441 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5473 : {
5474 3406 : if (sym->new_sym->n.sym->backend_decl)
5475 3362 : expr->symtree = sym->new_sym;
5476 44 : else if (sym->expr)
5477 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5478 : }
5479 :
5480 : /* ...and to subexpressions in expr->value. */
5481 12729 : switch (expr->expr_type)
5482 : {
5483 : case EXPR_VARIABLE:
5484 : case EXPR_CONSTANT:
5485 : case EXPR_NULL:
5486 : case EXPR_SUBSTRING:
5487 : break;
5488 :
5489 1565 : case EXPR_OP:
5490 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5491 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5492 1565 : break;
5493 :
5494 0 : case EXPR_CONDITIONAL:
5495 0 : gfc_apply_interface_mapping_to_expr (mapping,
5496 0 : expr->value.conditional.true_expr);
5497 0 : gfc_apply_interface_mapping_to_expr (mapping,
5498 0 : expr->value.conditional.false_expr);
5499 0 : break;
5500 :
5501 2975 : case EXPR_FUNCTION:
5502 9556 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5503 6581 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5504 :
5505 2975 : if (expr->value.function.esym == NULL
5506 2662 : && expr->value.function.isym != NULL
5507 2650 : && expr->value.function.actual
5508 2649 : && expr->value.function.actual->expr
5509 2649 : && expr->value.function.actual->expr->symtree
5510 5207 : && gfc_map_intrinsic_function (expr, mapping))
5511 : break;
5512 :
5513 6190 : for (sym = mapping->syms; sym; sym = sym->next)
5514 3556 : if (sym->old == expr->value.function.esym)
5515 : {
5516 24 : expr->value.function.esym = sym->new_sym->n.sym;
5517 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5518 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5519 : }
5520 : break;
5521 :
5522 47 : case EXPR_ARRAY:
5523 47 : case EXPR_STRUCTURE:
5524 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5525 47 : break;
5526 :
5527 0 : case EXPR_COMPCALL:
5528 0 : case EXPR_PPC:
5529 0 : case EXPR_UNKNOWN:
5530 0 : gcc_unreachable ();
5531 : break;
5532 : }
5533 :
5534 : return;
5535 : }
5536 :
5537 :
5538 : /* Evaluate interface expression EXPR using MAPPING. Store the result
5539 : in SE. */
5540 :
5541 : void
5542 4130 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5543 : gfc_se * se, gfc_expr * expr)
5544 : {
5545 4130 : expr = gfc_copy_expr (expr);
5546 4130 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5547 4130 : gfc_conv_expr (se, expr);
5548 4130 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5549 4130 : gfc_free_expr (expr);
5550 4130 : }
5551 :
5552 :
5553 : /* Returns a reference to a temporary array into which a component of
5554 : an actual argument derived type array is copied and then returned
5555 : after the function call. */
5556 : void
5557 2789 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5558 : sym_intent intent, bool formal_ptr,
5559 : const gfc_symbol *fsym, const char *proc_name,
5560 : gfc_symbol *sym, bool check_contiguous,
5561 : bool deep_copy, bool span_only)
5562 : {
5563 2789 : gfc_se lse;
5564 2789 : gfc_se rse;
5565 2789 : gfc_ss *lss;
5566 2789 : gfc_ss *rss;
5567 2789 : gfc_loopinfo loop;
5568 2789 : gfc_loopinfo loop2;
5569 2789 : gfc_array_info *info;
5570 2789 : tree offset;
5571 2789 : tree tmp_index;
5572 2789 : tree tmp;
5573 2789 : tree base_type;
5574 2789 : tree size;
5575 2789 : stmtblock_t body;
5576 2789 : int n;
5577 2789 : int dimen;
5578 2789 : gfc_se work_se;
5579 2789 : gfc_se *parmse;
5580 2789 : bool pass_optional;
5581 2789 : bool readonly;
5582 :
5583 2789 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5584 :
5585 2748 : if (pass_optional || check_contiguous)
5586 : {
5587 1398 : gfc_init_se (&work_se, NULL);
5588 1398 : parmse = &work_se;
5589 : }
5590 : else
5591 : parmse = se;
5592 :
5593 2789 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5594 : {
5595 : /* We will create a temporary array, so let us warn. */
5596 868 : char * msg;
5597 :
5598 868 : if (fsym && proc_name)
5599 868 : msg = xasprintf ("An array temporary was created for argument "
5600 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5601 : else
5602 0 : msg = xasprintf ("An array temporary was created");
5603 :
5604 868 : tmp = build_int_cst (logical_type_node, 1);
5605 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5606 : &expr->where, msg);
5607 868 : free (msg);
5608 : }
5609 :
5610 2789 : gfc_init_se (&lse, NULL);
5611 2789 : gfc_init_se (&rse, NULL);
5612 :
5613 : /* Walk the argument expression. */
5614 2789 : rss = gfc_walk_expr (expr);
5615 :
5616 2789 : gcc_assert (rss != gfc_ss_terminator);
5617 :
5618 : /* Initialize the scalarizer. */
5619 2789 : gfc_init_loopinfo (&loop);
5620 2789 : gfc_add_ss_to_loop (&loop, rss);
5621 :
5622 : /* Calculate the bounds of the scalarization. */
5623 2789 : gfc_conv_ss_startstride (&loop);
5624 :
5625 : /* Build an ss for the temporary. */
5626 2789 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5627 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5628 :
5629 2789 : base_type = gfc_typenode_for_spec (&expr->ts);
5630 2789 : if (GFC_ARRAY_TYPE_P (base_type)
5631 2789 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5632 0 : base_type = gfc_get_element_type (base_type);
5633 :
5634 2789 : if (expr->ts.type == BT_CLASS)
5635 127 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5636 :
5637 3971 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5638 1182 : ? expr->ts.u.cl->backend_decl
5639 : : NULL),
5640 : loop.dimen);
5641 :
5642 2789 : parmse->string_length = loop.temp_ss->info->string_length;
5643 :
5644 : /* Associate the SS with the loop. */
5645 2789 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5646 :
5647 : /* Setup the scalarizing loops. */
5648 2789 : gfc_conv_loop_setup (&loop, &expr->where);
5649 :
5650 : /* Pass the temporary descriptor back to the caller. */
5651 2789 : info = &loop.temp_ss->info->data.array;
5652 2789 : parmse->expr = info->descriptor;
5653 :
5654 : /* Setup the gfc_se structures. */
5655 2789 : gfc_copy_loopinfo_to_se (&lse, &loop);
5656 2789 : gfc_copy_loopinfo_to_se (&rse, &loop);
5657 :
5658 2789 : rse.ss = rss;
5659 2789 : lse.ss = loop.temp_ss;
5660 2789 : gfc_mark_ss_chain_used (rss, 1);
5661 2789 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5662 :
5663 : /* Start the scalarized loop body. */
5664 2789 : gfc_start_scalarized_body (&loop, &body);
5665 :
5666 : /* Translate the expression. */
5667 2789 : gfc_conv_expr (&rse, expr);
5668 :
5669 2789 : gfc_conv_tmp_array_ref (&lse);
5670 :
5671 2789 : if (intent != INTENT_OUT)
5672 : {
5673 2751 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, deep_copy, false);
5674 2751 : gfc_add_expr_to_block (&body, tmp);
5675 2751 : gcc_assert (rse.ss == gfc_ss_terminator);
5676 2751 : gfc_trans_scalarizing_loops (&loop, &body);
5677 : }
5678 : else
5679 : {
5680 : /* Make sure that the temporary declaration survives by merging
5681 : all the loop declarations into the current context. */
5682 85 : for (n = 0; n < loop.dimen; n++)
5683 : {
5684 47 : gfc_merge_block_scope (&body);
5685 47 : body = loop.code[loop.order[n]];
5686 : }
5687 38 : gfc_merge_block_scope (&body);
5688 : }
5689 :
5690 : /* Add the post block after the second loop, so that any
5691 : freeing of allocated memory is done at the right time. */
5692 2789 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5693 :
5694 : /**********Copy the temporary back again.*********/
5695 :
5696 2789 : gfc_init_se (&lse, NULL);
5697 2789 : gfc_init_se (&rse, NULL);
5698 :
5699 : /* Walk the argument expression. */
5700 2789 : lss = gfc_walk_expr (expr);
5701 2789 : rse.ss = loop.temp_ss;
5702 2789 : lse.ss = lss;
5703 :
5704 : /* Initialize the scalarizer. */
5705 2789 : gfc_init_loopinfo (&loop2);
5706 2789 : gfc_add_ss_to_loop (&loop2, lss);
5707 :
5708 2789 : dimen = rse.ss->dimen;
5709 :
5710 : /* Skip the write-out loop for this case. */
5711 2789 : if (gfc_is_class_array_function (expr))
5712 13 : goto class_array_fcn;
5713 :
5714 : /* Calculate the bounds of the scalarization. */
5715 2776 : gfc_conv_ss_startstride (&loop2);
5716 :
5717 : /* Setup the scalarizing loops. */
5718 2776 : gfc_conv_loop_setup (&loop2, &expr->where);
5719 :
5720 2776 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5721 2776 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5722 :
5723 2776 : gfc_mark_ss_chain_used (lss, 1);
5724 2776 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5725 :
5726 : /* Declare the variable to hold the temporary offset and start the
5727 : scalarized loop body. */
5728 2776 : offset = gfc_create_var (gfc_array_index_type, NULL);
5729 2776 : gfc_start_scalarized_body (&loop2, &body);
5730 :
5731 : /* Build the offsets for the temporary from the loop variables. The
5732 : temporary array has lbounds of zero and strides of one in all
5733 : dimensions, so this is very simple. The offset is only computed
5734 : outside the innermost loop, so the overall transfer could be
5735 : optimized further. */
5736 2776 : info = &rse.ss->info->data.array;
5737 :
5738 2776 : tmp_index = gfc_index_zero_node;
5739 4159 : for (n = dimen - 1; n > 0; n--)
5740 : {
5741 1383 : tree tmp_str;
5742 1383 : tmp = rse.loop->loopvar[n];
5743 1383 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5744 : tmp, rse.loop->from[n]);
5745 1383 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5746 : tmp, tmp_index);
5747 :
5748 2766 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5749 : gfc_array_index_type,
5750 1383 : rse.loop->to[n-1], rse.loop->from[n-1]);
5751 1383 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5752 : gfc_array_index_type,
5753 : tmp_str, gfc_index_one_node);
5754 :
5755 1383 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5756 : gfc_array_index_type, tmp, tmp_str);
5757 : }
5758 :
5759 5552 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5760 : gfc_array_index_type,
5761 2776 : tmp_index, rse.loop->from[0]);
5762 2776 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5763 :
5764 5552 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5765 : gfc_array_index_type,
5766 2776 : rse.loop->loopvar[0], offset);
5767 :
5768 : /* Now use the offset for the reference. */
5769 2776 : tmp = build_fold_indirect_ref_loc (input_location,
5770 : info->data);
5771 2776 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5772 :
5773 2776 : if (expr->ts.type == BT_CHARACTER)
5774 1182 : rse.string_length = expr->ts.u.cl->backend_decl;
5775 :
5776 2776 : gfc_conv_expr (&lse, expr);
5777 :
5778 2776 : gcc_assert (lse.ss == gfc_ss_terminator);
5779 :
5780 : /* Do not do deallocations when we are looking at a g77-style argument. */
5781 :
5782 2776 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, !g77);
5783 2776 : gfc_add_expr_to_block (&body, tmp);
5784 :
5785 : /* Generate the copying loops. */
5786 2776 : gfc_trans_scalarizing_loops (&loop2, &body);
5787 :
5788 : /* Wrap the whole thing up by adding the second loop to the post-block
5789 : and following it by the post-block of the first loop. In this way,
5790 : if the temporary needs freeing, it is done after use!
5791 : If input expr is read-only, e.g. a PARAMETER array, copying back
5792 : modified values is undefined behavior. */
5793 5552 : readonly = (expr->expr_type == EXPR_VARIABLE
5794 2710 : && expr->symtree
5795 5486 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5796 :
5797 2776 : if ((intent != INTENT_IN) && !readonly)
5798 : {
5799 1181 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5800 1181 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5801 : }
5802 :
5803 1595 : class_array_fcn:
5804 :
5805 : /* A deep copy allocated fresh components for the temporary; free them
5806 : again once the call has returned, before the temporary itself goes.
5807 : Only INTENT_IN is supported, as writing the temporary back would leave
5808 : the actual argument holding the freed component pointers. */
5809 2789 : gcc_assert (!deep_copy || intent == INTENT_IN);
5810 2789 : if (deep_copy && expr->ts.type == BT_DERIVED
5811 24 : && expr->ts.u.derived->attr.alloc_comp)
5812 : {
5813 24 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, parmse->expr,
5814 : dimen);
5815 24 : gfc_add_expr_to_block (&parmse->post, tmp);
5816 : }
5817 :
5818 2789 : gfc_add_block_to_block (&parmse->post, &loop.post);
5819 :
5820 2789 : gfc_cleanup_loop (&loop);
5821 2789 : gfc_cleanup_loop (&loop2);
5822 :
5823 : /* Pass the string length to the argument expression. */
5824 2789 : if (expr->ts.type == BT_CHARACTER)
5825 1182 : parmse->string_length = expr->ts.u.cl->backend_decl;
5826 :
5827 : /* Determine the offset for pointer formal arguments and set the
5828 : lbounds to one. */
5829 2789 : if (formal_ptr)
5830 : {
5831 18 : size = gfc_index_one_node;
5832 18 : offset = gfc_index_zero_node;
5833 36 : for (n = 0; n < dimen; n++)
5834 : {
5835 18 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5836 : gfc_rank_cst[n]);
5837 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5838 : gfc_array_index_type, tmp,
5839 : gfc_index_one_node);
5840 18 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5841 : parmse->expr,
5842 : gfc_rank_cst[n],
5843 : tmp);
5844 18 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5845 : parmse->expr,
5846 : gfc_rank_cst[n],
5847 : gfc_index_one_node);
5848 18 : size = gfc_evaluate_now (size, &parmse->pre);
5849 18 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5850 : gfc_array_index_type,
5851 : offset, size);
5852 18 : offset = gfc_evaluate_now (offset, &parmse->pre);
5853 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5854 : gfc_array_index_type,
5855 18 : rse.loop->to[n], rse.loop->from[n]);
5856 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5857 : gfc_array_index_type,
5858 : tmp, gfc_index_one_node);
5859 18 : size = fold_build2_loc (input_location, MULT_EXPR,
5860 : gfc_array_index_type, size, tmp);
5861 : }
5862 :
5863 18 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5864 : offset);
5865 : }
5866 :
5867 : /* We want either the address for the data or the address of the descriptor,
5868 : depending on the mode of passing array arguments. */
5869 2789 : if (g77)
5870 458 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5871 : else
5872 2331 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5873 :
5874 : /* Basically make this into
5875 :
5876 : if (present)
5877 : {
5878 : if (contiguous)
5879 : {
5880 : pointer = a;
5881 : }
5882 : else
5883 : {
5884 : parmse->pre();
5885 : pointer = parmse->expr;
5886 : }
5887 : }
5888 : else
5889 : pointer = NULL;
5890 :
5891 : foo (pointer);
5892 : if (present && !contiguous)
5893 : se->post();
5894 :
5895 : */
5896 :
5897 2789 : if (pass_optional || check_contiguous)
5898 : {
5899 1398 : tree type;
5900 1398 : stmtblock_t else_block;
5901 1398 : tree pre_stmts, post_stmts;
5902 1398 : tree pointer;
5903 1398 : tree else_stmt;
5904 1398 : tree present_var = NULL_TREE;
5905 1398 : tree cont_var = NULL_TREE;
5906 1398 : tree post_cond;
5907 :
5908 1398 : type = TREE_TYPE (parmse->expr);
5909 1398 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5910 1063 : type = TREE_TYPE (type);
5911 1398 : pointer = gfc_create_var (type, "arg_ptr");
5912 :
5913 1398 : if (check_contiguous)
5914 : {
5915 1368 : gfc_se cont_se, array_se;
5916 1368 : stmtblock_t if_block, else_block;
5917 1368 : tree if_stmt, else_stmt;
5918 1368 : mpz_t size;
5919 1368 : bool size_set;
5920 :
5921 1368 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5922 :
5923 : /* If the size is known to be one at compile-time, set
5924 : cont_var to true unconditionally. This may look
5925 : inelegant, but we're only doing this during
5926 : optimization, so the statements will be optimized away,
5927 : and this saves complexity here. */
5928 :
5929 1368 : size_set = gfc_array_size (expr, &size);
5930 1368 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5931 : {
5932 6 : gfc_add_modify (&se->pre, cont_var,
5933 : build_one_cst (boolean_type_node));
5934 : }
5935 : else
5936 : {
5937 : /* cont_var = is_contiguous (expr), or just that the span is the
5938 : element length for a dummy that takes any stride. */
5939 1362 : gfc_init_se (&cont_se, parmse);
5940 1362 : if (span_only)
5941 12 : gfc_conv_span_is_elem_len (&cont_se, expr);
5942 : else
5943 1350 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5944 1362 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5945 1362 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5946 1362 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5947 : }
5948 :
5949 1368 : if (size_set)
5950 1155 : mpz_clear (size);
5951 :
5952 : /* arrayse->expr = descriptor of a. */
5953 1368 : gfc_init_se (&array_se, se);
5954 1368 : gfc_conv_expr_descriptor (&array_se, expr);
5955 1368 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5956 1368 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5957 :
5958 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5959 1368 : gfc_init_block (&if_block);
5960 1368 : if (GFC_DESCRIPTOR_TYPE_P (type))
5961 1039 : gfc_add_modify (&if_block, pointer, array_se.expr);
5962 : else
5963 : {
5964 329 : tmp = gfc_conv_array_data (array_se.expr);
5965 329 : tmp = fold_convert (type, tmp);
5966 329 : gfc_add_modify (&if_block, pointer, tmp);
5967 : }
5968 1368 : if_stmt = gfc_finish_block (&if_block);
5969 :
5970 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5971 1368 : gfc_init_block (&else_block);
5972 1368 : gfc_add_block_to_block (&else_block, &parmse->pre);
5973 1697 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5974 1368 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5975 : : parmse->expr);
5976 1368 : gfc_add_modify (&else_block, pointer, tmp);
5977 1368 : else_stmt = gfc_finish_block (&else_block);
5978 :
5979 : /* And put the above into an if statement. */
5980 1368 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5981 : gfc_likely (cont_var,
5982 : PRED_FORTRAN_CONTIGUOUS),
5983 : if_stmt, else_stmt);
5984 : }
5985 : else
5986 : {
5987 : /* pointer = parmse->expr; . */
5988 36 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5989 30 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5990 : : parmse->expr);
5991 30 : gfc_add_modify (&parmse->pre, pointer, tmp);
5992 30 : pre_stmts = gfc_finish_block (&parmse->pre);
5993 : }
5994 :
5995 1398 : if (pass_optional)
5996 : {
5997 41 : present_var = gfc_create_var (boolean_type_node, "present");
5998 :
5999 : /* present_var = present(sym); . */
6000 41 : tmp = gfc_conv_expr_present (sym);
6001 41 : tmp = fold_convert (boolean_type_node, tmp);
6002 41 : gfc_add_modify (&se->pre, present_var, tmp);
6003 :
6004 : /* else_stmt = { pointer = NULL; } . */
6005 41 : gfc_init_block (&else_block);
6006 41 : if (GFC_DESCRIPTOR_TYPE_P (type))
6007 24 : gfc_conv_descriptor_data_set (&else_block, pointer,
6008 : null_pointer_node);
6009 : else
6010 17 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
6011 41 : else_stmt = gfc_finish_block (&else_block);
6012 :
6013 41 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
6014 : gfc_likely (present_var,
6015 : PRED_FORTRAN_ABSENT_DUMMY),
6016 : pre_stmts, else_stmt);
6017 41 : gfc_add_expr_to_block (&se->pre, tmp);
6018 : }
6019 : else
6020 1357 : gfc_add_expr_to_block (&se->pre, pre_stmts);
6021 :
6022 1398 : post_stmts = gfc_finish_block (&parmse->post);
6023 :
6024 : /* Put together the post stuff, plus the optional
6025 : deallocation. */
6026 1398 : if (check_contiguous)
6027 : {
6028 : /* !cont_var. */
6029 1368 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6030 : cont_var,
6031 : build_zero_cst (boolean_type_node));
6032 1368 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
6033 :
6034 1368 : if (pass_optional)
6035 : {
6036 11 : tree present_likely = gfc_likely (present_var,
6037 : PRED_FORTRAN_ABSENT_DUMMY);
6038 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6039 : boolean_type_node, present_likely,
6040 : tmp);
6041 : }
6042 : else
6043 : post_cond = tmp;
6044 : }
6045 : else
6046 : {
6047 30 : gcc_assert (pass_optional);
6048 : post_cond = present_var;
6049 : }
6050 :
6051 1398 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
6052 : post_stmts, build_empty_stmt (input_location));
6053 1398 : gfc_add_expr_to_block (&se->post, tmp);
6054 1398 : if (GFC_DESCRIPTOR_TYPE_P (type))
6055 : {
6056 1063 : type = TREE_TYPE (parmse->expr);
6057 1063 : if (POINTER_TYPE_P (type))
6058 : {
6059 1063 : pointer = gfc_build_addr_expr (type, pointer);
6060 1063 : if (pass_optional)
6061 : {
6062 24 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
6063 24 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
6064 : tmp, pointer,
6065 : fold_convert (type,
6066 : null_pointer_node));
6067 : }
6068 : }
6069 : else
6070 0 : gcc_assert (!pass_optional);
6071 : }
6072 1398 : se->expr = pointer;
6073 1398 : se->string_length = parmse->string_length;
6074 : }
6075 :
6076 2789 : return;
6077 : }
6078 :
6079 :
6080 : /* Generate the code for argument list functions. */
6081 :
6082 : static void
6083 5826 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
6084 : {
6085 : /* Pass by value for g77 %VAL(arg), pass the address
6086 : indirectly for %LOC, else by reference. Thus %REF
6087 : is a "do-nothing" and %LOC is the same as an F95
6088 : pointer. */
6089 5826 : if (strcmp (name, "%VAL") == 0)
6090 5814 : gfc_conv_expr (se, expr);
6091 12 : else if (strcmp (name, "%LOC") == 0)
6092 : {
6093 6 : gfc_conv_expr_reference (se, expr);
6094 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
6095 : }
6096 6 : else if (strcmp (name, "%REF") == 0)
6097 6 : gfc_conv_expr_reference (se, expr);
6098 : else
6099 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
6100 5826 : }
6101 :
6102 :
6103 : /* This function tells whether the middle-end representation of the expression
6104 : E given as input may point to data otherwise accessible through a variable
6105 : (sub-)reference.
6106 : It is assumed that the only expressions that may alias are variables,
6107 : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
6108 : may alias.
6109 : This function is used to decide whether freeing an expression's allocatable
6110 : components is safe or should be avoided.
6111 :
6112 : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
6113 : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
6114 : is necessary because for array constructors, aliasing depends on how
6115 : the array is used:
6116 : - If E is an array constructor used as argument to an elemental procedure,
6117 : the array, which is generated through shallow copy by the scalarizer,
6118 : is used directly and can alias the expressions it was copied from.
6119 : - If E is an array constructor used as argument to a non-elemental
6120 : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
6121 : the array as in the previous case, but then that array is used
6122 : to initialize a new descriptor through deep copy. There is no alias
6123 : possible in that case.
6124 : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
6125 : above. */
6126 :
6127 : static bool
6128 7746 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6129 : {
6130 7746 : gfc_constructor *c;
6131 :
6132 7746 : if (e->expr_type == EXPR_VARIABLE)
6133 : return true;
6134 562 : else if (e->expr_type == EXPR_FUNCTION)
6135 : {
6136 161 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
6137 :
6138 161 : if (proc_ifc->result != NULL
6139 161 : && ((proc_ifc->result->ts.type == BT_CLASS
6140 25 : && proc_ifc->result->ts.u.derived->attr.is_class
6141 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
6142 161 : || proc_ifc->result->attr.pointer))
6143 : return true;
6144 : else
6145 160 : return false;
6146 : }
6147 401 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6148 : return false;
6149 :
6150 79 : for (c = gfc_constructor_first (e->value.constructor);
6151 233 : c; c = gfc_constructor_next (c))
6152 189 : if (c->expr
6153 189 : && expr_may_alias_variables (c->expr, array_may_alias))
6154 : return true;
6155 :
6156 : return false;
6157 : }
6158 :
6159 :
6160 : /* A helper function to set the dtype for unallocated or unassociated
6161 : entities. */
6162 :
6163 : static void
6164 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6165 : {
6166 891 : tree tmp;
6167 891 : tree desc;
6168 891 : tree cond;
6169 891 : tree type;
6170 891 : stmtblock_t block;
6171 :
6172 : /* TODO Figure out how to handle optional dummies. */
6173 891 : if (e && e->expr_type == EXPR_VARIABLE
6174 807 : && e->symtree->n.sym->attr.optional)
6175 108 : return;
6176 :
6177 819 : desc = parmse->expr;
6178 819 : if (desc == NULL_TREE)
6179 : return;
6180 :
6181 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6182 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6183 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6184 192 : desc = gfc_class_data_get (desc);
6185 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6186 : return;
6187 :
6188 783 : gfc_init_block (&block);
6189 783 : tmp = gfc_conv_descriptor_data_get (desc);
6190 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6191 : logical_type_node, tmp,
6192 783 : build_int_cst (TREE_TYPE (tmp), 0));
6193 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6194 783 : gfc_conv_descriptor_dtype_set (&block, desc,
6195 : gfc_get_dtype_rank_type (e->rank, type));
6196 783 : cond = build3_v (COND_EXPR, cond,
6197 : gfc_finish_block (&block),
6198 : build_empty_stmt (input_location));
6199 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6200 : }
6201 :
6202 :
6203 :
6204 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6205 : ISO_Fortran_binding array descriptors. */
6206 :
6207 : static void
6208 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6209 : {
6210 6537 : stmtblock_t block, block2;
6211 6537 : tree cfi, gfc, tmp, tmp2;
6212 6537 : tree present = NULL;
6213 6537 : tree gfc_strlen = NULL;
6214 6537 : tree rank;
6215 6537 : gfc_se se;
6216 :
6217 6537 : if (fsym->attr.optional
6218 1094 : && e->expr_type == EXPR_VARIABLE
6219 1094 : && e->symtree->n.sym->attr.optional)
6220 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6221 :
6222 6537 : gfc_init_block (&block);
6223 :
6224 : /* Convert original argument to a tree. */
6225 6537 : gfc_init_se (&se, NULL);
6226 6537 : if (e->rank == 0)
6227 : {
6228 687 : se.want_pointer = 1;
6229 687 : gfc_conv_expr (&se, e);
6230 687 : gfc = se.expr;
6231 : }
6232 : else
6233 : {
6234 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6235 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6236 : length assumed-length/assumed-size CHARACTER array. This only
6237 : applies if the actual argument is a "variable"; if it's some
6238 : non-lvalue expression, we are going to evaluate it to a
6239 : temporary below anyway. */
6240 5850 : se.force_no_tmp = 1;
6241 5850 : if ((fsym->attr.contiguous
6242 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6243 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6244 937 : || fsym->as->type == AS_EXPLICIT)))
6245 2023 : && !gfc_is_simply_contiguous (e, false, true)
6246 6883 : && gfc_expr_is_variable (e))
6247 : {
6248 1027 : bool optional = fsym->attr.optional;
6249 1027 : fsym->attr.optional = 0;
6250 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6251 1027 : fsym->attr.pointer, fsym,
6252 1027 : fsym->ns->proc_name->name, NULL,
6253 : /* check_contiguous= */ true);
6254 1027 : fsym->attr.optional = optional;
6255 : }
6256 : else
6257 4823 : gfc_conv_expr_descriptor (&se, e);
6258 5850 : gfc = se.expr;
6259 : /* For dt(:)%var, the base_addr is that of the subobject and elem_len is
6260 : its size, see below. The descriptor built for a subreference of the
6261 : array provides both. While sm is fine as it uses span*stride and not
6262 : elem_len. */
6263 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6264 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6265 : }
6266 6537 : if (e->ts.type == BT_CHARACTER)
6267 : {
6268 3409 : if (se.string_length)
6269 : gfc_strlen = se.string_length;
6270 1 : else if (e->ts.u.cl->backend_decl)
6271 : gfc_strlen = e->ts.u.cl->backend_decl;
6272 : else
6273 0 : gcc_unreachable ();
6274 : }
6275 6537 : gfc_add_block_to_block (&block, &se.pre);
6276 :
6277 : /* Create array descriptor and set version, rank, attribute, type. */
6278 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6279 : ? GFC_MAX_DIMENSIONS : e->rank,
6280 : false), "cfi");
6281 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6282 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6283 : {
6284 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6285 2338 : tmp = build_pointer_type (tmp);
6286 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6287 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6288 : }
6289 : else
6290 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6291 :
6292 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6293 6537 : gfc_add_modify (&block, tmp,
6294 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6295 6537 : if (e->rank < 0)
6296 305 : rank = gfc_conv_descriptor_rank_get (gfc);
6297 : else
6298 6232 : rank = gfc_rank_cst[e->rank];
6299 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6300 6537 : gfc_add_modify (&block, tmp,
6301 6537 : fold_convert (TREE_TYPE (tmp), rank));
6302 6537 : int itype = CFI_type_other;
6303 6537 : if (e->ts.f90_type == BT_VOID)
6304 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6305 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6306 : else
6307 : {
6308 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6309 1 : e->ts = fsym->ts;
6310 6441 : switch (e->ts.type)
6311 : {
6312 2296 : case BT_INTEGER:
6313 2296 : case BT_LOGICAL:
6314 2296 : case BT_REAL:
6315 2296 : case BT_COMPLEX:
6316 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6317 2296 : break;
6318 3410 : case BT_CHARACTER:
6319 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6320 3410 : break;
6321 : case BT_DERIVED:
6322 6537 : itype = CFI_type_struct;
6323 : break;
6324 0 : case BT_VOID:
6325 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6326 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6327 : break;
6328 : case BT_ASSUMED:
6329 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6330 : break;
6331 1 : case BT_CLASS:
6332 1 : if (fsym->ts.type == BT_ASSUMED)
6333 : {
6334 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6335 : // type specifier is assumed-type and is an unlimited polymorphic
6336 : // entity." The actual argument _data component is passed.
6337 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6338 : break;
6339 : }
6340 : else
6341 0 : gcc_unreachable ();
6342 :
6343 0 : case BT_UNSIGNED:
6344 0 : gfc_internal_error ("Unsigned not yet implemented");
6345 :
6346 0 : case BT_PROCEDURE:
6347 0 : case BT_HOLLERITH:
6348 0 : case BT_UNION:
6349 0 : case BT_BOZ:
6350 0 : case BT_UNKNOWN:
6351 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6352 0 : gcc_unreachable ();
6353 : }
6354 : }
6355 :
6356 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6357 6537 : gfc_add_modify (&block, tmp,
6358 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6359 :
6360 6537 : int attr = CFI_attribute_other;
6361 6537 : if (fsym->attr.pointer)
6362 : attr = CFI_attribute_pointer;
6363 5774 : else if (fsym->attr.allocatable)
6364 433 : attr = CFI_attribute_allocatable;
6365 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6366 6537 : gfc_add_modify (&block, tmp,
6367 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6368 :
6369 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6370 : That is very sensible for undefined pointers, but the C code might assume
6371 : that the pointer retains the value, in particular, if it was NULL. */
6372 6537 : if (e->rank == 0)
6373 : {
6374 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6375 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6376 : }
6377 : else
6378 : {
6379 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6380 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6381 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6382 : }
6383 :
6384 : /* Set elem_len if known - must be before the next if block.
6385 : Note that allocatable implies 'len=:'. */
6386 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6387 : {
6388 : /* Length is known at compile time; use 'block' for it. */
6389 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6390 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6391 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6392 : }
6393 :
6394 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6395 91 : goto done;
6396 :
6397 : /* When allocatable + intent out, free the cfi descriptor. */
6398 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6399 : {
6400 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6401 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6402 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6403 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6404 90 : gfc_add_modify (&block, tmp,
6405 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6406 90 : goto done;
6407 : }
6408 :
6409 : /* If not unallocated/unassociated. */
6410 6356 : gfc_init_block (&block2);
6411 :
6412 : /* Set elem_len, which may be only known at run time. */
6413 6356 : if (e->ts.type == BT_CHARACTER
6414 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6415 : {
6416 3408 : gcc_assert (gfc_strlen);
6417 3409 : tmp = gfc_strlen;
6418 3409 : if (e->ts.kind != 1)
6419 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6420 : gfc_charlen_type_node, tmp,
6421 : build_int_cst (gfc_charlen_type_node,
6422 1117 : e->ts.kind));
6423 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6424 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6425 : }
6426 2947 : else if (e->ts.type == BT_ASSUMED)
6427 : {
6428 54 : tmp = gfc_conv_descriptor_elem_len_get (gfc);
6429 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6430 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6431 : }
6432 :
6433 6356 : if (e->ts.type == BT_ASSUMED)
6434 : {
6435 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6436 : an CFI descriptor. Use the type in the descriptor as it provide
6437 : mode information. (Quality of implementation feature.) */
6438 54 : tree cond;
6439 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6440 54 : tree type = fold_convert (TREE_TYPE (ctype),
6441 : gfc_conv_descriptor_type_get (gfc));
6442 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6443 : gfc_conv_descriptor_elem_len_get (gfc));
6444 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6445 54 : kind, build_int_cst (TREE_TYPE (type),
6446 : CFI_type_kind_shift));
6447 :
6448 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6449 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6450 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6451 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6452 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6453 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6454 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6455 : ctype,
6456 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6457 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6458 : tmp, tmp2);
6459 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6460 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6461 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6462 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6463 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6464 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6465 : tmp, tmp2);
6466 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6467 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6468 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6469 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6470 54 : tmp = build_int_cst (TREE_TYPE (type),
6471 : CFI_type_from_type_kind (CFI_type_Character, 1));
6472 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6473 : ctype, tmp);
6474 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6475 : tmp, tmp2);
6476 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6477 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6478 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6479 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6480 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6481 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6482 54 : build_int_cst (TREE_TYPE (type),
6483 : CFI_type_Complex));
6484 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6485 : ctype, tmp);
6486 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6487 : tmp, tmp2);
6488 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6489 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6490 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6491 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6492 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6493 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6494 : cond, tmp);
6495 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6496 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6497 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6498 : cond, tmp);
6499 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6500 : type, kind);
6501 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6502 : ctype, tmp);
6503 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6504 : tmp, tmp2);
6505 54 : gfc_add_expr_to_block (&block2, tmp2);
6506 : }
6507 :
6508 6356 : if (e->rank != 0)
6509 : {
6510 : /* Loop: for (i = 0; i < rank; ++i). */
6511 5735 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6512 : /* Loop body. */
6513 5735 : stmtblock_t loop_body;
6514 5735 : gfc_init_block (&loop_body);
6515 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6516 : ? gfc->dim[i].lbound : 0 */
6517 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6518 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6519 : else
6520 5087 : tmp = gfc_index_zero_node;
6521 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6522 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6523 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6524 : gfc_conv_descriptor_ubound_get (gfc, idx),
6525 : gfc_conv_descriptor_lbound_get (gfc, idx));
6526 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6527 : tmp, gfc_index_one_node);
6528 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6529 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6530 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6531 : gfc_conv_descriptor_stride_get (gfc, idx),
6532 : gfc_conv_descriptor_span_get (gfc));
6533 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6534 :
6535 : /* Generate loop. */
6536 5735 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6537 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6538 :
6539 5735 : if (e->expr_type == EXPR_VARIABLE
6540 5573 : && e->ref
6541 5573 : && e->ref->u.ar.type == AR_FULL
6542 2732 : && e->symtree->n.sym->attr.dummy
6543 988 : && e->symtree->n.sym->as
6544 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6545 : {
6546 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6547 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6548 : }
6549 : }
6550 :
6551 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6552 : {
6553 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6554 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6555 : tmp, null_pointer_node);
6556 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6557 : build_empty_stmt (input_location));
6558 1015 : gfc_add_expr_to_block (&block, tmp);
6559 : }
6560 : else
6561 5341 : gfc_add_block_to_block (&block, &block2);
6562 :
6563 :
6564 6537 : done:
6565 6537 : if (present)
6566 : {
6567 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6568 103 : TREE_TYPE (parmse->expr),
6569 : present, parmse->expr, null_pointer_node);
6570 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6571 : build_empty_stmt (input_location));
6572 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6573 : }
6574 : else
6575 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6576 :
6577 6537 : gfc_init_block (&block);
6578 :
6579 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6580 1196 : || fsym->attr.intent == INTENT_IN)
6581 5550 : goto post_call;
6582 :
6583 987 : gfc_init_block (&block2);
6584 987 : if (e->rank == 0)
6585 : {
6586 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6587 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6588 : }
6589 : else
6590 : {
6591 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6592 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6593 :
6594 559 : if (fsym->attr.allocatable)
6595 : {
6596 : /* gfc->span = cfi->elem_len. */
6597 252 : tmp = fold_convert (gfc_array_index_type,
6598 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6599 : }
6600 : else
6601 : {
6602 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6603 : ? cfi->dim[0].sm : cfi->elem_len). */
6604 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6605 307 : tmp2 = fold_convert (gfc_array_index_type,
6606 : gfc_get_cfi_desc_elem_len (cfi));
6607 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6608 : gfc_array_index_type, tmp, tmp2);
6609 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6610 : tmp, gfc_index_zero_node);
6611 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6612 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6613 : }
6614 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6615 :
6616 : /* Calculate offset + set lbound, ubound and stride. */
6617 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6618 : /* Loop: for (i = 0; i < rank; ++i). */
6619 559 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6620 : /* Loop body. */
6621 559 : stmtblock_t loop_body;
6622 559 : gfc_init_block (&loop_body);
6623 : /* gfc->dim[i].lbound = ... */
6624 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6625 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6626 :
6627 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6628 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6629 : gfc_conv_descriptor_lbound_get (gfc, idx),
6630 : gfc_index_one_node);
6631 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6632 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6633 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6634 :
6635 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6636 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6637 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6638 : gfc_array_index_type, tmp,
6639 : fold_convert (gfc_array_index_type,
6640 : gfc_get_cfi_desc_elem_len (cfi)));
6641 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6642 :
6643 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6644 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6645 : gfc_conv_descriptor_stride_get (gfc, idx),
6646 : gfc_conv_descriptor_lbound_get (gfc, idx));
6647 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6648 : gfc_conv_descriptor_offset_get (gfc), tmp);
6649 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6650 : /* Generate loop. */
6651 559 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6652 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6653 : }
6654 :
6655 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6656 : {
6657 60 : tmp = fold_convert (gfc_charlen_type_node,
6658 : gfc_get_cfi_desc_elem_len (cfi));
6659 60 : if (e->ts.kind != 1)
6660 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6661 : gfc_charlen_type_node, tmp,
6662 : build_int_cst (gfc_charlen_type_node,
6663 24 : e->ts.kind));
6664 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6665 : }
6666 :
6667 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6668 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6669 : tmp, null_pointer_node);
6670 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6671 : build_empty_stmt (input_location));
6672 987 : gfc_add_expr_to_block (&block, tmp);
6673 :
6674 6537 : post_call:
6675 6537 : gfc_add_block_to_block (&block, &se.post);
6676 6537 : if (present && block.head)
6677 : {
6678 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6679 : build_empty_stmt (input_location));
6680 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6681 : }
6682 6531 : else if (block.head)
6683 1564 : gfc_add_block_to_block (&parmse->post, &block);
6684 6537 : }
6685 :
6686 :
6687 : /* Create "conditional temporary" to handle scalar dummy variables with the
6688 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6689 : as fallback. Does not handle CLASS. */
6690 :
6691 : static void
6692 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6693 : {
6694 234 : tree temp;
6695 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6696 234 : gcc_assert (e->rank == 0);
6697 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6698 234 : TREE_STATIC (temp) = 1;
6699 234 : TREE_CONSTANT (temp) = 1;
6700 234 : TREE_READONLY (temp) = 1;
6701 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6702 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6703 234 : TREE_TYPE (parmse->expr),
6704 : cond, parmse->expr, temp);
6705 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6706 234 : }
6707 :
6708 :
6709 : /* Returns true if the type specified in TS is a character type whose length
6710 : is constant. Otherwise returns false. */
6711 :
6712 : static bool
6713 22204 : gfc_const_length_character_type_p (gfc_typespec *ts)
6714 : {
6715 22204 : return (ts->type == BT_CHARACTER
6716 515 : && ts->u.cl
6717 515 : && ts->u.cl->length
6718 479 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6719 22671 : && ts->u.cl->length->ts.type == BT_INTEGER);
6720 : }
6721 :
6722 :
6723 : /* Returns true if FORMAL contains an explicit-shape array dummy with the
6724 : VALUE attribute. The bounds of such a dummy may have to be evaluated
6725 : on the caller side, which needs an interface mapping. */
6726 :
6727 : static bool
6728 115283 : has_value_array_dummy (gfc_formal_arglist *formal)
6729 : {
6730 308742 : for (; formal; formal = formal->next)
6731 193525 : if (formal->sym && formal->sym->attr.value && formal->sym->attr.dimension
6732 174 : && formal->sym->as && formal->sym->as->type == AS_EXPLICIT)
6733 : return true;
6734 :
6735 : return false;
6736 : }
6737 :
6738 :
6739 : /* Sequence association (F2023, 15.5.2.12) of a scalar actual argument E with
6740 : an explicit-shape array dummy FSYM that has the VALUE attribute. Copy as
6741 : many elements as the dummy declares into a temporary and pass that.
6742 : MAPPING supplies the caller-side values of any dummy arguments appearing
6743 : in the bounds or the character length of FSYM. */
6744 :
6745 : static void
6746 36 : conv_seq_assoc_value_arg (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
6747 : gfc_interface_mapping *mapping)
6748 : {
6749 36 : tree nelems, elem_type, elem_size, tmpvar, src, tmp;
6750 36 : gfc_se se;
6751 36 : int n;
6752 :
6753 36 : gcc_assert (fsym->as && fsym->as->type == AS_EXPLICIT);
6754 :
6755 : /* Address of the first element of the actual argument's sequence. */
6756 36 : gfc_init_se (&se, NULL);
6757 36 : if (e->ts.type == BT_CHARACTER)
6758 : {
6759 12 : gfc_conv_expr (&se, e);
6760 12 : gfc_conv_string_parameter (&se);
6761 : /* The hidden length argument is that of the actual argument, as it
6762 : is for a dummy that does not have the VALUE attribute. */
6763 12 : parmse->string_length = se.string_length;
6764 : }
6765 : else
6766 24 : gfc_conv_expr_reference (&se, e);
6767 36 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6768 36 : gfc_add_block_to_block (&parmse->post, &se.post);
6769 36 : src = se.expr;
6770 :
6771 : /* Number of elements of the dummy. */
6772 36 : nelems = gfc_index_one_node;
6773 78 : for (n = 0; n < fsym->as->rank; n++)
6774 : {
6775 42 : tree lbound, ubound, extent;
6776 :
6777 42 : gfc_init_se (&se, NULL);
6778 42 : gfc_apply_interface_mapping (mapping, &se, fsym->as->upper[n]);
6779 42 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6780 42 : gfc_add_block_to_block (&parmse->post, &se.post);
6781 42 : ubound = fold_convert (gfc_array_index_type, se.expr);
6782 :
6783 42 : if (fsym->as->lower[n])
6784 : {
6785 42 : gfc_init_se (&se, NULL);
6786 42 : gfc_apply_interface_mapping (mapping, &se, fsym->as->lower[n]);
6787 42 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6788 42 : gfc_add_block_to_block (&parmse->post, &se.post);
6789 42 : lbound = fold_convert (gfc_array_index_type, se.expr);
6790 : }
6791 : else
6792 0 : lbound = gfc_index_one_node;
6793 :
6794 42 : extent = fold_build2_loc (input_location, MINUS_EXPR,
6795 : gfc_array_index_type, ubound, lbound);
6796 42 : extent = fold_build2_loc (input_location, PLUS_EXPR,
6797 : gfc_array_index_type, extent,
6798 : gfc_index_one_node);
6799 42 : extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6800 : extent, gfc_index_zero_node);
6801 42 : nelems = fold_build2_loc (input_location, MULT_EXPR,
6802 : gfc_array_index_type, nelems, extent);
6803 : }
6804 36 : nelems = gfc_evaluate_now (nelems, &parmse->pre);
6805 :
6806 : /* Element type and size of the dummy. For characters the element
6807 : sequence is grouped by the character length of the dummy. */
6808 36 : if (fsym->ts.type == BT_CHARACTER)
6809 : {
6810 12 : tree len;
6811 :
6812 12 : if (fsym->ts.u.cl->length)
6813 : {
6814 12 : gfc_init_se (&se, NULL);
6815 12 : gfc_apply_interface_mapping (mapping, &se, fsym->ts.u.cl->length);
6816 12 : gfc_add_block_to_block (&parmse->pre, &se.pre);
6817 12 : gfc_add_block_to_block (&parmse->post, &se.post);
6818 12 : len = fold_convert (gfc_charlen_type_node, se.expr);
6819 : }
6820 : else
6821 0 : len = fold_convert (gfc_charlen_type_node, parmse->string_length);
6822 :
6823 12 : tree char_size = TYPE_SIZE_UNIT (gfc_get_char_type (fsym->ts.kind));
6824 :
6825 12 : elem_type = gfc_get_character_type_len (fsym->ts.kind, len);
6826 12 : elem_size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6827 : fold_convert (size_type_node, len),
6828 : fold_convert (size_type_node, char_size));
6829 : }
6830 : else
6831 : {
6832 24 : elem_type = gfc_typenode_for_spec (&fsym->ts);
6833 24 : elem_size = fold_convert (size_type_node, TYPE_SIZE_UNIT (elem_type));
6834 : }
6835 :
6836 : /* The temporary holding the copy. Allocate at least one element so that
6837 : a zero-sized dummy does not produce a degenerate array type. */
6838 36 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
6839 : nelems, gfc_index_one_node);
6840 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6841 : tmp, gfc_index_one_node);
6842 36 : tmp = build_array_type (elem_type,
6843 : build_range_type (gfc_array_index_type,
6844 : gfc_index_zero_node, tmp));
6845 36 : tmpvar = gfc_create_var (tmp, "seq_copy");
6846 36 : gfc_add_expr_to_block (&parmse->pre,
6847 : fold_build1_loc (input_location, DECL_EXPR, tmp,
6848 : tmpvar));
6849 :
6850 36 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6851 : fold_convert (size_type_node, nelems), elem_size);
6852 36 : tmp = gfc_build_memcpy_call (fold_convert (pvoid_type_node,
6853 : gfc_build_addr_expr (NULL_TREE,
6854 : tmpvar)),
6855 : fold_convert (pvoid_type_node, src), tmp);
6856 36 : gfc_add_expr_to_block (&parmse->pre, tmp);
6857 :
6858 : /* The memcpy also copied the component pointers of a derived type, which
6859 : would leave the temporary sharing the actual argument's allocatable
6860 : components. Give the copy components of its own and free them again
6861 : once the call has returned. */
6862 36 : if (fsym->ts.type == BT_DERIVED && fsym->ts.u.derived->attr.alloc_comp)
6863 : {
6864 6 : tree src_ptr = fold_convert (build_pointer_type (elem_type), src);
6865 6 : tree elem_idx = gfc_create_var (gfc_array_index_type, "elem");
6866 6 : tree dest_elem = gfc_build_array_ref (tmpvar, elem_idx, NULL_TREE);
6867 6 : tree src_offset = fold_build2_loc (input_location, MULT_EXPR, sizetype,
6868 : fold_convert (sizetype, elem_idx),
6869 : elem_size);
6870 6 : tree src_elem
6871 6 : = build_fold_indirect_ref_loc (input_location,
6872 : fold_build_pointer_plus_loc
6873 : (input_location, src_ptr, src_offset));
6874 :
6875 6 : tmp = gfc_copy_alloc_comp (fsym->ts.u.derived, src_elem, dest_elem, 0, 0);
6876 6 : gfc_simple_for_loop (&parmse->pre, elem_idx, gfc_index_zero_node, nelems,
6877 : LT_EXPR, gfc_index_one_node, tmp);
6878 :
6879 6 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived, dest_elem, 0);
6880 6 : gfc_simple_for_loop (&parmse->post, elem_idx, gfc_index_zero_node, nelems,
6881 : LT_EXPR, gfc_index_one_node, tmp);
6882 : }
6883 :
6884 36 : if (fsym->ts.type == BT_CHARACTER)
6885 12 : parmse->expr
6886 12 : = gfc_build_addr_expr (build_pointer_type (gfc_get_char_type
6887 : (fsym->ts.kind)), tmpvar);
6888 : else
6889 24 : parmse->expr = gfc_build_addr_expr (build_pointer_type (elem_type), tmpvar);
6890 36 : }
6891 :
6892 :
6893 : /* Helper function for the handling of (currently) scalar dummy variables
6894 : with the VALUE attribute. Argument parmse should already be set up. */
6895 : static void
6896 22649 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6897 : vec<tree, va_gc> *& optionalargs)
6898 : {
6899 22649 : tree tmp;
6900 :
6901 22649 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6902 :
6903 22649 : if (IS_PDT (e))
6904 : {
6905 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6906 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6907 6 : gfc_add_expr_to_block (&parmse->pre,
6908 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6909 : parmse->expr, tmp,
6910 : e->rank, 0));
6911 6 : parmse->expr = tmp;
6912 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6913 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6914 6 : return;
6915 : }
6916 :
6917 : /* Absent actual argument for optional scalar dummy. */
6918 22643 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6919 : {
6920 : /* For scalar arguments with VALUE attribute which are passed by
6921 : value, pass "0" and a hidden argument for the optional status. */
6922 439 : if (fsym->ts.type == BT_CHARACTER)
6923 : {
6924 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6925 : zero. */
6926 102 : parmse->expr = null_pointer_node;
6927 102 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6928 : }
6929 337 : else if (gfc_bt_struct (fsym->ts.type)
6930 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6931 : {
6932 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6933 : are pointers and passed as such below. */
6934 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6935 24 : TREE_CONSTANT (temp) = 1;
6936 24 : TREE_READONLY (temp) = 1;
6937 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6938 24 : parmse->expr = temp;
6939 24 : }
6940 : else
6941 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6942 : integer_zero_node);
6943 439 : vec_safe_push (optionalargs, boolean_false_node);
6944 :
6945 439 : return;
6946 : }
6947 :
6948 : /* Assumed-length or non-constant-length CHARACTER VALUE dummy: copy
6949 : the actual argument and pass the copy. */
6950 22204 : if (fsym->ts.type == BT_CHARACTER
6951 515 : && (!fsym->ts.u.cl || !fsym->ts.u.cl->length
6952 479 : || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT))
6953 : {
6954 : /* An optional actual argument that is absent has nothing to copy
6955 : from; pass a null pointer and a length of zero instead. */
6956 48 : tree present = NULL_TREE;
6957 48 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
6958 24 : && e->symtree->n.sym->attr.optional)
6959 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
6960 :
6961 48 : gfc_conv_string_parameter (parmse);
6962 48 : tree len = fold_convert (gfc_charlen_type_node, parmse->string_length);
6963 48 : if (present)
6964 : {
6965 12 : len = fold_build3_loc (input_location, COND_EXPR,
6966 : gfc_charlen_type_node, present, len,
6967 : build_zero_cst (gfc_charlen_type_node));
6968 12 : len = gfc_evaluate_now (len, &parmse->pre);
6969 12 : parmse->string_length = len;
6970 : }
6971 48 : tree chartype = gfc_get_character_type_len (fsym->ts.kind, len);
6972 48 : tree val_copy = gfc_create_var (chartype, "val_copy");
6973 48 : tmp = fold_build1_loc (input_location, DECL_EXPR, chartype, val_copy);
6974 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
6975 : /* The copy size is in bytes, not in characters. */
6976 48 : tree bytes
6977 48 : = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
6978 : fold_convert (size_type_node, len),
6979 48 : fold_convert (size_type_node,
6980 : TYPE_SIZE_UNIT (gfc_get_char_type
6981 : (fsym->ts.kind))));
6982 48 : tmp = gfc_build_memcpy_call (
6983 : fold_convert (pvoid_type_node,
6984 : gfc_build_addr_expr (NULL_TREE, val_copy)),
6985 : fold_convert (pvoid_type_node, parmse->expr), bytes);
6986 48 : if (present)
6987 12 : tmp = build3_v (COND_EXPR, present, tmp,
6988 : build_empty_stmt (input_location));
6989 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
6990 48 : parmse->expr = fold_convert (
6991 : build_pointer_type (gfc_get_char_type (fsym->ts.kind)),
6992 : gfc_build_addr_expr (NULL_TREE, val_copy));
6993 48 : if (present)
6994 24 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6995 12 : TREE_TYPE (parmse->expr), present,
6996 : parmse->expr,
6997 12 : fold_convert (TREE_TYPE (parmse->expr),
6998 : null_pointer_node));
6999 : }
7000 :
7001 : /* Truncate a too long constant character actual argument. */
7002 22204 : if (gfc_const_length_character_type_p (&fsym->ts)
7003 467 : && e->expr_type == EXPR_CONSTANT
7004 22287 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
7005 : e->value.character.length) < 0)
7006 : {
7007 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
7008 :
7009 : /* Truncate actual string argument. */
7010 17 : gfc_conv_expr (parmse, e);
7011 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
7012 17 : e->value.character.string);
7013 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
7014 :
7015 17 : if (flen == 1)
7016 : {
7017 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
7018 14 : gfc_conv_string_parameter (parmse);
7019 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
7020 : e->ts.kind);
7021 : }
7022 :
7023 : /* Indicate value,optional scalar dummy argument as present. */
7024 17 : if (fsym->attr.optional)
7025 1 : vec_safe_push (optionalargs, boolean_true_node);
7026 : return;
7027 : }
7028 :
7029 : /* gfortran argument passing conventions:
7030 : actual arguments to CHARACTER(len=1),VALUE
7031 : dummy arguments are actually passed by value.
7032 : Strings are truncated to length 1. */
7033 22187 : if (gfc_length_one_character_type_p (&fsym->ts))
7034 : {
7035 378 : if (e->expr_type == EXPR_CONSTANT
7036 54 : && e->value.character.length > 1)
7037 : {
7038 0 : e->value.character.length = 1;
7039 0 : gfc_conv_expr (parmse, e);
7040 : }
7041 :
7042 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
7043 378 : gfc_conv_string_parameter (parmse);
7044 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
7045 : e->ts.kind);
7046 : /* Truncate resulting string to length 1. */
7047 378 : parmse->string_length = slen1;
7048 : }
7049 :
7050 22187 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
7051 : {
7052 : /* F2018:15.5.2.12 Argument presence and
7053 : restrictions on arguments not present. */
7054 847 : if (e->expr_type == EXPR_VARIABLE
7055 674 : && e->rank == 0
7056 1467 : && (gfc_expr_attr (e).allocatable
7057 620 : || gfc_expr_attr (e).pointer))
7058 : {
7059 198 : gfc_se argse;
7060 198 : tree cond;
7061 198 : gfc_init_se (&argse, NULL);
7062 198 : argse.want_pointer = 1;
7063 198 : gfc_conv_expr (&argse, e);
7064 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
7065 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
7066 : argse.expr, cond);
7067 198 : if (e->symtree->n.sym->attr.dummy)
7068 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7069 : logical_type_node,
7070 : gfc_conv_expr_present (e->symtree->n.sym),
7071 : cond);
7072 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
7073 : /* Create "conditional temporary". */
7074 198 : conv_cond_temp (parmse, e, cond);
7075 : }
7076 649 : else if (e->expr_type != EXPR_VARIABLE
7077 476 : || !e->symtree->n.sym->attr.optional
7078 272 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
7079 377 : vec_safe_push (optionalargs, boolean_true_node);
7080 : else
7081 : {
7082 272 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
7083 272 : if (gfc_bt_struct (fsym->ts.type)
7084 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
7085 36 : conv_cond_temp (parmse, e, tmp);
7086 236 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
7087 84 : parmse->expr
7088 168 : = fold_build3_loc (input_location, COND_EXPR,
7089 84 : TREE_TYPE (parmse->expr),
7090 : tmp, parmse->expr,
7091 84 : fold_convert (TREE_TYPE (parmse->expr),
7092 : integer_zero_node));
7093 :
7094 544 : vec_safe_push (optionalargs,
7095 272 : fold_convert (boolean_type_node, tmp));
7096 : }
7097 : }
7098 : }
7099 :
7100 :
7101 : /* Helper function for the handling of NULL() actual arguments associated with
7102 : non-optional dummy variables. Argument parmse should already be set up. */
7103 : static void
7104 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
7105 : {
7106 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
7107 :
7108 : /* Obtain the character length for a NULL() actual with a character
7109 : MOLD argument. Otherwise substitute a suitable dummy length.
7110 : Here we handle only non-optional dummies of non-bind(c) procedures. */
7111 426 : if (fsym->ts.type == BT_CHARACTER)
7112 : {
7113 216 : if (e->ts.type == BT_CHARACTER
7114 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
7115 : {
7116 : /* MOLD is present. Substitute a temporary character NULL pointer.
7117 : For an assumed-rank dummy we need a descriptor that passes the
7118 : correct rank. */
7119 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
7120 : {
7121 54 : tree tmp;
7122 54 : tmp = gfc_create_null_actual_descriptor (&parmse->pre, &e->ts,
7123 : fsym->attr, e->rank);
7124 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7125 54 : }
7126 : else
7127 : {
7128 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
7129 108 : gfc_add_modify (&parmse->pre, tmp,
7130 108 : build_zero_cst (TREE_TYPE (tmp)));
7131 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7132 : }
7133 :
7134 : /* Ensure that a usable length is available. */
7135 162 : if (parmse->string_length == NULL_TREE)
7136 : {
7137 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
7138 :
7139 162 : if (ts->u.cl->length != NULL
7140 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
7141 108 : gfc_conv_const_charlen (ts->u.cl);
7142 :
7143 162 : if (ts->u.cl->backend_decl)
7144 162 : parmse->string_length = ts->u.cl->backend_decl;
7145 : }
7146 : }
7147 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
7148 : {
7149 : /* MOLD is not present. Pass length of associated dummy character
7150 : argument if constant, or zero. */
7151 54 : if (fsym->ts.u.cl->length != NULL
7152 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7153 : {
7154 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
7155 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
7156 : }
7157 : else
7158 : {
7159 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
7160 : "slen");
7161 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
7162 : build_zero_cst (gfc_charlen_type_node));
7163 : }
7164 : }
7165 : }
7166 210 : else if (fsym->ts.type == BT_DERIVED)
7167 : {
7168 210 : if (e->ts.type != BT_UNKNOWN)
7169 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
7170 : For an assumed-rank dummy we provide a descriptor that passes
7171 : the correct rank. */
7172 : {
7173 138 : tree tmp = gfc_create_null_actual_descriptor (&parmse->pre, &e->ts,
7174 : fsym->attr, e->rank);
7175 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7176 : }
7177 : else
7178 : /* MOLD is not present. Use attributes from dummy argument, which is
7179 : not allowed to be assumed-rank. */
7180 : {
7181 72 : int dummy_rank = fsym->as ? fsym->as->rank : 0;
7182 72 : tree tmp = gfc_create_null_actual_descriptor (&parmse->pre, &fsym->ts,
7183 : fsym->attr, dummy_rank);
7184 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
7185 : }
7186 : }
7187 426 : }
7188 :
7189 :
7190 : /* Return true if a subobject of the elements of an array is referenced. */
7191 :
7192 : static bool
7193 18 : is_subobject_ref (gfc_expr *e)
7194 : {
7195 18 : bool seen_array = false;
7196 :
7197 48 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
7198 : {
7199 36 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
7200 : seen_array = true;
7201 18 : else if (seen_array)
7202 : return true;
7203 : }
7204 :
7205 : return false;
7206 : }
7207 :
7208 :
7209 : /* Return true if expr is a span addressed dummy that is passed on as a whole,
7210 : rather than a reference to a subobject of the elements of an array. */
7211 :
7212 : static bool
7213 769 : is_whole_span_addressed_dummy (gfc_expr *e)
7214 : {
7215 769 : return e->expr_type == EXPR_VARIABLE
7216 769 : && e->symtree && e->symtree->n.sym
7217 769 : && gfc_is_span_addressed_dummy (e->symtree->n.sym)
7218 787 : && !is_subobject_ref (e);
7219 : }
7220 :
7221 :
7222 : /* Return true if the dummy fsym has an array descriptor and so addresses its
7223 : elements by the strides held in it. Such a dummy accepts an actual
7224 : argument of any stride; only a dummy without a descriptor, or one declared
7225 : CONTIGUOUS, needs it packed into contiguous storage. */
7226 :
7227 : static bool
7228 12 : dummy_accepts_strided_arg (gfc_symbol *fsym, bool nodesc_arg)
7229 : {
7230 12 : return fsym && !nodesc_arg && !fsym->attr.contiguous && fsym->as
7231 24 : && (fsym->as->type == AS_ASSUMED_SHAPE
7232 0 : || fsym->as->type == AS_ASSUMED_RANK
7233 0 : || fsym->as->type == AS_DEFERRED);
7234 : }
7235 :
7236 :
7237 : /* Return true if the actual argument expr for the dummy fsym may be passed as
7238 : a copy-in/copy-out temporary. A pointer associated with a TARGET or POINTER
7239 : dummy must remain valid after the call, so the actual argument is passed
7240 : directly, with a descriptor whose span provides the element spacing. An
7241 : actual argument with a vector subscript is not definable and its pointer
7242 : association is undefined on return, so it is still copied. */
7243 :
7244 : static bool
7245 1010 : copy_in_out_allowed (gfc_symbol *fsym, gfc_expr *e, bool nodesc_arg)
7246 : {
7247 1010 : if (fsym == NULL || nodesc_arg || gfc_has_vector_subscript (e))
7248 : return true;
7249 :
7250 905 : if (gfc_dummy_requires_direct_arg (fsym))
7251 : return false;
7252 :
7253 797 : return !(fsym->attr.pointer && !fsym->attr.contiguous && fsym->as
7254 6 : && (fsym->as->type == AS_ASSUMED_SHAPE
7255 : || fsym->as->type == AS_ASSUMED_RANK
7256 : || fsym->as->type == AS_DEFERRED));
7257 : }
7258 :
7259 :
7260 : /* Generate code for a procedure call. Note can return se->post != NULL.
7261 : If se->direct_byref is set then se->expr contains the return parameter.
7262 : Return nonzero, if the call has alternate specifiers.
7263 : 'expr' is only needed for procedure pointer components. */
7264 :
7265 : int
7266 138252 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
7267 : gfc_actual_arglist * args, gfc_expr * expr,
7268 : vec<tree, va_gc> *append_args)
7269 : {
7270 138252 : gfc_interface_mapping mapping;
7271 138252 : vec<tree, va_gc> *arglist;
7272 138252 : vec<tree, va_gc> *retargs;
7273 138252 : tree tmp;
7274 138252 : tree fntype;
7275 138252 : gfc_se parmse;
7276 138252 : gfc_array_info *info;
7277 138252 : int byref;
7278 138252 : int parm_kind;
7279 138252 : tree type;
7280 138252 : tree var;
7281 138252 : tree len;
7282 138252 : tree base_object;
7283 138252 : vec<tree, va_gc> *stringargs;
7284 138252 : vec<tree, va_gc> *optionalargs;
7285 138252 : tree result = NULL;
7286 138252 : gfc_formal_arglist *formal;
7287 138252 : gfc_actual_arglist *arg;
7288 138252 : int has_alternate_specifier = 0;
7289 138252 : bool need_interface_mapping;
7290 138252 : bool is_builtin;
7291 138252 : bool callee_alloc;
7292 138252 : bool ulim_copy;
7293 138252 : gfc_typespec ts;
7294 138252 : gfc_charlen cl;
7295 138252 : gfc_expr *e;
7296 138252 : gfc_symbol *fsym;
7297 138252 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
7298 138252 : gfc_component *comp = NULL;
7299 138252 : int arglen;
7300 138252 : unsigned int argc;
7301 138252 : tree arg1_cntnr = NULL_TREE;
7302 138252 : bool call_needed_for_length = true;
7303 138252 : arglist = NULL;
7304 138252 : retargs = NULL;
7305 138252 : stringargs = NULL;
7306 138252 : optionalargs = NULL;
7307 138252 : var = NULL_TREE;
7308 138252 : len = NULL_TREE;
7309 138252 : gfc_clear_ts (&ts);
7310 138252 : gfc_intrinsic_sym *isym = expr && expr->rank ?
7311 : expr->value.function.isym : NULL;
7312 :
7313 138252 : comp = gfc_get_proc_ptr_comp (expr);
7314 :
7315 276504 : bool elemental_proc = (comp
7316 2049 : && comp->ts.interface
7317 1995 : && comp->ts.interface->attr.elemental)
7318 1850 : || (comp && comp->attr.elemental)
7319 140102 : || sym->attr.elemental;
7320 :
7321 138252 : if (se->ss != NULL)
7322 : {
7323 25095 : if (!elemental_proc)
7324 : {
7325 21536 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
7326 21536 : if (se->ss->info->useflags)
7327 : {
7328 5802 : gcc_assert ((!comp && gfc_return_by_reference (sym)
7329 : && sym->result->attr.dimension)
7330 : || (comp && comp->attr.dimension)
7331 : || gfc_is_class_array_function (expr));
7332 5802 : gcc_assert (se->loop != NULL);
7333 : /* Access the previously obtained result. */
7334 5802 : gfc_conv_tmp_array_ref (se);
7335 5802 : return 0;
7336 : }
7337 : }
7338 19293 : info = &se->ss->info->data.array;
7339 : }
7340 : else
7341 : info = NULL;
7342 :
7343 132450 : stmtblock_t post, clobbers, dealloc_blk;
7344 132450 : gfc_init_block (&post);
7345 132450 : gfc_init_block (&clobbers);
7346 132450 : gfc_init_block (&dealloc_blk);
7347 132450 : gfc_init_interface_mapping (&mapping);
7348 132450 : if (!comp)
7349 : {
7350 130450 : formal = gfc_sym_get_dummy_args (sym);
7351 245418 : need_interface_mapping = sym->attr.dimension ||
7352 114968 : (sym->ts.type == BT_CHARACTER
7353 3204 : && sym->ts.u.cl->length
7354 2452 : && sym->ts.u.cl->length->expr_type
7355 : != EXPR_CONSTANT)
7356 243821 : || has_value_array_dummy (formal);
7357 : }
7358 : else
7359 : {
7360 2000 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
7361 3931 : need_interface_mapping = comp->attr.dimension ||
7362 1931 : (comp->ts.type == BT_CHARACTER
7363 229 : && comp->ts.u.cl->length
7364 220 : && comp->ts.u.cl->length->expr_type
7365 : != EXPR_CONSTANT)
7366 3912 : || has_value_array_dummy (formal);
7367 : }
7368 :
7369 132450 : base_object = NULL_TREE;
7370 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7371 : is the third and fourth argument to such a function call a value
7372 : denoting the number of elements to copy (i.e., most of the time the
7373 : length of a deferred length string). */
7374 264900 : ulim_copy = (formal == NULL)
7375 32311 : && UNLIMITED_POLY (sym)
7376 132530 : && comp && (strcmp ("_copy", comp->name) == 0);
7377 :
7378 : /* Scan for allocatable actual arguments passed to allocatable dummy
7379 : arguments with INTENT(OUT). As the corresponding actual arguments are
7380 : deallocated before execution of the procedure, we evaluate actual
7381 : argument expressions to avoid problems with possible dependencies. */
7382 132450 : bool force_eval_args = false;
7383 132450 : gfc_formal_arglist *tmp_formal;
7384 405474 : for (arg = args, tmp_formal = formal; arg != NULL;
7385 239671 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7386 : {
7387 273547 : e = arg->expr;
7388 273547 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7389 259971 : if (e && fsym
7390 228045 : && e->expr_type == EXPR_VARIABLE
7391 100534 : && fsym->attr.intent == INTENT_OUT
7392 6468 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7393 6468 : ? CLASS_DATA (fsym)->attr.allocatable
7394 4820 : : fsym->attr.allocatable)
7395 523 : && e->symtree
7396 523 : && e->symtree->n.sym
7397 533518 : && gfc_variable_attr (e, NULL).allocatable)
7398 : {
7399 : force_eval_args = true;
7400 : break;
7401 : }
7402 : }
7403 :
7404 : /* Evaluate the arguments. */
7405 406411 : for (arg = args, argc = 0; arg != NULL;
7406 273961 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7407 : {
7408 273961 : bool finalized = false;
7409 273961 : tree derived_array = NULL_TREE;
7410 273961 : symbol_attribute *attr;
7411 :
7412 273961 : e = arg->expr;
7413 273961 : fsym = formal ? formal->sym : NULL;
7414 514569 : parm_kind = MISSING;
7415 :
7416 240608 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7417 : : fsym->attr)
7418 : : nullptr;
7419 : /* If the procedure requires an explicit interface, the actual
7420 : argument is passed according to the corresponding formal
7421 : argument. If the corresponding formal argument is a POINTER,
7422 : ALLOCATABLE or assumed shape, we do not use g77's calling
7423 : convention, and pass the address of the array descriptor
7424 : instead. Otherwise we use g77's calling convention, in other words
7425 : pass the array data pointer without descriptor. */
7426 240555 : bool nodesc_arg = fsym != NULL
7427 240555 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7428 231441 : && fsym->as
7429 41469 : && fsym->as->type != AS_ASSUMED_SHAPE
7430 24946 : && fsym->as->type != AS_ASSUMED_RANK;
7431 273961 : if (comp)
7432 2755 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7433 : else
7434 271206 : nodesc_arg
7435 : = nodesc_arg
7436 271206 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7437 :
7438 : /* Class array expressions are sometimes coming completely unadorned
7439 : with either arrayspec or _data component. Correct that here.
7440 : OOP-TODO: Move this to the frontend. */
7441 273961 : if (e && e->expr_type == EXPR_VARIABLE
7442 114659 : && !e->ref
7443 52185 : && e->ts.type == BT_CLASS
7444 2645 : && (CLASS_DATA (e)->attr.codimension
7445 2645 : || CLASS_DATA (e)->attr.dimension))
7446 : {
7447 0 : gfc_typespec temp_ts = e->ts;
7448 0 : gfc_add_class_array_ref (e);
7449 0 : e->ts = temp_ts;
7450 : }
7451 :
7452 273961 : if (e == NULL
7453 260379 : || (e->expr_type == EXPR_NULL
7454 745 : && fsym
7455 745 : && fsym->attr.value
7456 72 : && fsym->attr.optional
7457 72 : && !fsym->attr.dimension
7458 72 : && fsym->ts.type != BT_CLASS))
7459 : {
7460 13654 : if (se->ignore_optional)
7461 : {
7462 : /* Some intrinsics have already been resolved to the correct
7463 : parameters. */
7464 434 : continue;
7465 : }
7466 13456 : else if (arg->label)
7467 : {
7468 224 : has_alternate_specifier = 1;
7469 224 : continue;
7470 : }
7471 : else
7472 : {
7473 13232 : gfc_init_se (&parmse, NULL);
7474 :
7475 : /* For scalar arguments with VALUE attribute which are passed by
7476 : value, pass "0" and a hidden argument gives the optional
7477 : status. */
7478 13232 : if (fsym && fsym->attr.optional && fsym->attr.value
7479 475 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7480 : {
7481 439 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7482 : }
7483 : else
7484 : {
7485 : /* Pass a NULL pointer for an absent arg. */
7486 12793 : parmse.expr = null_pointer_node;
7487 :
7488 : /* Is it an absent character dummy? */
7489 12793 : bool absent_char = false;
7490 12793 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7491 :
7492 : /* Fall back to inferred type only if no formal. */
7493 12793 : if (fsym)
7494 11735 : absent_char = (fsym->ts.type == BT_CHARACTER);
7495 1058 : else if (dummy_arg)
7496 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7497 : == BT_CHARACTER);
7498 12793 : if (absent_char)
7499 1133 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7500 : 0);
7501 : }
7502 : }
7503 : }
7504 260307 : else if (e->expr_type == EXPR_NULL
7505 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7506 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7507 293 : && fsym->ts.type == BT_DERIVED)
7508 : {
7509 210 : gfc_init_se (&parmse, NULL);
7510 210 : gfc_conv_expr_reference (&parmse, e);
7511 210 : conv_null_actual (&parmse, e, fsym);
7512 : }
7513 260097 : else if (arg->expr->expr_type == EXPR_NULL
7514 463 : && fsym && !fsym->attr.pointer
7515 163 : && (fsym->ts.type != BT_CLASS
7516 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7517 : {
7518 : /* Pass a NULL pointer to denote an absent arg. */
7519 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7520 : && (fsym->ts.type != BT_CLASS
7521 : || !CLASS_DATA (fsym)->attr.allocatable));
7522 163 : gfc_init_se (&parmse, NULL);
7523 163 : parmse.expr = null_pointer_node;
7524 163 : if (fsym->ts.type == BT_CHARACTER)
7525 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7526 : }
7527 259934 : else if (fsym && fsym->ts.type == BT_CLASS
7528 11465 : && e->ts.type == BT_DERIVED)
7529 : {
7530 : /* The derived type needs to be converted to a temporary
7531 : CLASS object. */
7532 4778 : gfc_init_se (&parmse, se);
7533 4778 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7534 4778 : fsym->attr.optional
7535 1008 : && e->expr_type == EXPR_VARIABLE
7536 1008 : && e->symtree->n.sym->attr.optional,
7537 4778 : CLASS_DATA (fsym)->attr.class_pointer
7538 4597 : || CLASS_DATA (fsym)->attr.allocatable,
7539 : sym->name, &derived_array);
7540 : }
7541 223230 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7542 954 : && e->ts.type != BT_PROCEDURE
7543 930 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7544 930 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7545 : {
7546 : /* The intrinsic type needs to be converted to a temporary
7547 : CLASS object for the unlimited polymorphic formal. */
7548 930 : gfc_find_vtab (&e->ts);
7549 930 : gfc_init_se (&parmse, se);
7550 930 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7551 :
7552 : }
7553 254226 : else if (se->ss && se->ss->info->useflags)
7554 : {
7555 5837 : gfc_ss *ss;
7556 :
7557 5837 : ss = se->ss;
7558 :
7559 : /* An elemental function inside a scalarized loop. */
7560 5837 : gfc_init_se (&parmse, se);
7561 5837 : parm_kind = ELEMENTAL;
7562 :
7563 : /* When no fsym is present, ulim_copy is set and this is a third or
7564 : fourth argument, use call-by-value instead of by reference to
7565 : hand the length properties to the copy routine (i.e., most of the
7566 : time this will be a call to a __copy_character_* routine where the
7567 : third and fourth arguments are the lengths of a deferred length
7568 : char array). */
7569 5837 : if ((fsym && fsym->attr.value)
7570 5603 : || (ulim_copy && (argc == 2 || argc == 3)))
7571 234 : gfc_conv_expr (&parmse, e);
7572 5603 : else if (e->expr_type == EXPR_ARRAY)
7573 : {
7574 306 : gfc_conv_expr (&parmse, e);
7575 306 : if (e->ts.type != BT_CHARACTER)
7576 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7577 : }
7578 : else
7579 5297 : gfc_conv_expr_reference (&parmse, e);
7580 :
7581 5837 : if (e->ts.type == BT_CHARACTER && !e->rank
7582 174 : && e->expr_type == EXPR_FUNCTION)
7583 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7584 : parmse.expr);
7585 :
7586 5787 : if (fsym && fsym->ts.type == BT_DERIVED
7587 7459 : && gfc_is_class_container_ref (e))
7588 : {
7589 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7590 :
7591 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7592 24 : && e->symtree->n.sym->attr.optional)
7593 : {
7594 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7595 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7596 0 : TREE_TYPE (parmse.expr),
7597 : cond, parmse.expr,
7598 0 : fold_convert (TREE_TYPE (parmse.expr),
7599 : null_pointer_node));
7600 : }
7601 : }
7602 :
7603 : /* Scalar dummy arguments of intrinsic type or derived type with
7604 : VALUE attribute. */
7605 5837 : if (fsym
7606 5787 : && fsym->attr.value
7607 234 : && fsym->ts.type != BT_CLASS)
7608 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7609 :
7610 : /* If we are passing an absent array as optional dummy to an
7611 : elemental procedure, make sure that we pass NULL when the data
7612 : pointer is NULL. We need this extra conditional because of
7613 : scalarization which passes arrays elements to the procedure,
7614 : ignoring the fact that the array can be absent/unallocated/... */
7615 5603 : else if (ss->info->can_be_null_ref
7616 415 : && ss->info->type != GFC_SS_REFERENCE)
7617 : {
7618 193 : tree descriptor_data;
7619 :
7620 193 : descriptor_data = ss->info->data.array.data;
7621 193 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7622 : descriptor_data,
7623 193 : fold_convert (TREE_TYPE (descriptor_data),
7624 : null_pointer_node));
7625 193 : parmse.expr
7626 386 : = fold_build3_loc (input_location, COND_EXPR,
7627 193 : TREE_TYPE (parmse.expr),
7628 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7629 193 : fold_convert (TREE_TYPE (parmse.expr),
7630 : null_pointer_node),
7631 : parmse.expr);
7632 : }
7633 :
7634 : /* The scalarizer does not repackage the reference to a class
7635 : array - instead it returns a pointer to the data element. */
7636 5837 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7637 210 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7638 186 : fsym->attr.intent != INTENT_IN
7639 : && (CLASS_DATA (fsym)->attr.class_pointer
7640 24 : || CLASS_DATA (fsym)->attr.allocatable),
7641 186 : fsym->attr.optional
7642 0 : && e->expr_type == EXPR_VARIABLE
7643 0 : && e->symtree->n.sym->attr.optional,
7644 186 : CLASS_DATA (fsym)->attr.class_pointer
7645 186 : || CLASS_DATA (fsym)->attr.allocatable);
7646 : }
7647 : else
7648 : {
7649 248389 : bool scalar;
7650 248389 : gfc_ss *argss;
7651 :
7652 248389 : gfc_init_se (&parmse, NULL);
7653 :
7654 : /* Check whether the expression is a scalar or not; we cannot use
7655 : e->rank as it can be nonzero for functions arguments. */
7656 248389 : argss = gfc_walk_expr (e);
7657 248389 : scalar = argss == gfc_ss_terminator;
7658 248389 : if (!scalar)
7659 61261 : gfc_free_ss_chain (argss);
7660 :
7661 : /* Special handling for passing scalar polymorphic coarrays;
7662 : otherwise one passes "class->_data.data" instead of "&class". */
7663 248389 : if (e->rank == 0 && e->ts.type == BT_CLASS
7664 3599 : && fsym && fsym->ts.type == BT_CLASS
7665 3177 : && CLASS_DATA (fsym)->attr.codimension
7666 55 : && !CLASS_DATA (fsym)->attr.dimension)
7667 : {
7668 55 : gfc_add_class_array_ref (e);
7669 55 : parmse.want_coarray = 1;
7670 55 : scalar = false;
7671 : }
7672 :
7673 : /* A scalar or transformational function. */
7674 248389 : if (scalar)
7675 : {
7676 187073 : if (e->expr_type == EXPR_VARIABLE
7677 55590 : && e->symtree->n.sym->attr.cray_pointee
7678 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7679 : {
7680 : /* The Cray pointer needs to be converted to a pointer to
7681 : a type given by the expression. */
7682 6 : gfc_conv_expr (&parmse, e);
7683 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7684 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7685 6 : parmse.expr = convert (type, tmp);
7686 : }
7687 :
7688 187067 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7689 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7690 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7691 :
7692 186380 : else if (fsym && fsym->attr.value && fsym->attr.dimension)
7693 : /* Scalar actual argument sequence associated with a VALUE
7694 : array dummy. */
7695 36 : conv_seq_assoc_value_arg (&parmse, e, fsym, &mapping);
7696 :
7697 158091 : else if (fsym && fsym->attr.value)
7698 : {
7699 22148 : if (fsym->ts.type == BT_CHARACTER
7700 591 : && fsym->ts.is_c_interop
7701 181 : && fsym->ns->proc_name != NULL
7702 181 : && fsym->ns->proc_name->attr.is_bind_c)
7703 : {
7704 172 : parmse.expr = NULL;
7705 172 : conv_scalar_char_value (fsym, &parmse, &e);
7706 172 : if (parmse.expr == NULL)
7707 166 : gfc_conv_expr (&parmse, e);
7708 : }
7709 : else
7710 : {
7711 21976 : gfc_conv_expr (&parmse, e);
7712 21976 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7713 : }
7714 : }
7715 :
7716 164196 : else if (arg->name && arg->name[0] == '%')
7717 : /* Argument list functions %VAL, %LOC and %REF are signalled
7718 : through arg->name. */
7719 5826 : conv_arglist_function (&parmse, arg->expr, arg->name);
7720 158370 : else if ((e->expr_type == EXPR_FUNCTION)
7721 8305 : && ((e->value.function.esym
7722 2154 : && e->value.function.esym->result->attr.pointer)
7723 8210 : || (!e->value.function.esym
7724 6151 : && e->symtree->n.sym->attr.pointer))
7725 95 : && fsym && fsym->attr.target)
7726 : /* Make sure the function only gets called once. */
7727 8 : gfc_conv_expr_reference (&parmse, e);
7728 158362 : else if (e->expr_type == EXPR_FUNCTION
7729 8297 : && e->symtree->n.sym->result
7730 7262 : && e->symtree->n.sym->result != e->symtree->n.sym
7731 138 : && e->symtree->n.sym->result->attr.proc_pointer)
7732 : {
7733 : /* Functions returning procedure pointers. */
7734 18 : gfc_conv_expr (&parmse, e);
7735 18 : if (fsym && fsym->attr.proc_pointer)
7736 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7737 : }
7738 :
7739 : else
7740 : {
7741 158344 : bool defer_to_dealloc_blk = false;
7742 158344 : if (e->ts.type == BT_CLASS && fsym
7743 3532 : && fsym->ts.type == BT_CLASS
7744 3110 : && (!CLASS_DATA (fsym)->as
7745 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7746 2754 : && CLASS_DATA (e)->attr.codimension)
7747 : {
7748 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7749 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7750 48 : gfc_add_class_array_ref (e);
7751 48 : parmse.want_coarray = 1;
7752 48 : gfc_conv_expr_reference (&parmse, e);
7753 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7754 48 : fsym->attr.optional
7755 48 : && e->expr_type == EXPR_VARIABLE);
7756 : }
7757 158296 : else if (e->ts.type == BT_CLASS && fsym
7758 3484 : && fsym->ts.type == BT_CLASS
7759 3062 : && !CLASS_DATA (fsym)->as
7760 2706 : && !CLASS_DATA (e)->as
7761 2596 : && strcmp (fsym->ts.u.derived->name,
7762 : e->ts.u.derived->name))
7763 : {
7764 1649 : type = gfc_typenode_for_spec (&fsym->ts);
7765 1649 : var = gfc_create_var (type, fsym->name);
7766 1649 : gfc_conv_expr (&parmse, e);
7767 1649 : if (fsym->attr.optional
7768 153 : && e->expr_type == EXPR_VARIABLE
7769 153 : && e->symtree->n.sym->attr.optional)
7770 : {
7771 66 : stmtblock_t block;
7772 66 : tree cond;
7773 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7774 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7775 : logical_type_node, tmp,
7776 66 : fold_convert (TREE_TYPE (tmp),
7777 : null_pointer_node));
7778 66 : gfc_start_block (&block);
7779 66 : gfc_add_modify (&block, var,
7780 : fold_build1_loc (input_location,
7781 : VIEW_CONVERT_EXPR,
7782 : type, parmse.expr));
7783 66 : gfc_add_expr_to_block (&parmse.pre,
7784 : fold_build3_loc (input_location,
7785 : COND_EXPR, void_type_node,
7786 : cond, gfc_finish_block (&block),
7787 : build_empty_stmt (input_location)));
7788 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7789 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7790 66 : TREE_TYPE (parmse.expr),
7791 : cond, parmse.expr,
7792 66 : fold_convert (TREE_TYPE (parmse.expr),
7793 : null_pointer_node));
7794 66 : }
7795 : else
7796 : {
7797 : /* Since the internal representation of unlimited
7798 : polymorphic expressions includes an extra field
7799 : that other class objects do not, a cast to the
7800 : formal type does not work. */
7801 1583 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7802 : {
7803 91 : tree efield;
7804 :
7805 : /* Evaluate arguments just once, when they have
7806 : side effects. */
7807 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7808 : {
7809 25 : tree cldata, zero;
7810 :
7811 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7812 : &parmse.pre);
7813 :
7814 : /* Prevent memory leak, when old component
7815 : was allocated already. */
7816 25 : cldata = gfc_class_data_get (parmse.expr);
7817 25 : zero = build_int_cst (TREE_TYPE (cldata),
7818 : 0);
7819 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7820 : logical_type_node,
7821 : cldata, zero);
7822 25 : tmp = build3_v (COND_EXPR, tmp,
7823 : gfc_call_free (cldata),
7824 : build_empty_stmt (
7825 : input_location));
7826 25 : gfc_add_expr_to_block (&parmse.finalblock,
7827 : tmp);
7828 25 : gfc_add_modify (&parmse.finalblock,
7829 : cldata, zero);
7830 : }
7831 :
7832 : /* Set the _data field. */
7833 91 : tmp = gfc_class_data_get (var);
7834 91 : efield = fold_convert (TREE_TYPE (tmp),
7835 : gfc_class_data_get (parmse.expr));
7836 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7837 :
7838 : /* Set the _vptr field. */
7839 91 : tmp = gfc_class_vptr_get (var);
7840 91 : efield = fold_convert (TREE_TYPE (tmp),
7841 : gfc_class_vptr_get (parmse.expr));
7842 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7843 :
7844 : /* Set the _len field. */
7845 91 : tmp = gfc_class_len_get (var);
7846 91 : gfc_add_modify (&parmse.pre, tmp,
7847 91 : build_int_cst (TREE_TYPE (tmp), 0));
7848 91 : }
7849 : else
7850 : {
7851 1492 : tmp = fold_build1_loc (input_location,
7852 : VIEW_CONVERT_EXPR,
7853 : type, parmse.expr);
7854 1492 : gfc_add_modify (&parmse.pre, var, tmp);
7855 1583 : ;
7856 : }
7857 1583 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7858 : }
7859 : }
7860 : else
7861 : {
7862 156647 : gfc_conv_expr_reference (&parmse, e);
7863 :
7864 156647 : gfc_symbol *dsym = fsym;
7865 156647 : gfc_dummy_arg *dummy;
7866 :
7867 : /* Use associated dummy as fallback for formal
7868 : argument if there is no explicit interface. */
7869 156647 : if (dsym == NULL
7870 27441 : && (dummy = arg->associated_dummy)
7871 24901 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7872 180141 : && dummy->u.non_intrinsic->sym)
7873 156647 : dsym = dummy->u.non_intrinsic->sym;
7874 :
7875 156647 : if (dsym
7876 152700 : && dsym->attr.intent == INTENT_OUT
7877 3279 : && !dsym->attr.allocatable
7878 3136 : && !dsym->attr.pointer
7879 3118 : && e->expr_type == EXPR_VARIABLE
7880 3117 : && e->ref == NULL
7881 3002 : && e->symtree
7882 3002 : && e->symtree->n.sym
7883 3002 : && !e->symtree->n.sym->attr.dimension
7884 3002 : && e->ts.type != BT_CHARACTER
7885 2900 : && e->ts.type != BT_CLASS
7886 2664 : && (e->ts.type != BT_DERIVED
7887 492 : || (dsym->ts.type == BT_DERIVED
7888 492 : && e->ts.u.derived == dsym->ts.u.derived
7889 : /* Types with allocatable components are
7890 : excluded from clobbering because we need
7891 : the unclobbered pointers to free the
7892 : allocatable components in the callee.
7893 : Same goes for finalizable types or types
7894 : with finalizable components, we need to
7895 : pass the unclobbered values to the
7896 : finalization routines.
7897 : For parameterized types, it's less clear
7898 : but they may not have a constant size
7899 : so better exclude them in any case. */
7900 477 : && !e->ts.u.derived->attr.alloc_comp
7901 351 : && !e->ts.u.derived->attr.pdt_type
7902 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7903 2481 : && e->ts.type != BT_PROCEDURE
7904 159092 : && !sym->attr.elemental)
7905 : {
7906 1112 : tree var;
7907 1112 : var = build_fold_indirect_ref_loc (input_location,
7908 : parmse.expr);
7909 1112 : tree clobber = build_clobber (TREE_TYPE (var));
7910 1112 : gfc_add_modify (&clobbers, var, clobber);
7911 : }
7912 : }
7913 : /* Catch base objects that are not variables. */
7914 158344 : if (e->ts.type == BT_CLASS
7915 3532 : && e->expr_type != EXPR_VARIABLE
7916 306 : && expr && e == expr->base_expr)
7917 80 : base_object = build_fold_indirect_ref_loc (input_location,
7918 : parmse.expr);
7919 :
7920 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7921 : allocated on entry, it must be deallocated. */
7922 130903 : if (fsym && fsym->attr.intent == INTENT_OUT
7923 3208 : && (fsym->attr.allocatable
7924 3065 : || (fsym->ts.type == BT_CLASS
7925 265 : && CLASS_DATA (fsym)->attr.allocatable))
7926 158642 : && !is_CFI_desc (fsym, NULL))
7927 : {
7928 298 : stmtblock_t block;
7929 298 : tree ptr;
7930 :
7931 298 : defer_to_dealloc_blk = true;
7932 :
7933 298 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7934 : &parmse.pre);
7935 :
7936 298 : if (parmse.class_container != NULL_TREE)
7937 162 : parmse.class_container
7938 162 : = gfc_evaluate_data_ref_now (parmse.class_container,
7939 : &parmse.pre);
7940 :
7941 298 : gfc_init_block (&block);
7942 298 : ptr = parmse.expr;
7943 298 : if (e->ts.type == BT_CLASS)
7944 162 : ptr = gfc_class_data_get (ptr);
7945 :
7946 298 : tree cls = parmse.class_container;
7947 298 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7948 : NULL_TREE, true,
7949 : e, e->ts, cls);
7950 298 : gfc_add_expr_to_block (&block, tmp);
7951 298 : gfc_add_modify (&block, ptr,
7952 298 : fold_convert (TREE_TYPE (ptr),
7953 : null_pointer_node));
7954 :
7955 298 : if (fsym->ts.type == BT_CLASS)
7956 155 : gfc_reset_vptr (&block, nullptr,
7957 : build_fold_indirect_ref (parmse.expr),
7958 155 : fsym->ts.u.derived);
7959 :
7960 298 : if (fsym->attr.optional
7961 42 : && e->expr_type == EXPR_VARIABLE
7962 42 : && e->symtree->n.sym->attr.optional)
7963 : {
7964 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7965 : void_type_node,
7966 18 : gfc_conv_expr_present (e->symtree->n.sym),
7967 : gfc_finish_block (&block),
7968 : build_empty_stmt (input_location));
7969 : }
7970 : else
7971 280 : tmp = gfc_finish_block (&block);
7972 :
7973 298 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7974 : }
7975 :
7976 : /* A class array element needs converting back to be a
7977 : class object, if the formal argument is a class object. */
7978 158344 : if (fsym && fsym->ts.type == BT_CLASS
7979 3134 : && e->ts.type == BT_CLASS
7980 3110 : && ((CLASS_DATA (fsym)->as
7981 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7982 2754 : || CLASS_DATA (e)->attr.dimension))
7983 : {
7984 466 : gfc_se class_se = parmse;
7985 466 : gfc_init_block (&class_se.pre);
7986 466 : gfc_init_block (&class_se.post);
7987 :
7988 733 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7989 466 : fsym->attr.intent != INTENT_IN
7990 : && (CLASS_DATA (fsym)->attr.class_pointer
7991 267 : || CLASS_DATA (fsym)->attr.allocatable),
7992 466 : fsym->attr.optional
7993 198 : && e->expr_type == EXPR_VARIABLE
7994 198 : && e->symtree->n.sym->attr.optional,
7995 466 : CLASS_DATA (fsym)->attr.class_pointer
7996 430 : || CLASS_DATA (fsym)->attr.allocatable);
7997 :
7998 466 : parmse.expr = class_se.expr;
7999 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
8000 466 : ? &dealloc_blk
8001 : : &parmse.pre;
8002 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
8003 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
8004 : }
8005 :
8006 130903 : if (fsym && (fsym->ts.type == BT_DERIVED
8007 118957 : || fsym->ts.type == BT_ASSUMED)
8008 12813 : && e->ts.type == BT_CLASS
8009 410 : && !CLASS_DATA (e)->attr.dimension
8010 374 : && !CLASS_DATA (e)->attr.codimension)
8011 : {
8012 374 : parmse.expr = gfc_class_data_get (parmse.expr);
8013 : /* The result is a class temporary, whose _data component
8014 : must be freed to avoid a memory leak. */
8015 374 : if (e->expr_type == EXPR_FUNCTION
8016 23 : && CLASS_DATA (e)->attr.allocatable)
8017 : {
8018 19 : tree zero;
8019 :
8020 : /* Finalize the expression. */
8021 19 : gfc_finalize_tree_expr (&parmse, NULL,
8022 19 : gfc_expr_attr (e), e->rank);
8023 19 : gfc_add_block_to_block (&parmse.post,
8024 : &parmse.finalblock);
8025 :
8026 : /* Then free the class _data. */
8027 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
8028 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
8029 : logical_type_node,
8030 : parmse.expr, zero);
8031 19 : tmp = build3_v (COND_EXPR, tmp,
8032 : gfc_call_free (parmse.expr),
8033 : build_empty_stmt (input_location));
8034 19 : gfc_add_expr_to_block (&parmse.post, tmp);
8035 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
8036 : }
8037 : }
8038 :
8039 : /* Wrap scalar variable in a descriptor. We need to convert
8040 : the address of a pointer back to the pointer itself before,
8041 : we can assign it to the data field. */
8042 :
8043 130903 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
8044 1344 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
8045 : {
8046 1272 : tmp = parmse.expr;
8047 1272 : if (TREE_CODE (tmp) == ADDR_EXPR)
8048 754 : tmp = TREE_OPERAND (tmp, 0);
8049 1272 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
8050 : fsym->attr);
8051 1272 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
8052 : parmse.expr);
8053 : }
8054 129631 : else if (fsym && e->expr_type != EXPR_NULL
8055 129333 : && ((fsym->attr.pointer
8056 1740 : && fsym->attr.flavor != FL_PROCEDURE)
8057 127599 : || (fsym->attr.proc_pointer
8058 199 : && !(e->expr_type == EXPR_VARIABLE
8059 199 : && e->symtree->n.sym->attr.dummy))
8060 127412 : || (fsym->attr.proc_pointer
8061 12 : && e->expr_type == EXPR_VARIABLE
8062 12 : && gfc_is_proc_ptr_comp (e))
8063 127406 : || (fsym->attr.allocatable
8064 1041 : && fsym->attr.flavor != FL_PROCEDURE)))
8065 : {
8066 : /* Scalar pointer dummy args require an extra level of
8067 : indirection. The null pointer already contains
8068 : this level of indirection. */
8069 2962 : parm_kind = SCALAR_POINTER;
8070 2962 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
8071 : }
8072 : }
8073 : }
8074 61316 : else if (e->ts.type == BT_CLASS
8075 2807 : && fsym && fsym->ts.type == BT_CLASS
8076 2425 : && (CLASS_DATA (fsym)->attr.dimension
8077 55 : || CLASS_DATA (fsym)->attr.codimension))
8078 : {
8079 : /* Pass a class array. */
8080 2425 : gfc_conv_expr_descriptor (&parmse, e);
8081 2425 : bool defer_to_dealloc_blk = false;
8082 :
8083 2425 : if (fsym->attr.optional
8084 798 : && e->expr_type == EXPR_VARIABLE
8085 798 : && e->symtree->n.sym->attr.optional)
8086 : {
8087 438 : stmtblock_t block;
8088 :
8089 438 : gfc_init_block (&block);
8090 438 : gfc_add_block_to_block (&block, &parmse.pre);
8091 :
8092 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
8093 : void_type_node,
8094 438 : gfc_conv_expr_present (e->symtree->n.sym),
8095 : gfc_finish_block (&block),
8096 : build_empty_stmt (input_location));
8097 :
8098 438 : gfc_add_expr_to_block (&parmse.pre, t);
8099 : }
8100 :
8101 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8102 : allocated on entry, it must be deallocated. */
8103 2425 : if (fsym->attr.intent == INTENT_OUT
8104 153 : && CLASS_DATA (fsym)->attr.allocatable)
8105 : {
8106 122 : stmtblock_t block;
8107 122 : tree ptr;
8108 :
8109 : /* In case the data reference to deallocate is dependent on
8110 : its own content, save the resulting pointer to a variable
8111 : and only use that variable from now on, before the
8112 : expression becomes invalid. */
8113 122 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
8114 : &parmse.pre);
8115 :
8116 122 : if (parmse.class_container != NULL_TREE)
8117 122 : parmse.class_container
8118 122 : = gfc_evaluate_data_ref_now (parmse.class_container,
8119 : &parmse.pre);
8120 :
8121 122 : gfc_init_block (&block);
8122 122 : ptr = parmse.expr;
8123 122 : ptr = gfc_class_data_get (ptr);
8124 :
8125 122 : tree cls = parmse.class_container;
8126 122 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
8127 : NULL_TREE, NULL_TREE,
8128 : NULL_TREE, true, e,
8129 : GFC_CAF_COARRAY_NOCOARRAY,
8130 : cls);
8131 122 : gfc_add_expr_to_block (&block, tmp);
8132 122 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
8133 : void_type_node, ptr,
8134 : null_pointer_node);
8135 122 : gfc_add_expr_to_block (&block, tmp);
8136 122 : gfc_reset_vptr (&block, e, parmse.class_container);
8137 :
8138 122 : if (fsym->attr.optional
8139 30 : && e->expr_type == EXPR_VARIABLE
8140 30 : && (!e->ref
8141 30 : || (e->ref->type == REF_ARRAY
8142 0 : && e->ref->u.ar.type != AR_FULL))
8143 0 : && e->symtree->n.sym->attr.optional)
8144 : {
8145 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
8146 : void_type_node,
8147 0 : gfc_conv_expr_present (e->symtree->n.sym),
8148 : gfc_finish_block (&block),
8149 : build_empty_stmt (input_location));
8150 : }
8151 : else
8152 122 : tmp = gfc_finish_block (&block);
8153 :
8154 122 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8155 122 : defer_to_dealloc_blk = true;
8156 : }
8157 :
8158 2425 : gfc_se class_se = parmse;
8159 2425 : gfc_init_block (&class_se.pre);
8160 2425 : gfc_init_block (&class_se.post);
8161 :
8162 2425 : if (e->expr_type != EXPR_VARIABLE)
8163 : {
8164 : int n;
8165 : /* Set the bounds and offset correctly. */
8166 60 : for (n = 0; n < e->rank; n++)
8167 30 : gfc_conv_shift_descriptor_lbound (&class_se.pre,
8168 : class_se.expr,
8169 : n, gfc_index_one_node);
8170 : }
8171 :
8172 : /* The conversion does not repackage the reference to a class
8173 : array - _data descriptor. */
8174 3852 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
8175 2425 : fsym->attr.intent != INTENT_IN
8176 : && (CLASS_DATA (fsym)->attr.class_pointer
8177 1241 : || CLASS_DATA (fsym)->attr.allocatable),
8178 2425 : fsym->attr.optional
8179 798 : && e->expr_type == EXPR_VARIABLE
8180 798 : && e->symtree->n.sym->attr.optional,
8181 2425 : CLASS_DATA (fsym)->attr.class_pointer
8182 1999 : || CLASS_DATA (fsym)->attr.allocatable);
8183 :
8184 2425 : parmse.expr = class_se.expr;
8185 2303 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
8186 2425 : ? &dealloc_blk
8187 : : &parmse.pre;
8188 2425 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
8189 2425 : gfc_add_block_to_block (&parmse.post, &class_se.post);
8190 :
8191 2425 : if (e->expr_type == EXPR_OP
8192 12 : && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
8193 2437 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
8194 : {
8195 12 : tree cond;
8196 12 : tree dealloc_expr = gfc_finish_block (&parmse.post);
8197 12 : tmp = TREE_OPERAND (parmse.expr, 0);
8198 12 : gfc_init_block (&parmse.post);
8199 12 : cond = gfc_class_data_get (tmp);
8200 12 : tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
8201 : tmp, e->rank, true);
8202 12 : gfc_add_expr_to_block (&parmse.post, tmp);
8203 12 : cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
8204 12 : cond = gfc_conv_descriptor_data_get (cond);
8205 12 : cond = fold_build2_loc (input_location, NE_EXPR,
8206 : logical_type_node, cond,
8207 12 : build_int_cst (TREE_TYPE (cond), 0));
8208 12 : tmp = build3_v (COND_EXPR, cond, dealloc_expr,
8209 : build_empty_stmt (input_location));
8210 :
8211 : /* This specific case should not be processed further and so
8212 : bundle everything up and proceed to the next argument. */
8213 12 : if (fsym && need_interface_mapping && e)
8214 12 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8215 12 : gfc_add_expr_to_block (&parmse.post, tmp);
8216 12 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8217 12 : gfc_add_block_to_block (&post, &parmse.post);
8218 12 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8219 12 : vec_safe_push (arglist, parmse.expr);
8220 12 : continue;
8221 12 : }
8222 2413 : }
8223 : else
8224 : {
8225 : /* If the argument is a function call that may not create
8226 : a temporary for the result, we have to check that we
8227 : can do it, i.e. that there is no alias between this
8228 : argument and another one. */
8229 58891 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
8230 : {
8231 406 : gfc_expr *iarg;
8232 406 : sym_intent intent;
8233 :
8234 406 : if (fsym != NULL)
8235 397 : intent = fsym->attr.intent;
8236 : else
8237 : intent = INTENT_UNKNOWN;
8238 :
8239 406 : if (gfc_check_fncall_dependency (e, intent, sym, args,
8240 : NOT_ELEMENTAL))
8241 21 : parmse.force_tmp = 1;
8242 :
8243 406 : iarg = e->value.function.actual->expr;
8244 :
8245 : /* Temporary needed if aliasing due to host association. */
8246 406 : if (sym->attr.contained
8247 168 : && !sym->attr.pure
8248 168 : && !sym->attr.implicit_pure
8249 84 : && !sym->attr.use_assoc
8250 84 : && iarg->expr_type == EXPR_VARIABLE
8251 84 : && sym->ns == iarg->symtree->n.sym->ns)
8252 36 : parmse.force_tmp = 1;
8253 :
8254 : /* Ditto within module. */
8255 406 : if (sym->attr.use_assoc
8256 6 : && !sym->attr.pure
8257 6 : && !sym->attr.implicit_pure
8258 0 : && iarg->expr_type == EXPR_VARIABLE
8259 0 : && sym->module == iarg->symtree->n.sym->module)
8260 0 : parmse.force_tmp = 1;
8261 : }
8262 :
8263 : /* Special case for assumed-rank arrays: when passing an
8264 : argument to a nonallocatable/nonpointer dummy, the bounds have
8265 : to be reset as otherwise a last-dim ubound of -1 is
8266 : indistinguishable from an assumed-size array in the callee. */
8267 58891 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
8268 35800 : && fsym->as->type == AS_ASSUMED_RANK
8269 11978 : && e->rank != -1
8270 11664 : && e->expr_type == EXPR_VARIABLE
8271 11199 : && ((fsym->ts.type == BT_CLASS
8272 0 : && !CLASS_DATA (fsym)->attr.class_pointer
8273 0 : && !CLASS_DATA (fsym)->attr.allocatable)
8274 11199 : || (fsym->ts.type != BT_CLASS
8275 11199 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
8276 : {
8277 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
8278 10656 : gfc_ref *ref;
8279 10920 : for (ref = e->ref; ref->next; ref = ref->next)
8280 : {
8281 342 : if (ref->next->type == REF_INQUIRY)
8282 : break;
8283 294 : if (ref->type == REF_ARRAY
8284 30 : && ref->u.ar.type != AR_ELEMENT)
8285 : break;
8286 10656 : };
8287 10656 : if (ref->u.ar.type == AR_FULL
8288 9906 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
8289 9786 : ref->u.ar.type = AR_SECTION;
8290 : }
8291 :
8292 58891 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
8293 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
8294 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
8295 :
8296 53041 : else if (fsym && fsym->attr.value && fsym->attr.dimension
8297 102 : && e->rank != -1)
8298 : /* VALUE array dummy: pass a private copy of the actual
8299 : argument. Allocatable components are copied deeply, so
8300 : that the callee cannot reach the actual argument's data.
8301 : The symbol passed is that of the actual argument, so that
8302 : the copy is suppressed and a null pointer passed when an
8303 : optional actual argument is absent. */
8304 102 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, INTENT_IN,
8305 : false, fsym, sym->name,
8306 102 : e->expr_type == EXPR_VARIABLE
8307 102 : ? e->symtree->n.sym : NULL,
8308 : false, true);
8309 :
8310 52939 : else if (e->expr_type == EXPR_VARIABLE
8311 41349 : && is_subref_array (e)
8312 1118 : && !(fsym && fsym->attr.pointer)
8313 53792 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8314 : /* The actual argument is a component reference to an
8315 : array of derived types. In this case, the argument
8316 : is converted to a temporary, which is passed and then
8317 : written back after the procedure call. The elements of
8318 : a span addressed dummy passed on as a whole are usually
8319 : contiguous, so the copy is made conditional. A dummy that
8320 : has a descriptor takes any stride, so for it the condition
8321 : is only that the span be the element length. */
8322 : {
8323 769 : bool whole_span = is_whole_span_addressed_dummy (e);
8324 1508 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8325 727 : fsym ? fsym->attr.intent : INTENT_INOUT,
8326 727 : fsym && fsym->attr.pointer, fsym, sym->name,
8327 : NULL, whole_span, false,
8328 : whole_span
8329 12 : && dummy_accepts_strided_arg (fsym,
8330 : nodesc_arg));
8331 : }
8332 :
8333 52170 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
8334 381 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
8335 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
8336 : /* An assumed size class actual argument being passed to
8337 : a 'no descriptor' formal argument just requires the
8338 : data pointer to be passed. For class dummy arguments
8339 : this is stored in the symbol backend decl.. */
8340 6 : parmse.expr = e->symtree->n.sym->backend_decl;
8341 :
8342 52164 : else if (gfc_is_class_array_ref (e, NULL)
8343 368 : && fsym && fsym->ts.type == BT_DERIVED
8344 52308 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8345 : /* The actual argument is a component reference to an
8346 : array of derived types. In this case, the argument
8347 : is converted to a temporary, which is passed and then
8348 : written back after the procedure call. */
8349 114 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8350 114 : fsym->attr.intent,
8351 114 : fsym->attr.pointer);
8352 :
8353 52050 : else if (gfc_is_class_array_function (e)
8354 13 : && fsym && fsym->ts.type == BT_DERIVED
8355 52063 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8356 : /* See previous comment. For function actual argument,
8357 : the write out is not needed so the intent is set as
8358 : intent in. */
8359 : {
8360 13 : e->must_finalize = 1;
8361 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8362 13 : INTENT_IN, fsym->attr.pointer);
8363 : }
8364 48456 : else if (fsym && fsym->attr.contiguous
8365 90 : && (fsym->attr.target
8366 1762 : ? gfc_is_not_contiguous (e)
8367 1672 : : !gfc_is_simply_contiguous (e, false, true))
8368 357 : && gfc_expr_is_variable (e)
8369 54144 : && e->rank != -1)
8370 : {
8371 333 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8372 333 : fsym->attr.intent,
8373 333 : fsym->attr.pointer);
8374 : }
8375 : else
8376 : {
8377 : /* Having declined copy-in/copy-out above, a subobject of an
8378 : array is described by a spanned descriptor. */
8379 51704 : if (e->expr_type == EXPR_VARIABLE && is_subref_array (e))
8380 349 : parmse.force_no_tmp = 1;
8381 :
8382 : /* This is where we introduce a temporary to store the
8383 : result of a non-lvalue array expression. */
8384 51704 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
8385 : sym->name, NULL);
8386 : }
8387 :
8388 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8389 : allocated on entry, it must be deallocated.
8390 : CFI descriptors are handled elsewhere. */
8391 55268 : if (fsym && fsym->attr.allocatable
8392 1787 : && fsym->attr.intent == INTENT_OUT
8393 58634 : && !is_CFI_desc (fsym, NULL))
8394 : {
8395 161 : if (fsym->ts.type == BT_DERIVED
8396 47 : && fsym->ts.u.derived->attr.alloc_comp)
8397 : {
8398 : // deallocate the components first
8399 11 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
8400 : parmse.expr, e->rank);
8401 : /* But check whether dummy argument is optional. */
8402 11 : if (tmp != NULL_TREE
8403 11 : && fsym->attr.optional
8404 6 : && e->expr_type == EXPR_VARIABLE
8405 6 : && e->symtree->n.sym->attr.optional)
8406 : {
8407 6 : tree present;
8408 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
8409 6 : tmp = build3_v (COND_EXPR, present, tmp,
8410 : build_empty_stmt (input_location));
8411 : }
8412 11 : if (tmp != NULL_TREE)
8413 11 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8414 : }
8415 :
8416 161 : tmp = parmse.expr;
8417 : /* With bind(C), the actual argument is replaced by a bind-C
8418 : descriptor; in this case, the data component arrives here,
8419 : which shall not be dereferenced, but still freed and
8420 : nullified. */
8421 161 : if (TREE_TYPE(tmp) != pvoid_type_node)
8422 161 : tmp = build_fold_indirect_ref_loc (input_location,
8423 : parmse.expr);
8424 161 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8425 : NULL_TREE, NULL_TREE, true,
8426 : e,
8427 : GFC_CAF_COARRAY_NOCOARRAY);
8428 161 : if (fsym->attr.optional
8429 48 : && e->expr_type == EXPR_VARIABLE
8430 48 : && e->symtree->n.sym->attr.optional)
8431 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
8432 : void_type_node,
8433 24 : gfc_conv_expr_present (e->symtree->n.sym),
8434 : tmp, build_empty_stmt (input_location));
8435 161 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8436 : }
8437 : }
8438 : }
8439 : /* Special case for an assumed-rank dummy argument. */
8440 273527 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
8441 57666 : && (fsym->ts.type == BT_CLASS
8442 57666 : ? (CLASS_DATA (fsym)->as
8443 4696 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
8444 52970 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8445 : {
8446 12815 : if (fsym->ts.type == BT_CLASS
8447 12815 : ? (CLASS_DATA (fsym)->attr.class_pointer
8448 1067 : || CLASS_DATA (fsym)->attr.allocatable)
8449 11748 : : (fsym->attr.pointer || fsym->attr.allocatable))
8450 : {
8451 : /* Unallocated allocatable arrays and unassociated pointer
8452 : arrays need their dtype setting if they are argument
8453 : associated with assumed rank dummies to set the rank. */
8454 891 : set_dtype_for_unallocated (&parmse, e);
8455 : }
8456 11924 : else if (e->expr_type == EXPR_VARIABLE
8457 11421 : && e->symtree->n.sym->attr.dummy
8458 722 : && (e->ts.type == BT_CLASS
8459 915 : ? (e->ref && e->ref->next
8460 193 : && e->ref->next->type == REF_ARRAY
8461 193 : && e->ref->next->u.ar.type == AR_FULL
8462 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8463 529 : : (e->ref && e->ref->type == REF_ARRAY
8464 529 : && e->ref->u.ar.type == AR_FULL
8465 757 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8466 : {
8467 : /* Assumed-size actual to assumed-rank dummy requires
8468 : dim[rank-1].ubound = -1. */
8469 180 : tree minus_one;
8470 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8471 180 : if (fsym->ts.type == BT_CLASS)
8472 60 : tmp = gfc_class_data_get (tmp);
8473 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8474 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8475 180 : gfc_rank_cst[e->rank - 1],
8476 : minus_one);
8477 : }
8478 : }
8479 :
8480 : /* The case with fsym->attr.optional is that of a user subroutine
8481 : with an interface indicating an optional argument. When we call
8482 : an intrinsic subroutine, however, fsym is NULL, but we might still
8483 : have an optional argument, so we proceed to the substitution
8484 : just in case. Arguments passed to bind(c) procedures via CFI
8485 : descriptors are handled elsewhere. */
8486 260367 : if (e && (fsym == NULL || fsym->attr.optional)
8487 334146 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8488 : {
8489 : /* If an optional argument is itself an optional dummy argument,
8490 : check its presence and substitute a null if absent. This is
8491 : only needed when passing an array to an elemental procedure
8492 : as then array elements are accessed - or no NULL pointer is
8493 : allowed and a "1" or "0" should be passed if not present.
8494 : When passing a non-array-descriptor full array to a
8495 : non-array-descriptor dummy, no check is needed. For
8496 : array-descriptor actual to array-descriptor dummy, see
8497 : PR 41911 for why a check has to be inserted.
8498 : fsym == NULL is checked as intrinsics required the descriptor
8499 : but do not always set fsym.
8500 : Also, it is necessary to pass a NULL pointer to library routines
8501 : which usually ignore optional arguments, so they can handle
8502 : these themselves. */
8503 59525 : if (e->expr_type == EXPR_VARIABLE
8504 26584 : && e->symtree->n.sym->attr.optional
8505 2463 : && (((e->rank != 0 && elemental_proc)
8506 2288 : || e->representation.length || e->ts.type == BT_CHARACTER
8507 2044 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8508 1934 : || (e->rank != 0
8509 1094 : && (fsym == NULL
8510 1058 : || (fsym->as
8511 296 : && (fsym->as->type == AS_ASSUMED_SHAPE
8512 241 : || fsym->as->type == AS_ASSUMED_RANK
8513 123 : || fsym->as->type == AS_DEFERRED)))))
8514 1691 : || se->ignore_optional))
8515 800 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8516 800 : e->representation.length);
8517 : }
8518 :
8519 : /* Make the class container for the first argument available with class
8520 : valued transformational functions. */
8521 273527 : if (argc == 0 && e && e->ts.type == BT_CLASS
8522 5093 : && isym && isym->transformational
8523 84 : && se->ss && se->ss->info)
8524 : {
8525 84 : arg1_cntnr = parmse.expr;
8526 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8527 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8528 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8529 84 : se->ss->info->class_container = arg1_cntnr;
8530 : }
8531 :
8532 : /* Obtain the character length of an assumed character length procedure
8533 : from the typespec of the actual argument. */
8534 273527 : if (e
8535 260367 : && parmse.string_length == NULL_TREE
8536 224655 : && e->ts.type == BT_PROCEDURE
8537 1941 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8538 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8539 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8540 : {
8541 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8542 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8543 : }
8544 :
8545 273527 : if (fsym && e)
8546 : {
8547 : /* Obtain the character length for a NULL() actual with a character
8548 : MOLD argument. Otherwise substitute a suitable dummy length.
8549 : Here we handle non-optional dummies of non-bind(c) procedures. */
8550 228441 : if (e->expr_type == EXPR_NULL
8551 745 : && fsym->ts.type == BT_CHARACTER
8552 296 : && !fsym->attr.optional
8553 228659 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8554 216 : conv_null_actual (&parmse, e, fsym);
8555 : }
8556 :
8557 : /* If any actual argument of the procedure is allocatable and passed
8558 : to an allocatable dummy with INTENT(OUT), we conservatively
8559 : evaluate actual argument expressions before deallocations are
8560 : performed and the procedure is executed. May create temporaries.
8561 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8562 260367 : if (e && fsym && force_eval_args
8563 1144 : && fsym->attr.intent != INTENT_OUT
8564 273954 : && !gfc_is_constant_expr (e))
8565 274 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8566 :
8567 273527 : if (fsym && need_interface_mapping && e)
8568 40672 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8569 :
8570 273527 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8571 273527 : gfc_add_block_to_block (&post, &parmse.post);
8572 273527 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8573 :
8574 : /* Allocated allocatable components of derived types must be
8575 : deallocated for non-variable scalars, array arguments to elemental
8576 : procedures, and array arguments with descriptor to non-elemental
8577 : procedures. As bounds information for descriptorless arrays is no
8578 : longer available here, they are dealt with in trans-array.cc
8579 : (gfc_conv_array_parameter). */
8580 260367 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8581 28733 : && e->ts.u.derived->attr.alloc_comp
8582 7701 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8583 281084 : && !expr_may_alias_variables (e, elemental_proc))
8584 : {
8585 372 : int parm_rank;
8586 : /* It is known the e returns a structure type with at least one
8587 : allocatable component. When e is a function, ensure that the
8588 : function is called once only by using a temporary variable. */
8589 372 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8590 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8591 : parmse.expr, &se->pre);
8592 :
8593 372 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8594 152 : tmp = parmse.expr;
8595 : else
8596 220 : tmp = build_fold_indirect_ref_loc (input_location,
8597 : parmse.expr);
8598 :
8599 372 : parm_rank = e->rank;
8600 372 : switch (parm_kind)
8601 : {
8602 : case (ELEMENTAL):
8603 : case (SCALAR):
8604 372 : parm_rank = 0;
8605 : break;
8606 :
8607 0 : case (SCALAR_POINTER):
8608 0 : tmp = build_fold_indirect_ref_loc (input_location,
8609 : tmp);
8610 0 : break;
8611 : }
8612 :
8613 372 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8614 : {
8615 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8616 : Therefore, class actuals can be handled correctly but derived
8617 : types passed to class formals need the _data component. */
8618 82 : tmp = gfc_class_data_get (tmp);
8619 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8620 : {
8621 56 : if (UNLIMITED_POLY (fsym))
8622 : {
8623 12 : tree type = gfc_typenode_for_spec (&e->ts);
8624 12 : type = build_pointer_type (type);
8625 12 : tmp = fold_convert (type, tmp);
8626 : }
8627 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8628 : }
8629 : }
8630 :
8631 372 : if (e->expr_type == EXPR_OP
8632 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8633 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8634 : {
8635 24 : tree local_tmp;
8636 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8637 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8638 : parm_rank, 0);
8639 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8640 : }
8641 :
8642 : /* Items of array expressions passed to a polymorphic formal arguments
8643 : create their own clean up, so prevent double free. */
8644 372 : if (!finalized && !e->must_finalize
8645 371 : && !(e->expr_type == EXPR_ARRAY && fsym
8646 86 : && fsym->ts.type == BT_CLASS))
8647 : {
8648 351 : bool scalar_res_outside_loop;
8649 1041 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8650 151 : && parm_rank == 0
8651 490 : && parmse.loop;
8652 :
8653 : /* Scalars passed to an assumed rank argument are converted to
8654 : a descriptor. Obtain the data field before deallocating any
8655 : allocatable components. */
8656 298 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8657 612 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8658 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8659 :
8660 351 : if (scalar_res_outside_loop)
8661 : {
8662 : /* Go through the ss chain to find the argument and use
8663 : the stored value. */
8664 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8665 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8666 60 : if (tmp_ss->info
8667 48 : && tmp_ss->info->expr == e
8668 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8669 : {
8670 18 : tmp = tmp_ss->info->data.scalar.value;
8671 18 : break;
8672 : }
8673 : }
8674 :
8675 351 : STRIP_NOPS (tmp);
8676 :
8677 351 : if (derived_array != NULL_TREE)
8678 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8679 : derived_array,
8680 : parm_rank);
8681 351 : else if ((e->ts.type == BT_CLASS
8682 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8683 351 : || e->ts.type == BT_DERIVED)
8684 351 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8685 : parm_rank, 0, true);
8686 0 : else if (e->ts.type == BT_CLASS)
8687 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8688 : tmp, parm_rank);
8689 :
8690 351 : if (scalar_res_outside_loop)
8691 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8692 : else
8693 321 : gfc_prepend_expr_to_block (&post, tmp);
8694 : }
8695 : }
8696 :
8697 : /* Add argument checking of passing an unallocated/NULL actual to
8698 : a nonallocatable/nonpointer dummy. */
8699 :
8700 273527 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8701 : {
8702 6546 : symbol_attribute attr;
8703 6546 : char *msg;
8704 6546 : tree cond;
8705 6546 : tree tmp;
8706 6546 : symbol_attribute fsym_attr;
8707 :
8708 6546 : if (fsym)
8709 : {
8710 6385 : if (fsym->ts.type == BT_CLASS)
8711 : {
8712 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8713 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8714 : }
8715 : else
8716 6064 : fsym_attr = fsym->attr;
8717 : }
8718 :
8719 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8720 4094 : attr = gfc_expr_attr (e);
8721 : else
8722 6081 : goto end_pointer_check;
8723 :
8724 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8725 : allocatable to an optional dummy, cf. 12.5.2.12. */
8726 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8727 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8728 1032 : goto end_pointer_check;
8729 :
8730 3062 : if (attr.optional)
8731 : {
8732 : /* If the actual argument is an optional pointer/allocatable and
8733 : the formal argument takes an nonpointer optional value,
8734 : it is invalid to pass a non-present argument on, even
8735 : though there is no technical reason for this in gfortran.
8736 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8737 60 : tree present, null_ptr, type;
8738 :
8739 60 : if (attr.allocatable
8740 0 : && (fsym == NULL || !fsym_attr.allocatable))
8741 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8742 : "allocated or not present",
8743 0 : e->symtree->n.sym->name);
8744 60 : else if (attr.pointer
8745 12 : && (fsym == NULL || !fsym_attr.pointer))
8746 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8747 : "associated or not present",
8748 12 : e->symtree->n.sym->name);
8749 48 : else if (attr.proc_pointer && !e->value.function.actual
8750 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8751 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8752 : "associated or not present",
8753 0 : e->symtree->n.sym->name);
8754 : else
8755 48 : goto end_pointer_check;
8756 :
8757 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8758 12 : type = TREE_TYPE (present);
8759 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8760 : logical_type_node, present,
8761 : fold_convert (type,
8762 : null_pointer_node));
8763 12 : type = TREE_TYPE (parmse.expr);
8764 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8765 : logical_type_node, parmse.expr,
8766 : fold_convert (type,
8767 : null_pointer_node));
8768 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8769 : logical_type_node, present, null_ptr);
8770 : }
8771 : else
8772 : {
8773 3002 : if (attr.allocatable
8774 256 : && (fsym == NULL || !fsym_attr.allocatable))
8775 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8776 190 : "allocated", e->symtree->n.sym->name);
8777 2812 : else if (attr.pointer
8778 272 : && (fsym == NULL || !fsym_attr.pointer))
8779 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8780 184 : "associated", e->symtree->n.sym->name);
8781 2628 : else if (attr.proc_pointer && !e->value.function.actual
8782 80 : && (fsym == NULL
8783 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8784 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8785 79 : "associated", e->symtree->n.sym->name);
8786 : else
8787 2549 : goto end_pointer_check;
8788 :
8789 453 : tmp = parmse.expr;
8790 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8791 : {
8792 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8793 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8794 76 : tmp = gfc_class_data_get (tmp);
8795 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8796 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8797 : }
8798 :
8799 : /* If the argument is passed by value, we need to strip the
8800 : INDIRECT_REF. */
8801 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8802 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8803 :
8804 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8805 : logical_type_node, tmp,
8806 453 : fold_convert (TREE_TYPE (tmp),
8807 : null_pointer_node));
8808 : }
8809 :
8810 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8811 : msg);
8812 465 : free (msg);
8813 : }
8814 266981 : end_pointer_check:
8815 :
8816 : /* Deferred length dummies pass the character length by reference
8817 : so that the value can be returned. */
8818 273527 : if (parmse.string_length && fsym && fsym->ts.deferred)
8819 : {
8820 795 : if (INDIRECT_REF_P (parmse.string_length))
8821 : {
8822 : /* In chains of functions/procedure calls the string_length already
8823 : is a pointer to the variable holding the length. Therefore
8824 : remove the deref on call. */
8825 90 : tmp = parmse.string_length;
8826 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8827 : }
8828 : else
8829 : {
8830 705 : tmp = parmse.string_length;
8831 705 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8832 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8833 705 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8834 : }
8835 :
8836 795 : if (e && e->expr_type == EXPR_VARIABLE
8837 638 : && fsym->attr.allocatable
8838 368 : && e->ts.u.cl->backend_decl
8839 368 : && VAR_P (e->ts.u.cl->backend_decl))
8840 : {
8841 284 : if (INDIRECT_REF_P (tmp))
8842 0 : tmp = TREE_OPERAND (tmp, 0);
8843 284 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8844 : fold_convert (gfc_charlen_type_node, tmp));
8845 : }
8846 : }
8847 :
8848 : /* Character strings are passed as two parameters, a length and a
8849 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8850 : An unlimited polymorphic formal argument likewise does not
8851 : need the length. */
8852 273527 : if (parmse.string_length != NULL_TREE
8853 37140 : && !sym->attr.is_bind_c
8854 36444 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8855 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8856 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8857 30559 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8858 30450 : && !(fsym && UNLIMITED_POLY (fsym)))
8859 36154 : vec_safe_push (stringargs, parmse.string_length);
8860 :
8861 : /* When calling __copy for character expressions to unlimited
8862 : polymorphic entities, the dst argument needs a string length. */
8863 52036 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8864 5326 : && startswith (sym->name, "__vtab_CHARACTER")
8865 0 : && arg->next && arg->next->expr
8866 0 : && (arg->next->expr->ts.type == BT_DERIVED
8867 0 : || arg->next->expr->ts.type == BT_CLASS)
8868 273527 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8869 0 : vec_safe_push (stringargs, parmse.string_length);
8870 :
8871 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8872 : pass the token and the offset as additional arguments. */
8873 273527 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8874 132 : && attr->codimension && !attr->allocatable)
8875 : {
8876 : /* Token and offset. */
8877 5 : vec_safe_push (stringargs, null_pointer_node);
8878 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8879 5 : gcc_assert (fsym->attr.optional);
8880 : }
8881 240538 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8882 145 : && !attr->allocatable)
8883 : {
8884 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8885 123 : tree offset, tmp2;
8886 :
8887 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8888 123 : caf_type = TREE_TYPE (caf_decl);
8889 123 : if (POINTER_TYPE_P (caf_type)
8890 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8891 3 : caf_desc = TREE_TYPE (caf_type);
8892 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8893 : caf_desc = caf_type;
8894 :
8895 51 : if (caf_desc
8896 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8897 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8898 : {
8899 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8900 54 : ? build_fold_indirect_ref (caf_decl)
8901 : : caf_decl;
8902 51 : tmp = gfc_conv_descriptor_token (tmp);
8903 : }
8904 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8905 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8906 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8907 : else
8908 : {
8909 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8910 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8911 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8912 : }
8913 :
8914 123 : vec_safe_push (stringargs, tmp);
8915 :
8916 123 : if (caf_desc
8917 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8918 51 : offset = build_int_cst (gfc_array_index_type, 0);
8919 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8920 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8921 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8922 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8923 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8924 : else
8925 60 : offset = build_int_cst (gfc_array_index_type, 0);
8926 :
8927 123 : if (caf_desc)
8928 : {
8929 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8930 54 : ? build_fold_indirect_ref (caf_decl)
8931 : : caf_decl;
8932 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8933 : }
8934 : else
8935 : {
8936 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8937 72 : tmp = caf_decl;
8938 : }
8939 :
8940 108 : tmp2 = fsym->ts.type == BT_CLASS
8941 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8942 123 : if ((fsym->ts.type != BT_CLASS
8943 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8944 59 : || fsym->as->type == AS_ASSUMED_RANK))
8945 74 : || (fsym->ts.type == BT_CLASS
8946 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8947 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8948 : {
8949 54 : if (fsym->ts.type == BT_CLASS)
8950 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8951 : else
8952 : {
8953 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8954 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8955 : }
8956 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8957 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8958 : }
8959 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8960 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8961 : else
8962 : {
8963 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8964 : }
8965 :
8966 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8967 : gfc_array_index_type,
8968 : fold_convert (gfc_array_index_type, tmp2),
8969 : fold_convert (gfc_array_index_type, tmp));
8970 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8971 : gfc_array_index_type, offset, tmp);
8972 :
8973 123 : vec_safe_push (stringargs, offset);
8974 : }
8975 :
8976 273527 : vec_safe_push (arglist, parmse.expr);
8977 : }
8978 :
8979 132450 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8980 132450 : gfc_add_block_to_block (&se->pre, &clobbers);
8981 132450 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8982 :
8983 132450 : if (comp)
8984 2000 : ts = comp->ts;
8985 130450 : else if (sym->ts.type == BT_CLASS)
8986 863 : ts = CLASS_DATA (sym)->ts;
8987 : else
8988 129587 : ts = sym->ts;
8989 :
8990 132450 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8991 210 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8992 132240 : else if (ts.type == BT_CHARACTER)
8993 : {
8994 5046 : if (ts.u.cl->length == NULL)
8995 : {
8996 : /* Assumed character length results are not allowed by C418 of the 2003
8997 : standard and are trapped in resolve.cc; except in the case of SPREAD
8998 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8999 : we take the character length of the first argument for the result.
9000 : For dummies, we have to look through the formal argument list for
9001 : this function and use the character length found there.
9002 : Likewise, we handle the case of deferred-length character dummy
9003 : arguments to intrinsics that determine the characteristics of
9004 : the result, which cannot be deferred-length. */
9005 2315 : if (expr->value.function.isym)
9006 1703 : ts.deferred = false;
9007 2315 : if (ts.deferred)
9008 605 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
9009 1710 : else if (!sym->attr.dummy)
9010 1703 : cl.backend_decl = (*stringargs)[0];
9011 : else
9012 : {
9013 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
9014 26 : for (; formal; formal = formal->next)
9015 12 : if (strcmp (formal->sym->name, sym->name) == 0)
9016 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
9017 : }
9018 : len = cl.backend_decl;
9019 : }
9020 : else
9021 : {
9022 2731 : tree tmp;
9023 :
9024 : /* Calculate the length of the returned string. */
9025 2731 : gfc_init_se (&parmse, NULL);
9026 2731 : if (need_interface_mapping)
9027 1885 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
9028 : else
9029 846 : gfc_conv_expr (&parmse, ts.u.cl->length);
9030 2731 : gfc_add_block_to_block (&se->pre, &parmse.pre);
9031 2731 : gfc_add_block_to_block (&se->post, &parmse.post);
9032 2731 : tmp = parmse.expr;
9033 : /* TODO: It would be better to have the charlens as
9034 : gfc_charlen_type_node already when the interface is
9035 : created instead of converting it here (see PR 84615). */
9036 2731 : tmp = fold_build2_loc (input_location, MAX_EXPR,
9037 : gfc_charlen_type_node,
9038 : fold_convert (gfc_charlen_type_node, tmp),
9039 : build_zero_cst (gfc_charlen_type_node));
9040 2731 : cl.backend_decl = tmp;
9041 :
9042 : /* The length was fully computed above from the specification
9043 : expression, without needing the callee to actually run. */
9044 2731 : call_needed_for_length = false;
9045 : }
9046 :
9047 : /* Set up a charlen structure for it. */
9048 5046 : cl.next = NULL;
9049 5046 : cl.length = NULL;
9050 5046 : ts.u.cl = &cl;
9051 :
9052 5046 : len = cl.backend_decl;
9053 : }
9054 :
9055 2000 : byref = (comp && (comp->attr.dimension
9056 1931 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
9057 132450 : || (!comp && gfc_return_by_reference (sym));
9058 :
9059 : if (byref)
9060 : {
9061 18835 : if (se->direct_byref)
9062 : {
9063 : /* Sometimes, too much indirection can be applied; e.g. for
9064 : function_result = array_valued_recursive_function. */
9065 6993 : if (TREE_TYPE (TREE_TYPE (se->expr))
9066 6993 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
9067 7011 : && GFC_DESCRIPTOR_TYPE_P
9068 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
9069 18 : se->expr = build_fold_indirect_ref_loc (input_location,
9070 : se->expr);
9071 :
9072 : /* If the lhs of an assignment x = f(..) is allocatable and
9073 : f2003 is allowed, we must do the automatic reallocation.
9074 : TODO - deal with intrinsics, without using a temporary. */
9075 6993 : if (flag_realloc_lhs
9076 6918 : && se->ss && se->ss->loop_chain
9077 203 : && se->ss->loop_chain->is_alloc_lhs
9078 203 : && !expr->value.function.isym
9079 203 : && sym->result->as != NULL)
9080 : {
9081 : /* Evaluate the bounds of the result, if known. */
9082 203 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
9083 : sym->result->as);
9084 :
9085 : /* Perform the automatic reallocation. */
9086 203 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
9087 : expr, NULL);
9088 203 : gfc_add_expr_to_block (&se->pre, tmp);
9089 :
9090 : /* Pass the temporary as the first argument. */
9091 203 : result = info->descriptor;
9092 : }
9093 : else
9094 6790 : result = build_fold_indirect_ref_loc (input_location,
9095 : se->expr);
9096 6993 : vec_safe_push (retargs, se->expr);
9097 : }
9098 11842 : else if (comp && comp->attr.dimension)
9099 : {
9100 66 : gcc_assert (se->loop && info);
9101 :
9102 : /* Set the type of the array. vtable charlens are not always reliable.
9103 : Use the interface, if possible. */
9104 66 : if (comp->ts.type == BT_CHARACTER
9105 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
9106 1 : && comp->ts.interface && comp->ts.interface->result)
9107 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
9108 : else
9109 65 : tmp = gfc_typenode_for_spec (&comp->ts);
9110 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
9111 :
9112 : /* Evaluate the bounds of the result, if known. */
9113 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
9114 :
9115 : /* If the lhs of an assignment x = f(..) is allocatable and
9116 : f2003 is allowed, we must not generate the function call
9117 : here but should just send back the results of the mapping.
9118 : This is signalled by the function ss being flagged. */
9119 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
9120 : {
9121 0 : gfc_free_interface_mapping (&mapping);
9122 0 : return has_alternate_specifier;
9123 : }
9124 :
9125 : /* Create a temporary to store the result. In case the function
9126 : returns a pointer, the temporary will be a shallow copy and
9127 : mustn't be deallocated. */
9128 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
9129 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
9130 : tmp, NULL_TREE, false,
9131 : !comp->attr.pointer, callee_alloc,
9132 66 : &se->ss->info->expr->where);
9133 :
9134 : /* Pass the temporary as the first argument. */
9135 66 : result = info->descriptor;
9136 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
9137 66 : vec_safe_push (retargs, tmp);
9138 : }
9139 11547 : else if (!comp && sym->result->attr.dimension)
9140 : {
9141 8492 : gcc_assert (se->loop && info);
9142 :
9143 : /* Set the type of the array. */
9144 8492 : tmp = gfc_typenode_for_spec (&ts);
9145 8492 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
9146 8492 : gcc_assert (se->ss->dimen == se->loop->dimen);
9147 :
9148 : /* Evaluate the bounds of the result, if known. */
9149 8492 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
9150 :
9151 : /* If the lhs of an assignment x = f(..) is allocatable and
9152 : f2003 is allowed, we must not generate the function call
9153 : here but should just send back the results of the mapping.
9154 : This is signalled by the function ss being flagged. */
9155 8492 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
9156 : {
9157 0 : gfc_free_interface_mapping (&mapping);
9158 0 : return has_alternate_specifier;
9159 : }
9160 :
9161 : /* Create a temporary to store the result. In case the function
9162 : returns a pointer, the temporary will be a shallow copy and
9163 : mustn't be deallocated. */
9164 8492 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
9165 8492 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
9166 : tmp, NULL_TREE, false,
9167 : !sym->attr.pointer, callee_alloc,
9168 8492 : &se->ss->info->expr->where);
9169 :
9170 : /* Pass the temporary as the first argument. */
9171 8492 : result = info->descriptor;
9172 8492 : tmp = gfc_build_addr_expr (NULL_TREE, result);
9173 8492 : vec_safe_push (retargs, tmp);
9174 : }
9175 3284 : else if (ts.type == BT_CHARACTER)
9176 : {
9177 : /* Pass the string length. */
9178 3223 : type = gfc_get_character_type (ts.kind, ts.u.cl);
9179 3223 : type = build_pointer_type (type);
9180 :
9181 : /* Emit a DECL_EXPR for the VLA type. */
9182 3223 : tmp = TREE_TYPE (type);
9183 3223 : if (TYPE_SIZE (tmp)
9184 3223 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
9185 : {
9186 1935 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
9187 1935 : DECL_ARTIFICIAL (tmp) = 1;
9188 1935 : DECL_IGNORED_P (tmp) = 1;
9189 1935 : tmp = fold_build1_loc (input_location, DECL_EXPR,
9190 1935 : TREE_TYPE (tmp), tmp);
9191 1935 : gfc_add_expr_to_block (&se->pre, tmp);
9192 : }
9193 :
9194 : /* Return an address to a char[0:len-1]* temporary for
9195 : character pointers. */
9196 3223 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9197 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9198 : {
9199 648 : var = gfc_create_var (type, "pstr");
9200 :
9201 648 : if ((!comp && sym->attr.allocatable)
9202 21 : || (comp && comp->attr.allocatable))
9203 : {
9204 361 : gfc_add_modify (&se->pre, var,
9205 361 : fold_convert (TREE_TYPE (var),
9206 : null_pointer_node));
9207 361 : tmp = gfc_call_free (var);
9208 361 : gfc_add_expr_to_block (&se->post, tmp);
9209 : }
9210 :
9211 : /* Provide an address expression for the function arguments. */
9212 648 : var = gfc_build_addr_expr (NULL_TREE, var);
9213 : }
9214 : else
9215 2575 : var = gfc_conv_string_tmp (se, type, len);
9216 :
9217 3223 : vec_safe_push (retargs, var);
9218 : }
9219 : else
9220 : {
9221 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
9222 :
9223 61 : type = gfc_get_complex_type (ts.kind);
9224 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
9225 61 : vec_safe_push (retargs, var);
9226 : }
9227 :
9228 : /* Add the string length to the argument list. */
9229 18835 : if (ts.type == BT_CHARACTER && ts.deferred)
9230 : {
9231 605 : tmp = len;
9232 605 : if (!VAR_P (tmp))
9233 0 : tmp = gfc_evaluate_now (len, &se->pre);
9234 605 : TREE_STATIC (tmp) = 1;
9235 605 : gfc_add_modify (&se->pre, tmp,
9236 605 : build_int_cst (TREE_TYPE (tmp), 0));
9237 605 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
9238 605 : vec_safe_push (retargs, tmp);
9239 : }
9240 18230 : else if (ts.type == BT_CHARACTER)
9241 4441 : vec_safe_push (retargs, len);
9242 : }
9243 :
9244 132450 : gfc_free_interface_mapping (&mapping);
9245 :
9246 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
9247 246480 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
9248 158011 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
9249 132450 : vec_safe_reserve (retargs, arglen);
9250 :
9251 : /* Add the return arguments. */
9252 132450 : vec_safe_splice (retargs, arglist);
9253 :
9254 : /* Add the hidden present status for optional+value to the arguments. */
9255 132450 : vec_safe_splice (retargs, optionalargs);
9256 :
9257 : /* Add the hidden string length parameters to the arguments. */
9258 132450 : vec_safe_splice (retargs, stringargs);
9259 :
9260 : /* We may want to append extra arguments here. This is used e.g. for
9261 : calls to libgfortran_matmul_??, which need extra information. */
9262 132450 : vec_safe_splice (retargs, append_args);
9263 :
9264 132450 : arglist = retargs;
9265 :
9266 : /* Generate the actual call. */
9267 132450 : is_builtin = false;
9268 132450 : if (base_object == NULL_TREE)
9269 132370 : conv_function_val (se, &is_builtin, sym, expr, args);
9270 : else
9271 80 : conv_base_obj_fcn_val (se, base_object, expr);
9272 :
9273 : /* If there are alternate return labels, function type should be
9274 : integer. Can't modify the type in place though, since it can be shared
9275 : with other functions. For dummy arguments, the typing is done to
9276 : this result, even if it has to be repeated for each call. */
9277 132450 : if (has_alternate_specifier
9278 132450 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
9279 : {
9280 7 : if (!sym->attr.dummy)
9281 : {
9282 0 : TREE_TYPE (sym->backend_decl)
9283 0 : = build_function_type (integer_type_node,
9284 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
9285 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
9286 : }
9287 : else
9288 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
9289 : }
9290 :
9291 132450 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
9292 132450 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
9293 :
9294 132450 : if (is_builtin)
9295 567 : se->expr = update_builtin_function (se->expr, sym);
9296 :
9297 : /* Allocatable scalar function results must be freed and nullified
9298 : after use. This necessitates the creation of a temporary to
9299 : hold the result to prevent duplicate calls. */
9300 132450 : symbol_attribute attr = comp ? comp->attr : sym->attr;
9301 132450 : bool allocatable = attr.allocatable && !attr.dimension;
9302 135806 : gfc_symbol *der = comp ?
9303 2000 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
9304 : :
9305 130450 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
9306 3356 : bool finalizable = der != NULL && der->ns->proc_name
9307 6709 : && gfc_is_finalizable (der, NULL);
9308 :
9309 132450 : if (!byref && finalizable)
9310 188 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9311 :
9312 132450 : if (!byref && sym->ts.type != BT_CHARACTER
9313 113405 : && allocatable && !finalizable)
9314 : {
9315 236 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
9316 236 : gfc_add_modify (&se->pre, tmp, se->expr);
9317 236 : se->expr = tmp;
9318 236 : tmp = gfc_call_free (tmp);
9319 236 : gfc_add_expr_to_block (&post, tmp);
9320 236 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
9321 : }
9322 :
9323 : /* If we have a pointer function, but we don't want a pointer, e.g.
9324 : something like
9325 : x = f()
9326 : where f is pointer valued, we have to dereference the result. */
9327 132450 : if (!se->want_pointer && !byref
9328 113013 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9329 1658 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
9330 462 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9331 :
9332 : /* f2c calling conventions require a scalar default real function to
9333 : return a double precision result. Convert this back to default
9334 : real. We only care about the cases that can happen in Fortran 77.
9335 : */
9336 132450 : if (flag_f2c && sym->ts.type == BT_REAL
9337 98 : && sym->ts.kind == gfc_default_real_kind
9338 74 : && !sym->attr.pointer
9339 55 : && !sym->attr.allocatable
9340 43 : && !sym->attr.always_explicit)
9341 43 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
9342 :
9343 : /* A pure function may still have side-effects - it may modify its
9344 : parameters. */
9345 132450 : TREE_SIDE_EFFECTS (se->expr) = 1;
9346 : #if 0
9347 : if (!sym->attr.pure)
9348 : TREE_SIDE_EFFECTS (se->expr) = 1;
9349 : #endif
9350 :
9351 132450 : if (byref)
9352 : {
9353 : /* Add the function call to the pre chain. There is no expression. */
9354 18835 : if (!se->no_function_call || call_needed_for_length)
9355 18803 : gfc_add_expr_to_block (&se->pre, se->expr);
9356 :
9357 18835 : se->expr = NULL_TREE;
9358 :
9359 18835 : if (!se->direct_byref)
9360 : {
9361 11842 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
9362 : {
9363 8558 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
9364 : {
9365 : /* Check the data pointer hasn't been modified. This would
9366 : happen in a function returning a pointer. */
9367 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9368 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
9369 : logical_type_node,
9370 : tmp, info->data);
9371 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
9372 : gfc_msg_fault);
9373 : }
9374 8558 : se->expr = info->descriptor;
9375 : /* Bundle in the string length. */
9376 8558 : se->string_length = len;
9377 :
9378 8558 : if (finalizable)
9379 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9380 : }
9381 3284 : else if (ts.type == BT_CHARACTER)
9382 : {
9383 : /* Dereference for character pointer results. */
9384 3223 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9385 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9386 648 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9387 : else
9388 2575 : se->expr = var;
9389 :
9390 3223 : se->string_length = len;
9391 : }
9392 : else
9393 : {
9394 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
9395 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9396 : }
9397 : }
9398 : }
9399 :
9400 : /* Associate the rhs class object's meta-data with the result, when the
9401 : result is a temporary. */
9402 114035 : if (args && args->expr && args->expr->ts.type == BT_CLASS
9403 5105 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
9404 132482 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
9405 : {
9406 32 : gfc_se parmse;
9407 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
9408 :
9409 32 : gfc_init_se (&parmse, NULL);
9410 32 : parmse.data_not_needed = 1;
9411 32 : gfc_conv_expr (&parmse, class_expr);
9412 32 : if (!DECL_LANG_SPECIFIC (result))
9413 32 : gfc_allocate_lang_decl (result);
9414 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
9415 32 : gfc_free_expr (class_expr);
9416 : /* -fcheck= can add diagnostic code, which has to be placed before
9417 : the call. */
9418 32 : if (parmse.pre.head != NULL)
9419 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
9420 32 : gcc_assert (parmse.post.head == NULL_TREE);
9421 : }
9422 :
9423 : /* Follow the function call with the argument post block. */
9424 132450 : if (byref)
9425 : {
9426 : /* Transformational functions of derived types with allocatable
9427 : components must have the result allocatable components copied
9428 : BEFORE the argument post block is appended. Copying the result
9429 : first, then freeing the argument, gives the correct order. */
9430 18835 : arg = expr->value.function.actual;
9431 18835 : if (result && arg && expr->rank
9432 14704 : && isym && isym->transformational
9433 13123 : && isym->id != GFC_ISYM_REDUCE
9434 12997 : && arg->expr
9435 12937 : && arg->expr->ts.type == BT_DERIVED
9436 241 : && arg->expr->ts.u.derived->attr.alloc_comp)
9437 : {
9438 48 : tree tmp2;
9439 : /* Copy the allocatable components. We have to use a
9440 : temporary here to prevent source allocatable components
9441 : from being corrupted. */
9442 48 : tmp2 = gfc_evaluate_now (result, &se->pre);
9443 48 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
9444 : result, tmp2, expr->rank, 0);
9445 48 : gfc_add_expr_to_block (&se->pre, tmp);
9446 48 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
9447 : expr->rank);
9448 48 : gfc_add_expr_to_block (&se->pre, tmp);
9449 :
9450 : /* Finally free the temporary's data field. */
9451 48 : tmp = gfc_conv_descriptor_data_get (tmp2);
9452 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9453 : NULL_TREE, NULL_TREE, true,
9454 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9455 48 : gfc_add_expr_to_block (&se->pre, tmp);
9456 : }
9457 :
9458 18835 : gfc_add_block_to_block (&se->pre, &post);
9459 : }
9460 : else
9461 : {
9462 : /* For a function with a class array result, save the result as
9463 : a temporary, set the info fields needed by the scalarizer and
9464 : call the finalization function of the temporary. Note that the
9465 : nullification of allocatable components needed by the result
9466 : is done in gfc_trans_assignment_1. */
9467 35501 : if (expr && (gfc_is_class_array_function (expr)
9468 35179 : || gfc_is_alloc_class_scalar_function (expr))
9469 853 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9470 114456 : && expr->must_finalize)
9471 : {
9472 : /* TODO Eliminate the doubling of temporaries. This
9473 : one is necessary to ensure no memory leakage. */
9474 333 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9475 :
9476 : /* Finalize the result, if necessary. */
9477 666 : attr = expr->value.function.esym
9478 333 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9479 14 : : CLASS_DATA (expr)->attr;
9480 333 : if (!((gfc_is_class_array_function (expr)
9481 120 : || gfc_is_alloc_class_scalar_function (expr))
9482 333 : && attr.pointer))
9483 288 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9484 : }
9485 113615 : gfc_add_block_to_block (&se->post, &post);
9486 : }
9487 :
9488 : return has_alternate_specifier;
9489 : }
9490 :
9491 :
9492 : /* Fill a character string with spaces. */
9493 :
9494 : static tree
9495 31014 : fill_with_spaces (tree start, tree type, tree size)
9496 : {
9497 31014 : stmtblock_t block, loop;
9498 31014 : tree i, el, exit_label, cond, tmp;
9499 :
9500 : /* For a simple char type, we can call memset(). */
9501 31014 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9502 51416 : return build_call_expr_loc (input_location,
9503 : builtin_decl_explicit (BUILT_IN_MEMSET),
9504 : 3, start,
9505 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9506 25708 : lang_hooks.to_target_charset (' ')),
9507 : fold_convert (size_type_node, size));
9508 :
9509 : /* Otherwise, we use a loop:
9510 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9511 : *el = (type) ' ';
9512 : */
9513 :
9514 : /* Initialize variables. */
9515 5306 : gfc_init_block (&block);
9516 5306 : i = gfc_create_var (sizetype, "i");
9517 5306 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9518 5306 : el = gfc_create_var (build_pointer_type (type), "el");
9519 5306 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9520 5306 : exit_label = gfc_build_label_decl (NULL_TREE);
9521 5306 : TREE_USED (exit_label) = 1;
9522 :
9523 :
9524 : /* Loop body. */
9525 5306 : gfc_init_block (&loop);
9526 :
9527 : /* Exit condition. */
9528 5306 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9529 : build_zero_cst (sizetype));
9530 5306 : tmp = build1_v (GOTO_EXPR, exit_label);
9531 5306 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9532 : build_empty_stmt (input_location));
9533 5306 : gfc_add_expr_to_block (&loop, tmp);
9534 :
9535 : /* Assignment. */
9536 5306 : gfc_add_modify (&loop,
9537 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9538 5306 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9539 :
9540 : /* Increment loop variables. */
9541 5306 : gfc_add_modify (&loop, i,
9542 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9543 5306 : TYPE_SIZE_UNIT (type)));
9544 5306 : gfc_add_modify (&loop, el,
9545 : fold_build_pointer_plus_loc (input_location,
9546 5306 : el, TYPE_SIZE_UNIT (type)));
9547 :
9548 : /* Making the loop... actually loop! */
9549 5306 : tmp = gfc_finish_block (&loop);
9550 5306 : tmp = build1_v (LOOP_EXPR, tmp);
9551 5306 : gfc_add_expr_to_block (&block, tmp);
9552 :
9553 : /* The exit label. */
9554 5306 : tmp = build1_v (LABEL_EXPR, exit_label);
9555 5306 : gfc_add_expr_to_block (&block, tmp);
9556 :
9557 :
9558 5306 : return gfc_finish_block (&block);
9559 : }
9560 :
9561 :
9562 : /* Generate code to copy a string. */
9563 :
9564 : void
9565 36249 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9566 : int dkind, tree slength, tree src, int skind)
9567 : {
9568 36249 : tree tmp, dlen, slen;
9569 36249 : tree dsc;
9570 36249 : tree ssc;
9571 36249 : tree cond;
9572 36249 : tree cond2;
9573 36249 : tree tmp2;
9574 36249 : tree tmp3;
9575 36249 : tree tmp4;
9576 36249 : tree chartype;
9577 36249 : stmtblock_t tempblock;
9578 :
9579 36249 : gcc_assert (dkind == skind);
9580 :
9581 36249 : if (slength != NULL_TREE)
9582 : {
9583 36249 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9584 36249 : ssc = gfc_string_to_single_character (slen, src, skind);
9585 : }
9586 : else
9587 : {
9588 0 : slen = build_one_cst (gfc_charlen_type_node);
9589 0 : ssc = src;
9590 : }
9591 :
9592 36249 : if (dlength != NULL_TREE)
9593 : {
9594 36249 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9595 36249 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9596 : }
9597 : else
9598 : {
9599 0 : dlen = build_one_cst (gfc_charlen_type_node);
9600 0 : dsc = dest;
9601 : }
9602 :
9603 : /* Assign directly if the types are compatible. */
9604 36249 : if (dsc != NULL_TREE && ssc != NULL_TREE
9605 36249 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9606 : {
9607 5235 : gfc_add_modify (block, dsc, ssc);
9608 5235 : return;
9609 : }
9610 :
9611 : /* The string copy algorithm below generates code like
9612 :
9613 : if (destlen > 0)
9614 : {
9615 : if (srclen < destlen)
9616 : {
9617 : memmove (dest, src, srclen);
9618 : // Pad with spaces.
9619 : memset (&dest[srclen], ' ', destlen - srclen);
9620 : }
9621 : else
9622 : {
9623 : // Truncate if too long.
9624 : memmove (dest, src, destlen);
9625 : }
9626 : }
9627 : */
9628 :
9629 : /* Do nothing if the destination length is zero. */
9630 31014 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9631 31014 : build_zero_cst (TREE_TYPE (dlen)));
9632 :
9633 : /* For non-default character kinds, we have to multiply the string
9634 : length by the base type size. */
9635 31014 : chartype = gfc_get_char_type (dkind);
9636 31014 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9637 : slen,
9638 31014 : fold_convert (TREE_TYPE (slen),
9639 : TYPE_SIZE_UNIT (chartype)));
9640 31014 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9641 : dlen,
9642 31014 : fold_convert (TREE_TYPE (dlen),
9643 : TYPE_SIZE_UNIT (chartype)));
9644 :
9645 31014 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9646 30966 : dest = fold_convert (pvoid_type_node, dest);
9647 : else
9648 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9649 :
9650 31014 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9651 31010 : src = fold_convert (pvoid_type_node, src);
9652 : else
9653 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9654 :
9655 : /* Truncate string if source is too long. */
9656 31014 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9657 : dlen);
9658 :
9659 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9660 31014 : if (!CONSTANT_CLASS_P (cond2))
9661 : {
9662 9514 : dest = gfc_evaluate_now (dest, block);
9663 9514 : src = gfc_evaluate_now (src, block);
9664 : }
9665 :
9666 : /* Copy and pad with spaces. */
9667 31014 : tmp3 = build_call_expr_loc (input_location,
9668 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9669 : 3, dest, src,
9670 : fold_convert (size_type_node, slen));
9671 :
9672 : /* Wstringop-overflow appears at -O3 even though this warning is not
9673 : explicitly available in fortran nor can it be switched off. If the
9674 : source length is a constant, its negative appears as a very large
9675 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9676 : the result of the MINUS_EXPR suppresses this spurious warning. */
9677 31014 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9678 31014 : TREE_TYPE(dlen), dlen, slen);
9679 31014 : if (slength && TREE_CONSTANT (slength))
9680 27440 : tmp = gfc_evaluate_now (tmp, block);
9681 :
9682 31014 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9683 31014 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9684 :
9685 31014 : gfc_init_block (&tempblock);
9686 31014 : gfc_add_expr_to_block (&tempblock, tmp3);
9687 31014 : gfc_add_expr_to_block (&tempblock, tmp4);
9688 31014 : tmp3 = gfc_finish_block (&tempblock);
9689 :
9690 : /* The truncated memmove if the slen >= dlen. */
9691 31014 : tmp2 = build_call_expr_loc (input_location,
9692 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9693 : 3, dest, src,
9694 : fold_convert (size_type_node, dlen));
9695 :
9696 : /* The whole copy_string function is there. */
9697 31014 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9698 : tmp3, tmp2);
9699 31014 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9700 : build_empty_stmt (input_location));
9701 31014 : gfc_add_expr_to_block (block, tmp);
9702 : }
9703 :
9704 :
9705 : /* Translate a statement function.
9706 : The value of a statement function reference is obtained by evaluating the
9707 : expression using the values of the actual arguments for the values of the
9708 : corresponding dummy arguments. */
9709 :
9710 : static void
9711 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9712 : {
9713 269 : gfc_symbol *sym;
9714 269 : gfc_symbol *fsym;
9715 269 : gfc_formal_arglist *fargs;
9716 269 : gfc_actual_arglist *args;
9717 269 : gfc_se lse;
9718 269 : gfc_se rse;
9719 269 : gfc_saved_var *saved_vars;
9720 269 : tree *temp_vars;
9721 269 : tree type;
9722 269 : tree tmp;
9723 269 : int n;
9724 :
9725 269 : sym = expr->symtree->n.sym;
9726 269 : args = expr->value.function.actual;
9727 269 : gfc_init_se (&lse, NULL);
9728 269 : gfc_init_se (&rse, NULL);
9729 :
9730 269 : n = 0;
9731 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9732 458 : n++;
9733 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9734 269 : temp_vars = XCNEWVEC (tree, n);
9735 :
9736 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9737 458 : fargs = fargs->next, n++)
9738 : {
9739 : /* Each dummy shall be specified, explicitly or implicitly, to be
9740 : scalar. */
9741 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9742 458 : fsym = fargs->sym;
9743 :
9744 458 : if (fsym->ts.type == BT_CHARACTER)
9745 : {
9746 : /* Copy string arguments. */
9747 48 : tree arglen;
9748 :
9749 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9750 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9751 :
9752 : /* Create a temporary to hold the value. */
9753 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9754 1 : fsym->ts.u.cl->backend_decl
9755 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9756 :
9757 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9758 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9759 :
9760 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9761 :
9762 48 : gfc_conv_expr (&rse, args->expr);
9763 48 : gfc_conv_string_parameter (&rse);
9764 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9765 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9766 :
9767 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9768 : rse.string_length, rse.expr, fsym->ts.kind);
9769 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9770 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9771 : }
9772 : else
9773 : {
9774 : /* For everything else, just evaluate the expression. */
9775 :
9776 : /* Create a temporary to hold the value. */
9777 410 : type = gfc_typenode_for_spec (&fsym->ts);
9778 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9779 :
9780 410 : gfc_conv_expr (&lse, args->expr);
9781 :
9782 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9783 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9784 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9785 : }
9786 :
9787 458 : args = args->next;
9788 : }
9789 :
9790 : /* Use the temporary variables in place of the real ones. */
9791 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9792 458 : fargs = fargs->next, n++)
9793 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9794 :
9795 269 : gfc_conv_expr (se, sym->value);
9796 :
9797 269 : if (sym->ts.type == BT_CHARACTER)
9798 : {
9799 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9800 :
9801 : /* Force the expression to the correct length. */
9802 55 : if (!INTEGER_CST_P (se->string_length)
9803 101 : || tree_int_cst_lt (se->string_length,
9804 46 : sym->ts.u.cl->backend_decl))
9805 : {
9806 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9807 31 : tmp = gfc_create_var (type, sym->name);
9808 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9809 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9810 : sym->ts.kind, se->string_length, se->expr,
9811 : sym->ts.kind);
9812 31 : se->expr = tmp;
9813 : }
9814 55 : se->string_length = sym->ts.u.cl->backend_decl;
9815 : }
9816 :
9817 : /* Restore the original variables. */
9818 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9819 458 : fargs = fargs->next, n++)
9820 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9821 269 : free (temp_vars);
9822 269 : free (saved_vars);
9823 269 : }
9824 :
9825 :
9826 : /* Translate a function expression. */
9827 :
9828 : static void
9829 317409 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9830 : {
9831 317409 : gfc_symbol *sym;
9832 :
9833 317409 : if (expr->value.function.isym)
9834 : {
9835 266118 : gfc_conv_intrinsic_function (se, expr);
9836 266118 : return;
9837 : }
9838 :
9839 : /* expr.value.function.esym is the resolved (specific) function symbol for
9840 : most functions. However this isn't set for dummy procedures. */
9841 51291 : sym = expr->value.function.esym;
9842 51291 : if (!sym)
9843 1640 : sym = expr->symtree->n.sym;
9844 :
9845 : /* The IEEE_ARITHMETIC functions are caught here. */
9846 51291 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9847 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9848 : return;
9849 :
9850 : /* We distinguish statement functions from general functions to improve
9851 : runtime performance. */
9852 38834 : if (sym->attr.proc == PROC_ST_FUNCTION)
9853 : {
9854 269 : gfc_conv_statement_function (se, expr);
9855 269 : return;
9856 : }
9857 :
9858 38565 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9859 : NULL);
9860 : }
9861 :
9862 :
9863 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9864 :
9865 : static bool
9866 40212 : is_zero_initializer_p (gfc_expr * expr)
9867 : {
9868 40212 : if (expr->expr_type != EXPR_CONSTANT)
9869 : return false;
9870 :
9871 : /* We ignore constants with prescribed memory representations for now. */
9872 11574 : if (expr->representation.string)
9873 : return false;
9874 :
9875 11556 : switch (expr->ts.type)
9876 : {
9877 5399 : case BT_INTEGER:
9878 5399 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9879 :
9880 4849 : case BT_REAL:
9881 4849 : return mpfr_zero_p (expr->value.real)
9882 4849 : && MPFR_SIGN (expr->value.real) >= 0;
9883 :
9884 931 : case BT_LOGICAL:
9885 931 : return expr->value.logical == 0;
9886 :
9887 243 : case BT_COMPLEX:
9888 243 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9889 155 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9890 155 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9891 386 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9892 :
9893 : default:
9894 : break;
9895 : }
9896 : return false;
9897 : }
9898 :
9899 :
9900 : static void
9901 36555 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9902 : {
9903 36555 : gfc_ss *ss;
9904 :
9905 36555 : ss = se->ss;
9906 36555 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9907 36555 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9908 :
9909 36555 : gfc_conv_tmp_array_ref (se);
9910 36555 : }
9911 :
9912 :
9913 : /* Build a static initializer. EXPR is the expression for the initial value.
9914 : The other parameters describe the variable of the component being
9915 : initialized. EXPR may be null. */
9916 :
9917 : tree
9918 137245 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9919 : bool array, bool pointer, bool procptr)
9920 : {
9921 137245 : gfc_se se;
9922 :
9923 137245 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9924 42956 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9925 171 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9926 59 : return build_constructor (type, NULL);
9927 :
9928 137186 : if (!(expr || pointer || procptr))
9929 : return NULL_TREE;
9930 :
9931 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9932 : (these are the only two iso_c_binding derived types that can be
9933 : used as initialization expressions). If so, we need to modify
9934 : the 'expr' to be that for a (void *). */
9935 128771 : if (expr != NULL && expr->ts.type == BT_DERIVED
9936 38704 : && expr->ts.is_iso_c && expr->ts.u.derived)
9937 : {
9938 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9939 4 : return build_constructor (type, NULL);
9940 182 : else if (POINTER_TYPE_P (type))
9941 182 : return build_int_cst (type, 0);
9942 : else
9943 0 : gcc_unreachable ();
9944 : }
9945 :
9946 128585 : if (array && !procptr)
9947 : {
9948 8868 : tree ctor;
9949 : /* Arrays need special handling. */
9950 8868 : if (pointer)
9951 815 : ctor = gfc_build_null_descriptor (type);
9952 : /* Special case assigning an array to zero. */
9953 8053 : else if (is_zero_initializer_p (expr))
9954 226 : ctor = build_constructor (type, NULL);
9955 : else
9956 7827 : ctor = gfc_conv_array_initializer (type, expr);
9957 8868 : TREE_STATIC (ctor) = 1;
9958 8868 : return ctor;
9959 : }
9960 119717 : else if (pointer || procptr)
9961 : {
9962 56031 : if (ts->type == BT_CLASS && !procptr)
9963 : {
9964 1786 : gfc_init_se (&se, NULL);
9965 1786 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9966 1786 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9967 1786 : TREE_STATIC (se.expr) = 1;
9968 1786 : return se.expr;
9969 : }
9970 54245 : else if (!expr || expr->expr_type == EXPR_NULL)
9971 28842 : return fold_convert (type, null_pointer_node);
9972 : else
9973 : {
9974 25403 : gfc_init_se (&se, NULL);
9975 25403 : se.want_pointer = 1;
9976 25403 : gfc_conv_expr (&se, expr);
9977 25403 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9978 : return se.expr;
9979 : }
9980 : }
9981 : else
9982 : {
9983 63686 : switch (ts->type)
9984 : {
9985 18625 : case_bt_struct:
9986 18625 : case BT_CLASS:
9987 18625 : gfc_init_se (&se, NULL);
9988 18625 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9989 809 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9990 : else
9991 17816 : gfc_conv_structure (&se, expr, 1);
9992 18625 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9993 18625 : TREE_STATIC (se.expr) = 1;
9994 18625 : return se.expr;
9995 :
9996 2705 : case BT_CHARACTER:
9997 2705 : if (expr->expr_type == EXPR_CONSTANT)
9998 : {
9999 2704 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
10000 2704 : TREE_STATIC (ctor) = 1;
10001 2704 : return ctor;
10002 : }
10003 :
10004 : /* Fallthrough. */
10005 42357 : default:
10006 42357 : gfc_init_se (&se, NULL);
10007 42357 : gfc_conv_constant (&se, expr);
10008 42357 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
10009 : return se.expr;
10010 : }
10011 : }
10012 : }
10013 :
10014 : static tree
10015 956 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
10016 : {
10017 956 : gfc_se rse;
10018 956 : gfc_se lse;
10019 956 : gfc_ss *rss;
10020 956 : gfc_ss *lss;
10021 956 : gfc_array_info *lss_array;
10022 956 : stmtblock_t body;
10023 956 : stmtblock_t block;
10024 956 : gfc_loopinfo loop;
10025 956 : int n;
10026 956 : tree tmp;
10027 :
10028 956 : gfc_start_block (&block);
10029 :
10030 : /* Initialize the scalarizer. */
10031 956 : gfc_init_loopinfo (&loop);
10032 :
10033 956 : gfc_init_se (&lse, NULL);
10034 956 : gfc_init_se (&rse, NULL);
10035 :
10036 : /* Walk the rhs. */
10037 956 : rss = gfc_walk_expr (expr);
10038 956 : if (rss == gfc_ss_terminator)
10039 : /* The rhs is scalar. Add a ss for the expression. */
10040 208 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
10041 :
10042 : /* Create a SS for the destination. */
10043 956 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
10044 : GFC_SS_COMPONENT);
10045 956 : lss_array = &lss->info->data.array;
10046 956 : lss_array->shape = gfc_get_shape (cm->as->rank);
10047 956 : lss_array->descriptor = dest;
10048 956 : lss_array->data = gfc_conv_array_data (dest);
10049 956 : lss_array->offset = gfc_conv_array_offset (dest);
10050 1969 : for (n = 0; n < cm->as->rank; n++)
10051 : {
10052 1013 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
10053 1013 : lss_array->stride[n] = gfc_index_one_node;
10054 :
10055 1013 : mpz_init (lss_array->shape[n]);
10056 1013 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
10057 1013 : cm->as->lower[n]->value.integer);
10058 1013 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
10059 : }
10060 :
10061 : /* Associate the SS with the loop. */
10062 956 : gfc_add_ss_to_loop (&loop, lss);
10063 956 : gfc_add_ss_to_loop (&loop, rss);
10064 :
10065 : /* Calculate the bounds of the scalarization. */
10066 956 : gfc_conv_ss_startstride (&loop);
10067 :
10068 : /* Setup the scalarizing loops. */
10069 956 : gfc_conv_loop_setup (&loop, &expr->where);
10070 :
10071 : /* Setup the gfc_se structures. */
10072 956 : gfc_copy_loopinfo_to_se (&lse, &loop);
10073 956 : gfc_copy_loopinfo_to_se (&rse, &loop);
10074 :
10075 956 : rse.ss = rss;
10076 956 : gfc_mark_ss_chain_used (rss, 1);
10077 956 : lse.ss = lss;
10078 956 : gfc_mark_ss_chain_used (lss, 1);
10079 :
10080 : /* Start the scalarized loop body. */
10081 956 : gfc_start_scalarized_body (&loop, &body);
10082 :
10083 956 : gfc_conv_tmp_array_ref (&lse);
10084 956 : if (cm->ts.type == BT_CHARACTER)
10085 176 : lse.string_length = cm->ts.u.cl->backend_decl;
10086 :
10087 956 : gfc_conv_expr (&rse, expr);
10088 :
10089 956 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
10090 956 : gfc_add_expr_to_block (&body, tmp);
10091 :
10092 956 : gcc_assert (rse.ss == gfc_ss_terminator);
10093 :
10094 : /* Generate the copying loops. */
10095 956 : gfc_trans_scalarizing_loops (&loop, &body);
10096 :
10097 : /* Wrap the whole thing up. */
10098 956 : gfc_add_block_to_block (&block, &loop.pre);
10099 956 : gfc_add_block_to_block (&block, &loop.post);
10100 :
10101 956 : gcc_assert (lss_array->shape != NULL);
10102 956 : gfc_free_shape (&lss_array->shape, cm->as->rank);
10103 956 : gfc_cleanup_loop (&loop);
10104 :
10105 956 : return gfc_finish_block (&block);
10106 : }
10107 :
10108 :
10109 : static stmtblock_t *final_block;
10110 :
10111 :
10112 : /* Get the address of element index of contiguous character array data whose elements
10113 : are len characters of ksize bytes each. */
10114 :
10115 : static tree
10116 196 : gfc_char_elem_addr (tree char_ptr, tree data, tree idx, tree len, tree ksize)
10117 : {
10118 196 : tree offset = fold_build2_loc (input_location, MULT_EXPR,
10119 : gfc_array_index_type, len, ksize);
10120 196 : offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10121 : idx, offset);
10122 196 : return fold_build_pointer_plus_loc (input_location,
10123 196 : fold_convert (char_ptr, data), offset);
10124 : }
10125 :
10126 :
10127 : /* Copy a deferred-shape allocatable character array component in a structure
10128 : constructor when the source element length (SRC_LEN) may differ from the
10129 : component's declared length. Like gfc_duplicate_allocatable, a
10130 : contiguous source layout is assumed. DEST and SRC are array descriptors;
10131 : DEST already carries the source's bounds. */
10132 :
10133 : static tree
10134 98 : gfc_trans_alloc_char_subarray_assign (tree dest, gfc_component *cm, tree src,
10135 : tree src_len, int rank)
10136 : {
10137 98 : stmtblock_t block, body;
10138 98 : tree dlen, slen, ksize, nelems, idx, size, tmp, pchar, cond;
10139 :
10140 98 : gfc_init_block (&block);
10141 :
10142 98 : pchar = gfc_get_pchar_type (cm->ts.kind);
10143 98 : ksize = fold_convert (gfc_array_index_type,
10144 : TYPE_SIZE_UNIT (gfc_get_char_type (cm->ts.kind)));
10145 98 : dlen = fold_convert (gfc_array_index_type, cm->ts.u.cl->backend_decl);
10146 98 : slen = fold_convert (gfc_array_index_type, src_len);
10147 98 : nelems = gfc_full_array_size (&block, src, rank);
10148 98 : nelems = gfc_evaluate_now (nelems, &block);
10149 :
10150 : /* Allocate the destination data: nelems elements of the component length. */
10151 98 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10152 : nelems, dlen);
10153 98 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10154 : size, ksize);
10155 98 : tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (dest));
10156 98 : gfc_conv_descriptor_data_set (&block, dest,
10157 : gfc_call_malloc (&block, tmp, size));
10158 :
10159 : /* Copy element IDX, padding or truncating to the component length. */
10160 98 : idx = gfc_create_var (gfc_array_index_type, "idx");
10161 98 : gfc_init_block (&body);
10162 98 : gfc_trans_string_copy (&body, cm->ts.u.cl->backend_decl,
10163 : gfc_char_elem_addr (pchar,
10164 : gfc_conv_descriptor_data_get (dest),
10165 : idx, dlen, ksize),
10166 : cm->ts.kind, src_len,
10167 : gfc_char_elem_addr (pchar,
10168 : gfc_conv_descriptor_data_get (src),
10169 : idx, slen, ksize),
10170 : cm->ts.kind);
10171 98 : gfc_simple_for_loop (&block, idx, gfc_index_zero_node, nelems, LT_EXPR,
10172 : gfc_index_one_node, gfc_finish_block (&body));
10173 :
10174 98 : tmp = gfc_finish_block (&block);
10175 :
10176 : /* Null the destination if the source is unallocated. */
10177 98 : gfc_init_block (&body);
10178 98 : gfc_conv_descriptor_data_set (&body, dest, null_pointer_node);
10179 98 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10180 : fold_convert (pvoid_type_node,
10181 : gfc_conv_descriptor_data_get (src)),
10182 : null_pointer_node);
10183 98 : return build3_v (COND_EXPR, cond, tmp, gfc_finish_block (&body));
10184 : }
10185 :
10186 :
10187 : static tree
10188 1330 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
10189 : gfc_expr * expr)
10190 : {
10191 1330 : gfc_se se;
10192 1330 : stmtblock_t block;
10193 1330 : tree offset;
10194 1330 : int n;
10195 1330 : tree tmp;
10196 1330 : tree tmp2;
10197 1330 : gfc_array_spec *as;
10198 1330 : gfc_expr *arg = NULL;
10199 :
10200 1330 : gfc_start_block (&block);
10201 1330 : gfc_init_se (&se, NULL);
10202 :
10203 : /* Get the descriptor for the expressions. */
10204 1330 : se.want_pointer = 0;
10205 1330 : gfc_conv_expr_descriptor (&se, expr);
10206 1330 : gfc_add_block_to_block (&block, &se.pre);
10207 1330 : gfc_add_modify (&block, dest, se.expr);
10208 1330 : if (cm->ts.type == BT_CHARACTER
10209 1330 : && gfc_deferred_strlen (cm, &tmp))
10210 : {
10211 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10212 30 : TREE_TYPE (tmp),
10213 30 : TREE_OPERAND (dest, 0),
10214 : tmp, NULL_TREE);
10215 30 : gfc_add_modify (&block, tmp,
10216 30 : fold_convert (TREE_TYPE (tmp),
10217 : se.string_length));
10218 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
10219 : "slen");
10220 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
10221 : }
10222 :
10223 : /* Deal with arrays of derived types with allocatable components. */
10224 1330 : if (gfc_bt_struct (cm->ts.type)
10225 199 : && cm->ts.u.derived->attr.alloc_comp)
10226 : // TODO: Fix caf_mode
10227 113 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
10228 : se.expr, dest,
10229 113 : cm->as->rank, 0);
10230 1217 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
10231 36 : && CLASS_DATA(cm)->attr.allocatable)
10232 : {
10233 36 : if (cm->ts.u.derived->attr.alloc_comp)
10234 : // TODO: Fix caf_mode
10235 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
10236 : se.expr, dest,
10237 : expr->rank, 0);
10238 : else
10239 : {
10240 36 : tmp = TREE_TYPE (dest);
10241 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10242 : tmp, expr->rank, NULL_TREE);
10243 : }
10244 : }
10245 1181 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10246 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10247 : gfc_typenode_for_spec (&cm->ts),
10248 30 : cm->as->rank, NULL_TREE);
10249 1151 : else if (cm->ts.type == BT_CHARACTER)
10250 : /* Explicit-length character: the source element length may differ from
10251 : the component length, so a bitwise duplicate would copy the wrong
10252 : bytes. Copy element by element with padding/truncation. */
10253 98 : tmp = gfc_trans_alloc_char_subarray_assign (dest, cm, se.expr,
10254 : se.string_length,
10255 98 : cm->as->rank);
10256 : else
10257 1053 : tmp = gfc_duplicate_allocatable (dest, se.expr,
10258 1053 : TREE_TYPE(cm->backend_decl),
10259 1053 : cm->as->rank, NULL_TREE);
10260 :
10261 :
10262 1330 : gfc_add_expr_to_block (&block, tmp);
10263 1330 : gfc_add_block_to_block (&block, &se.post);
10264 :
10265 1330 : if (final_block && !cm->attr.allocatable
10266 96 : && expr->expr_type == EXPR_ARRAY)
10267 : {
10268 96 : tree data_ptr;
10269 96 : data_ptr = gfc_conv_descriptor_data_get (dest);
10270 96 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
10271 96 : }
10272 1234 : else if (final_block && cm->attr.allocatable)
10273 162 : gfc_add_block_to_block (final_block, &se.finalblock);
10274 :
10275 1330 : if (expr->expr_type != EXPR_VARIABLE)
10276 : {
10277 1191 : if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp)
10278 : {
10279 214 : tmp = gfc_deallocate_alloc_comp_no_caf (cm->ts.u.derived,
10280 107 : se.expr, cm->as->rank, true);
10281 107 : gfc_add_expr_to_block (&block, tmp);
10282 : }
10283 1191 : gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
10284 : }
10285 :
10286 : /* We need to know if the argument of a conversion function is a
10287 : variable, so that the correct lower bound can be used. */
10288 1330 : if (expr->expr_type == EXPR_FUNCTION
10289 68 : && expr->value.function.isym
10290 56 : && expr->value.function.isym->conversion
10291 56 : && expr->value.function.actual->expr
10292 56 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
10293 56 : arg = expr->value.function.actual->expr;
10294 :
10295 : /* Obtain the array spec of full array references. */
10296 56 : if (arg)
10297 56 : as = gfc_get_full_arrayspec_from_expr (arg);
10298 : else
10299 1274 : as = gfc_get_full_arrayspec_from_expr (expr);
10300 :
10301 : /* Shift the lbound and ubound of temporaries to being unity,
10302 : rather than zero, based. Always calculate the offset. */
10303 1330 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
10304 1330 : offset = gfc_conv_descriptor_offset_get (dest);
10305 1330 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
10306 :
10307 4046 : for (n = 0; n < expr->rank; n++)
10308 : {
10309 1386 : tree span;
10310 1386 : tree lbound;
10311 :
10312 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
10313 : TODO It looks as if gfc_conv_expr_descriptor should return
10314 : the correct bounds and that the following should not be
10315 : necessary. This would simplify gfc_conv_intrinsic_bound
10316 : as well. */
10317 1386 : if (as && as->lower[n])
10318 : {
10319 92 : gfc_se lbse;
10320 92 : gfc_init_se (&lbse, NULL);
10321 92 : gfc_conv_expr (&lbse, as->lower[n]);
10322 92 : gfc_add_block_to_block (&block, &lbse.pre);
10323 92 : lbound = gfc_evaluate_now (lbse.expr, &block);
10324 92 : }
10325 1294 : else if (as && arg)
10326 : {
10327 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
10328 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
10329 : gfc_rank_cst[n]);
10330 : }
10331 1260 : else if (as)
10332 82 : lbound = gfc_conv_descriptor_lbound_get (dest,
10333 : gfc_rank_cst[n]);
10334 : else
10335 1178 : lbound = gfc_index_one_node;
10336 :
10337 1386 : lbound = fold_convert (gfc_array_index_type, lbound);
10338 :
10339 : /* Shift the bounds and set the offset accordingly. */
10340 1386 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
10341 1386 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10342 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
10343 1386 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
10344 : span, lbound);
10345 1386 : gfc_conv_descriptor_ubound_set (&block, dest,
10346 : gfc_rank_cst[n], tmp);
10347 1386 : gfc_conv_descriptor_lbound_set (&block, dest,
10348 : gfc_rank_cst[n], lbound);
10349 :
10350 1386 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10351 : gfc_conv_descriptor_lbound_get (dest,
10352 : gfc_rank_cst[n]),
10353 : gfc_conv_descriptor_stride_get (dest,
10354 : gfc_rank_cst[n]));
10355 1386 : gfc_add_modify (&block, tmp2, tmp);
10356 1386 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
10357 : offset, tmp2);
10358 1386 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
10359 : }
10360 :
10361 1330 : if (arg)
10362 : {
10363 : /* If a conversion expression has a null data pointer
10364 : argument, nullify the allocatable component. */
10365 56 : tree non_null_expr;
10366 56 : tree null_expr;
10367 :
10368 56 : if (arg->symtree->n.sym->attr.allocatable
10369 24 : || arg->symtree->n.sym->attr.pointer)
10370 : {
10371 32 : non_null_expr = gfc_finish_block (&block);
10372 32 : gfc_start_block (&block);
10373 32 : gfc_conv_descriptor_data_set (&block, dest,
10374 : null_pointer_node);
10375 32 : null_expr = gfc_finish_block (&block);
10376 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
10377 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
10378 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
10379 32 : return build3_v (COND_EXPR, tmp,
10380 : null_expr, non_null_expr);
10381 : }
10382 : }
10383 :
10384 1298 : return gfc_finish_block (&block);
10385 : }
10386 :
10387 :
10388 : /* Allocate or reallocate scalar component, as necessary. */
10389 :
10390 : static void
10391 428 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
10392 : gfc_component *cm, gfc_expr *expr2,
10393 : tree slen)
10394 : {
10395 428 : tree tmp;
10396 428 : tree ptr;
10397 428 : tree size;
10398 428 : tree size_in_bytes;
10399 428 : tree lhs_cl_size = NULL_TREE;
10400 428 : gfc_se se;
10401 :
10402 428 : if (!comp)
10403 0 : return;
10404 :
10405 428 : if (!expr2 || expr2->rank)
10406 : return;
10407 :
10408 428 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10409 :
10410 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10411 : {
10412 145 : gcc_assert (expr2->ts.type == BT_CHARACTER);
10413 145 : size = expr2->ts.u.cl->backend_decl;
10414 145 : if (!size || !VAR_P (size))
10415 145 : size = gfc_create_var (TREE_TYPE (slen), "slen");
10416 145 : gfc_add_modify (block, size, slen);
10417 :
10418 145 : gfc_deferred_strlen (cm, &tmp);
10419 145 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
10420 : gfc_charlen_type_node,
10421 145 : TREE_OPERAND (comp, 0),
10422 : tmp, NULL_TREE);
10423 :
10424 145 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
10425 145 : tmp = TYPE_SIZE_UNIT (tmp);
10426 290 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10427 145 : TREE_TYPE (tmp), tmp,
10428 145 : fold_convert (TREE_TYPE (tmp), size));
10429 : }
10430 283 : else if (cm->ts.type == BT_CLASS)
10431 : {
10432 109 : if (expr2->ts.type != BT_CLASS)
10433 : {
10434 109 : if (expr2->ts.type == BT_CHARACTER)
10435 : {
10436 24 : gfc_init_se (&se, NULL);
10437 24 : gfc_conv_expr (&se, expr2);
10438 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
10439 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10440 : gfc_charlen_type_node,
10441 : se.string_length, size);
10442 24 : size = fold_convert (size_type_node, size);
10443 : }
10444 : else
10445 : {
10446 85 : if (expr2->ts.type == BT_DERIVED)
10447 54 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
10448 : else
10449 31 : tmp = gfc_typenode_for_spec (&expr2->ts);
10450 85 : size = TYPE_SIZE_UNIT (tmp);
10451 : }
10452 : }
10453 : else
10454 : {
10455 0 : gfc_expr *e2vtab;
10456 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
10457 0 : gfc_add_vptr_component (e2vtab);
10458 0 : gfc_add_size_component (e2vtab);
10459 0 : gfc_init_se (&se, NULL);
10460 0 : gfc_conv_expr (&se, e2vtab);
10461 0 : gfc_add_block_to_block (block, &se.pre);
10462 0 : size = fold_convert (size_type_node, se.expr);
10463 0 : gfc_free_expr (e2vtab);
10464 : }
10465 : size_in_bytes = size;
10466 : }
10467 : else
10468 : {
10469 : /* Otherwise use the length in bytes of the rhs. */
10470 174 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
10471 174 : size_in_bytes = size;
10472 : }
10473 :
10474 428 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10475 : size_in_bytes, size_one_node);
10476 :
10477 428 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
10478 : {
10479 6 : tmp = build_call_expr_loc (input_location,
10480 : builtin_decl_explicit (BUILT_IN_CALLOC),
10481 : 2, build_one_cst (size_type_node),
10482 : size_in_bytes);
10483 6 : tmp = fold_convert (TREE_TYPE (comp), tmp);
10484 6 : gfc_add_modify (block, comp, tmp);
10485 : }
10486 : else
10487 : {
10488 422 : tmp = build_call_expr_loc (input_location,
10489 : builtin_decl_explicit (BUILT_IN_MALLOC),
10490 : 1, size_in_bytes);
10491 422 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
10492 109 : ptr = gfc_class_data_get (comp);
10493 : else
10494 : ptr = comp;
10495 422 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
10496 422 : gfc_add_modify (block, ptr, tmp);
10497 : }
10498 :
10499 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10500 : /* Update the lhs character length. */
10501 145 : gfc_add_modify (block, lhs_cl_size,
10502 145 : fold_convert (TREE_TYPE (lhs_cl_size), size));
10503 : }
10504 :
10505 :
10506 : /* Assign a single component of a derived type constructor. */
10507 :
10508 : static tree
10509 30820 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
10510 : gfc_expr * expr, bool init)
10511 : {
10512 30820 : gfc_se se;
10513 30820 : gfc_se lse;
10514 30820 : stmtblock_t block;
10515 30820 : tree tmp;
10516 30820 : tree vtab;
10517 :
10518 30820 : gfc_start_block (&block);
10519 :
10520 30820 : if (cm->attr.pointer || cm->attr.proc_pointer)
10521 : {
10522 : /* Only care about pointers here, not about allocatables. */
10523 2704 : gfc_init_se (&se, NULL);
10524 : /* Pointer component. */
10525 2704 : if ((cm->attr.dimension || cm->attr.codimension)
10526 682 : && !cm->attr.proc_pointer)
10527 : {
10528 : /* Array pointer. */
10529 666 : if (expr->expr_type == EXPR_NULL)
10530 660 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10531 : else
10532 : {
10533 6 : se.direct_byref = 1;
10534 6 : se.expr = dest;
10535 6 : gfc_conv_expr_descriptor (&se, expr);
10536 6 : gfc_add_block_to_block (&block, &se.pre);
10537 6 : gfc_add_block_to_block (&block, &se.post);
10538 : }
10539 : }
10540 : else
10541 : {
10542 : /* Scalar pointers. */
10543 2038 : se.want_pointer = 1;
10544 2038 : gfc_conv_expr (&se, expr);
10545 2038 : gfc_add_block_to_block (&block, &se.pre);
10546 :
10547 2038 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10548 12 : && expr->symtree->n.sym->attr.dummy)
10549 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10550 :
10551 2038 : gfc_add_modify (&block, dest,
10552 2038 : fold_convert (TREE_TYPE (dest), se.expr));
10553 2038 : gfc_add_block_to_block (&block, &se.post);
10554 : }
10555 : }
10556 28116 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10557 : {
10558 : /* NULL initialization for CLASS components. */
10559 976 : tmp = gfc_trans_structure_assign (dest,
10560 : gfc_class_initializer (&cm->ts, expr),
10561 : false);
10562 976 : gfc_add_expr_to_block (&block, tmp);
10563 : }
10564 27140 : else if ((cm->attr.dimension || cm->attr.codimension)
10565 : && !cm->attr.proc_pointer)
10566 : {
10567 5093 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10568 : {
10569 2843 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10570 2843 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10571 2 : gfc_conv_descriptor_token_set (&block, dest, null_pointer_node);
10572 : }
10573 2250 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10574 : {
10575 1294 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10576 1294 : gfc_add_expr_to_block (&block, tmp);
10577 : }
10578 : else
10579 : {
10580 956 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10581 956 : gfc_add_expr_to_block (&block, tmp);
10582 : }
10583 : }
10584 22047 : else if (cm->ts.type == BT_CLASS
10585 157 : && CLASS_DATA (cm)->attr.dimension
10586 36 : && CLASS_DATA (cm)->attr.allocatable
10587 36 : && expr->ts.type == BT_DERIVED)
10588 : {
10589 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10590 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10591 36 : tmp = gfc_class_vptr_get (dest);
10592 36 : gfc_add_modify (&block, tmp,
10593 36 : fold_convert (TREE_TYPE (tmp), vtab));
10594 36 : tmp = gfc_class_data_get (dest);
10595 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10596 36 : gfc_add_expr_to_block (&block, tmp);
10597 : }
10598 22011 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10599 1844 : && (init
10600 1717 : || (cm->ts.type == BT_CHARACTER
10601 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10602 : {
10603 : /* NULL initialization for allocatable components.
10604 : Deferred-length character is dealt with later. */
10605 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10606 : null_pointer_node));
10607 : }
10608 21860 : else if (init && (cm->attr.allocatable
10609 13919 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10610 121 : && expr->ts.type != BT_CLASS)))
10611 : {
10612 428 : tree size;
10613 428 : tree tmp2;
10614 :
10615 428 : gfc_init_se (&se, NULL);
10616 428 : gfc_conv_expr (&se, expr);
10617 :
10618 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10619 : if (!cm->attr.dimension) part above. */
10620 428 : gfc_add_block_to_block (&block, &se.pre);
10621 : /* Take care about non-array allocatable components here. The alloc_*
10622 : routine below is motivated by the alloc_scalar_allocatable_for_
10623 : assignment() routine, but with the realloc portions removed and
10624 : different input. */
10625 428 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10626 : se.string_length);
10627 :
10628 428 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10629 0 : && expr->symtree->n.sym->attr.dummy)
10630 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10631 :
10632 428 : if (cm->ts.type == BT_CLASS)
10633 : {
10634 109 : tmp = gfc_class_data_get (dest);
10635 109 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10636 109 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10637 109 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10638 109 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10639 109 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10640 : }
10641 : else
10642 319 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10643 :
10644 : /* For deferred strings insert a memcpy. */
10645 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10646 : {
10647 145 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10648 145 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10649 : ? se.string_length
10650 0 : : expr->ts.u.cl->backend_decl);
10651 145 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10652 145 : gfc_add_expr_to_block (&block, tmp);
10653 : }
10654 283 : else if (cm->ts.type == BT_CLASS)
10655 : {
10656 : /* Fix the expression for memcpy. */
10657 109 : if (expr->expr_type != EXPR_VARIABLE)
10658 73 : se.expr = gfc_evaluate_now (se.expr, &block);
10659 :
10660 109 : if (expr->ts.type == BT_CHARACTER)
10661 : {
10662 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10663 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10664 : gfc_charlen_type_node,
10665 : se.string_length, size);
10666 24 : size = fold_convert (size_type_node, size);
10667 : }
10668 : else
10669 85 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10670 :
10671 : /* Now copy the expression to the constructor component _data. */
10672 109 : gfc_add_expr_to_block (&block,
10673 : gfc_build_memcpy_call (tmp, se.expr, size));
10674 :
10675 109 : if (expr->ts.type == BT_DERIVED
10676 54 : && expr->ts.u.derived->attr.alloc_comp
10677 6 : && expr->expr_type != EXPR_NULL)
10678 : {
10679 6 : tmp2 = gfc_class_data_get (dest);
10680 6 : tmp2 = gfc_copy_alloc_comp (expr->ts.u.derived, tmp2,
10681 : gfc_class_data_get (dest),
10682 : expr->rank, 0);
10683 6 : gfc_add_expr_to_block (&block, tmp2);
10684 : }
10685 :
10686 : /* Fill the unlimited polymorphic _len field. */
10687 109 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10688 : {
10689 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10690 24 : gfc_add_modify (&block, tmp,
10691 24 : fold_convert (TREE_TYPE (tmp),
10692 : se.string_length));
10693 : }
10694 : }
10695 : else
10696 : {
10697 174 : gfc_add_modify (&block, tmp,
10698 174 : fold_convert (TREE_TYPE (tmp), se.expr));
10699 174 : if (expr->ts.type == BT_DERIVED
10700 32 : && expr->ts.u.derived->attr.alloc_comp
10701 6 : && expr->expr_type != EXPR_NULL)
10702 : {
10703 6 : tmp2 = build_fold_indirect_ref_loc (input_location, dest);
10704 6 : tmp2 = gfc_copy_alloc_comp (cm->ts.u.derived, tmp2,
10705 : se.expr, expr->rank, 0);
10706 6 : gfc_add_expr_to_block (&block, tmp2);
10707 : }
10708 : }
10709 :
10710 428 : gfc_add_block_to_block (&block, &se.post);
10711 428 : }
10712 21432 : else if (expr->ts.type == BT_UNION)
10713 : {
10714 13 : tree tmp;
10715 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10716 : /* We mark that the entire union should be initialized with a contrived
10717 : EXPR_NULL expression at the beginning. */
10718 13 : if (c != NULL && c->n.component == NULL
10719 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10720 : {
10721 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10722 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10723 6 : gfc_add_expr_to_block (&block, tmp);
10724 6 : c = gfc_constructor_next (c);
10725 : }
10726 : /* The following constructor expression, if any, represents a specific
10727 : map initializer, as given by the user. */
10728 13 : if (c != NULL && c->expr != NULL)
10729 : {
10730 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10731 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10732 6 : gfc_add_expr_to_block (&block, tmp);
10733 : }
10734 : }
10735 21419 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10736 : {
10737 3537 : if (expr->expr_type != EXPR_STRUCTURE)
10738 : {
10739 494 : tree dealloc = NULL_TREE;
10740 494 : gfc_init_se (&se, NULL);
10741 494 : gfc_conv_expr (&se, expr);
10742 494 : gfc_add_block_to_block (&block, &se.pre);
10743 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10744 : expression in a temporary variable and deallocate the allocatable
10745 : components. Then we can the copy the expression to the result. */
10746 494 : if (cm->ts.u.derived->attr.alloc_comp
10747 372 : && expr->expr_type != EXPR_VARIABLE)
10748 : {
10749 336 : se.expr = gfc_evaluate_now (se.expr, &block);
10750 336 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10751 : expr->rank);
10752 : }
10753 494 : gfc_add_modify (&block, dest,
10754 494 : fold_convert (TREE_TYPE (dest), se.expr));
10755 494 : if (cm->ts.u.derived->attr.alloc_comp
10756 372 : && expr->expr_type != EXPR_NULL)
10757 : {
10758 : // TODO: Fix caf_mode
10759 54 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10760 : dest, expr->rank, 0);
10761 54 : gfc_add_expr_to_block (&block, tmp);
10762 54 : if (dealloc != NULL_TREE)
10763 18 : gfc_add_expr_to_block (&block, dealloc);
10764 : }
10765 494 : gfc_add_block_to_block (&block, &se.post);
10766 : }
10767 : else
10768 : {
10769 : /* Nested constructors. */
10770 3043 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10771 3043 : gfc_add_expr_to_block (&block, tmp);
10772 : }
10773 : }
10774 17882 : else if (gfc_deferred_strlen (cm, &tmp))
10775 : {
10776 125 : tree strlen;
10777 125 : strlen = tmp;
10778 125 : gcc_assert (strlen);
10779 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10780 125 : TREE_TYPE (strlen),
10781 125 : TREE_OPERAND (dest, 0),
10782 : strlen, NULL_TREE);
10783 :
10784 125 : if (expr->expr_type == EXPR_NULL)
10785 : {
10786 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10787 107 : gfc_add_modify (&block, dest, tmp);
10788 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10789 107 : gfc_add_modify (&block, strlen, tmp);
10790 : }
10791 : else
10792 : {
10793 18 : tree size;
10794 18 : gfc_init_se (&se, NULL);
10795 18 : gfc_conv_expr (&se, expr);
10796 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10797 18 : size = fold_convert (size_type_node, size);
10798 18 : tmp = build_call_expr_loc (input_location,
10799 : builtin_decl_explicit (BUILT_IN_MALLOC),
10800 : 1, size);
10801 18 : gfc_add_modify (&block, dest,
10802 18 : fold_convert (TREE_TYPE (dest), tmp));
10803 18 : gfc_add_modify (&block, strlen,
10804 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10805 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10806 18 : gfc_add_expr_to_block (&block, tmp);
10807 : }
10808 : }
10809 17757 : else if (cm->ts.type == BT_CLASS
10810 12 : && !CLASS_DATA (cm)->as
10811 12 : && expr->ts.type == BT_CLASS)
10812 : {
10813 12 : tree vptr1, vptr2;
10814 12 : tree data1, data2;
10815 12 : tree size, fcn;
10816 :
10817 12 : gfc_init_se (&se, NULL);
10818 :
10819 12 : gfc_conv_expr (&se, expr);
10820 :
10821 : /* Copy the _vptr to the destination.... */
10822 12 : vptr1 = gfc_class_vptr_get (dest);
10823 12 : vptr2 = gfc_class_vptr_get (se.expr);
10824 12 : gfc_add_modify (&block, vptr1,
10825 12 : fold_convert (TREE_TYPE (vptr1), vptr2));
10826 :
10827 : /* ....and the _len field if necessary. */
10828 12 : size = gfc_vptr_size_get (vptr2);
10829 12 : if (UNLIMITED_POLY (cm) && UNLIMITED_POLY (expr))
10830 : {
10831 0 : gfc_add_modify (&block, gfc_class_len_get (dest),
10832 : gfc_class_len_get (se.expr));
10833 0 : size = gfc_resize_class_size_with_len (&block, se.expr, size);
10834 : }
10835 :
10836 : /* Allocate the destination data. */
10837 12 : data1 = gfc_class_data_get (dest);
10838 12 : data2 = gfc_class_data_get (se.expr);
10839 12 : tmp = gfc_call_malloc (&block, TREE_TYPE (data1), size);
10840 12 : gfc_add_modify (&block, data1, tmp);
10841 :
10842 : /* Now call the copy function. */
10843 12 : fcn = gfc_vptr_copy_get (vptr2);
10844 12 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10845 12 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
10846 12 : tmp = build_call_expr_loc (input_location, fcn, 2,
10847 : data2, data1);
10848 12 : gfc_add_expr_to_block (&block, tmp);
10849 12 : }
10850 17745 : else if (!cm->attr.artificial)
10851 : {
10852 : /* Scalar component (excluding deferred parameters). */
10853 17624 : gfc_init_se (&se, NULL);
10854 17624 : gfc_init_se (&lse, NULL);
10855 :
10856 17624 : gfc_conv_expr (&se, expr);
10857 17624 : if (cm->ts.type == BT_CHARACTER)
10858 1057 : lse.string_length = cm->ts.u.cl->backend_decl;
10859 17624 : lse.expr = dest;
10860 17624 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10861 17624 : gfc_add_expr_to_block (&block, tmp);
10862 : }
10863 30820 : return gfc_finish_block (&block);
10864 : }
10865 :
10866 : /* Assign a derived type constructor to a variable. */
10867 :
10868 : tree
10869 21292 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10870 : {
10871 21292 : gfc_constructor *c;
10872 21292 : gfc_component *cm;
10873 21292 : stmtblock_t block;
10874 21292 : tree field;
10875 21292 : tree tmp;
10876 21292 : gfc_se se;
10877 :
10878 21292 : gfc_start_block (&block);
10879 :
10880 21292 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10881 179 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10882 13 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10883 : {
10884 179 : gfc_se lse;
10885 :
10886 179 : gfc_init_se (&se, NULL);
10887 179 : gfc_init_se (&lse, NULL);
10888 179 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10889 179 : lse.expr = dest;
10890 179 : gfc_add_modify (&block, lse.expr,
10891 179 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10892 :
10893 179 : return gfc_finish_block (&block);
10894 : }
10895 :
10896 : /* Make sure that the derived type has been completely built. */
10897 21113 : if (!expr->ts.u.derived->backend_decl
10898 21113 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10899 : {
10900 230 : tmp = gfc_typenode_for_spec (&expr->ts);
10901 230 : gcc_assert (tmp);
10902 : }
10903 :
10904 21113 : cm = expr->ts.u.derived->components;
10905 :
10906 :
10907 21113 : if (coarray)
10908 225 : gfc_init_se (&se, NULL);
10909 :
10910 21113 : for (c = gfc_constructor_first (expr->value.constructor);
10911 55149 : c; c = gfc_constructor_next (c), cm = cm->next)
10912 : {
10913 : /* Skip absent members in default initializers. */
10914 34036 : if (!c->expr && !cm->attr.allocatable)
10915 3216 : continue;
10916 :
10917 : /* Register the component with the caf-lib before it is initialized.
10918 : Register only allocatable components, that are not coarray'ed
10919 : components (%comp[*]). Only register when the constructor is the
10920 : null-expression. */
10921 30820 : if (coarray && !cm->attr.codimension
10922 515 : && (cm->attr.allocatable || cm->attr.pointer)
10923 179 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10924 : {
10925 177 : tree token, desc, size;
10926 354 : bool is_array = cm->ts.type == BT_CLASS
10927 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10928 :
10929 177 : field = cm->backend_decl;
10930 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
10931 177 : TREE_TYPE (field), dest, field, NULL_TREE);
10932 177 : if (cm->ts.type == BT_CLASS)
10933 0 : field = gfc_class_data_get (field);
10934 :
10935 177 : token
10936 : = is_array
10937 177 : ? gfc_conv_descriptor_token (field)
10938 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10939 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10940 52 : gfc_comp_caf_token (cm), NULL_TREE);
10941 :
10942 177 : if (is_array)
10943 : {
10944 : /* The _caf_register routine looks at the rank of the array
10945 : descriptor to decide whether the data registered is an array
10946 : or not. */
10947 125 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10948 125 : : cm->as->rank;
10949 : /* When the rank is not known just set a positive rank, which
10950 : suffices to recognize the data as array. */
10951 125 : if (rank < 0)
10952 0 : rank = 1;
10953 125 : size = build_zero_cst (size_type_node);
10954 125 : desc = field;
10955 125 : gfc_conv_descriptor_rank_set (&block, desc, rank);
10956 : }
10957 : else
10958 : {
10959 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10960 52 : cm->ts.type == BT_CLASS
10961 52 : ? CLASS_DATA (cm)->attr
10962 : : cm->attr);
10963 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10964 : }
10965 177 : gfc_add_block_to_block (&block, &se.pre);
10966 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10967 : 7, size, build_int_cst (
10968 : integer_type_node,
10969 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10970 : gfc_build_addr_expr (pvoid_type_node,
10971 : token),
10972 : gfc_build_addr_expr (NULL_TREE, desc),
10973 : null_pointer_node, null_pointer_node,
10974 : integer_zero_node);
10975 177 : gfc_add_expr_to_block (&block, tmp);
10976 : }
10977 30820 : field = cm->backend_decl;
10978 30820 : gcc_assert(field);
10979 30820 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10980 : dest, field, NULL_TREE);
10981 30820 : if (!c->expr)
10982 : {
10983 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10984 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10985 0 : gfc_free_expr (e);
10986 : }
10987 : else
10988 30820 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10989 30820 : gfc_add_expr_to_block (&block, tmp);
10990 : }
10991 21113 : return gfc_finish_block (&block);
10992 : }
10993 :
10994 : static void
10995 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10996 : gfc_component *un, gfc_expr *init)
10997 : {
10998 21 : gfc_constructor *ctor;
10999 :
11000 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
11001 : return;
11002 :
11003 21 : ctor = gfc_constructor_first (init->value.constructor);
11004 :
11005 21 : if (ctor == NULL || ctor->expr == NULL)
11006 : return;
11007 :
11008 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
11009 :
11010 : /* If we have an 'initialize all' constructor, do it first. */
11011 21 : if (ctor->expr->expr_type == EXPR_NULL)
11012 : {
11013 9 : tree union_type = TREE_TYPE (un->backend_decl);
11014 9 : tree val = build_constructor (union_type, NULL);
11015 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
11016 9 : ctor = gfc_constructor_next (ctor);
11017 : }
11018 :
11019 : /* Add the map initializer on top. */
11020 21 : if (ctor != NULL && ctor->expr != NULL)
11021 : {
11022 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
11023 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
11024 12 : TREE_TYPE (un->backend_decl),
11025 12 : un->attr.dimension, un->attr.pointer,
11026 12 : un->attr.proc_pointer);
11027 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
11028 : }
11029 : }
11030 :
11031 : /* Build an expression for a constructor. If init is nonzero then
11032 : this is part of a static variable initializer. */
11033 :
11034 : void
11035 39136 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
11036 : {
11037 39136 : gfc_constructor *c;
11038 39136 : gfc_component *cm;
11039 39136 : tree val;
11040 39136 : tree type;
11041 39136 : tree tmp;
11042 39136 : vec<constructor_elt, va_gc> *v = NULL;
11043 :
11044 39136 : gcc_assert (se->ss == NULL);
11045 39136 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
11046 39136 : type = gfc_typenode_for_spec (&expr->ts);
11047 :
11048 39136 : if (!init)
11049 : {
11050 16458 : if (IS_PDT (expr) && expr->must_finalize)
11051 276 : final_block = &se->finalblock;
11052 :
11053 : /* Create a temporary variable and fill it in. */
11054 16458 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
11055 : /* The symtree in expr is NULL, if the code to generate is for
11056 : initializing the static members only. */
11057 32916 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
11058 16458 : se->want_coarray);
11059 16458 : gfc_add_expr_to_block (&se->pre, tmp);
11060 16458 : final_block = NULL;
11061 16458 : return;
11062 : }
11063 :
11064 22678 : cm = expr->ts.u.derived->components;
11065 :
11066 22678 : for (c = gfc_constructor_first (expr->value.constructor);
11067 115981 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
11068 : {
11069 : /* Skip absent members in default initializers and allocatable
11070 : components. Although the latter have a default initializer
11071 : of EXPR_NULL,... by default, the static nullify is not needed
11072 : since this is done every time we come into scope. */
11073 102156 : if (!c->expr
11074 90867 : || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)
11075 177843 : || (IS_PDT (cm) && has_parameterized_comps (cm->ts.u.derived)))
11076 8853 : continue;
11077 :
11078 84450 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
11079 49139 : && strcmp (cm->name, "_extends") == 0
11080 1368 : && cm->initializer->symtree)
11081 : {
11082 1368 : tree vtab;
11083 1368 : gfc_symbol *vtabs;
11084 1368 : vtabs = cm->initializer->symtree->n.sym;
11085 1368 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
11086 1368 : vtab = unshare_expr_without_location (vtab);
11087 1368 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
11088 1368 : }
11089 83082 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
11090 : {
11091 8987 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
11092 8987 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
11093 : fold_convert (TREE_TYPE (cm->backend_decl),
11094 : val));
11095 8987 : }
11096 74095 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
11097 425 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
11098 : fold_convert (TREE_TYPE (cm->backend_decl),
11099 425 : integer_zero_node));
11100 73670 : else if (cm->ts.type == BT_UNION)
11101 21 : gfc_conv_union_initializer (v, cm, c->expr);
11102 : else
11103 : {
11104 73649 : val = gfc_conv_initializer (c->expr, &cm->ts,
11105 73649 : TREE_TYPE (cm->backend_decl),
11106 73649 : cm->attr.dimension, cm->attr.pointer,
11107 73649 : cm->attr.proc_pointer);
11108 73649 : val = unshare_expr_without_location (val);
11109 :
11110 : /* Append it to the constructor list. */
11111 166952 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
11112 : }
11113 : }
11114 :
11115 22678 : se->expr = build_constructor (type, v);
11116 22678 : if (init)
11117 22678 : TREE_CONSTANT (se->expr) = 1;
11118 : }
11119 :
11120 :
11121 : /* Translate a substring expression. */
11122 :
11123 : static void
11124 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
11125 : {
11126 258 : gfc_ref *ref;
11127 :
11128 258 : ref = expr->ref;
11129 :
11130 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
11131 :
11132 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
11133 258 : expr->value.character.length,
11134 258 : expr->value.character.string);
11135 :
11136 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
11137 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
11138 :
11139 258 : if (ref)
11140 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
11141 258 : }
11142 :
11143 :
11144 : /* Entry point for expression translation. Evaluates a scalar quantity.
11145 : EXPR is the expression to be translated, and SE is the state structure if
11146 : called from within the scalarized. */
11147 :
11148 : void
11149 3699875 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
11150 : {
11151 3699875 : gfc_ss *ss;
11152 :
11153 3699875 : ss = se->ss;
11154 3699875 : if (ss && ss->info->expr == expr
11155 241766 : && (ss->info->type == GFC_SS_SCALAR
11156 : || ss->info->type == GFC_SS_REFERENCE))
11157 : {
11158 40916 : gfc_ss_info *ss_info;
11159 :
11160 40916 : ss_info = ss->info;
11161 : /* Substitute a scalar expression evaluated outside the scalarization
11162 : loop. */
11163 40916 : se->expr = ss_info->data.scalar.value;
11164 40916 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
11165 844 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
11166 :
11167 40916 : se->string_length = ss_info->string_length;
11168 40916 : gfc_advance_se_ss_chain (se);
11169 40916 : return;
11170 : }
11171 :
11172 : /* We need to convert the expressions for the iso_c_binding derived types.
11173 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
11174 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
11175 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
11176 : updated to be an integer with a kind equal to the size of a (void *). */
11177 3658959 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
11178 14938 : && expr->ts.u.derived->attr.is_bind_c)
11179 : {
11180 14029 : if (expr->expr_type == EXPR_VARIABLE
11181 9572 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
11182 9572 : || expr->symtree->n.sym->intmod_sym_id
11183 : == ISOCBINDING_NULL_FUNPTR))
11184 : {
11185 : /* Set expr_type to EXPR_NULL, which will result in
11186 : null_pointer_node being used below. */
11187 0 : expr->expr_type = EXPR_NULL;
11188 : }
11189 : else
11190 : {
11191 : /* Update the type/kind of the expression to be what the new
11192 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
11193 14029 : expr->ts.type = BT_INTEGER;
11194 14029 : expr->ts.f90_type = BT_VOID;
11195 14029 : expr->ts.kind = gfc_index_integer_kind;
11196 : }
11197 : }
11198 :
11199 3658959 : gfc_fix_class_refs (expr);
11200 :
11201 3658959 : switch (expr->expr_type)
11202 : {
11203 511917 : case EXPR_OP:
11204 511917 : gfc_conv_expr_op (se, expr);
11205 511917 : break;
11206 :
11207 159 : case EXPR_CONDITIONAL:
11208 159 : gfc_conv_conditional_expr (se, expr);
11209 159 : break;
11210 :
11211 310499 : case EXPR_FUNCTION:
11212 310499 : gfc_conv_function_expr (se, expr);
11213 310499 : break;
11214 :
11215 1152363 : case EXPR_CONSTANT:
11216 1152363 : gfc_conv_constant (se, expr);
11217 1152363 : break;
11218 :
11219 1626462 : case EXPR_VARIABLE:
11220 1626462 : gfc_conv_variable (se, expr);
11221 1626462 : break;
11222 :
11223 4288 : case EXPR_NULL:
11224 4288 : se->expr = null_pointer_node;
11225 4288 : break;
11226 :
11227 258 : case EXPR_SUBSTRING:
11228 258 : gfc_conv_substring_expr (se, expr);
11229 258 : break;
11230 :
11231 16458 : case EXPR_STRUCTURE:
11232 16458 : gfc_conv_structure (se, expr, 0);
11233 : /* F2008 4.5.6.3 para 5: If an executable construct references a
11234 : structure constructor or array constructor, the entity created by
11235 : the constructor is finalized after execution of the innermost
11236 : executable construct containing the reference. This, in fact,
11237 : was later deleted by the Combined Technical Corrigenda 1 TO 4 for
11238 : fortran 2008 (f08/0011). */
11239 16458 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
11240 16458 : && !(gfc_option.allow_std & GFC_STD_GNU)
11241 139 : && expr->must_finalize
11242 16470 : && gfc_may_be_finalized (expr->ts))
11243 : {
11244 12 : locus loc;
11245 12 : gfc_locus_from_location (&loc, input_location);
11246 12 : gfc_warning (0, "The structure constructor at %L has been"
11247 : " finalized. This feature was removed by f08/0011."
11248 : " Use -std=f2018 or -std=gnu to eliminate the"
11249 : " finalization.", &loc);
11250 12 : symbol_attribute attr;
11251 12 : attr.allocatable = attr.pointer = 0;
11252 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
11253 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
11254 : }
11255 : break;
11256 :
11257 36555 : case EXPR_ARRAY:
11258 36555 : gfc_conv_array_constructor_expr (se, expr);
11259 36555 : gfc_add_block_to_block (&se->post, &se->finalblock);
11260 36555 : break;
11261 :
11262 0 : default:
11263 0 : gcc_unreachable ();
11264 3699875 : break;
11265 : }
11266 : }
11267 :
11268 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
11269 : of an assignment. */
11270 : void
11271 378990 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
11272 : {
11273 378990 : gfc_conv_expr (se, expr);
11274 : /* All numeric lvalues should have empty post chains. If not we need to
11275 : figure out a way of rewriting an lvalue so that it has no post chain. */
11276 378990 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
11277 378990 : }
11278 :
11279 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
11280 : numeric expressions. Used for scalar values where inserting cleanup code
11281 : is inconvenient. */
11282 : void
11283 1047811 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
11284 : {
11285 1047811 : tree val;
11286 :
11287 1047811 : gcc_assert (expr->ts.type != BT_CHARACTER);
11288 1047811 : gfc_conv_expr (se, expr);
11289 1047811 : if (se->post.head)
11290 : {
11291 2565 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
11292 2565 : gfc_add_modify (&se->pre, val, se->expr);
11293 2565 : se->expr = val;
11294 2565 : gfc_add_block_to_block (&se->pre, &se->post);
11295 : }
11296 1047811 : }
11297 :
11298 : /* Helper to translate an expression and convert it to a particular type. */
11299 : void
11300 297579 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
11301 : {
11302 297579 : gfc_conv_expr_val (se, expr);
11303 297579 : se->expr = convert (type, se->expr);
11304 297579 : }
11305 :
11306 :
11307 : /* Converts an expression so that it can be passed by reference. Scalar
11308 : values only. */
11309 :
11310 : void
11311 230178 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
11312 : {
11313 230178 : gfc_ss *ss;
11314 230178 : tree var;
11315 :
11316 230178 : ss = se->ss;
11317 230178 : if (ss && ss->info->expr == expr
11318 8023 : && ss->info->type == GFC_SS_REFERENCE)
11319 : {
11320 : /* Returns a reference to the scalar evaluated outside the loop
11321 : for this case. */
11322 907 : gfc_conv_expr (se, expr);
11323 :
11324 907 : if (expr->ts.type == BT_CHARACTER
11325 114 : && expr->expr_type != EXPR_FUNCTION)
11326 102 : gfc_conv_string_parameter (se);
11327 : else
11328 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11329 :
11330 : return;
11331 : }
11332 :
11333 229271 : if (expr->ts.type == BT_CHARACTER)
11334 : {
11335 49915 : gfc_conv_expr (se, expr);
11336 49915 : gfc_conv_string_parameter (se);
11337 49915 : return;
11338 : }
11339 :
11340 179356 : if (expr->expr_type == EXPR_VARIABLE)
11341 : {
11342 71572 : se->want_pointer = 1;
11343 71572 : gfc_conv_expr (se, expr);
11344 71572 : if (se->post.head)
11345 : {
11346 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11347 0 : gfc_add_modify (&se->pre, var, se->expr);
11348 0 : gfc_add_block_to_block (&se->pre, &se->post);
11349 0 : se->expr = var;
11350 : }
11351 : return;
11352 : }
11353 :
11354 107784 : if (expr->expr_type == EXPR_CONDITIONAL)
11355 : {
11356 18 : se->want_pointer = 1;
11357 18 : gfc_conv_expr (se, expr);
11358 18 : return;
11359 : }
11360 :
11361 107766 : if (expr->expr_type == EXPR_FUNCTION
11362 13858 : && ((expr->value.function.esym
11363 2107 : && expr->value.function.esym->result
11364 2106 : && expr->value.function.esym->result->attr.pointer
11365 83 : && !expr->value.function.esym->result->attr.dimension)
11366 13781 : || (!expr->value.function.esym && !expr->ref
11367 11645 : && expr->symtree->n.sym->attr.pointer
11368 0 : && !expr->symtree->n.sym->attr.dimension)))
11369 : {
11370 77 : se->want_pointer = 1;
11371 77 : gfc_conv_expr (se, expr);
11372 77 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11373 77 : gfc_add_modify (&se->pre, var, se->expr);
11374 77 : se->expr = var;
11375 77 : return;
11376 : }
11377 :
11378 107689 : gfc_conv_expr (se, expr);
11379 :
11380 : /* Create a temporary var to hold the value. */
11381 107689 : if (TREE_CONSTANT (se->expr))
11382 : {
11383 : tree tmp = se->expr;
11384 85242 : STRIP_TYPE_NOPS (tmp);
11385 85242 : var = build_decl (input_location,
11386 85242 : CONST_DECL, NULL, TREE_TYPE (tmp));
11387 85242 : DECL_INITIAL (var) = tmp;
11388 85242 : TREE_STATIC (var) = 1;
11389 85242 : pushdecl (var);
11390 : }
11391 : else
11392 : {
11393 22447 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11394 22447 : gfc_add_modify (&se->pre, var, se->expr);
11395 : }
11396 :
11397 107689 : if (!expr->must_finalize)
11398 107593 : gfc_add_block_to_block (&se->pre, &se->post);
11399 :
11400 : /* Take the address of that value. */
11401 107689 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
11402 : }
11403 :
11404 :
11405 : /* Get the _len component for an unlimited polymorphic expression. */
11406 :
11407 : static tree
11408 1872 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
11409 : {
11410 1872 : gfc_se se;
11411 1872 : gfc_ref *ref = expr->ref;
11412 :
11413 1872 : gfc_init_se (&se, NULL);
11414 3858 : while (ref && ref->next)
11415 : ref = ref->next;
11416 1872 : gfc_add_len_component (expr);
11417 1872 : gfc_conv_expr (&se, expr);
11418 1872 : gfc_add_block_to_block (block, &se.pre);
11419 1872 : gcc_assert (se.post.head == NULL_TREE);
11420 1872 : if (ref)
11421 : {
11422 286 : gfc_free_ref_list (ref->next);
11423 286 : ref->next = NULL;
11424 : }
11425 : else
11426 : {
11427 1586 : gfc_free_ref_list (expr->ref);
11428 1586 : expr->ref = NULL;
11429 : }
11430 1872 : return se.expr;
11431 : }
11432 :
11433 :
11434 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
11435 : statement-list outside of the scalarizer-loop. When code is generated, that
11436 : depends on the scalarized expression, it is added to RSE.PRE.
11437 : Returns le's _vptr tree and when set the len expressions in to_lenp and
11438 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
11439 : expression. */
11440 :
11441 : static tree
11442 4637 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
11443 : gfc_expr * re, gfc_se *rse,
11444 : tree * to_lenp, tree * from_lenp,
11445 : tree * from_vptrp)
11446 : {
11447 4637 : gfc_se se;
11448 4637 : gfc_expr * vptr_expr;
11449 4637 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
11450 4637 : bool set_vptr = false, temp_rhs = false;
11451 4637 : stmtblock_t *pre = block;
11452 4637 : tree class_expr = NULL_TREE;
11453 4637 : tree from_vptr = NULL_TREE;
11454 :
11455 : /* Create a temporary for complicated expressions. */
11456 4637 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
11457 1311 : && rse->expr != NULL_TREE)
11458 : {
11459 1311 : if (!DECL_P (rse->expr))
11460 : {
11461 392 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11462 37 : class_expr = gfc_get_class_from_expr (rse->expr);
11463 :
11464 392 : if (rse->loop)
11465 159 : pre = &rse->loop->pre;
11466 : else
11467 233 : pre = &rse->pre;
11468 :
11469 392 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
11470 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
11471 : else
11472 355 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
11473 :
11474 392 : rse->expr = tmp;
11475 : }
11476 : else
11477 919 : pre = &rse->pre;
11478 :
11479 : temp_rhs = true;
11480 : }
11481 :
11482 : /* Get the _vptr for the left-hand side expression. */
11483 4637 : gfc_init_se (&se, NULL);
11484 4637 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
11485 4637 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
11486 : {
11487 : /* Care about _len for unlimited polymorphic entities. */
11488 4637 : if (UNLIMITED_POLY (vptr_expr)
11489 3587 : || (vptr_expr->ts.type == BT_DERIVED
11490 2539 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11491 1552 : to_len = trans_get_upoly_len (block, vptr_expr);
11492 4637 : gfc_add_vptr_component (vptr_expr);
11493 4637 : set_vptr = true;
11494 : }
11495 : else
11496 0 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11497 4637 : se.want_pointer = 1;
11498 4637 : gfc_conv_expr (&se, vptr_expr);
11499 4637 : gfc_free_expr (vptr_expr);
11500 4637 : gfc_add_block_to_block (block, &se.pre);
11501 4637 : gcc_assert (se.post.head == NULL_TREE);
11502 4637 : lhs_vptr = se.expr;
11503 4637 : STRIP_NOPS (lhs_vptr);
11504 :
11505 : /* Set the _vptr only when the left-hand side of the assignment is a
11506 : class-object. */
11507 4637 : if (set_vptr)
11508 : {
11509 : /* Get the vptr from the rhs expression only, when it is variable.
11510 : Functions are expected to be assigned to a temporary beforehand. */
11511 3197 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
11512 5466 : ? gfc_find_and_cut_at_last_class_ref (re)
11513 : : NULL;
11514 829 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
11515 : {
11516 829 : if (to_len != NULL_TREE)
11517 : {
11518 : /* Get the _len information from the rhs. */
11519 335 : if (UNLIMITED_POLY (vptr_expr)
11520 : || (vptr_expr->ts.type == BT_DERIVED
11521 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11522 308 : from_len = trans_get_upoly_len (block, vptr_expr);
11523 : }
11524 829 : gfc_add_vptr_component (vptr_expr);
11525 : }
11526 : else
11527 : {
11528 3808 : if (re->expr_type == EXPR_VARIABLE
11529 2368 : && DECL_P (re->symtree->n.sym->backend_decl)
11530 2368 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
11531 834 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
11532 3875 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
11533 : re->symtree->n.sym->backend_decl))))
11534 : {
11535 43 : vptr_expr = NULL;
11536 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
11537 : re->symtree->n.sym->backend_decl));
11538 43 : if (to_len && UNLIMITED_POLY (re))
11539 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
11540 : re->symtree->n.sym->backend_decl));
11541 : }
11542 3765 : else if (temp_rhs && re->ts.type == BT_CLASS)
11543 : {
11544 227 : vptr_expr = NULL;
11545 227 : if (class_expr)
11546 : tmp = class_expr;
11547 190 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11548 0 : tmp = gfc_get_class_from_expr (rse->expr);
11549 : else
11550 : tmp = rse->expr;
11551 :
11552 227 : se.expr = gfc_class_vptr_get (tmp);
11553 227 : from_vptr = se.expr;
11554 227 : if (UNLIMITED_POLY (re))
11555 74 : from_len = gfc_class_len_get (tmp);
11556 :
11557 : }
11558 3538 : else if (re->expr_type != EXPR_NULL)
11559 : /* Only when rhs is non-NULL use its declared type for vptr
11560 : initialisation. */
11561 3409 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
11562 : else
11563 : /* When the rhs is NULL use the vtab of lhs' declared type. */
11564 129 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11565 : }
11566 :
11567 4441 : if (vptr_expr)
11568 : {
11569 4367 : gfc_init_se (&se, NULL);
11570 4367 : se.want_pointer = 1;
11571 4367 : gfc_conv_expr (&se, vptr_expr);
11572 4367 : gfc_free_expr (vptr_expr);
11573 4367 : gfc_add_block_to_block (block, &se.pre);
11574 4367 : gcc_assert (se.post.head == NULL_TREE);
11575 4367 : from_vptr = se.expr;
11576 : }
11577 4637 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
11578 : se.expr));
11579 :
11580 4637 : if (to_len != NULL_TREE)
11581 : {
11582 : /* The _len component needs to be set. Figure how to get the
11583 : value of the right-hand side. */
11584 1552 : if (from_len == NULL_TREE)
11585 : {
11586 1170 : if (rse->string_length != NULL_TREE)
11587 : from_len = rse->string_length;
11588 712 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
11589 : {
11590 0 : gfc_init_se (&se, NULL);
11591 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
11592 0 : gfc_add_block_to_block (block, &se.pre);
11593 0 : gcc_assert (se.post.head == NULL_TREE);
11594 0 : from_len = gfc_evaluate_now (se.expr, block);
11595 : }
11596 : else
11597 712 : from_len = build_zero_cst (gfc_charlen_type_node);
11598 : }
11599 1552 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
11600 : from_len));
11601 : }
11602 : }
11603 :
11604 : /* Return the _len and _vptr trees only, when requested. */
11605 4637 : if (to_lenp)
11606 3421 : *to_lenp = to_len;
11607 4637 : if (from_lenp)
11608 3421 : *from_lenp = from_len;
11609 4637 : if (from_vptrp)
11610 3421 : *from_vptrp = from_vptr;
11611 4637 : return lhs_vptr;
11612 : }
11613 :
11614 :
11615 : /* Assign tokens for pointer components. */
11616 :
11617 : static void
11618 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11619 : gfc_expr *expr2)
11620 : {
11621 12 : symbol_attribute lhs_attr, rhs_attr;
11622 12 : tree tmp, lhs_tok, rhs_tok;
11623 : /* Flag to indicated component refs on the rhs. */
11624 12 : bool rhs_cr;
11625 :
11626 12 : lhs_attr = gfc_caf_attr (expr1);
11627 12 : if (expr2->expr_type != EXPR_NULL)
11628 : {
11629 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11630 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11631 : {
11632 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11633 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11634 :
11635 4 : if (rhs_cr)
11636 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11637 : else
11638 : {
11639 4 : tree caf_decl;
11640 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11641 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11642 : NULL_TREE, NULL);
11643 : }
11644 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11645 : lhs_tok,
11646 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11647 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11648 : }
11649 : }
11650 4 : else if (lhs_attr.codimension)
11651 : {
11652 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11653 4 : if (!lhs_tok)
11654 : {
11655 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11656 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11657 : }
11658 : else
11659 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11660 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11661 : lhs_tok, null_pointer_node);
11662 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11663 : }
11664 12 : }
11665 :
11666 :
11667 : /* Do everything that is needed for a CLASS function expr2. */
11668 :
11669 : static tree
11670 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11671 : gfc_expr *expr1, gfc_expr *expr2)
11672 : {
11673 18 : tree expr1_vptr = NULL_TREE;
11674 18 : tree tmp;
11675 :
11676 18 : gfc_conv_function_expr (rse, expr2);
11677 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11678 :
11679 18 : if (expr1->ts.type != BT_CLASS)
11680 12 : rse->expr = gfc_class_data_get (rse->expr);
11681 : else
11682 : {
11683 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11684 : expr2, rse,
11685 : NULL, NULL, NULL);
11686 6 : gfc_add_block_to_block (block, &rse->pre);
11687 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11688 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11689 :
11690 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11691 6 : fold_convert (TREE_TYPE (expr1_vptr),
11692 : gfc_class_vptr_get (tmp)));
11693 6 : rse->expr = gfc_class_data_get (tmp);
11694 : }
11695 :
11696 18 : return expr1_vptr;
11697 : }
11698 :
11699 :
11700 : tree
11701 10241 : gfc_trans_pointer_assign (gfc_code * code)
11702 : {
11703 10241 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11704 : }
11705 :
11706 :
11707 : /* Generate code for a pointer assignment. */
11708 :
11709 : tree
11710 10296 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11711 : {
11712 10296 : gfc_se lse;
11713 10296 : gfc_se rse;
11714 10296 : stmtblock_t block;
11715 10296 : tree desc;
11716 10296 : tree tmp;
11717 10296 : tree expr1_vptr = NULL_TREE;
11718 10296 : bool scalar, non_proc_ptr_assign;
11719 10296 : gfc_ss *ss;
11720 :
11721 10296 : gfc_start_block (&block);
11722 :
11723 10296 : gfc_init_se (&lse, NULL);
11724 :
11725 : /* Usually testing whether this is not a proc pointer assignment. */
11726 10296 : non_proc_ptr_assign
11727 10296 : = !(gfc_expr_attr (expr1).proc_pointer
11728 1213 : && ((expr2->expr_type == EXPR_VARIABLE
11729 981 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11730 282 : || expr2->expr_type == EXPR_NULL));
11731 :
11732 : /* Check whether the expression is a scalar or not; we cannot use
11733 : expr1->rank as it can be nonzero for proc pointers. */
11734 10296 : ss = gfc_walk_expr (expr1);
11735 10296 : scalar = ss == gfc_ss_terminator;
11736 10296 : if (!scalar)
11737 4426 : gfc_free_ss_chain (ss);
11738 :
11739 10296 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11740 90 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11741 : {
11742 66 : gfc_add_data_component (expr2);
11743 : /* The following is required as gfc_add_data_component doesn't
11744 : update ts.type if there is a trailing REF_ARRAY. */
11745 66 : expr2->ts.type = BT_DERIVED;
11746 : }
11747 :
11748 10296 : if (scalar)
11749 : {
11750 : /* Scalar pointers. */
11751 5870 : lse.want_pointer = 1;
11752 5870 : gfc_conv_expr (&lse, expr1);
11753 5870 : gfc_init_se (&rse, NULL);
11754 5870 : rse.want_pointer = 1;
11755 5870 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11756 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11757 : else
11758 5864 : gfc_conv_expr (&rse, expr2);
11759 :
11760 5870 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11761 : {
11762 769 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11763 : NULL, NULL);
11764 769 : lse.expr = gfc_class_data_get (lse.expr);
11765 : }
11766 :
11767 5870 : if (expr1->symtree->n.sym->attr.proc_pointer
11768 863 : && expr1->symtree->n.sym->attr.dummy)
11769 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11770 : lse.expr);
11771 :
11772 5870 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11773 47 : && expr2->symtree->n.sym->attr.dummy)
11774 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11775 : rse.expr);
11776 :
11777 5870 : gfc_add_block_to_block (&block, &lse.pre);
11778 5870 : gfc_add_block_to_block (&block, &rse.pre);
11779 :
11780 : /* Check character lengths if character expression. The test is only
11781 : really added if -fbounds-check is enabled. Exclude deferred
11782 : character length lefthand sides. */
11783 960 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11784 786 : && !expr1->ts.deferred
11785 371 : && !expr1->symtree->n.sym->attr.proc_pointer
11786 6234 : && !gfc_is_proc_ptr_comp (expr1))
11787 : {
11788 345 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11789 345 : gcc_assert (lse.string_length && rse.string_length);
11790 345 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11791 : lse.string_length, rse.string_length,
11792 : &block);
11793 : }
11794 :
11795 : /* The assignment to an deferred character length sets the string
11796 : length to that of the rhs. */
11797 5870 : if (expr1->ts.deferred)
11798 : {
11799 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11800 413 : gfc_add_modify (&block, lse.string_length,
11801 413 : fold_convert (TREE_TYPE (lse.string_length),
11802 : rse.string_length));
11803 117 : else if (lse.string_length != NULL)
11804 115 : gfc_add_modify (&block, lse.string_length,
11805 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11806 : }
11807 :
11808 5870 : gfc_add_modify (&block, lse.expr,
11809 5870 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11810 :
11811 5870 : if (flag_coarray == GFC_FCOARRAY_LIB)
11812 : {
11813 342 : if (expr1->ref)
11814 : /* Also set the tokens for pointer components in derived typed
11815 : coarrays. */
11816 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11817 330 : else if (gfc_caf_attr (expr1).codimension)
11818 : {
11819 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11820 :
11821 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11822 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11823 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11824 : NULL_TREE, expr1);
11825 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11826 : NULL_TREE, expr2);
11827 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11828 : }
11829 : }
11830 :
11831 5870 : gfc_add_block_to_block (&block, &rse.post);
11832 5870 : gfc_add_block_to_block (&block, &lse.post);
11833 : }
11834 : else
11835 : {
11836 4426 : gfc_ref* remap;
11837 4426 : bool rank_remap;
11838 4426 : tree strlen_lhs;
11839 4426 : tree strlen_rhs = NULL_TREE;
11840 :
11841 : /* Array pointer. Find the last reference on the LHS and if it is an
11842 : array section ref, we're dealing with bounds remapping. In this case,
11843 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11844 : not see it and process the bounds remapping afterwards explicitly. */
11845 9830 : for (remap = expr1->ref; remap; remap = remap->next)
11846 5783 : if (!remap->next && remap->type == REF_ARRAY
11847 4426 : && remap->u.ar.type == AR_SECTION)
11848 : break;
11849 4426 : rank_remap = (remap && remap->u.ar.end[0]);
11850 :
11851 379 : if (remap && expr2->expr_type == EXPR_NULL)
11852 : {
11853 2 : gfc_error ("If bounds remapping is specified at %L, "
11854 : "the pointer target shall not be NULL", &expr1->where);
11855 2 : return NULL_TREE;
11856 : }
11857 :
11858 4424 : gfc_init_se (&lse, NULL);
11859 4424 : if (remap)
11860 377 : lse.descriptor_only = 1;
11861 4424 : gfc_conv_expr_descriptor (&lse, expr1);
11862 4424 : strlen_lhs = lse.string_length;
11863 4424 : desc = lse.expr;
11864 :
11865 4424 : if (expr2->expr_type == EXPR_NULL)
11866 : {
11867 : /* Just set the data pointer to null. */
11868 692 : gfc_nullify_descriptor (&lse.pre, lse.expr);
11869 : }
11870 3732 : else if (rank_remap)
11871 : {
11872 : /* If we are rank-remapping, just get the RHS's descriptor and
11873 : process this later on. */
11874 254 : gfc_init_se (&rse, NULL);
11875 254 : rse.direct_byref = 1;
11876 254 : rse.byref_noassign = 1;
11877 :
11878 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11879 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11880 : expr1, expr2);
11881 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11882 : {
11883 : tree bound[GFC_MAX_DIMENSIONS];
11884 : int i;
11885 :
11886 26 : for (i = 0; i < expr2->rank; i++)
11887 13 : bound[i] = NULL_TREE;
11888 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11889 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11890 : bound, bound, 0,
11891 : GFC_ARRAY_POINTER_CONT, false);
11892 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11893 13 : rse.descriptor_only = 0;
11894 13 : rse.expr = tmp;
11895 13 : rse.direct_byref = 1;
11896 13 : gfc_conv_expr_descriptor (&rse, expr2);
11897 13 : strlen_rhs = rse.string_length;
11898 13 : rse.expr = tmp;
11899 : }
11900 : else
11901 : {
11902 229 : gfc_conv_expr_descriptor (&rse, expr2);
11903 229 : strlen_rhs = rse.string_length;
11904 229 : if (expr1->ts.type == BT_CLASS)
11905 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11906 : expr2, &rse,
11907 : NULL, NULL,
11908 : NULL);
11909 : }
11910 : }
11911 3478 : else if (expr2->expr_type == EXPR_VARIABLE)
11912 : {
11913 : /* Assign directly to the LHS's descriptor. */
11914 3346 : lse.descriptor_only = 0;
11915 3346 : lse.direct_byref = 1;
11916 3346 : gfc_conv_expr_descriptor (&lse, expr2);
11917 3346 : strlen_rhs = lse.string_length;
11918 3346 : gfc_init_se (&rse, NULL);
11919 :
11920 3346 : if (expr1->ts.type == BT_CLASS)
11921 : {
11922 368 : rse.expr = NULL_TREE;
11923 368 : rse.string_length = strlen_rhs;
11924 368 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11925 : NULL, NULL, NULL);
11926 : }
11927 :
11928 3346 : if (remap == NULL)
11929 : {
11930 : /* If the target is not a whole array, use the target array
11931 : reference for remap. */
11932 6859 : for (remap = expr2->ref; remap; remap = remap->next)
11933 3792 : if (remap->type == REF_ARRAY
11934 3283 : && remap->u.ar.type == AR_FULL
11935 2584 : && remap->next)
11936 : break;
11937 : }
11938 : }
11939 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11940 : {
11941 25 : gfc_init_se (&rse, NULL);
11942 25 : rse.want_pointer = 1;
11943 25 : gfc_conv_function_expr (&rse, expr2);
11944 25 : if (expr1->ts.type != BT_CLASS)
11945 : {
11946 12 : rse.expr = gfc_class_data_get (rse.expr);
11947 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11948 : }
11949 : else
11950 : {
11951 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11952 : expr2, &rse, NULL,
11953 : NULL, NULL);
11954 13 : gfc_add_block_to_block (&block, &rse.pre);
11955 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11956 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11957 :
11958 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11959 13 : fold_convert (TREE_TYPE (expr1_vptr),
11960 : gfc_class_vptr_get (tmp)));
11961 13 : rse.expr = gfc_class_data_get (tmp);
11962 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11963 : }
11964 : }
11965 : else
11966 : {
11967 : /* Assign to a temporary descriptor and then copy that
11968 : temporary to the pointer. */
11969 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11970 107 : lse.descriptor_only = 0;
11971 107 : lse.expr = tmp;
11972 107 : lse.direct_byref = 1;
11973 107 : gfc_conv_expr_descriptor (&lse, expr2);
11974 107 : strlen_rhs = lse.string_length;
11975 107 : gfc_add_modify (&lse.pre, desc, tmp);
11976 : }
11977 :
11978 4424 : if (expr1->ts.type == BT_CHARACTER
11979 596 : && expr1->ts.deferred)
11980 : {
11981 338 : gfc_symbol *psym = expr1->symtree->n.sym;
11982 338 : tmp = NULL_TREE;
11983 338 : if (psym->ts.type == BT_CHARACTER
11984 337 : && psym->ts.u.cl->backend_decl)
11985 337 : tmp = psym->ts.u.cl->backend_decl;
11986 1 : else if (expr1->ts.u.cl->backend_decl
11987 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11988 0 : tmp = expr1->ts.u.cl->backend_decl;
11989 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11990 : {
11991 1 : gfc_ref *ref = expr1->ref;
11992 3 : for (;ref; ref = ref->next)
11993 : {
11994 2 : if (ref->type == REF_COMPONENT
11995 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11996 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11997 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11998 1 : TREE_TYPE (tmp),
11999 1 : TREE_OPERAND (lse.expr, 0),
12000 : tmp, NULL_TREE);
12001 : }
12002 : }
12003 :
12004 338 : gcc_assert (tmp);
12005 :
12006 338 : if (expr2->expr_type != EXPR_NULL)
12007 326 : gfc_add_modify (&block, tmp,
12008 326 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
12009 : else
12010 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
12011 : }
12012 :
12013 4424 : gfc_add_block_to_block (&block, &lse.pre);
12014 4424 : if (rank_remap)
12015 254 : gfc_add_block_to_block (&block, &rse.pre);
12016 :
12017 : /* If we do bounds remapping, update LHS descriptor accordingly. */
12018 4424 : if (remap)
12019 : {
12020 533 : int dim;
12021 533 : gcc_assert (remap->u.ar.dimen == expr1->rank);
12022 :
12023 : /* Always set dtype. */
12024 533 : gfc_conv_descriptor_dtype_set (&block, desc,
12025 533 : gfc_get_dtype (TREE_TYPE (desc)));
12026 :
12027 : /* For unlimited polymorphic LHS use elem_len from RHS. */
12028 533 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
12029 : {
12030 60 : tree elem_len;
12031 60 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
12032 60 : elem_len = fold_convert (gfc_array_index_type, tmp);
12033 60 : elem_len = gfc_evaluate_now (elem_len, &block);
12034 60 : gfc_conv_descriptor_elem_len_set (&block, desc, elem_len);
12035 : }
12036 :
12037 533 : if (rank_remap)
12038 : {
12039 : /* Do rank remapping. We already have the RHS's descriptor
12040 : converted in rse and now have to build the correct LHS
12041 : descriptor for it. */
12042 :
12043 254 : tree data, span;
12044 254 : tree offs, stride;
12045 254 : tree lbound, ubound;
12046 :
12047 : /* Copy data pointer. */
12048 254 : data = gfc_conv_descriptor_data_get (rse.expr);
12049 254 : gfc_conv_descriptor_data_set (&block, desc, data);
12050 :
12051 : /* Copy the span. */
12052 254 : if (VAR_P (rse.expr)
12053 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
12054 12 : span = gfc_conv_descriptor_span_get (rse.expr);
12055 : else
12056 : {
12057 242 : tmp = TREE_TYPE (rse.expr);
12058 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
12059 242 : span = fold_convert (gfc_array_index_type, tmp);
12060 : }
12061 254 : gfc_conv_descriptor_span_set (&block, desc, span);
12062 :
12063 : /* Copy offset but adjust it such that it would correspond
12064 : to a lbound of zero. */
12065 254 : if (expr2->rank == -1)
12066 42 : gfc_conv_descriptor_offset_set (&block, desc,
12067 : gfc_index_zero_node);
12068 : else
12069 : {
12070 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
12071 654 : for (dim = 0; dim < expr2->rank; ++dim)
12072 : {
12073 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
12074 : gfc_rank_cst[dim]);
12075 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
12076 : gfc_rank_cst[dim]);
12077 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12078 : gfc_array_index_type, stride,
12079 : lbound);
12080 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
12081 : gfc_array_index_type, offs, tmp);
12082 : }
12083 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
12084 : }
12085 : /* Set the bounds as declared for the LHS and calculate strides as
12086 : well as another offset update accordingly. */
12087 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
12088 : gfc_rank_cst[0]);
12089 895 : for (dim = 0; dim < expr1->rank; ++dim)
12090 : {
12091 387 : gfc_se lower_se;
12092 387 : gfc_se upper_se;
12093 :
12094 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
12095 :
12096 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
12097 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
12098 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
12099 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
12100 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
12101 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
12102 :
12103 : /* Convert declared bounds. */
12104 387 : gfc_init_se (&lower_se, NULL);
12105 387 : gfc_init_se (&upper_se, NULL);
12106 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
12107 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
12108 :
12109 387 : gfc_add_block_to_block (&block, &lower_se.pre);
12110 387 : gfc_add_block_to_block (&block, &upper_se.pre);
12111 :
12112 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
12113 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
12114 :
12115 387 : lbound = gfc_evaluate_now (lbound, &block);
12116 387 : ubound = gfc_evaluate_now (ubound, &block);
12117 :
12118 387 : gfc_add_block_to_block (&block, &lower_se.post);
12119 387 : gfc_add_block_to_block (&block, &upper_se.post);
12120 :
12121 : /* Set bounds in descriptor. */
12122 387 : gfc_conv_descriptor_lbound_set (&block, desc,
12123 : gfc_rank_cst[dim], lbound);
12124 387 : gfc_conv_descriptor_ubound_set (&block, desc,
12125 : gfc_rank_cst[dim], ubound);
12126 :
12127 : /* Set stride. */
12128 387 : stride = gfc_evaluate_now (stride, &block);
12129 387 : gfc_conv_descriptor_stride_set (&block, desc,
12130 : gfc_rank_cst[dim], stride);
12131 :
12132 : /* Update offset. */
12133 387 : offs = gfc_conv_descriptor_offset_get (desc);
12134 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12135 : gfc_array_index_type, lbound, stride);
12136 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
12137 : gfc_array_index_type, offs, tmp);
12138 387 : offs = gfc_evaluate_now (offs, &block);
12139 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
12140 :
12141 : /* Update stride. */
12142 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
12143 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
12144 : gfc_array_index_type, stride, tmp);
12145 : }
12146 : }
12147 : else
12148 : {
12149 : /* Bounds remapping. Just shift the lower bounds. */
12150 :
12151 279 : gcc_assert (expr1->rank == expr2->rank);
12152 :
12153 666 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
12154 : {
12155 387 : gfc_se lbound_se;
12156 :
12157 387 : gcc_assert (!remap->u.ar.end[dim]);
12158 387 : gfc_init_se (&lbound_se, NULL);
12159 387 : if (remap->u.ar.start[dim])
12160 : {
12161 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
12162 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
12163 : }
12164 : else
12165 : /* This remap arises from a target that is not a whole
12166 : array. The start expressions will be NULL but we need
12167 : the lbounds to be one. */
12168 162 : lbound_se.expr = gfc_index_one_node;
12169 387 : gfc_conv_shift_descriptor_lbound (&block, desc,
12170 : dim, lbound_se.expr);
12171 387 : gfc_add_block_to_block (&block, &lbound_se.post);
12172 : }
12173 : }
12174 : }
12175 :
12176 : /* If rank remapping was done, check with -fcheck=bounds that
12177 : the target is at least as large as the pointer. */
12178 4424 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
12179 72 : && expr2->rank != -1)
12180 : {
12181 54 : tree lsize, rsize;
12182 54 : tree fault;
12183 54 : const char* msg;
12184 :
12185 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
12186 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
12187 :
12188 54 : lsize = gfc_evaluate_now (lsize, &block);
12189 54 : rsize = gfc_evaluate_now (rsize, &block);
12190 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
12191 : rsize, lsize);
12192 :
12193 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
12194 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
12195 : msg, rsize, lsize);
12196 : }
12197 :
12198 : /* Check string lengths if applicable. The check is only really added
12199 : to the output code if -fbounds-check is enabled. */
12200 4424 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
12201 : {
12202 530 : gcc_assert (expr2->ts.type == BT_CHARACTER);
12203 530 : gcc_assert (strlen_lhs && strlen_rhs);
12204 530 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
12205 : strlen_lhs, strlen_rhs, &block);
12206 : }
12207 :
12208 4424 : gfc_add_block_to_block (&block, &lse.post);
12209 4424 : if (rank_remap)
12210 254 : gfc_add_block_to_block (&block, &rse.post);
12211 : }
12212 :
12213 10294 : return gfc_finish_block (&block);
12214 : }
12215 :
12216 :
12217 : /* Makes sure se is suitable for passing as a function string parameter. */
12218 : /* TODO: Need to check all callers of this function. It may be abused. */
12219 :
12220 : void
12221 248446 : gfc_conv_string_parameter (gfc_se * se)
12222 : {
12223 248446 : tree type;
12224 :
12225 248446 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
12226 248446 : && integer_onep (se->string_length))
12227 : {
12228 691 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
12229 691 : return;
12230 : }
12231 :
12232 247755 : if (TREE_CODE (se->expr) == STRING_CST)
12233 : {
12234 103438 : type = TREE_TYPE (TREE_TYPE (se->expr));
12235 103438 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
12236 103438 : return;
12237 : }
12238 :
12239 144317 : if (TREE_CODE (se->expr) == COND_EXPR)
12240 : {
12241 478 : tree cond = TREE_OPERAND (se->expr, 0);
12242 478 : tree lhs = TREE_OPERAND (se->expr, 1);
12243 478 : tree rhs = TREE_OPERAND (se->expr, 2);
12244 :
12245 478 : gfc_se lse, rse;
12246 478 : gfc_init_se (&lse, NULL);
12247 478 : gfc_init_se (&rse, NULL);
12248 :
12249 478 : lse.expr = lhs;
12250 478 : lse.string_length = se->string_length;
12251 478 : gfc_conv_string_parameter (&lse);
12252 :
12253 478 : rse.expr = rhs;
12254 478 : rse.string_length = se->string_length;
12255 478 : gfc_conv_string_parameter (&rse);
12256 :
12257 478 : se->expr
12258 478 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
12259 : cond, lse.expr, rse.expr);
12260 : }
12261 :
12262 144317 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
12263 56324 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
12264 144413 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
12265 : {
12266 88089 : type = TREE_TYPE (se->expr);
12267 88089 : if (TREE_CODE (se->expr) != INDIRECT_REF)
12268 82959 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
12269 : else
12270 : {
12271 5130 : if (TREE_CODE (type) == ARRAY_TYPE)
12272 5130 : type = TREE_TYPE (type);
12273 5130 : type = gfc_get_character_type_len_for_eltype (type,
12274 : se->string_length);
12275 5130 : type = build_pointer_type (type);
12276 5130 : se->expr = gfc_build_addr_expr (type, se->expr);
12277 : }
12278 : }
12279 :
12280 144317 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
12281 : }
12282 :
12283 :
12284 : /* Generate code for assignment of scalar variables. Includes character
12285 : strings and derived types with allocatable components.
12286 : If you know that the LHS has no allocations, set dealloc to false.
12287 :
12288 : DEEP_COPY has no effect if the typespec TS is not a derived type with
12289 : allocatable components. Otherwise, if it is set, an explicit copy of each
12290 : allocatable component is made. This is necessary as a simple copy of the
12291 : whole object would copy array descriptors as is, so that the lhs's
12292 : allocatable components would point to the rhs's after the assignment.
12293 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
12294 : necessary if the rhs is a non-pointer function, as the allocatable components
12295 : are not accessible by other means than the function's result after the
12296 : function has returned. It is even more subtle when temporaries are involved,
12297 : as the two following examples show:
12298 : 1. When we evaluate an array constructor, a temporary is created. Thus
12299 : there is theoretically no alias possible. However, no deep copy is
12300 : made for this temporary, so that if the constructor is made of one or
12301 : more variable with allocatable components, those components still point
12302 : to the variable's: DEEP_COPY should be set for the assignment from the
12303 : temporary to the lhs in that case.
12304 : 2. When assigning a scalar to an array, we evaluate the scalar value out
12305 : of the loop, store it into a temporary variable, and assign from that.
12306 : In that case, deep copying when assigning to the temporary would be a
12307 : waste of resources; however deep copies should happen when assigning from
12308 : the temporary to each array element: again DEEP_COPY should be set for
12309 : the assignment from the temporary to the lhs. */
12310 :
12311 : tree
12312 343466 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
12313 : bool deep_copy, bool dealloc, bool in_coarray,
12314 : bool assoc_assign)
12315 : {
12316 343466 : stmtblock_t block;
12317 343466 : tree tmp;
12318 343466 : tree cond;
12319 343466 : int caf_mode;
12320 :
12321 343466 : gfc_init_block (&block);
12322 :
12323 343466 : if (ts.type == BT_CHARACTER)
12324 : {
12325 33729 : tree rlen = NULL;
12326 33729 : tree llen = NULL;
12327 :
12328 33729 : if (lse->string_length != NULL_TREE)
12329 : {
12330 33729 : gfc_conv_string_parameter (lse);
12331 33729 : gfc_add_block_to_block (&block, &lse->pre);
12332 33729 : llen = lse->string_length;
12333 : }
12334 :
12335 33729 : if (rse->string_length != NULL_TREE)
12336 : {
12337 33729 : gfc_conv_string_parameter (rse);
12338 33729 : gfc_add_block_to_block (&block, &rse->pre);
12339 33729 : rlen = rse->string_length;
12340 : }
12341 :
12342 33729 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
12343 : rse->expr, ts.kind);
12344 : }
12345 290019 : else if (gfc_bt_struct (ts.type)
12346 309737 : && (ts.u.derived->attr.alloc_comp
12347 12798 : || (deep_copy && has_parameterized_comps (ts.u.derived))))
12348 : {
12349 7082 : tree tmp_var = NULL_TREE;
12350 7082 : cond = NULL_TREE;
12351 :
12352 : /* Are the rhs and the lhs the same? */
12353 7082 : if (deep_copy)
12354 : {
12355 4248 : if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
12356 3095 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
12357 4248 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12358 : gfc_build_addr_expr (NULL_TREE, lse->expr),
12359 : gfc_build_addr_expr (NULL_TREE, rse->expr));
12360 4248 : cond = gfc_evaluate_now (cond, &lse->pre);
12361 : }
12362 :
12363 : /* Deallocate the lhs allocated components as long as it is not
12364 : the same as the rhs. This must be done following the assignment
12365 : to prevent deallocating data that could be used in the rhs
12366 : expression. */
12367 7082 : if (dealloc)
12368 : {
12369 2007 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
12370 2007 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
12371 : 0, gfc_may_be_finalized (ts));
12372 2007 : if (deep_copy)
12373 845 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12374 : tmp);
12375 2007 : gfc_add_expr_to_block (&lse->post, tmp);
12376 : }
12377 :
12378 7082 : gfc_add_block_to_block (&block, &rse->pre);
12379 :
12380 : /* Skip finalization for self-assignment. */
12381 7082 : if (deep_copy && lse->finalblock.head)
12382 : {
12383 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12384 : gfc_finish_block (&lse->finalblock));
12385 24 : gfc_add_expr_to_block (&block, tmp);
12386 : }
12387 : else
12388 7058 : gfc_add_block_to_block (&block, &lse->finalblock);
12389 :
12390 7082 : gfc_add_block_to_block (&block, &lse->pre);
12391 :
12392 7082 : if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
12393 7082 : == TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)))
12394 6740 : gfc_add_modify (&block, lse->expr,
12395 6740 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12396 : else
12397 : {
12398 342 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12399 342 : TREE_TYPE (lse->expr), rse->expr);
12400 342 : gfc_add_modify (&block, lse->expr, tmp);
12401 : }
12402 :
12403 : /* Restore pointer address of coarray components. */
12404 7082 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
12405 : {
12406 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
12407 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12408 : tmp);
12409 5 : gfc_add_expr_to_block (&block, tmp);
12410 : }
12411 :
12412 : /* Do a deep copy if the rhs is a variable, if it is not the
12413 : same as the lhs. */
12414 7082 : if (deep_copy)
12415 : {
12416 4248 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
12417 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
12418 4248 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
12419 : caf_mode);
12420 4248 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12421 : tmp);
12422 4248 : gfc_add_expr_to_block (&block, tmp);
12423 : }
12424 : }
12425 302655 : else if (gfc_bt_struct (ts.type))
12426 : {
12427 12636 : gfc_add_block_to_block (&block, &rse->pre);
12428 12636 : gfc_add_block_to_block (&block, &lse->finalblock);
12429 12636 : gfc_add_block_to_block (&block, &lse->pre);
12430 12636 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12431 12636 : TREE_TYPE (lse->expr), rse->expr);
12432 12636 : gfc_add_modify (&block, lse->expr, tmp);
12433 : }
12434 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
12435 290019 : else if (ts.type == BT_CLASS)
12436 : {
12437 800 : gfc_add_block_to_block (&block, &lse->pre);
12438 800 : gfc_add_block_to_block (&block, &rse->pre);
12439 800 : gfc_add_block_to_block (&block, &lse->finalblock);
12440 :
12441 800 : if (!trans_scalar_class_assign (&block, lse, rse))
12442 : {
12443 : /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
12444 : for the lhs which ensures that class data rhs cast as a string
12445 : assigns correctly. */
12446 654 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12447 654 : TREE_TYPE (rse->expr), lse->expr);
12448 654 : gfc_add_modify (&block, tmp, rse->expr);
12449 :
12450 : /* Copy allocatable components but guard against class pointer
12451 : assign, which arrives here. */
12452 : #define DATA_DT ts.u.derived->components->ts.u.derived
12453 654 : if (deep_copy
12454 201 : && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
12455 43 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
12456 158 : && ts.u.derived->components
12457 812 : && DATA_DT && DATA_DT->attr.alloc_comp)
12458 : {
12459 6 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
12460 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
12461 : : 0;
12462 6 : tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
12463 : caf_mode);
12464 6 : gfc_add_expr_to_block (&block, tmp);
12465 : }
12466 : #undef DATA_DT
12467 : }
12468 : }
12469 289219 : else if (ts.type != BT_CLASS)
12470 : {
12471 289219 : gfc_add_block_to_block (&block, &lse->pre);
12472 289219 : gfc_add_block_to_block (&block, &rse->pre);
12473 :
12474 289219 : if (in_coarray)
12475 : {
12476 861 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
12477 : {
12478 0 : tree rtype = TREE_TYPE (TREE_TYPE (rse->expr));
12479 0 : tree rtoken = TYPE_LANG_SPECIFIC (rtype)->caf_token;
12480 0 : gfc_conv_descriptor_token_set (&block, lse->expr, rtoken);
12481 : }
12482 861 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
12483 0 : lse->expr = gfc_conv_array_data (lse->expr);
12484 276 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
12485 861 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
12486 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
12487 : }
12488 289219 : gfc_add_modify (&block, lse->expr,
12489 289219 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12490 : }
12491 :
12492 343466 : gfc_add_block_to_block (&block, &lse->post);
12493 343466 : gfc_add_block_to_block (&block, &rse->post);
12494 :
12495 343466 : return gfc_finish_block (&block);
12496 : }
12497 :
12498 :
12499 : /* There are quite a lot of restrictions on the optimisation in using an
12500 : array function assign without a temporary. */
12501 :
12502 : static bool
12503 14472 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
12504 : {
12505 14472 : gfc_ref * ref;
12506 14472 : bool seen_array_ref;
12507 14472 : bool c = false;
12508 14472 : gfc_symbol *sym = expr1->symtree->n.sym;
12509 :
12510 : /* Play it safe with class functions assigned to a derived type. */
12511 14472 : if (gfc_is_class_array_function (expr2)
12512 14472 : && expr1->ts.type == BT_DERIVED)
12513 : return true;
12514 :
12515 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
12516 14448 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
12517 : return true;
12518 :
12519 : /* Elemental functions are scalarized so that they don't need a
12520 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
12521 : they would need special treatment in gfc_trans_arrayfunc_assign. */
12522 8525 : if (expr2->value.function.esym != NULL
12523 1589 : && expr2->value.function.esym->attr.elemental)
12524 : return true;
12525 :
12526 : /* Need a temporary if rhs is not FULL or a contiguous section. */
12527 8166 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
12528 : return true;
12529 :
12530 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
12531 7916 : if (gfc_ref_needs_temporary_p (expr1->ref))
12532 : return true;
12533 :
12534 : /* Functions returning pointers or allocatables need temporaries. */
12535 7904 : if (gfc_expr_attr (expr2).pointer
12536 7904 : || gfc_expr_attr (expr2).allocatable)
12537 : return true;
12538 :
12539 : /* Character array functions need temporaries unless the
12540 : character lengths are the same. */
12541 7528 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
12542 : {
12543 562 : if (UNLIMITED_POLY (expr1))
12544 : return true;
12545 :
12546 556 : if (expr1->ts.u.cl->length == NULL
12547 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12548 : return true;
12549 :
12550 493 : if (expr2->ts.u.cl->length == NULL
12551 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12552 : return true;
12553 :
12554 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
12555 475 : expr2->ts.u.cl->length->value.integer) != 0)
12556 : return true;
12557 : }
12558 :
12559 : /* Check that no LHS component references appear during an array
12560 : reference. This is needed because we do not have the means to
12561 : span any arbitrary stride with an array descriptor. This check
12562 : is not needed for the rhs because the function result has to be
12563 : a complete type. */
12564 7435 : seen_array_ref = false;
12565 14870 : for (ref = expr1->ref; ref; ref = ref->next)
12566 : {
12567 7448 : if (ref->type == REF_ARRAY)
12568 : seen_array_ref= true;
12569 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
12570 : return true;
12571 : }
12572 :
12573 : /* Check for a dependency. */
12574 7422 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
12575 : expr2->value.function.esym,
12576 : expr2->value.function.actual,
12577 : NOT_ELEMENTAL))
12578 : return true;
12579 :
12580 : /* If we have reached here with an intrinsic function, we do not
12581 : need a temporary except in the particular case that reallocation
12582 : on assignment is active and the lhs is allocatable and a target,
12583 : or a pointer which may be a subref pointer. FIXME: The last
12584 : condition can go away when we use span in the intrinsics
12585 : directly.*/
12586 6985 : if (expr2->value.function.isym)
12587 6107 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
12588 12268 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
12589 :
12590 : /* If the LHS is a dummy, we need a temporary if it is not
12591 : INTENT(OUT). */
12592 803 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
12593 : return true;
12594 :
12595 : /* If the lhs has been host_associated, is in common, a pointer or is
12596 : a target and the function is not using a RESULT variable, aliasing
12597 : can occur and a temporary is needed. */
12598 797 : if ((sym->attr.host_assoc
12599 743 : || sym->attr.in_common
12600 737 : || sym->attr.pointer
12601 731 : || sym->attr.cray_pointee
12602 731 : || sym->attr.target)
12603 66 : && expr2->symtree != NULL
12604 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
12605 : return true;
12606 :
12607 : /* A PURE function can unconditionally be called without a temporary. */
12608 755 : if (expr2->value.function.esym != NULL
12609 730 : && expr2->value.function.esym->attr.pure)
12610 : return false;
12611 :
12612 : /* Implicit_pure functions are those which could legally be declared
12613 : to be PURE. */
12614 727 : if (expr2->value.function.esym != NULL
12615 702 : && expr2->value.function.esym->attr.implicit_pure)
12616 : return false;
12617 :
12618 444 : if (!sym->attr.use_assoc
12619 444 : && !sym->attr.in_common
12620 444 : && !sym->attr.pointer
12621 438 : && !sym->attr.target
12622 438 : && !sym->attr.cray_pointee
12623 438 : && expr2->value.function.esym)
12624 : {
12625 : /* A temporary is not needed if the function is not contained and
12626 : the variable is local or host associated and not a pointer or
12627 : a target. */
12628 413 : if (!expr2->value.function.esym->attr.contained)
12629 : return false;
12630 :
12631 : /* A temporary is not needed if the lhs has never been host
12632 : associated and the procedure is contained. */
12633 164 : else if (!sym->attr.host_assoc)
12634 : return false;
12635 :
12636 : /* A temporary is not needed if the variable is local and not
12637 : a pointer, a target or a result. */
12638 6 : if (sym->ns->parent
12639 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12640 0 : return false;
12641 : }
12642 :
12643 : /* Default to temporary use. */
12644 : return true;
12645 : }
12646 :
12647 :
12648 : /* Provide the loop info so that the lhs descriptor can be built for
12649 : reallocatable assignments from extrinsic function calls. */
12650 :
12651 : static void
12652 203 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12653 : gfc_loopinfo *loop)
12654 : {
12655 : /* Signal that the function call should not be made by
12656 : gfc_conv_loop_setup. */
12657 203 : se->ss->is_alloc_lhs = 1;
12658 203 : gfc_init_loopinfo (loop);
12659 203 : gfc_add_ss_to_loop (loop, *ss);
12660 203 : gfc_add_ss_to_loop (loop, se->ss);
12661 203 : gfc_conv_ss_startstride (loop);
12662 203 : gfc_conv_loop_setup (loop, where);
12663 203 : gfc_copy_loopinfo_to_se (se, loop);
12664 203 : gfc_add_block_to_block (&se->pre, &loop->pre);
12665 203 : gfc_add_block_to_block (&se->pre, &loop->post);
12666 203 : se->ss->is_alloc_lhs = 0;
12667 203 : }
12668 :
12669 :
12670 : /* For assignment to a reallocatable lhs from intrinsic functions,
12671 : replace the se.expr (ie. the result) with a temporary descriptor.
12672 : Null the data field so that the library allocates space for the
12673 : result. Free the data of the original descriptor after the function,
12674 : in case it appears in an argument expression and transfer the
12675 : result to the original descriptor. */
12676 :
12677 : static void
12678 2137 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12679 : {
12680 2137 : tree desc;
12681 2137 : tree res_desc;
12682 2137 : tree tmp;
12683 2137 : tree offset;
12684 2137 : tree zero_cond;
12685 2137 : tree not_same_shape;
12686 2137 : stmtblock_t shape_block;
12687 2137 : int n;
12688 :
12689 : /* Use the allocation done by the library. Substitute the lhs
12690 : descriptor with a copy, whose data field is nulled.*/
12691 2137 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12692 2137 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12693 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12694 :
12695 2137 : res_desc = gfc_create_unallocated_library_result_descriptor (&se->pre, desc,
12696 : dtype);
12697 2137 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12698 :
12699 : /* Free the lhs after the function call and copy the result data to
12700 : the lhs descriptor. */
12701 2137 : tmp = gfc_conv_descriptor_data_get (desc);
12702 2137 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12703 : logical_type_node, tmp,
12704 2137 : build_int_cst (TREE_TYPE (tmp), 0));
12705 2137 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12706 2137 : tmp = gfc_call_free (tmp);
12707 2137 : gfc_add_expr_to_block (&se->post, tmp);
12708 :
12709 2137 : tmp = gfc_conv_descriptor_data_get (res_desc);
12710 2137 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12711 :
12712 : /* Check that the shapes are the same between lhs and expression.
12713 : The evaluation of the shape is done in 'shape_block' to avoid
12714 : uninitialized warnings from the lhs bounds. */
12715 2137 : not_same_shape = boolean_false_node;
12716 2137 : gfc_start_block (&shape_block);
12717 9015 : for (n = 0 ; n < rank; n++)
12718 : {
12719 4741 : tree tmp1;
12720 4741 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12721 4741 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12722 4741 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12723 : gfc_array_index_type, tmp, tmp1);
12724 4741 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12725 4741 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12726 : gfc_array_index_type, tmp, tmp1);
12727 4741 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12728 4741 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12729 : gfc_array_index_type, tmp, tmp1);
12730 4741 : tmp = fold_build2_loc (input_location, NE_EXPR,
12731 : logical_type_node, tmp,
12732 : gfc_index_zero_node);
12733 4741 : tmp = gfc_evaluate_now (tmp, &shape_block);
12734 4741 : if (n == 0)
12735 : not_same_shape = tmp;
12736 : else
12737 2604 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12738 : logical_type_node, tmp,
12739 : not_same_shape);
12740 : }
12741 :
12742 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12743 : shapes being different. */
12744 2137 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12745 : zero_cond, not_same_shape);
12746 2137 : gfc_add_modify (&shape_block, zero_cond, tmp);
12747 2137 : tmp = gfc_finish_block (&shape_block);
12748 2137 : tmp = build3_v (COND_EXPR, zero_cond,
12749 : build_empty_stmt (input_location), tmp);
12750 2137 : gfc_add_expr_to_block (&se->post, tmp);
12751 :
12752 : /* Now reset the bounds returned from the function call to bounds based
12753 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12754 : of 'variable and 'expr' are different. Set the offset accordingly. */
12755 2137 : offset = gfc_index_zero_node;
12756 6878 : for (n = 0 ; n < rank; n++)
12757 : {
12758 4741 : tree lbound;
12759 :
12760 4741 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12761 4741 : lbound = fold_build3_loc (input_location, COND_EXPR,
12762 : gfc_array_index_type, zero_cond,
12763 : gfc_index_one_node, lbound);
12764 4741 : lbound = gfc_evaluate_now (lbound, &se->post);
12765 :
12766 4741 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12767 4741 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12768 : gfc_array_index_type, tmp, lbound);
12769 4741 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12770 : gfc_rank_cst[n], lbound);
12771 4741 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12772 : gfc_rank_cst[n], tmp);
12773 :
12774 : /* Set stride and accumulate the offset. */
12775 4741 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12776 4741 : gfc_conv_descriptor_stride_set (&se->post, desc,
12777 : gfc_rank_cst[n], tmp);
12778 4741 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12779 : gfc_array_index_type, lbound, tmp);
12780 4741 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12781 : gfc_array_index_type, offset, tmp);
12782 4741 : offset = gfc_evaluate_now (offset, &se->post);
12783 : }
12784 :
12785 2137 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12786 2137 : }
12787 :
12788 :
12789 :
12790 : /* Try to translate array(:) = func (...), where func is a transformational
12791 : array function, without using a temporary. Returns NULL if this isn't the
12792 : case. */
12793 :
12794 : static tree
12795 14512 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12796 : {
12797 14512 : gfc_se se;
12798 14512 : gfc_ss *ss = NULL;
12799 14512 : gfc_component *comp = NULL;
12800 14512 : gfc_loopinfo loop;
12801 14512 : tree tmp;
12802 14512 : tree lhs;
12803 14512 : gfc_se final_se;
12804 14512 : gfc_symbol *sym = expr1->symtree->n.sym;
12805 14512 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12806 :
12807 : /* If the symbol is host associated and has not been referenced in its name
12808 : space, it might be lacking a backend_decl and vtable. */
12809 14512 : if (sym->backend_decl == NULL_TREE)
12810 : return NULL_TREE;
12811 :
12812 14472 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12813 : return NULL_TREE;
12814 :
12815 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12816 : functions. */
12817 6867 : comp = gfc_get_proc_ptr_comp (expr2);
12818 :
12819 6867 : if (!(expr2->value.function.isym
12820 718 : || (comp && comp->attr.dimension)
12821 718 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12822 718 : && expr2->value.function.esym->result->attr.dimension)))
12823 : return NULL_TREE;
12824 :
12825 6867 : gfc_init_se (&se, NULL);
12826 6867 : gfc_start_block (&se.pre);
12827 6867 : se.want_pointer = 1;
12828 :
12829 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12830 : backend decl, stash the original away for the finalization so that the
12831 : value used is that before the assignment. This is necessary because
12832 : evaluation of the rhs expression using direct by reference can change
12833 : the value. However, the standard mandates that the finalization must occur
12834 : after evaluation of the rhs. */
12835 6867 : gfc_init_se (&final_se, NULL);
12836 :
12837 6867 : if (finalizable)
12838 : {
12839 45 : tmp = sym->backend_decl;
12840 45 : lhs = sym->backend_decl;
12841 45 : if (INDIRECT_REF_P (tmp))
12842 0 : tmp = TREE_OPERAND (tmp, 0);
12843 45 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12844 45 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12845 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12846 : {
12847 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12848 : expr1->rank, 0);
12849 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12850 : }
12851 : }
12852 :
12853 45 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12854 : {
12855 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12856 45 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12857 : }
12858 :
12859 6867 : if (finalizable)
12860 45 : sym->backend_decl = lhs;
12861 :
12862 6867 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12863 :
12864 6867 : if (expr1->ts.type == BT_DERIVED
12865 264 : && expr1->ts.u.derived->attr.alloc_comp)
12866 : {
12867 110 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12868 110 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12869 : expr1->rank);
12870 110 : gfc_add_expr_to_block (&se.pre, tmp);
12871 : }
12872 :
12873 6867 : se.direct_byref = 1;
12874 6867 : se.ss = gfc_walk_expr (expr2);
12875 6867 : gcc_assert (se.ss != gfc_ss_terminator);
12876 :
12877 : /* Since this is a direct by reference call, references to the lhs can be
12878 : used for finalization of the function result just as long as the blocks
12879 : from final_se are added at the right time. */
12880 6867 : gfc_init_se (&final_se, NULL);
12881 6867 : if (finalizable && expr2->value.function.esym)
12882 : {
12883 32 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12884 32 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12885 32 : expr2->value.function.esym->attr,
12886 : expr2->rank);
12887 : }
12888 :
12889 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12890 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12891 : Clearly, this cannot be done for an allocatable function result, since
12892 : the shape of the result is unknown and, in any case, the function must
12893 : correctly take care of the reallocation internally. For intrinsic
12894 : calls, the array data is freed and the library takes care of allocation.
12895 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12896 : to the library. */
12897 6867 : if (flag_realloc_lhs
12898 6792 : && gfc_is_reallocatable_lhs (expr1)
12899 9207 : && !gfc_expr_attr (expr1).codimension
12900 2340 : && !gfc_is_coindexed (expr1)
12901 9207 : && !(expr2->value.function.esym
12902 203 : && expr2->value.function.esym->result->attr.allocatable))
12903 : {
12904 2340 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12905 :
12906 2340 : if (!expr2->value.function.isym)
12907 : {
12908 203 : ss = gfc_walk_expr (expr1);
12909 203 : gcc_assert (ss != gfc_ss_terminator);
12910 :
12911 203 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12912 203 : ss->is_alloc_lhs = 1;
12913 : }
12914 : else
12915 : {
12916 2137 : tree dtype = NULL_TREE;
12917 2137 : tree type = gfc_typenode_for_spec (&expr2->ts);
12918 2137 : if (expr1->ts.type == BT_CLASS)
12919 : {
12920 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12921 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12922 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12923 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12924 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12925 : }
12926 2137 : fcncall_realloc_result (&se, expr1->rank, dtype);
12927 : }
12928 : }
12929 :
12930 6867 : gfc_conv_function_expr (&se, expr2);
12931 :
12932 : /* Fix the result. */
12933 6867 : gfc_add_block_to_block (&se.pre, &se.post);
12934 6867 : if (finalizable)
12935 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12936 :
12937 : /* Do the finalization, including final calls from function arguments. */
12938 45 : if (finalizable)
12939 : {
12940 45 : gfc_add_block_to_block (&se.pre, &final_se.post);
12941 45 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12942 45 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12943 : }
12944 :
12945 6867 : if (ss)
12946 203 : gfc_cleanup_loop (&loop);
12947 : else
12948 6664 : gfc_free_ss_chain (se.ss);
12949 :
12950 6867 : return gfc_finish_block (&se.pre);
12951 : }
12952 :
12953 :
12954 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12955 : can't be done. */
12956 :
12957 : static tree
12958 4054 : gfc_trans_zero_assign (gfc_expr * expr)
12959 : {
12960 4054 : tree dest, len, type;
12961 4054 : tree tmp;
12962 4054 : gfc_symbol *sym;
12963 :
12964 4054 : sym = expr->symtree->n.sym;
12965 4054 : dest = gfc_get_symbol_decl (sym);
12966 :
12967 4054 : type = TREE_TYPE (dest);
12968 4054 : if (POINTER_TYPE_P (type))
12969 255 : type = TREE_TYPE (type);
12970 4054 : if (GFC_ARRAY_TYPE_P (type))
12971 : {
12972 : /* Determine the length of the array. */
12973 2850 : len = GFC_TYPE_ARRAY_SIZE (type);
12974 2850 : if (!len || TREE_CODE (len) != INTEGER_CST)
12975 : return NULL_TREE;
12976 : }
12977 1204 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12978 1204 : && gfc_is_simply_contiguous (expr, false, false))
12979 : {
12980 1092 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12981 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12982 1092 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12983 1092 : dest = gfc_conv_descriptor_data_get (dest);
12984 : }
12985 : else
12986 : return NULL_TREE;
12987 :
12988 : /* If we are zeroing a local array avoid taking its address by emitting
12989 : a = {} instead. */
12990 3757 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12991 2622 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12992 2622 : dest, build_constructor (TREE_TYPE (dest),
12993 2622 : NULL));
12994 :
12995 : /* Multiply len by element size. */
12996 1135 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12997 1135 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12998 : len, fold_convert (gfc_array_index_type, tmp));
12999 :
13000 : /* Convert arguments to the correct types. */
13001 1135 : dest = fold_convert (pvoid_type_node, dest);
13002 1135 : len = fold_convert (size_type_node, len);
13003 :
13004 : /* Construct call to __builtin_memset. */
13005 1135 : tmp = build_call_expr_loc (input_location,
13006 : builtin_decl_explicit (BUILT_IN_MEMSET),
13007 : 3, dest, integer_zero_node, len);
13008 1135 : return fold_convert (void_type_node, tmp);
13009 : }
13010 :
13011 :
13012 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
13013 : that constructs the call to __builtin_memcpy. */
13014 :
13015 : tree
13016 8148 : gfc_build_memcpy_call (tree dst, tree src, tree len)
13017 : {
13018 8148 : tree tmp;
13019 :
13020 : /* Convert arguments to the correct types. */
13021 8148 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
13022 7763 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
13023 : else
13024 385 : dst = fold_convert (pvoid_type_node, dst);
13025 :
13026 8148 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
13027 7650 : src = gfc_build_addr_expr (pvoid_type_node, src);
13028 : else
13029 498 : src = fold_convert (pvoid_type_node, src);
13030 :
13031 8148 : len = fold_convert (size_type_node, len);
13032 :
13033 : /* Construct call to __builtin_memcpy. */
13034 8148 : tmp = build_call_expr_loc (input_location,
13035 : builtin_decl_explicit (BUILT_IN_MEMCPY),
13036 : 3, dst, src, len);
13037 8148 : return fold_convert (void_type_node, tmp);
13038 : }
13039 :
13040 :
13041 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
13042 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
13043 : source/rhs, both are gfc_full_array_ref_p which have been checked for
13044 : dependencies. */
13045 :
13046 : static tree
13047 2603 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
13048 : {
13049 2603 : tree dst, dlen, dtype;
13050 2603 : tree src, slen, stype;
13051 2603 : tree tmp;
13052 :
13053 2603 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
13054 2603 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
13055 :
13056 2603 : dtype = TREE_TYPE (dst);
13057 2603 : if (POINTER_TYPE_P (dtype))
13058 265 : dtype = TREE_TYPE (dtype);
13059 2603 : stype = TREE_TYPE (src);
13060 2603 : if (POINTER_TYPE_P (stype))
13061 293 : stype = TREE_TYPE (stype);
13062 :
13063 2603 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
13064 : return NULL_TREE;
13065 :
13066 : /* Determine the lengths of the arrays. */
13067 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
13068 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
13069 : return NULL_TREE;
13070 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
13071 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
13072 : dlen, fold_convert (gfc_array_index_type, tmp));
13073 :
13074 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
13075 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
13076 : return NULL_TREE;
13077 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
13078 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
13079 : slen, fold_convert (gfc_array_index_type, tmp));
13080 :
13081 : /* Sanity check that they are the same. This should always be
13082 : the case, as we should already have checked for conformance. */
13083 1486 : if (!tree_int_cst_equal (slen, dlen))
13084 : return NULL_TREE;
13085 :
13086 1486 : return gfc_build_memcpy_call (dst, src, dlen);
13087 : }
13088 :
13089 :
13090 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
13091 : this can't be done. EXPR1 is the destination/lhs for which
13092 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
13093 :
13094 : static tree
13095 8313 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
13096 : {
13097 8313 : unsigned HOST_WIDE_INT nelem;
13098 8313 : tree dst, dtype;
13099 8313 : tree src, stype;
13100 8313 : tree len;
13101 8313 : tree tmp;
13102 :
13103 8313 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
13104 8313 : if (nelem == 0)
13105 : return NULL_TREE;
13106 :
13107 6887 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
13108 6887 : dtype = TREE_TYPE (dst);
13109 6887 : if (POINTER_TYPE_P (dtype))
13110 265 : dtype = TREE_TYPE (dtype);
13111 6887 : if (!GFC_ARRAY_TYPE_P (dtype))
13112 : return NULL_TREE;
13113 :
13114 : /* Determine the lengths of the array. */
13115 6039 : len = GFC_TYPE_ARRAY_SIZE (dtype);
13116 6039 : if (!len || TREE_CODE (len) != INTEGER_CST)
13117 : return NULL_TREE;
13118 :
13119 : /* Confirm that the constructor is the same size. */
13120 5935 : if (compare_tree_int (len, nelem) != 0)
13121 : return NULL_TREE;
13122 :
13123 5935 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
13124 5935 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
13125 : fold_convert (gfc_array_index_type, tmp));
13126 :
13127 5935 : stype = gfc_typenode_for_spec (&expr2->ts);
13128 5935 : src = gfc_build_constant_array_constructor (expr2, stype);
13129 :
13130 5935 : return gfc_build_memcpy_call (dst, src, len);
13131 : }
13132 :
13133 :
13134 : /* Tells whether the expression is to be treated as a variable reference. */
13135 :
13136 : bool
13137 318809 : gfc_expr_is_variable (gfc_expr *expr)
13138 : {
13139 319087 : gfc_expr *arg;
13140 319087 : gfc_component *comp;
13141 319087 : gfc_symbol *func_ifc;
13142 :
13143 319087 : if (expr->expr_type == EXPR_VARIABLE)
13144 : return true;
13145 :
13146 283090 : arg = gfc_get_noncopying_intrinsic_argument (expr);
13147 283090 : if (arg)
13148 : {
13149 278 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
13150 : return gfc_expr_is_variable (arg);
13151 : }
13152 :
13153 : /* A data-pointer-returning function should be considered as a variable
13154 : too. */
13155 282812 : if (expr->expr_type == EXPR_FUNCTION
13156 37652 : && expr->ref == NULL)
13157 : {
13158 37257 : if (expr->value.function.isym != NULL)
13159 : return false;
13160 :
13161 9757 : if (expr->value.function.esym != NULL)
13162 : {
13163 9748 : func_ifc = expr->value.function.esym;
13164 9748 : goto found_ifc;
13165 : }
13166 9 : gcc_assert (expr->symtree);
13167 9 : func_ifc = expr->symtree->n.sym;
13168 9 : goto found_ifc;
13169 : }
13170 :
13171 245555 : comp = gfc_get_proc_ptr_comp (expr);
13172 245555 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
13173 395 : && comp)
13174 : {
13175 281 : func_ifc = comp->ts.interface;
13176 281 : goto found_ifc;
13177 : }
13178 :
13179 245274 : if (expr->expr_type == EXPR_COMPCALL)
13180 : {
13181 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
13182 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
13183 0 : goto found_ifc;
13184 : }
13185 :
13186 : return false;
13187 :
13188 10038 : found_ifc:
13189 10038 : gcc_assert (func_ifc->attr.function
13190 : && func_ifc->result != NULL);
13191 10038 : return func_ifc->result->attr.pointer;
13192 : }
13193 :
13194 :
13195 : /* Is the lhs OK for automatic reallocation? */
13196 :
13197 : static bool
13198 269537 : is_scalar_reallocatable_lhs (gfc_expr *expr)
13199 : {
13200 269537 : gfc_ref * ref;
13201 :
13202 : /* An allocatable variable with no reference. */
13203 269537 : if (expr->symtree->n.sym->attr.allocatable
13204 6848 : && !expr->ref)
13205 : return true;
13206 :
13207 : /* All that can be left are allocatable components. However, we do
13208 : not check for allocatable components here because the expression
13209 : could be an allocatable component of a pointer component. */
13210 266728 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
13211 243500 : && expr->symtree->n.sym->ts.type != BT_CLASS)
13212 : return false;
13213 :
13214 : /* Find an allocatable component ref last. */
13215 41331 : for (ref = expr->ref; ref; ref = ref->next)
13216 17063 : if (ref->type == REF_COMPONENT
13217 12611 : && !ref->next
13218 9725 : && ref->u.c.component->attr.allocatable)
13219 : return true;
13220 :
13221 : return false;
13222 : }
13223 :
13224 :
13225 : /* Allocate or reallocate scalar lhs, as necessary. */
13226 :
13227 : static void
13228 3691 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
13229 : tree string_length,
13230 : gfc_expr *expr1,
13231 : gfc_expr *expr2)
13232 :
13233 : {
13234 3691 : tree cond;
13235 3691 : tree tmp;
13236 3691 : tree size;
13237 3691 : tree size_in_bytes;
13238 3691 : tree jump_label1;
13239 3691 : tree jump_label2;
13240 3691 : gfc_se lse;
13241 3691 : gfc_ref *ref;
13242 :
13243 3691 : if (!expr1 || expr1->rank)
13244 0 : return;
13245 :
13246 3691 : if (!expr2 || expr2->rank)
13247 : return;
13248 :
13249 5199 : for (ref = expr1->ref; ref; ref = ref->next)
13250 1508 : if (ref->type == REF_SUBSTRING)
13251 : return;
13252 :
13253 3691 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
13254 :
13255 : /* Since this is a scalar lhs, we can afford to do this. That is,
13256 : there is no risk of side effects being repeated. */
13257 3691 : gfc_init_se (&lse, NULL);
13258 3691 : lse.want_pointer = 1;
13259 3691 : gfc_conv_expr (&lse, expr1);
13260 :
13261 3691 : jump_label1 = gfc_build_label_decl (NULL_TREE);
13262 3691 : jump_label2 = gfc_build_label_decl (NULL_TREE);
13263 :
13264 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
13265 3691 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
13266 3691 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
13267 : lse.expr, tmp);
13268 3691 : tmp = build3_v (COND_EXPR, cond,
13269 : build1_v (GOTO_EXPR, jump_label1),
13270 : build_empty_stmt (input_location));
13271 3691 : gfc_add_expr_to_block (block, tmp);
13272 :
13273 3691 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13274 : {
13275 : /* Use the rhs string length and the lhs element size. Note that 'size' is
13276 : used below for the string-length comparison, only. */
13277 1542 : size = string_length;
13278 1542 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
13279 3084 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
13280 1542 : TREE_TYPE (tmp), tmp,
13281 1542 : fold_convert (TREE_TYPE (tmp), size));
13282 : }
13283 : else
13284 : {
13285 : /* Otherwise use the length in bytes of the rhs. */
13286 2149 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
13287 2149 : size_in_bytes = size;
13288 : }
13289 :
13290 3691 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13291 : size_in_bytes, size_one_node);
13292 :
13293 3691 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
13294 : {
13295 32 : tree caf_decl, token;
13296 32 : gfc_se caf_se;
13297 32 : symbol_attribute attr;
13298 :
13299 32 : gfc_clear_attr (&attr);
13300 32 : gfc_init_se (&caf_se, NULL);
13301 :
13302 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
13303 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
13304 : NULL);
13305 32 : gfc_add_block_to_block (block, &caf_se.pre);
13306 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
13307 : gfc_build_addr_expr (NULL_TREE, token),
13308 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
13309 : expr1, 1);
13310 : }
13311 3659 : else if (expr1->ts.type == BT_DERIVED
13312 3659 : && (expr1->ts.u.derived->attr.alloc_comp
13313 220 : || has_parameterized_comps (expr1->ts.u.derived)))
13314 : {
13315 128 : tmp = build_call_expr_loc (input_location,
13316 : builtin_decl_explicit (BUILT_IN_CALLOC),
13317 : 2, build_one_cst (size_type_node),
13318 : size_in_bytes);
13319 128 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13320 128 : gfc_add_modify (block, lse.expr, tmp);
13321 : }
13322 : else
13323 : {
13324 3531 : tmp = build_call_expr_loc (input_location,
13325 : builtin_decl_explicit (BUILT_IN_MALLOC),
13326 : 1, size_in_bytes);
13327 3531 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13328 3531 : gfc_add_modify (block, lse.expr, tmp);
13329 : }
13330 :
13331 3691 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13332 : {
13333 : /* Deferred characters need checking for lhs and rhs string
13334 : length. Other deferred parameter variables will have to
13335 : come here too. */
13336 1542 : tmp = build1_v (GOTO_EXPR, jump_label2);
13337 1542 : gfc_add_expr_to_block (block, tmp);
13338 : }
13339 3691 : tmp = build1_v (LABEL_EXPR, jump_label1);
13340 3691 : gfc_add_expr_to_block (block, tmp);
13341 :
13342 : /* For a deferred length character, reallocate if lengths of lhs and
13343 : rhs are different. */
13344 3691 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
13345 : {
13346 1542 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13347 : lse.string_length,
13348 1542 : fold_convert (TREE_TYPE (lse.string_length),
13349 : size));
13350 : /* Jump past the realloc if the lengths are the same. */
13351 1542 : tmp = build3_v (COND_EXPR, cond,
13352 : build1_v (GOTO_EXPR, jump_label2),
13353 : build_empty_stmt (input_location));
13354 1542 : gfc_add_expr_to_block (block, tmp);
13355 1542 : tmp = build_call_expr_loc (input_location,
13356 : builtin_decl_explicit (BUILT_IN_REALLOC),
13357 : 2, fold_convert (pvoid_type_node, lse.expr),
13358 : size_in_bytes);
13359 1542 : tree omp_cond = NULL_TREE;
13360 1542 : if (flag_openmp_allocators)
13361 : {
13362 1 : tree omp_tmp;
13363 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
13364 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
13365 :
13366 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
13367 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
13368 : fold_convert (pvoid_type_node,
13369 : lse.expr), size_in_bytes,
13370 : build_zero_cst (ptr_type_node),
13371 : build_zero_cst (ptr_type_node));
13372 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
13373 : omp_cond, omp_tmp, tmp);
13374 : }
13375 1542 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13376 1542 : gfc_add_modify (block, lse.expr, tmp);
13377 1542 : if (omp_cond)
13378 1 : gfc_add_expr_to_block (block,
13379 : build3_loc (input_location, COND_EXPR,
13380 : void_type_node, omp_cond,
13381 : gfc_omp_call_add_alloc (lse.expr),
13382 : build_empty_stmt (input_location)));
13383 1542 : tmp = build1_v (LABEL_EXPR, jump_label2);
13384 1542 : gfc_add_expr_to_block (block, tmp);
13385 :
13386 : /* Update the lhs character length. */
13387 1542 : size = string_length;
13388 1542 : gfc_add_modify (block, lse.string_length,
13389 1542 : fold_convert (TREE_TYPE (lse.string_length), size));
13390 : }
13391 : }
13392 :
13393 : /* Check for assignments of the type
13394 :
13395 : a = a + 4
13396 :
13397 : to make sure we do not check for reallocation unnecessarily. */
13398 :
13399 :
13400 : /* Strip parentheses from an expression to get the underlying variable.
13401 : This is needed for self-assignment detection since (a) creates a
13402 : parentheses operator node. */
13403 :
13404 : static gfc_expr *
13405 8087 : strip_parentheses (gfc_expr *expr)
13406 : {
13407 0 : while (expr->expr_type == EXPR_OP
13408 320352 : && expr->value.op.op == INTRINSIC_PARENTHESES)
13409 596 : expr = expr->value.op.op1;
13410 319085 : return expr;
13411 : }
13412 :
13413 :
13414 : static bool
13415 7610 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
13416 : {
13417 8087 : gfc_actual_arglist *a;
13418 8087 : gfc_expr *e1, *e2;
13419 :
13420 : /* Strip parentheses to handle cases like a = (a). */
13421 16225 : expr1 = strip_parentheses (expr1);
13422 8087 : expr2 = strip_parentheses (expr2);
13423 :
13424 8087 : switch (expr2->expr_type)
13425 : {
13426 2212 : case EXPR_VARIABLE:
13427 2212 : return gfc_dep_compare_expr (expr1, expr2) == 0;
13428 :
13429 2839 : case EXPR_FUNCTION:
13430 2839 : if (expr2->value.function.esym
13431 305 : && expr2->value.function.esym->attr.elemental)
13432 : {
13433 75 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
13434 : {
13435 74 : e1 = a->expr;
13436 74 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
13437 : return false;
13438 : }
13439 : return true;
13440 : }
13441 2777 : else if (expr2->value.function.isym
13442 2520 : && expr2->value.function.isym->elemental)
13443 : {
13444 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
13445 : {
13446 322 : e1 = a->expr;
13447 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
13448 : return false;
13449 : }
13450 : return true;
13451 : }
13452 :
13453 : break;
13454 :
13455 671 : case EXPR_OP:
13456 671 : switch (expr2->value.op.op)
13457 : {
13458 19 : case INTRINSIC_NOT:
13459 19 : case INTRINSIC_UPLUS:
13460 19 : case INTRINSIC_UMINUS:
13461 19 : case INTRINSIC_PARENTHESES:
13462 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
13463 :
13464 627 : case INTRINSIC_PLUS:
13465 627 : case INTRINSIC_MINUS:
13466 627 : case INTRINSIC_TIMES:
13467 627 : case INTRINSIC_DIVIDE:
13468 627 : case INTRINSIC_POWER:
13469 627 : case INTRINSIC_AND:
13470 627 : case INTRINSIC_OR:
13471 627 : case INTRINSIC_EQV:
13472 627 : case INTRINSIC_NEQV:
13473 627 : case INTRINSIC_EQ:
13474 627 : case INTRINSIC_NE:
13475 627 : case INTRINSIC_GT:
13476 627 : case INTRINSIC_GE:
13477 627 : case INTRINSIC_LT:
13478 627 : case INTRINSIC_LE:
13479 627 : case INTRINSIC_EQ_OS:
13480 627 : case INTRINSIC_NE_OS:
13481 627 : case INTRINSIC_GT_OS:
13482 627 : case INTRINSIC_GE_OS:
13483 627 : case INTRINSIC_LT_OS:
13484 627 : case INTRINSIC_LE_OS:
13485 :
13486 627 : e1 = expr2->value.op.op1;
13487 627 : e2 = expr2->value.op.op2;
13488 :
13489 627 : if (e1->rank == 0 && e2->rank > 0)
13490 : return is_runtime_conformable (expr1, e2);
13491 569 : else if (e1->rank > 0 && e2->rank == 0)
13492 : return is_runtime_conformable (expr1, e1);
13493 169 : else if (e1->rank > 0 && e2->rank > 0)
13494 169 : return is_runtime_conformable (expr1, e1)
13495 169 : && is_runtime_conformable (expr1, e2);
13496 : break;
13497 :
13498 : default:
13499 : break;
13500 :
13501 : }
13502 :
13503 : break;
13504 :
13505 : default:
13506 : break;
13507 : }
13508 : return false;
13509 : }
13510 :
13511 :
13512 : static tree
13513 3421 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
13514 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
13515 : bool class_realloc)
13516 : {
13517 3421 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
13518 3421 : vec<tree, va_gc> *args = NULL;
13519 3421 : bool final_expr;
13520 :
13521 3421 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
13522 3421 : if (final_expr)
13523 : {
13524 515 : if (rse->loop)
13525 244 : gfc_prepend_expr_to_block (&rse->loop->pre,
13526 : gfc_finish_block (&lse->finalblock));
13527 : else
13528 271 : gfc_add_block_to_block (block, &lse->finalblock);
13529 : }
13530 :
13531 : /* Store the old vptr so that dynamic types can be compared for
13532 : reallocation to occur or not. */
13533 3421 : if (class_realloc)
13534 : {
13535 307 : tmp = lse->expr;
13536 307 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13537 0 : tmp = gfc_get_class_from_expr (tmp);
13538 : }
13539 :
13540 3421 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
13541 : &from_len, &rhs_vptr);
13542 3421 : if (rhs_vptr == NULL_TREE)
13543 43 : rhs_vptr = vptr;
13544 :
13545 : /* Generate (re)allocation of the lhs. */
13546 3421 : if (class_realloc)
13547 : {
13548 307 : stmtblock_t alloc, re_alloc;
13549 307 : tree class_han, re, size;
13550 :
13551 307 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13552 307 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
13553 : else
13554 0 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
13555 :
13556 307 : size = gfc_vptr_size_get (rhs_vptr);
13557 :
13558 : /* Take into account _len of unlimited polymorphic entities.
13559 : TODO: handle class(*) allocatable function results on rhs. */
13560 307 : if (UNLIMITED_POLY (rhs))
13561 : {
13562 18 : tree len;
13563 18 : if (rhs->expr_type == EXPR_VARIABLE)
13564 12 : len = trans_get_upoly_len (block, rhs);
13565 : else
13566 6 : len = gfc_class_len_get (tmp);
13567 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13568 : fold_convert (size_type_node, len),
13569 : size_one_node);
13570 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
13571 18 : size, fold_convert (TREE_TYPE (size), len));
13572 18 : }
13573 289 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
13574 27 : size = fold_build2_loc (input_location, MULT_EXPR,
13575 : gfc_charlen_type_node, size,
13576 : rse->string_length);
13577 :
13578 :
13579 307 : tmp = lse->expr;
13580 307 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
13581 307 : ? gfc_class_data_get (tmp) : tmp;
13582 :
13583 307 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
13584 0 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
13585 :
13586 : /* Allocate block. */
13587 307 : gfc_init_block (&alloc);
13588 307 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
13589 :
13590 : /* Reallocate if dynamic types are different. */
13591 307 : gfc_init_block (&re_alloc);
13592 307 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
13593 : {
13594 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
13595 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
13596 : }
13597 : else
13598 : {
13599 280 : tmp = fold_convert (pvoid_type_node, class_han);
13600 280 : re = build_call_expr_loc (input_location,
13601 : builtin_decl_explicit (BUILT_IN_REALLOC),
13602 : 2, tmp, size);
13603 280 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
13604 : tmp, re);
13605 280 : tmp = fold_build2_loc (input_location, NE_EXPR,
13606 : logical_type_node, rhs_vptr, old_vptr);
13607 280 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13608 : tmp, re, build_empty_stmt (input_location));
13609 280 : gfc_add_expr_to_block (&re_alloc, re);
13610 : }
13611 307 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
13612 307 : gfc_finish_block (&re_alloc) :
13613 0 : build_empty_stmt (input_location);
13614 :
13615 : /* Allocate if _data is NULL, reallocate otherwise. */
13616 307 : tmp = fold_build2_loc (input_location, EQ_EXPR,
13617 : logical_type_node, class_han,
13618 : build_int_cst (prvoid_type_node, 0));
13619 307 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13620 : gfc_unlikely (tmp,
13621 : PRED_FORTRAN_FAIL_ALLOC),
13622 : gfc_finish_block (&alloc),
13623 : realloc_expr);
13624 307 : gfc_add_expr_to_block (&lse->pre, tmp);
13625 : }
13626 :
13627 3421 : fcn = gfc_vptr_copy_get (vptr);
13628 :
13629 3421 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
13630 3421 : ? gfc_class_data_get (rse->expr) : rse->expr;
13631 3421 : if (use_vptr_copy)
13632 : {
13633 5728 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13634 584 : || INDIRECT_REF_P (tmp)
13635 427 : || (rhs->ts.type == BT_DERIVED
13636 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13637 0 : && !rhs->ts.u.derived->attr.pointer
13638 0 : && !rhs->ts.u.derived->attr.allocatable)
13639 3580 : || (UNLIMITED_POLY (rhs)
13640 134 : && !CLASS_DATA (rhs)->attr.pointer
13641 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13642 2726 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13643 : else
13644 427 : vec_safe_push (args, tmp);
13645 3153 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13646 3153 : ? gfc_class_data_get (lse->expr) : lse->expr;
13647 5466 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13648 840 : || INDIRECT_REF_P (tmp)
13649 307 : || (lhs->ts.type == BT_DERIVED
13650 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13651 0 : && !lhs->ts.u.derived->attr.pointer
13652 0 : && !lhs->ts.u.derived->attr.allocatable)
13653 3460 : || (UNLIMITED_POLY (lhs)
13654 119 : && !CLASS_DATA (lhs)->attr.pointer
13655 119 : && !CLASS_DATA (lhs)->attr.allocatable))
13656 2846 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13657 : else
13658 307 : vec_safe_push (args, tmp);
13659 :
13660 3153 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13661 :
13662 3153 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13663 : {
13664 442 : tree extcopy;
13665 442 : vec_safe_push (args, from_len);
13666 442 : vec_safe_push (args, to_len);
13667 442 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13668 :
13669 442 : tmp = fold_build2_loc (input_location, GT_EXPR,
13670 : logical_type_node, from_len,
13671 442 : build_zero_cst (TREE_TYPE (from_len)));
13672 442 : return fold_build3_loc (input_location, COND_EXPR,
13673 : void_type_node, tmp,
13674 442 : extcopy, stdcopy);
13675 : }
13676 : else
13677 : return stdcopy;
13678 : }
13679 : else
13680 : {
13681 268 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13682 268 : ? gfc_class_data_get (lse->expr) : lse->expr;
13683 268 : stmtblock_t tblock;
13684 268 : gfc_init_block (&tblock);
13685 268 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13686 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13687 268 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13688 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13689 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13690 268 : gfc_add_modify_loc (input_location, &tblock, rhst,
13691 268 : fold_convert (TREE_TYPE (rhst), tmp));
13692 268 : return gfc_finish_block (&tblock);
13693 : }
13694 : }
13695 :
13696 : bool
13697 313002 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13698 : {
13699 313002 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13700 : return false;
13701 :
13702 32474 : return lhs->symtree->n.sym->assoc
13703 32474 : && lhs->symtree->n.sym->assoc->target == rhs;
13704 : }
13705 :
13706 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13707 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13708 : init_flag indicates initialization expressions and dealloc that no
13709 : deallocate prior assignment is needed (if in doubt, set true).
13710 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13711 : routine instead of a pointer assignment. Alias resolution is only done,
13712 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13713 : where it is known, that newly allocated memory on the lhs can never be
13714 : an alias of the rhs. */
13715 :
13716 : static tree
13717 313002 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13718 : bool dealloc, bool use_vptr_copy, bool may_alias)
13719 : {
13720 313002 : gfc_se lse;
13721 313002 : gfc_se rse;
13722 313002 : gfc_ss *lss;
13723 313002 : gfc_ss *lss_section;
13724 313002 : gfc_ss *rss;
13725 313002 : gfc_loopinfo loop;
13726 313002 : tree tmp;
13727 313002 : stmtblock_t block;
13728 313002 : stmtblock_t body;
13729 313002 : bool final_expr;
13730 313002 : bool l_is_temp;
13731 313002 : bool scalar_to_array;
13732 313002 : tree string_length;
13733 313002 : int n;
13734 313002 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13735 313002 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr, rhs_attr;
13736 313002 : bool is_poly_assign;
13737 313002 : bool realloc_flag;
13738 313002 : bool assoc_assign = false;
13739 313002 : bool dummy_class_array_copy;
13740 :
13741 : /* Assignment of the form lhs = rhs. */
13742 313002 : gfc_start_block (&block);
13743 :
13744 313002 : gfc_init_se (&lse, NULL);
13745 313002 : gfc_init_se (&rse, NULL);
13746 :
13747 313002 : gfc_fix_class_refs (expr1);
13748 :
13749 626004 : realloc_flag = flag_realloc_lhs
13750 306776 : && gfc_is_reallocatable_lhs (expr1)
13751 8421 : && expr2->rank
13752 319952 : && !is_runtime_conformable (expr1, expr2);
13753 :
13754 : /* Walk the lhs. */
13755 313002 : lss = gfc_walk_expr (expr1);
13756 313002 : if (realloc_flag)
13757 : {
13758 6567 : lss->no_bounds_check = 1;
13759 6567 : lss->is_alloc_lhs = 1;
13760 : }
13761 : else
13762 306435 : lss->no_bounds_check = expr1->no_bounds_check;
13763 :
13764 313002 : rss = NULL;
13765 :
13766 313002 : if (expr2->expr_type != EXPR_VARIABLE
13767 313002 : && expr2->expr_type != EXPR_CONSTANT
13768 313002 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13769 : {
13770 906 : expr2->must_finalize = 1;
13771 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13772 : function, the result is finalized after execution of the innermost
13773 : executable construct containing the reference. */
13774 906 : if (expr2->expr_type == EXPR_FUNCTION
13775 906 : && (gfc_expr_attr (expr2).pointer
13776 310 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13777 147 : expr2->must_finalize = 0;
13778 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13779 : structure constructor or array constructor, the entity created by
13780 : the constructor is finalized after execution of the innermost
13781 : executable construct containing the reference.
13782 : These finalizations were later deleted by the Combined Technical
13783 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13784 759 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13785 759 : && (expr2->expr_type == EXPR_STRUCTURE
13786 716 : || expr2->expr_type == EXPR_ARRAY))
13787 387 : expr2->must_finalize = 0;
13788 : }
13789 :
13790 :
13791 : /* Checking whether a class assignment is desired is quite complicated and
13792 : needed at two locations, so do it once only before the information is
13793 : needed. */
13794 313002 : lhs_attr = gfc_expr_attr (expr1);
13795 313002 : rhs_attr = gfc_expr_attr (expr2);
13796 313002 : dummy_class_array_copy
13797 626004 : = (expr2->expr_type == EXPR_VARIABLE
13798 32474 : && expr2->rank > 0
13799 8468 : && expr2->symtree != NULL
13800 8468 : && expr2->symtree->n.sym->attr.dummy
13801 1507 : && expr2->ts.type == BT_CLASS
13802 163 : && !rhs_attr.pointer
13803 163 : && !rhs_attr.allocatable
13804 150 : && !CLASS_DATA (expr2)->attr.class_pointer
13805 313152 : && !CLASS_DATA (expr2)->attr.allocatable);
13806 :
13807 : /* What can be sent to trans_class_assignment includes all the obvious
13808 : candidates but scalar assignment of a class expression to a derived type
13809 : must be done using gfc_trans_scalar_assign; partly because it is simpler
13810 : and partly because some cases fail, eg. class assignment to derived_type
13811 : select type temporaries. */
13812 313002 : is_poly_assign
13813 313002 : = (use_vptr_copy
13814 295602 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13815 23395 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13816 21260 : || gfc_is_class_scalar_expr (expr1)
13817 19907 : || gfc_is_class_array_ref (expr2, NULL)
13818 19907 : || (gfc_is_class_scalar_expr (expr2)
13819 42 : && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
13820 316490 : && lhs_attr.flavor != FL_PROCEDURE;
13821 :
13822 313002 : assoc_assign = is_assoc_assign (expr1, expr2);
13823 :
13824 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13825 : mode. Avoid false-positive uninitialized diagnostics with initializing
13826 : the codimension flag unconditionally. */
13827 313002 : lhs_caf_attr.codimension = false;
13828 313002 : rhs_caf_attr.codimension = false;
13829 313002 : if (flag_coarray == GFC_FCOARRAY_LIB)
13830 : {
13831 6805 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13832 6805 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13833 : }
13834 :
13835 313002 : tree reallocation = NULL_TREE;
13836 313002 : if (lss != gfc_ss_terminator)
13837 : {
13838 : /* The assignment needs scalarization. */
13839 : lss_section = lss;
13840 :
13841 : /* Find a non-scalar SS from the lhs. */
13842 : while (lss_section != gfc_ss_terminator
13843 40630 : && lss_section->info->type != GFC_SS_SECTION)
13844 0 : lss_section = lss_section->next;
13845 :
13846 40630 : gcc_assert (lss_section != gfc_ss_terminator);
13847 :
13848 : /* Initialize the scalarizer. */
13849 40630 : gfc_init_loopinfo (&loop);
13850 :
13851 : /* Walk the rhs. */
13852 40630 : rss = gfc_walk_expr (expr2);
13853 40630 : if (rss == gfc_ss_terminator)
13854 : {
13855 : /* The rhs is scalar. Add a ss for the expression. */
13856 15211 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13857 15211 : lss->is_alloc_lhs = 0;
13858 : }
13859 :
13860 : /* When doing a class assign, then the handle to the rhs needs to be a
13861 : pointer to allow for polymorphism. */
13862 40630 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13863 509 : rss->info->type = GFC_SS_REFERENCE;
13864 :
13865 40630 : rss->no_bounds_check = expr2->no_bounds_check;
13866 : /* Associate the SS with the loop. */
13867 40630 : gfc_add_ss_to_loop (&loop, lss);
13868 40630 : gfc_add_ss_to_loop (&loop, rss);
13869 :
13870 : /* Calculate the bounds of the scalarization. */
13871 40630 : gfc_conv_ss_startstride (&loop);
13872 : /* Enable loop reversal. */
13873 690710 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13874 609450 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13875 : /* Resolve any data dependencies in the statement. */
13876 40630 : if (may_alias)
13877 38303 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13878 : /* Setup the scalarizing loops. */
13879 40630 : gfc_conv_loop_setup (&loop, &expr2->where);
13880 :
13881 : /* Setup the gfc_se structures. */
13882 40630 : gfc_copy_loopinfo_to_se (&lse, &loop);
13883 40630 : gfc_copy_loopinfo_to_se (&rse, &loop);
13884 :
13885 40630 : rse.ss = rss;
13886 40630 : gfc_mark_ss_chain_used (rss, 1);
13887 40630 : if (loop.temp_ss == NULL)
13888 : {
13889 39516 : lse.ss = lss;
13890 39516 : gfc_mark_ss_chain_used (lss, 1);
13891 : }
13892 : else
13893 : {
13894 1114 : lse.ss = loop.temp_ss;
13895 1114 : gfc_mark_ss_chain_used (lss, 3);
13896 1114 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13897 : }
13898 :
13899 : /* Allow the scalarizer to workshare array assignments. */
13900 40630 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13901 : == OMPWS_WORKSHARE_FLAG
13902 85 : && loop.temp_ss == NULL)
13903 : {
13904 73 : maybe_workshare = true;
13905 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13906 : }
13907 :
13908 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13909 40630 : if (realloc_flag)
13910 : {
13911 6567 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13912 6567 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13913 6567 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13914 : expr2);
13915 : }
13916 :
13917 : /* Start the scalarized loop body. */
13918 40630 : gfc_start_scalarized_body (&loop, &body);
13919 : }
13920 : else
13921 272372 : gfc_init_block (&body);
13922 :
13923 313002 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13924 :
13925 : /* Translate the expression. */
13926 626004 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13927 313002 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13928 313002 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13929 313002 : gfc_conv_expr (&rse, expr2);
13930 :
13931 : /* Deal with the case of a scalar class function assigned to a derived type.
13932 : */
13933 313002 : if (gfc_is_alloc_class_scalar_function (expr2)
13934 313002 : && expr1->ts.type == BT_DERIVED)
13935 : {
13936 60 : rse.expr = gfc_class_data_get (rse.expr);
13937 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13938 : }
13939 :
13940 : /* Stabilize a string length for temporaries. */
13941 313002 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13942 24886 : && !(VAR_P (rse.string_length)
13943 : || TREE_CODE (rse.string_length) == PARM_DECL
13944 : || INDIRECT_REF_P (rse.string_length)))
13945 24010 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13946 288992 : else if (expr2->ts.type == BT_CHARACTER)
13947 : {
13948 4424 : if (expr1->ts.deferred
13949 6881 : && gfc_expr_attr (expr1).allocatable
13950 7001 : && gfc_check_dependency (expr1, expr2, true))
13951 120 : rse.string_length =
13952 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13953 4424 : string_length = rse.string_length;
13954 : }
13955 : else
13956 : string_length = NULL_TREE;
13957 :
13958 313002 : if (l_is_temp)
13959 : {
13960 1114 : gfc_conv_tmp_array_ref (&lse);
13961 1114 : if (expr2->ts.type == BT_CHARACTER)
13962 123 : lse.string_length = string_length;
13963 : }
13964 : else
13965 : {
13966 311888 : gfc_conv_expr (&lse, expr1);
13967 : /* For some expression (e.g. complex numbers) fold_convert uses a
13968 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13969 : not updated when assigned to. */
13970 311888 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13971 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13972 :
13973 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13974 318041 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13975 : {
13976 36 : tree cond;
13977 36 : const char* msg;
13978 :
13979 36 : tmp = INDIRECT_REF_P (lse.expr)
13980 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13981 36 : STRIP_NOPS (tmp);
13982 :
13983 : /* We should only get array references here. */
13984 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13985 : || TREE_CODE (tmp) == ARRAY_REF);
13986 :
13987 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13988 : or the array itself(ARRAY_REF). */
13989 36 : tmp = TREE_OPERAND (tmp, 0);
13990 :
13991 : /* Provide the address of the array. */
13992 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13993 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13994 :
13995 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13996 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13997 36 : msg = _("Assignment of scalar to unallocated array");
13998 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13999 : &expr1->where, msg);
14000 : }
14001 :
14002 : /* Deallocate the lhs parameterized components if required. */
14003 311888 : if (dealloc
14004 292922 : && !expr1->symtree->n.sym->attr.associate_var
14005 290940 : && expr2->expr_type != EXPR_ARRAY
14006 284748 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
14007 : {
14008 367 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
14009 :
14010 367 : tmp = lse.expr;
14011 367 : if (pdt_dep)
14012 : {
14013 : /* Create a temporary for deallocation after assignment. */
14014 168 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
14015 168 : gfc_add_modify (&lse.pre, tmp, lse.expr);
14016 : }
14017 :
14018 367 : if (expr1->ts.type == BT_DERIVED)
14019 367 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
14020 : expr1->rank);
14021 0 : else if (expr1->ts.type == BT_CLASS)
14022 : {
14023 0 : tmp = gfc_class_data_get (tmp);
14024 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
14025 : tmp, expr1->rank);
14026 : }
14027 :
14028 367 : if (tmp && pdt_dep)
14029 92 : gfc_add_expr_to_block (&rse.post, tmp);
14030 275 : else if (tmp)
14031 67 : gfc_add_expr_to_block (&lse.pre, tmp);
14032 : }
14033 : }
14034 :
14035 : /* Assignments of scalar derived types with allocatable components
14036 : to arrays must be done with a deep copy and the rhs temporary
14037 : must have its components deallocated afterwards. */
14038 626004 : scalar_to_array = (expr2->ts.type == BT_DERIVED
14039 19985 : && expr2->ts.u.derived->attr.alloc_comp
14040 6958 : && !gfc_expr_is_variable (expr2)
14041 316777 : && expr1->rank && !expr2->rank);
14042 626004 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
14043 20280 : && expr1->rank
14044 3897 : && expr1->ts.u.derived->attr.alloc_comp
14045 314437 : && gfc_is_alloc_class_scalar_function (expr2));
14046 313002 : if (scalar_to_array && dealloc)
14047 : {
14048 59 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
14049 59 : gfc_prepend_expr_to_block (&loop.post, tmp);
14050 : }
14051 :
14052 : /* When assigning a character function result to a deferred-length variable,
14053 : the function call must happen before the (re)allocation of the lhs -
14054 : otherwise the character length of the result is not known.
14055 : NOTE 1: This relies on having the exact dependence of the length type
14056 : parameter available to the caller; gfortran saves it in the .mod files.
14057 : NOTE 2: Vector array references generate an index temporary that must
14058 : not go outside the loop. Otherwise, variables should not generate
14059 : a pre block.
14060 : NOTE 3: The concatenation operation generates a temporary pointer,
14061 : whose allocation must go to the innermost loop.
14062 : NOTE 4: Elemental functions may generate a temporary, too. */
14063 313002 : if (flag_realloc_lhs
14064 306776 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
14065 3020 : && !(lss != gfc_ss_terminator
14066 940 : && rss != gfc_ss_terminator
14067 940 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
14068 753 : || (expr2->expr_type == EXPR_FUNCTION
14069 160 : && expr2->value.function.esym != NULL
14070 26 : && expr2->value.function.esym->attr.elemental)
14071 740 : || (expr2->expr_type == EXPR_FUNCTION
14072 147 : && expr2->value.function.isym != NULL
14073 134 : && expr2->value.function.isym->elemental)
14074 684 : || (expr2->expr_type == EXPR_OP
14075 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
14076 2739 : gfc_add_block_to_block (&block, &rse.pre);
14077 :
14078 : /* Nullify the allocatable components corresponding to those of the lhs
14079 : derived type, so that the finalization of the function result does not
14080 : affect the lhs of the assignment. Prepend is used to ensure that the
14081 : nullification occurs before the call to the finalizer. In the case of
14082 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
14083 : as part of the deep copy. */
14084 312168 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
14085 332448 : && (gfc_is_class_array_function (expr2)
14086 19422 : || gfc_is_alloc_class_scalar_function (expr2)))
14087 : {
14088 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
14089 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
14090 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
14091 0 : gfc_add_block_to_block (&loop.post, &rse.post);
14092 : }
14093 :
14094 313002 : tmp = NULL_TREE;
14095 :
14096 313002 : if (is_poly_assign)
14097 : {
14098 10263 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
14099 575 : use_vptr_copy || (lhs_attr.allocatable
14100 307 : && !lhs_attr.dimension),
14101 3147 : !realloc_flag && flag_realloc_lhs
14102 575 : && !lhs_attr.pointer);
14103 3421 : if (expr2->expr_type == EXPR_FUNCTION
14104 232 : && expr2->ts.type == BT_DERIVED
14105 18 : && expr2->ts.u.derived->attr.alloc_comp)
14106 : {
14107 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
14108 : rse.expr, expr2->rank);
14109 18 : if (lss == gfc_ss_terminator)
14110 18 : gfc_add_expr_to_block (&rse.post, tmp2);
14111 : else
14112 0 : gfc_add_expr_to_block (&loop.post, tmp2);
14113 : }
14114 :
14115 3421 : expr1->must_finalize = 0;
14116 : }
14117 309581 : else if (!is_poly_assign
14118 309581 : && expr1->ts.type == BT_CLASS
14119 448 : && expr2->ts.type == BT_CLASS
14120 255 : && (expr2->must_finalize || dummy_class_array_copy))
14121 : {
14122 : /* This case comes about when the scalarizer provides array element
14123 : references to class temporaries or nonpointer dummy arrays. Use the
14124 : vptr copy function, since this does a deep copy of allocatable
14125 : components. */
14126 132 : tmp = gfc_get_vptr_from_expr (rse.expr);
14127 132 : if (tmp == NULL_TREE && dummy_class_array_copy)
14128 12 : tmp = gfc_get_vptr_from_expr (gfc_get_class_from_gfc_expr (expr2));
14129 132 : if (tmp != NULL_TREE)
14130 : {
14131 132 : tree fcn = gfc_vptr_copy_get (tmp);
14132 132 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
14133 132 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
14134 132 : tmp = build_call_expr_loc (input_location,
14135 : fcn, 2,
14136 : gfc_build_addr_expr (NULL, rse.expr),
14137 : gfc_build_addr_expr (NULL, lse.expr));
14138 : }
14139 : }
14140 :
14141 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
14142 : after evaluation of the rhs and before reallocation.
14143 : Skip finalization for self-assignment to avoid use-after-free.
14144 : Strip parentheses from both sides to handle cases like a = (a). */
14145 313002 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
14146 313002 : if (final_expr
14147 684 : && gfc_dep_compare_expr (strip_parentheses (expr1),
14148 : strip_parentheses (expr2)) != 0
14149 313662 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
14150 229 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
14151 : {
14152 660 : if (lss == gfc_ss_terminator)
14153 : {
14154 189 : gfc_add_block_to_block (&block, &rse.pre);
14155 189 : gfc_add_block_to_block (&block, &lse.finalblock);
14156 : }
14157 : else
14158 : {
14159 471 : gfc_add_block_to_block (&body, &rse.pre);
14160 471 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
14161 : &lse.finalblock);
14162 : }
14163 : }
14164 : else
14165 312342 : gfc_add_block_to_block (&body, &rse.pre);
14166 :
14167 313002 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
14168 2994 : && assoc_assign)
14169 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
14170 :
14171 : /* The finalization above is all that is wanted: the structure copy is done
14172 : component by component in generate_component_assignments. */
14173 313002 : if (expr1->finalize_only)
14174 24 : tmp = build_empty_stmt (input_location);
14175 :
14176 : /* If nothing else works, do it the old fashioned way! */
14177 313002 : if (tmp == NULL_TREE)
14178 : {
14179 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
14180 309425 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
14181 309425 : tmp
14182 618850 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
14183 309425 : gfc_expr_is_variable (expr2_stripped)
14184 278764 : || scalar_to_array
14185 278020 : || expr2->expr_type == EXPR_ARRAY,
14186 : !(l_is_temp || init_flag) && dealloc,
14187 309425 : expr1->symtree->n.sym->attr.codimension,
14188 : assoc_assign);
14189 : }
14190 :
14191 : /* Add the lse pre block to the body */
14192 313002 : gfc_add_block_to_block (&body, &lse.pre);
14193 313002 : gfc_add_expr_to_block (&body, tmp);
14194 :
14195 : /* Add the post blocks to the body. Scalar finalization must appear before
14196 : the post block in case any dellocations are done. */
14197 313002 : if (rse.finalblock.head
14198 313002 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
14199 154 : && gfc_expr_attr (expr2).elemental)))
14200 : {
14201 154 : gfc_add_block_to_block (&body, &rse.finalblock);
14202 154 : gfc_add_block_to_block (&body, &rse.post);
14203 : }
14204 : else
14205 312848 : gfc_add_block_to_block (&body, &rse.post);
14206 :
14207 313002 : gfc_add_block_to_block (&body, &lse.post);
14208 :
14209 313002 : if (lss == gfc_ss_terminator)
14210 : {
14211 : /* F2003: Add the code for reallocation on assignment. */
14212 269537 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
14213 276063 : && !is_poly_assign)
14214 3691 : alloc_scalar_allocatable_for_assignment (&block, string_length,
14215 : expr1, expr2);
14216 :
14217 : /* Use the scalar assignment as is. */
14218 272372 : gfc_add_block_to_block (&block, &body);
14219 : }
14220 : else
14221 : {
14222 40630 : gcc_assert (lse.ss == gfc_ss_terminator
14223 : && rse.ss == gfc_ss_terminator);
14224 :
14225 40630 : if (l_is_temp)
14226 : {
14227 1114 : gfc_trans_scalarized_loop_boundary (&loop, &body);
14228 :
14229 : /* We need to copy the temporary to the actual lhs. */
14230 1114 : gfc_init_se (&lse, NULL);
14231 1114 : gfc_init_se (&rse, NULL);
14232 1114 : gfc_copy_loopinfo_to_se (&lse, &loop);
14233 1114 : gfc_copy_loopinfo_to_se (&rse, &loop);
14234 :
14235 1114 : rse.ss = loop.temp_ss;
14236 1114 : lse.ss = lss;
14237 :
14238 1114 : gfc_conv_tmp_array_ref (&rse);
14239 1114 : gfc_conv_expr (&lse, expr1);
14240 :
14241 1114 : gcc_assert (lse.ss == gfc_ss_terminator
14242 : && rse.ss == gfc_ss_terminator);
14243 :
14244 1114 : if (expr2->ts.type == BT_CHARACTER)
14245 123 : rse.string_length = string_length;
14246 :
14247 1114 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
14248 : false, dealloc);
14249 1114 : gfc_add_expr_to_block (&body, tmp);
14250 : }
14251 :
14252 40630 : if (reallocation != NULL_TREE)
14253 6567 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
14254 :
14255 40630 : if (maybe_workshare)
14256 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
14257 :
14258 : /* Generate the copying loops. */
14259 40630 : gfc_trans_scalarizing_loops (&loop, &body);
14260 :
14261 : /* Wrap the whole thing up. */
14262 40630 : gfc_add_block_to_block (&block, &loop.pre);
14263 40630 : gfc_add_block_to_block (&block, &loop.post);
14264 :
14265 40630 : gfc_cleanup_loop (&loop);
14266 : }
14267 :
14268 : /* Since parameterized components cannot have default initializers,
14269 : the default PDT constructor leaves them unallocated. Do the
14270 : allocation now. */
14271 313002 : if (init_flag && IS_PDT (expr1)
14272 383 : && !expr1->symtree->n.sym->attr.allocatable
14273 383 : && !expr1->symtree->n.sym->attr.dummy)
14274 : {
14275 79 : gfc_symbol *sym = expr1->symtree->n.sym;
14276 79 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
14277 : sym->backend_decl,
14278 79 : sym->as ? sym->as->rank : 0,
14279 79 : sym->param_list);
14280 79 : gfc_add_expr_to_block (&block, tmp);
14281 : }
14282 :
14283 313002 : return gfc_finish_block (&block);
14284 : }
14285 :
14286 :
14287 : /* Check whether EXPR is a copyable array. */
14288 :
14289 : static bool
14290 991942 : copyable_array_p (gfc_expr * expr)
14291 : {
14292 991942 : if (expr->expr_type != EXPR_VARIABLE)
14293 : return false;
14294 :
14295 : /* First check it's an array. */
14296 967901 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
14297 : return false;
14298 :
14299 149773 : if (!gfc_full_array_ref_p (expr->ref, NULL))
14300 : return false;
14301 :
14302 : /* Next check that it's of a simple enough type. */
14303 117473 : switch (expr->ts.type)
14304 : {
14305 : case BT_INTEGER:
14306 : case BT_REAL:
14307 : case BT_COMPLEX:
14308 : case BT_LOGICAL:
14309 : return true;
14310 :
14311 : case BT_CHARACTER:
14312 : return false;
14313 :
14314 6803 : case_bt_struct:
14315 6803 : return (!expr->ts.u.derived->attr.alloc_comp
14316 6803 : && !expr->ts.u.derived->attr.pdt_type);
14317 :
14318 : default:
14319 : break;
14320 : }
14321 :
14322 : return false;
14323 : }
14324 :
14325 : /* Translate an assignment. */
14326 :
14327 : tree
14328 331047 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
14329 : bool dealloc, bool use_vptr_copy, bool may_alias)
14330 : {
14331 331047 : tree tmp;
14332 :
14333 : /* Special case a single function returning an array. */
14334 331047 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
14335 : {
14336 14512 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
14337 14512 : if (tmp)
14338 : return tmp;
14339 : }
14340 :
14341 : /* Special case assigning an array to zero. */
14342 324180 : if (copyable_array_p (expr1)
14343 324180 : && is_zero_initializer_p (expr2))
14344 : {
14345 4054 : tmp = gfc_trans_zero_assign (expr1);
14346 4054 : if (tmp)
14347 : return tmp;
14348 : }
14349 :
14350 : /* Special case copying one array to another. */
14351 320423 : if (copyable_array_p (expr1)
14352 28402 : && copyable_array_p (expr2)
14353 2699 : && gfc_compare_types (&expr1->ts, &expr2->ts)
14354 323122 : && !gfc_check_dependency (expr1, expr2, 0))
14355 : {
14356 2603 : tmp = gfc_trans_array_copy (expr1, expr2);
14357 2603 : if (tmp)
14358 : return tmp;
14359 : }
14360 :
14361 : /* Special case initializing an array from a constant array constructor. */
14362 318937 : if (copyable_array_p (expr1)
14363 26916 : && expr2->expr_type == EXPR_ARRAY
14364 327250 : && gfc_compare_types (&expr1->ts, &expr2->ts))
14365 : {
14366 8313 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
14367 8313 : if (tmp)
14368 : return tmp;
14369 : }
14370 :
14371 313002 : if (UNLIMITED_POLY (expr1) && expr1->rank)
14372 313002 : use_vptr_copy = true;
14373 :
14374 : /* Fallback to the scalarizer to generate explicit loops. */
14375 313002 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
14376 313002 : use_vptr_copy, may_alias);
14377 : }
14378 :
14379 : tree
14380 13475 : gfc_trans_init_assign (gfc_code * code)
14381 : {
14382 13475 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
14383 : }
14384 :
14385 : tree
14386 309085 : gfc_trans_assign (gfc_code * code)
14387 : {
14388 309085 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
14389 : }
14390 :
14391 : /* Generate a simple loop for internal use of the form
14392 : for (var = begin; var <cond> end; var += step)
14393 : body; */
14394 : void
14395 12281 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
14396 : enum tree_code cond, tree step, tree body)
14397 : {
14398 12281 : tree tmp;
14399 :
14400 : /* var = begin. */
14401 12281 : gfc_add_modify (block, var, begin);
14402 :
14403 : /* Loop: for (var = begin; var <cond> end; var += step). */
14404 12281 : tree label_loop = gfc_build_label_decl (NULL_TREE);
14405 12281 : tree label_cond = gfc_build_label_decl (NULL_TREE);
14406 12281 : TREE_USED (label_loop) = 1;
14407 12281 : TREE_USED (label_cond) = 1;
14408 :
14409 12281 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
14410 12281 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
14411 :
14412 : /* Loop body. */
14413 12281 : gfc_add_expr_to_block (block, body);
14414 :
14415 : /* End of loop body. */
14416 12281 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
14417 12281 : gfc_add_modify (block, var, tmp);
14418 12281 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
14419 12281 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
14420 12281 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
14421 : build_empty_stmt (input_location));
14422 12281 : gfc_add_expr_to_block (block, tmp);
14423 12281 : }
|
