Line data Source code
1 : /* Expression translation
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Paul Brook <paul@nowt.org>
4 : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 :
6 : This file is part of GCC.
7 :
8 : GCC is free software; you can redistribute it and/or modify it under
9 : the terms of the GNU General Public License as published by the Free
10 : Software Foundation; either version 3, or (at your option) any later
11 : version.
12 :
13 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : for more details.
17 :
18 : You should have received a copy of the GNU General Public License
19 : along with GCC; see the file COPYING3. If not see
20 : <http://www.gnu.org/licenses/>. */
21 :
22 : /* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
23 :
24 : #define INCLUDE_MEMORY
25 : #include "config.h"
26 : #include "system.h"
27 : #include "coretypes.h"
28 : #include "options.h"
29 : #include "tree.h"
30 : #include "gfortran.h"
31 : #include "trans.h"
32 : #include "stringpool.h"
33 : #include "diagnostic-core.h" /* For fatal_error. */
34 : #include "fold-const.h"
35 : #include "langhooks.h"
36 : #include "arith.h"
37 : #include "constructor.h"
38 : #include "trans-const.h"
39 : #include "trans-types.h"
40 : #include "trans-array.h"
41 : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 : #include "trans-stmt.h"
43 : #include "dependency.h"
44 : #include "gimplify.h"
45 : #include "tm.h" /* For CHAR_TYPE_SIZE. */
46 :
47 :
48 : /* Calculate the number of characters in a string. */
49 :
50 : static tree
51 36063 : gfc_get_character_len (tree type)
52 : {
53 36063 : tree len;
54 :
55 36063 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
56 : && TYPE_STRING_FLAG (type));
57 :
58 36063 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
59 36063 : len = (len) ? (len) : (integer_zero_node);
60 36063 : return fold_convert (gfc_charlen_type_node, len);
61 : }
62 :
63 :
64 :
65 : /* Calculate the number of bytes in a string. */
66 :
67 : tree
68 36063 : gfc_get_character_len_in_bytes (tree type)
69 : {
70 36063 : tree tmp, len;
71 :
72 36063 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
73 : && TYPE_STRING_FLAG (type));
74 :
75 36063 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
76 72126 : tmp = (tmp && !integer_zerop (tmp))
77 72126 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
78 36063 : len = gfc_get_character_len (type);
79 36063 : if (tmp && len && !integer_zerop (len))
80 35291 : len = fold_build2_loc (input_location, MULT_EXPR,
81 : gfc_charlen_type_node, len, tmp);
82 36063 : return len;
83 : }
84 :
85 :
86 : /* Convert a scalar to an array descriptor. To be used for assumed-rank
87 : arrays. */
88 :
89 : static tree
90 6265 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
91 : {
92 6265 : enum gfc_array_kind akind;
93 6265 : tree *lbound = NULL, *ubound = NULL;
94 6265 : int codim = 0;
95 :
96 6265 : if (attr.pointer)
97 : akind = GFC_ARRAY_POINTER_CONT;
98 5913 : else if (attr.allocatable)
99 : akind = GFC_ARRAY_ALLOCATABLE;
100 : else
101 5144 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
102 :
103 6265 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
104 5318 : scalar = TREE_TYPE (scalar);
105 6265 : if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
106 : {
107 4726 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
108 4726 : codim = lang_specific->corank;
109 4726 : lbound = lang_specific->lbound;
110 4726 : ubound = lang_specific->ubound;
111 : }
112 6265 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
113 : ubound, 1, akind,
114 6265 : !(attr.pointer || attr.target));
115 : }
116 :
117 : tree
118 5587 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
119 : {
120 5587 : tree desc, type, etype;
121 :
122 5587 : type = get_scalar_to_descriptor_type (scalar, attr);
123 5587 : etype = TREE_TYPE (scalar);
124 5587 : desc = gfc_create_var (type, "desc");
125 5587 : DECL_ARTIFICIAL (desc) = 1;
126 :
127 5587 : if (CONSTANT_CLASS_P (scalar))
128 : {
129 54 : tree tmp;
130 54 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
131 54 : gfc_add_modify (&se->pre, tmp, scalar);
132 54 : scalar = tmp;
133 : }
134 5587 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
135 947 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
136 4640 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
137 158 : etype = TREE_TYPE (etype);
138 5587 : gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
139 : gfc_get_dtype_rank_type (0, etype));
140 5587 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
141 5587 : gfc_conv_descriptor_span_set (&se->pre, desc,
142 : gfc_conv_descriptor_elem_len (desc));
143 :
144 : /* Copy pointer address back - but only if it could have changed and
145 : if the actual argument is a pointer and not, e.g., NULL(). */
146 5587 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
147 846 : gfc_add_modify (&se->post, scalar,
148 423 : fold_convert (TREE_TYPE (scalar),
149 : gfc_conv_descriptor_data_get (desc)));
150 5587 : return desc;
151 : }
152 :
153 :
154 : /* Get the coarray token from the ultimate array or component ref.
155 : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
156 :
157 : tree
158 508 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
159 : {
160 508 : gfc_symbol *sym = expr->symtree->n.sym;
161 1016 : bool is_coarray = sym->ts.type == BT_CLASS
162 508 : ? CLASS_DATA (sym)->attr.codimension
163 463 : : sym->attr.codimension;
164 508 : gfc_expr *caf_expr = gfc_copy_expr (expr);
165 508 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
166 :
167 1610 : while (ref)
168 : {
169 1102 : if (ref->type == REF_COMPONENT
170 415 : && (ref->u.c.component->attr.allocatable
171 104 : || ref->u.c.component->attr.pointer)
172 413 : && (is_coarray || ref->u.c.component->attr.codimension))
173 1102 : last_caf_ref = ref;
174 1102 : ref = ref->next;
175 : }
176 :
177 508 : if (last_caf_ref == NULL)
178 : {
179 178 : gfc_free_expr (caf_expr);
180 178 : return NULL_TREE;
181 : }
182 :
183 143 : tree comp = last_caf_ref->u.c.component->caf_token
184 330 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
185 : : NULL_TREE,
186 : caf;
187 330 : gfc_se se;
188 330 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
189 330 : if (comp == NULL_TREE && comp_ref)
190 : {
191 46 : gfc_free_expr (caf_expr);
192 46 : return NULL_TREE;
193 : }
194 284 : gfc_init_se (&se, outerse);
195 284 : gfc_free_ref_list (last_caf_ref->next);
196 284 : last_caf_ref->next = NULL;
197 284 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
198 568 : caf_expr->corank = last_caf_ref->u.c.component->as
199 284 : ? last_caf_ref->u.c.component->as->corank
200 : : expr->corank;
201 284 : se.want_pointer = comp_ref;
202 284 : gfc_conv_expr (&se, caf_expr);
203 284 : gfc_add_block_to_block (&outerse->pre, &se.pre);
204 :
205 284 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
206 143 : se.expr = TREE_OPERAND (se.expr, 0);
207 284 : gfc_free_expr (caf_expr);
208 :
209 284 : if (comp_ref)
210 143 : caf = fold_build3_loc (input_location, COMPONENT_REF,
211 143 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
212 : else
213 141 : caf = gfc_conv_descriptor_token (se.expr);
214 284 : return gfc_build_addr_expr (NULL_TREE, caf);
215 : }
216 :
217 :
218 : /* This is the seed for an eventual trans-class.c
219 :
220 : The following parameters should not be used directly since they might
221 : in future implementations. Use the corresponding APIs. */
222 : #define CLASS_DATA_FIELD 0
223 : #define CLASS_VPTR_FIELD 1
224 : #define CLASS_LEN_FIELD 2
225 : #define VTABLE_HASH_FIELD 0
226 : #define VTABLE_SIZE_FIELD 1
227 : #define VTABLE_EXTENDS_FIELD 2
228 : #define VTABLE_DEF_INIT_FIELD 3
229 : #define VTABLE_COPY_FIELD 4
230 : #define VTABLE_FINAL_FIELD 5
231 : #define VTABLE_DEALLOCATE_FIELD 6
232 :
233 :
234 : tree
235 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
236 : {
237 40 : tree tmp;
238 40 : tree field;
239 40 : vec<constructor_elt, va_gc> *init = NULL;
240 :
241 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
242 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
243 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
244 :
245 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
246 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
247 :
248 40 : return build_constructor (TREE_TYPE (decl), init);
249 : }
250 :
251 :
252 : tree
253 31455 : gfc_class_data_get (tree decl)
254 : {
255 31455 : tree data;
256 31455 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
257 5297 : decl = build_fold_indirect_ref_loc (input_location, decl);
258 31455 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
259 : CLASS_DATA_FIELD);
260 31455 : return fold_build3_loc (input_location, COMPONENT_REF,
261 31455 : TREE_TYPE (data), decl, data,
262 31455 : NULL_TREE);
263 : }
264 :
265 :
266 : tree
267 44515 : gfc_class_vptr_get (tree decl)
268 : {
269 44515 : tree vptr;
270 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
271 : then available through the saved descriptor. */
272 27411 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
273 46279 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
274 1261 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
275 44515 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
276 2326 : decl = build_fold_indirect_ref_loc (input_location, decl);
277 44515 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
278 : CLASS_VPTR_FIELD);
279 44515 : return fold_build3_loc (input_location, COMPONENT_REF,
280 44515 : TREE_TYPE (vptr), decl, vptr,
281 44515 : NULL_TREE);
282 : }
283 :
284 :
285 : tree
286 6656 : gfc_class_len_get (tree decl)
287 : {
288 6656 : tree len;
289 : /* For class arrays decl may be a temporary descriptor handle, the len is
290 : then available through the saved descriptor. */
291 4790 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
292 6905 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
293 85 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
294 6656 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
295 662 : decl = build_fold_indirect_ref_loc (input_location, decl);
296 6656 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
297 : CLASS_LEN_FIELD);
298 6656 : return fold_build3_loc (input_location, COMPONENT_REF,
299 6656 : TREE_TYPE (len), decl, len,
300 6656 : NULL_TREE);
301 : }
302 :
303 :
304 : /* Try to get the _len component of a class. When the class is not unlimited
305 : poly, i.e. no _len field exists, then return a zero node. */
306 :
307 : static tree
308 4839 : gfc_class_len_or_zero_get (tree decl)
309 : {
310 4839 : tree len;
311 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
312 : then available through the saved descriptor. */
313 2873 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
314 4887 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
315 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
316 4839 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
317 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
318 4839 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
319 : CLASS_LEN_FIELD);
320 6696 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
321 1857 : TREE_TYPE (len), decl, len,
322 : NULL_TREE)
323 2982 : : build_zero_cst (gfc_charlen_type_node);
324 : }
325 :
326 :
327 : tree
328 4680 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
329 : {
330 4680 : tree tmp;
331 4680 : tree tmp2;
332 4680 : tree type;
333 :
334 4680 : tmp = gfc_class_len_or_zero_get (class_expr);
335 :
336 : /* Include the len value in the element size if present. */
337 4680 : if (!integer_zerop (tmp))
338 : {
339 1698 : type = TREE_TYPE (size);
340 1698 : if (block)
341 : {
342 985 : size = gfc_evaluate_now (size, block);
343 985 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
344 : }
345 : else
346 713 : tmp = fold_convert (type , tmp);
347 1698 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
348 : type, size, tmp);
349 1698 : tmp = fold_build2_loc (input_location, GT_EXPR,
350 : logical_type_node, tmp,
351 : build_zero_cst (type));
352 1698 : size = fold_build3_loc (input_location, COND_EXPR,
353 : type, tmp, tmp2, size);
354 : }
355 : else
356 : return size;
357 :
358 1698 : if (block)
359 985 : size = gfc_evaluate_now (size, block);
360 :
361 : return size;
362 : }
363 :
364 :
365 : /* Get the specified FIELD from the VPTR. */
366 :
367 : static tree
368 20825 : vptr_field_get (tree vptr, int fieldno)
369 : {
370 20825 : tree field;
371 20825 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
372 20825 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
373 : fieldno);
374 20825 : field = fold_build3_loc (input_location, COMPONENT_REF,
375 20825 : TREE_TYPE (field), vptr, field,
376 : NULL_TREE);
377 20825 : gcc_assert (field);
378 20825 : return field;
379 : }
380 :
381 :
382 : /* Get the field from the class' vptr. */
383 :
384 : static tree
385 9702 : class_vtab_field_get (tree decl, int fieldno)
386 : {
387 9702 : tree vptr;
388 9702 : vptr = gfc_class_vptr_get (decl);
389 9702 : return vptr_field_get (vptr, fieldno);
390 : }
391 :
392 :
393 : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
394 : unison. */
395 : #define VTAB_GET_FIELD_GEN(name, field) tree \
396 : gfc_class_vtab_## name ##_get (tree cl) \
397 : { \
398 : return class_vtab_field_get (cl, field); \
399 : } \
400 : \
401 : tree \
402 : gfc_vptr_## name ##_get (tree vptr) \
403 : { \
404 : return vptr_field_get (vptr, field); \
405 : }
406 :
407 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
408 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
409 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
410 4290 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
411 1798 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
412 1023 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
413 : #undef VTAB_GET_FIELD_GEN
414 :
415 : /* The size field is returned as an array index type. Therefore treat
416 : it and only it specially. */
417 :
418 : tree
419 7732 : gfc_class_vtab_size_get (tree cl)
420 : {
421 7732 : tree size;
422 7732 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
423 : /* Always return size as an array index type. */
424 7732 : size = fold_convert (gfc_array_index_type, size);
425 7732 : gcc_assert (size);
426 7732 : return size;
427 : }
428 :
429 : tree
430 5799 : gfc_vptr_size_get (tree vptr)
431 : {
432 5799 : tree size;
433 5799 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
434 : /* Always return size as an array index type. */
435 5799 : size = fold_convert (gfc_array_index_type, size);
436 5799 : gcc_assert (size);
437 5799 : return size;
438 : }
439 :
440 :
441 : #undef CLASS_DATA_FIELD
442 : #undef CLASS_VPTR_FIELD
443 : #undef CLASS_LEN_FIELD
444 : #undef VTABLE_HASH_FIELD
445 : #undef VTABLE_SIZE_FIELD
446 : #undef VTABLE_EXTENDS_FIELD
447 : #undef VTABLE_DEF_INIT_FIELD
448 : #undef VTABLE_COPY_FIELD
449 : #undef VTABLE_FINAL_FIELD
450 :
451 :
452 : /* IF ts is null (default), search for the last _class ref in the chain
453 : of references of the expression and cut the chain there. Although
454 : this routine is similiar to class.cc:gfc_add_component_ref (), there
455 : is a significant difference: gfc_add_component_ref () concentrates
456 : on an array ref that is the last ref in the chain and is oblivious
457 : to the kind of refs following.
458 : ELSE IF ts is non-null the cut is at the class entity or component
459 : that is followed by an array reference, which is not an element.
460 : These calls come from trans-array.cc:build_class_array_ref, which
461 : handles scalarized class array references.*/
462 :
463 : gfc_expr *
464 9188 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
465 : gfc_typespec **ts)
466 : {
467 9188 : gfc_expr *base_expr;
468 9188 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
469 :
470 : /* Find the last class reference. */
471 9188 : class_ref = NULL;
472 9188 : array_ref = NULL;
473 :
474 9188 : if (ts)
475 : {
476 387 : if (e->symtree
477 362 : && e->symtree->n.sym->ts.type == BT_CLASS)
478 362 : *ts = &e->symtree->n.sym->ts;
479 : else
480 25 : *ts = NULL;
481 : }
482 :
483 23115 : for (ref = e->ref; ref; ref = ref->next)
484 : {
485 14299 : if (ts)
486 : {
487 942 : if (ref->type == REF_COMPONENT
488 442 : && ref->u.c.component->ts.type == BT_CLASS
489 0 : && ref->next && ref->next->type == REF_COMPONENT
490 0 : && !strcmp (ref->next->u.c.component->name, "_data")
491 0 : && ref->next->next
492 0 : && ref->next->next->type == REF_ARRAY
493 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
494 : {
495 0 : *ts = &ref->u.c.component->ts;
496 0 : class_ref = ref;
497 0 : break;
498 : }
499 :
500 942 : if (ref->next == NULL)
501 : break;
502 : }
503 : else
504 : {
505 13357 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
506 13357 : array_ref = ref;
507 :
508 13357 : if (ref->type == REF_COMPONENT
509 8059 : && ref->u.c.component->ts.type == BT_CLASS)
510 : {
511 : /* Component to the right of a part reference with nonzero
512 : rank must not have the ALLOCATABLE attribute. If attempts
513 : are made to reference such a component reference, an error
514 : results followed by an ICE. */
515 1584 : if (array_ref
516 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
517 : return NULL;
518 : class_ref = ref;
519 : }
520 : }
521 : }
522 :
523 9178 : if (ts && *ts == NULL)
524 : return NULL;
525 :
526 : /* Remove and store all subsequent references after the
527 : CLASS reference. */
528 9153 : if (class_ref)
529 : {
530 1394 : tail = class_ref->next;
531 1394 : class_ref->next = NULL;
532 : }
533 7759 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
534 : {
535 7741 : tail = e->ref;
536 7741 : e->ref = NULL;
537 : }
538 :
539 9153 : if (is_mold)
540 61 : base_expr = gfc_expr_to_initialize (e);
541 : else
542 9092 : base_expr = gfc_copy_expr (e);
543 :
544 : /* Restore the original tail expression. */
545 9153 : if (class_ref)
546 : {
547 1394 : gfc_free_ref_list (class_ref->next);
548 1394 : class_ref->next = tail;
549 : }
550 7759 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
551 : {
552 7741 : gfc_free_ref_list (e->ref);
553 7741 : e->ref = tail;
554 : }
555 : return base_expr;
556 : }
557 :
558 : /* Reset the vptr to the declared type, e.g. after deallocation.
559 : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
560 : one with e or class_type. At least one of the two has to be set. The
561 : generated assignment code is added at the end of BLOCK. */
562 :
563 : void
564 10800 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
565 : gfc_symbol *class_type)
566 : {
567 10800 : tree vptr = NULL_TREE;
568 :
569 10800 : if (class_container != NULL_TREE)
570 6389 : vptr = gfc_get_vptr_from_expr (class_container);
571 :
572 6389 : if (vptr == NULL_TREE)
573 : {
574 4418 : gfc_se se;
575 4418 : gcc_assert (e);
576 :
577 : /* Evaluate the expression and obtain the vptr from it. */
578 4418 : gfc_init_se (&se, NULL);
579 4418 : if (e->rank)
580 2179 : gfc_conv_expr_descriptor (&se, e);
581 : else
582 2239 : gfc_conv_expr (&se, e);
583 4418 : gfc_add_block_to_block (block, &se.pre);
584 :
585 4418 : vptr = gfc_get_vptr_from_expr (se.expr);
586 : }
587 :
588 : /* If a vptr is not found, we can do nothing more. */
589 4418 : if (vptr == NULL_TREE)
590 : return;
591 :
592 10790 : if (UNLIMITED_POLY (e)
593 9765 : || UNLIMITED_POLY (class_type)
594 : /* When the class_type's source is not a symbol (e.g. a component's ts),
595 : then look at the _data-components type. */
596 1508 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
597 1508 : && class_type->components && class_type->components->ts.u.derived
598 1502 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
599 1192 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
600 : else
601 : {
602 9598 : gfc_symbol *vtab, *type = nullptr;
603 9598 : tree vtable;
604 :
605 9598 : if (e)
606 8257 : type = e->ts.u.derived;
607 1341 : else if (class_type)
608 : {
609 1341 : if (class_type->ts.type == BT_CLASS)
610 0 : type = CLASS_DATA (class_type)->ts.u.derived;
611 : else
612 : type = class_type;
613 : }
614 8257 : gcc_assert (type);
615 : /* Return the vptr to the address of the declared type. */
616 9598 : vtab = gfc_find_derived_vtab (type);
617 9598 : vtable = vtab->backend_decl;
618 9598 : if (vtable == NULL_TREE)
619 76 : vtable = gfc_get_symbol_decl (vtab);
620 9598 : vtable = gfc_build_addr_expr (NULL, vtable);
621 9598 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
622 9598 : gfc_add_modify (block, vptr, vtable);
623 : }
624 : }
625 :
626 : /* Set the vptr of a class in to from the type given in from. If from is NULL,
627 : then reset the vptr to the default or to. */
628 :
629 : void
630 216 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
631 : {
632 216 : tree tmp, vptr_ref;
633 216 : gfc_symbol *type;
634 :
635 216 : vptr_ref = gfc_get_vptr_from_expr (to);
636 252 : if (POINTER_TYPE_P (TREE_TYPE (from))
637 216 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
638 : {
639 44 : gfc_add_modify (block, vptr_ref,
640 22 : fold_convert (TREE_TYPE (vptr_ref),
641 : gfc_get_vptr_from_expr (from)));
642 238 : return;
643 : }
644 194 : tmp = gfc_get_vptr_from_expr (from);
645 194 : if (tmp)
646 : {
647 158 : gfc_add_modify (block, vptr_ref,
648 158 : fold_convert (TREE_TYPE (vptr_ref), tmp));
649 158 : return;
650 : }
651 36 : if (VAR_P (from)
652 36 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
653 : {
654 36 : gfc_add_modify (block, vptr_ref,
655 36 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
656 36 : return;
657 : }
658 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
659 0 : && GFC_CLASS_TYPE_P (
660 : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
661 : {
662 0 : gfc_add_modify (block, vptr_ref,
663 0 : fold_convert (TREE_TYPE (vptr_ref),
664 : gfc_get_vptr_from_expr (TREE_OPERAND (
665 : TREE_OPERAND (from, 0), 0))));
666 0 : return;
667 : }
668 :
669 : /* If nothing of the above matches, set the vtype according to the type. */
670 0 : tmp = TREE_TYPE (from);
671 0 : if (POINTER_TYPE_P (tmp))
672 0 : tmp = TREE_TYPE (tmp);
673 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
674 : &type);
675 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
676 0 : gcc_assert (tmp);
677 0 : gfc_add_modify (block, vptr_ref,
678 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
679 : }
680 :
681 : /* Reset the len for unlimited polymorphic objects. */
682 :
683 : void
684 629 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
685 : {
686 629 : gfc_expr *e;
687 629 : gfc_se se_len;
688 629 : e = gfc_find_and_cut_at_last_class_ref (expr);
689 629 : if (e == NULL)
690 0 : return;
691 629 : gfc_add_len_component (e);
692 629 : gfc_init_se (&se_len, NULL);
693 629 : gfc_conv_expr (&se_len, e);
694 629 : gfc_add_modify (block, se_len.expr,
695 629 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
696 629 : gfc_free_expr (e);
697 : }
698 :
699 :
700 : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
701 : reference is found. Note that it is up to the caller to avoid using this
702 : for expressions other than variables. */
703 :
704 : tree
705 1331 : gfc_get_class_from_gfc_expr (gfc_expr *e)
706 : {
707 1331 : gfc_expr *class_expr;
708 1331 : gfc_se cse;
709 1331 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
710 1331 : if (class_expr == NULL)
711 : return NULL_TREE;
712 1331 : gfc_init_se (&cse, NULL);
713 1331 : gfc_conv_expr (&cse, class_expr);
714 1331 : gfc_free_expr (class_expr);
715 1331 : return cse.expr;
716 : }
717 :
718 :
719 : /* Obtain the last class reference in an expression.
720 : Return NULL_TREE if no class reference is found. */
721 :
722 : tree
723 105574 : gfc_get_class_from_expr (tree expr)
724 : {
725 105574 : tree tmp;
726 105574 : tree type;
727 105574 : bool array_descr_found = false;
728 105574 : bool comp_after_descr_found = false;
729 :
730 272194 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
731 : {
732 272194 : if (CONSTANT_CLASS_P (tmp))
733 : return NULL_TREE;
734 :
735 272157 : type = TREE_TYPE (tmp);
736 315700 : while (type)
737 : {
738 307826 : if (GFC_CLASS_TYPE_P (type))
739 : return tmp;
740 288516 : if (GFC_DESCRIPTOR_TYPE_P (type))
741 34446 : array_descr_found = true;
742 288516 : if (type != TYPE_CANONICAL (type))
743 43543 : type = TYPE_CANONICAL (type);
744 : else
745 : type = NULL_TREE;
746 : }
747 252847 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
748 : break;
749 :
750 : /* Avoid walking up the reference chain too far. For class arrays, the
751 : array descriptor is a direct component (through a pointer) of the class
752 : container. So there is exactly one COMPONENT_REF between a class
753 : container and its child array descriptor. After seeing an array
754 : descriptor, we can give up on the second COMPONENT_REF we see, if no
755 : class container was found until that point. */
756 166620 : if (array_descr_found)
757 : {
758 7241 : if (comp_after_descr_found)
759 : {
760 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
761 : return NULL_TREE;
762 : }
763 7229 : else if (TREE_CODE (tmp) == COMPONENT_REF)
764 7241 : comp_after_descr_found = true;
765 : }
766 : }
767 :
768 86227 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
769 57891 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
770 :
771 86227 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
772 : return tmp;
773 :
774 : return NULL_TREE;
775 : }
776 :
777 :
778 : /* Obtain the vptr of the last class reference in an expression.
779 : Return NULL_TREE if no class reference is found. */
780 :
781 : tree
782 11407 : gfc_get_vptr_from_expr (tree expr)
783 : {
784 11407 : tree tmp;
785 :
786 11407 : tmp = gfc_get_class_from_expr (expr);
787 :
788 11407 : if (tmp != NULL_TREE)
789 11354 : return gfc_class_vptr_get (tmp);
790 :
791 : return NULL_TREE;
792 : }
793 :
794 : static void
795 2311 : copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
796 : {
797 2311 : tree src_type = TREE_TYPE (src);
798 2311 : if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
799 : {
800 135 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
801 270 : for (int c = 0; c < lang_specific->corank; ++c)
802 : {
803 135 : int dim = lang_specific->rank + c;
804 135 : tree codim = gfc_rank_cst[dim];
805 :
806 135 : if (lang_specific->lbound[dim])
807 54 : gfc_conv_descriptor_lbound_set (block, dest, codim,
808 : lang_specific->lbound[dim]);
809 : else
810 81 : gfc_conv_descriptor_lbound_set (
811 : block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
812 135 : if (dim + 1 < lang_specific->corank)
813 : {
814 0 : if (lang_specific->ubound[dim])
815 0 : gfc_conv_descriptor_ubound_set (block, dest, codim,
816 : lang_specific->ubound[dim]);
817 : else
818 0 : gfc_conv_descriptor_ubound_set (
819 : block, dest, codim,
820 : gfc_conv_descriptor_ubound_get (src, codim));
821 : }
822 : }
823 : }
824 2311 : }
825 :
826 : void
827 1989 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
828 : bool lhs_type)
829 : {
830 1989 : tree lhs_dim, rhs_dim, type;
831 :
832 1989 : gfc_conv_descriptor_data_set (block, lhs_desc,
833 : gfc_conv_descriptor_data_get (rhs_desc));
834 1989 : gfc_conv_descriptor_offset_set (block, lhs_desc,
835 : gfc_conv_descriptor_offset_get (rhs_desc));
836 :
837 1989 : gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
838 : gfc_conv_descriptor_dtype (rhs_desc));
839 :
840 : /* Assign the dimension as range-ref. */
841 1989 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
842 1989 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
843 :
844 1989 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
845 1989 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
846 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
847 1989 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
848 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
849 1989 : gfc_add_modify (block, lhs_dim, rhs_dim);
850 :
851 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
852 1989 : copy_coarray_desc_part (block, lhs_desc, rhs_desc);
853 1989 : }
854 :
855 : /* Takes a derived type expression and returns the address of a temporary
856 : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
857 : used for the temporary class object.
858 : optional_alloc_ptr is false when the dummy is neither allocatable
859 : nor a pointer; that's only relevant for the optional handling.
860 : The optional argument 'derived_array' is used to preserve the parmse
861 : expression for deallocation of allocatable components. Assumed rank
862 : formal arguments made this necessary. */
863 : void
864 4887 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
865 : tree opt_vptr_src, bool optional,
866 : bool optional_alloc_ptr, const char *proc_name,
867 : tree *derived_array)
868 : {
869 4887 : tree cond_optional = NULL_TREE;
870 4887 : gfc_ss *ss;
871 4887 : tree ctree;
872 4887 : tree var;
873 4887 : tree tmp;
874 4887 : tree packed = NULL_TREE;
875 :
876 : /* The derived type needs to be converted to a temporary CLASS object. */
877 4887 : tmp = gfc_typenode_for_spec (&fsym->ts);
878 4887 : var = gfc_create_var (tmp, "class");
879 :
880 : /* Set the vptr. */
881 4887 : if (opt_vptr_src)
882 116 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
883 : else
884 4771 : gfc_reset_vptr (&parmse->pre, e, var);
885 :
886 : /* Now set the data field. */
887 4887 : ctree = gfc_class_data_get (var);
888 :
889 4887 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
890 : {
891 4 : tree token;
892 4 : tmp = gfc_get_tree_for_caf_expr (e);
893 4 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
894 2 : tmp = build_fold_indirect_ref (tmp);
895 4 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
896 4 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), token);
897 : }
898 :
899 4887 : if (optional)
900 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
901 :
902 : /* Set the _len as early as possible. */
903 4887 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
904 4887 : && fsym->ts.u.derived->components->ts.u.derived->attr
905 4887 : .unlimited_polymorphic)
906 : {
907 : /* Take care about initializing the _len component correctly. */
908 386 : tree len_tree = gfc_class_len_get (var);
909 386 : if (UNLIMITED_POLY (e))
910 : {
911 12 : gfc_expr *len;
912 12 : gfc_se se;
913 :
914 12 : len = gfc_find_and_cut_at_last_class_ref (e);
915 12 : gfc_add_len_component (len);
916 12 : gfc_init_se (&se, NULL);
917 12 : gfc_conv_expr (&se, len);
918 12 : if (optional)
919 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
920 : cond_optional, se.expr,
921 0 : fold_convert (TREE_TYPE (se.expr),
922 : integer_zero_node));
923 : else
924 12 : tmp = se.expr;
925 12 : gfc_free_expr (len);
926 12 : }
927 : else
928 374 : tmp = integer_zero_node;
929 386 : gfc_add_modify (&parmse->pre, len_tree,
930 386 : fold_convert (TREE_TYPE (len_tree), tmp));
931 : }
932 :
933 4887 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
934 : {
935 : /* If there is a ready made pointer to a derived type, use it
936 : rather than evaluating the expression again. */
937 522 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
938 522 : gfc_add_modify (&parmse->pre, ctree, tmp);
939 : }
940 4365 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
941 : {
942 : /* For an array reference in an elemental procedure call we need
943 : to retain the ss to provide the scalarized array reference. */
944 253 : gfc_conv_expr_reference (parmse, e);
945 253 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
946 253 : if (optional)
947 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
948 : cond_optional, tmp,
949 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
950 253 : gfc_add_modify (&parmse->pre, ctree, tmp);
951 : }
952 : else
953 : {
954 4112 : ss = gfc_walk_expr (e);
955 4112 : if (ss == gfc_ss_terminator)
956 : {
957 2900 : parmse->ss = NULL;
958 2900 : gfc_conv_expr_reference (parmse, e);
959 :
960 : /* Scalar to an assumed-rank array. */
961 2900 : if (fsym->ts.u.derived->components->as)
962 : {
963 322 : tree type;
964 322 : type = get_scalar_to_descriptor_type (parmse->expr,
965 : gfc_expr_attr (e));
966 322 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
967 : gfc_get_dtype (type));
968 322 : copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
969 322 : if (optional)
970 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
971 96 : TREE_TYPE (parmse->expr),
972 : cond_optional, parmse->expr,
973 96 : fold_convert (TREE_TYPE (parmse->expr),
974 : null_pointer_node));
975 322 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
976 : }
977 : else
978 : {
979 2578 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
980 2578 : if (optional)
981 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
982 : cond_optional, tmp,
983 132 : fold_convert (TREE_TYPE (tmp),
984 : null_pointer_node));
985 2578 : gfc_add_modify (&parmse->pre, ctree, tmp);
986 : }
987 : }
988 : else
989 : {
990 1212 : stmtblock_t block;
991 1212 : gfc_init_block (&block);
992 1212 : gfc_ref *ref;
993 1212 : int dim;
994 1212 : tree lbshift = NULL_TREE;
995 :
996 : /* Array refs with sections indicate, that a for a formal argument
997 : expecting contiguous repacking needs to be done. */
998 2273 : for (ref = e->ref; ref; ref = ref->next)
999 1211 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1000 : break;
1001 1212 : if (IS_CLASS_ARRAY (fsym)
1002 1104 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
1003 846 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
1004 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
1005 144 : fsym->attr.contiguous = 1;
1006 :
1007 : /* Detect any array references with vector subscripts. */
1008 2417 : for (ref = e->ref; ref; ref = ref->next)
1009 1211 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
1010 1169 : && ref->u.ar.type != AR_FULL)
1011 : {
1012 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
1013 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
1014 : break;
1015 150 : if (dim < ref->u.ar.dimen)
1016 : break;
1017 : }
1018 : /* Array references with vector subscripts and non-variable
1019 : expressions need be converted to a one-based descriptor. */
1020 1212 : if (ref || e->expr_type != EXPR_VARIABLE)
1021 49 : lbshift = gfc_index_one_node;
1022 :
1023 1212 : parmse->expr = var;
1024 1212 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
1025 : &lbshift, &packed);
1026 :
1027 1212 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
1028 : {
1029 1116 : *derived_array
1030 1116 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
1031 1116 : gfc_add_modify (&block, *derived_array, parmse->expr);
1032 : }
1033 :
1034 1212 : if (optional)
1035 : {
1036 348 : tmp = gfc_finish_block (&block);
1037 :
1038 348 : gfc_init_block (&block);
1039 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
1040 348 : if (derived_array && *derived_array != NULL_TREE)
1041 348 : gfc_conv_descriptor_data_set (&block, *derived_array,
1042 : null_pointer_node);
1043 :
1044 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
1045 : gfc_finish_block (&block));
1046 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
1047 : }
1048 : else
1049 864 : gfc_add_block_to_block (&parmse->pre, &block);
1050 : }
1051 : }
1052 :
1053 : /* Pass the address of the class object. */
1054 4887 : if (packed)
1055 96 : parmse->expr = packed;
1056 : else
1057 4791 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1058 :
1059 4887 : if (optional && optional_alloc_ptr)
1060 84 : parmse->expr
1061 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1062 : cond_optional, parmse->expr,
1063 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1064 4887 : }
1065 :
1066 : /* Create a new class container, which is required as scalar coarrays
1067 : have an array descriptor while normal scalars haven't. Optionally,
1068 : NULL pointer checks are added if the argument is OPTIONAL. */
1069 :
1070 : static void
1071 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1072 : gfc_typespec class_ts, bool optional)
1073 : {
1074 48 : tree var, ctree, tmp;
1075 48 : stmtblock_t block;
1076 48 : gfc_ref *ref;
1077 48 : gfc_ref *class_ref;
1078 :
1079 48 : gfc_init_block (&block);
1080 :
1081 48 : class_ref = NULL;
1082 144 : for (ref = e->ref; ref; ref = ref->next)
1083 : {
1084 96 : if (ref->type == REF_COMPONENT
1085 48 : && ref->u.c.component->ts.type == BT_CLASS)
1086 96 : class_ref = ref;
1087 : }
1088 :
1089 48 : if (class_ref == NULL
1090 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1091 48 : tmp = e->symtree->n.sym->backend_decl;
1092 : else
1093 : {
1094 : /* Remove everything after the last class reference, convert the
1095 : expression and then recover its tailend once more. */
1096 0 : gfc_se tmpse;
1097 0 : ref = class_ref->next;
1098 0 : class_ref->next = NULL;
1099 0 : gfc_init_se (&tmpse, NULL);
1100 0 : gfc_conv_expr (&tmpse, e);
1101 0 : class_ref->next = ref;
1102 0 : tmp = tmpse.expr;
1103 : }
1104 :
1105 48 : var = gfc_typenode_for_spec (&class_ts);
1106 48 : var = gfc_create_var (var, "class");
1107 :
1108 48 : ctree = gfc_class_vptr_get (var);
1109 96 : gfc_add_modify (&block, ctree,
1110 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1111 :
1112 48 : ctree = gfc_class_data_get (var);
1113 48 : tmp = gfc_conv_descriptor_data_get (
1114 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1115 : ? tmp
1116 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1117 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1118 :
1119 : /* Pass the address of the class object. */
1120 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1121 :
1122 48 : if (optional)
1123 : {
1124 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1125 48 : tree tmp2;
1126 :
1127 48 : tmp = gfc_finish_block (&block);
1128 :
1129 48 : gfc_init_block (&block);
1130 48 : tmp2 = gfc_class_data_get (var);
1131 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1132 : null_pointer_node));
1133 48 : tmp2 = gfc_finish_block (&block);
1134 :
1135 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1136 : cond, tmp, tmp2);
1137 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1138 : }
1139 : else
1140 0 : gfc_add_block_to_block (&parmse->pre, &block);
1141 48 : }
1142 :
1143 :
1144 : /* Takes an intrinsic type expression and returns the address of a temporary
1145 : class object of the 'declared' type. */
1146 : void
1147 882 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1148 : gfc_typespec class_ts)
1149 : {
1150 882 : gfc_symbol *vtab;
1151 882 : gfc_ss *ss;
1152 882 : tree ctree;
1153 882 : tree var;
1154 882 : tree tmp;
1155 882 : int dim;
1156 882 : bool unlimited_poly;
1157 :
1158 1764 : unlimited_poly = class_ts.type == BT_CLASS
1159 882 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1160 882 : && class_ts.u.derived->components->ts.u.derived
1161 882 : ->attr.unlimited_polymorphic;
1162 :
1163 : /* The intrinsic type needs to be converted to a temporary
1164 : CLASS object. */
1165 882 : tmp = gfc_typenode_for_spec (&class_ts);
1166 882 : var = gfc_create_var (tmp, "class");
1167 :
1168 : /* Force a temporary for component or substring references. */
1169 882 : if (unlimited_poly
1170 882 : && class_ts.u.derived->components->attr.dimension
1171 623 : && !class_ts.u.derived->components->attr.allocatable
1172 623 : && !class_ts.u.derived->components->attr.class_pointer
1173 1505 : && is_subref_array (e))
1174 17 : parmse->force_tmp = 1;
1175 :
1176 : /* Set the vptr. */
1177 882 : ctree = gfc_class_vptr_get (var);
1178 :
1179 882 : vtab = gfc_find_vtab (&e->ts);
1180 882 : gcc_assert (vtab);
1181 882 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1182 882 : gfc_add_modify (&parmse->pre, ctree,
1183 882 : fold_convert (TREE_TYPE (ctree), tmp));
1184 :
1185 : /* Now set the data field. */
1186 882 : ctree = gfc_class_data_get (var);
1187 882 : if (parmse->ss && parmse->ss->info->useflags)
1188 : {
1189 : /* For an array reference in an elemental procedure call we need
1190 : to retain the ss to provide the scalarized array reference. */
1191 36 : gfc_conv_expr_reference (parmse, e);
1192 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1193 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1194 : }
1195 : else
1196 : {
1197 846 : ss = gfc_walk_expr (e);
1198 846 : if (ss == gfc_ss_terminator)
1199 : {
1200 247 : parmse->ss = NULL;
1201 247 : gfc_conv_expr_reference (parmse, e);
1202 247 : if (class_ts.u.derived->components->as
1203 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1204 : {
1205 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1206 : gfc_expr_attr (e));
1207 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1208 24 : TREE_TYPE (ctree), tmp);
1209 : }
1210 : else
1211 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1212 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1213 : }
1214 : else
1215 : {
1216 599 : parmse->ss = ss;
1217 599 : gfc_conv_expr_descriptor (parmse, e);
1218 :
1219 : /* Array references with vector subscripts and non-variable expressions
1220 : need be converted to a one-based descriptor. */
1221 599 : if (e->expr_type != EXPR_VARIABLE)
1222 : {
1223 368 : for (dim = 0; dim < e->rank; ++dim)
1224 193 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1225 : dim, gfc_index_one_node);
1226 : }
1227 :
1228 599 : if (class_ts.u.derived->components->as->rank != e->rank)
1229 : {
1230 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1231 49 : TREE_TYPE (ctree), parmse->expr);
1232 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1233 : }
1234 : else
1235 550 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1236 : }
1237 : }
1238 :
1239 882 : gcc_assert (class_ts.type == BT_CLASS);
1240 882 : if (unlimited_poly)
1241 : {
1242 882 : ctree = gfc_class_len_get (var);
1243 : /* When the actual arg is a char array, then set the _len component of the
1244 : unlimited polymorphic entity to the length of the string. */
1245 882 : if (e->ts.type == BT_CHARACTER)
1246 : {
1247 : /* Start with parmse->string_length because this seems to be set to a
1248 : correct value more often. */
1249 175 : if (parmse->string_length)
1250 : tmp = parmse->string_length;
1251 : /* When the string_length is not yet set, then try the backend_decl of
1252 : the cl. */
1253 0 : else if (e->ts.u.cl->backend_decl)
1254 : tmp = e->ts.u.cl->backend_decl;
1255 : /* If both of the above approaches fail, then try to generate an
1256 : expression from the input, which is only feasible currently, when the
1257 : expression can be evaluated to a constant one. */
1258 : else
1259 : {
1260 : /* Try to simplify the expression. */
1261 0 : gfc_simplify_expr (e, 0);
1262 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1263 : {
1264 : /* Amazingly all data is present to compute the length of a
1265 : constant string, but the expression is not yet there. */
1266 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1267 : gfc_charlen_int_kind,
1268 : &e->where);
1269 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1270 0 : e->value.character.length);
1271 0 : gfc_conv_const_charlen (e->ts.u.cl);
1272 0 : e->ts.u.cl->resolved = 1;
1273 0 : tmp = e->ts.u.cl->backend_decl;
1274 : }
1275 : else
1276 : {
1277 0 : gfc_error ("Cannot compute the length of the char array "
1278 : "at %L.", &e->where);
1279 : }
1280 : }
1281 : }
1282 : else
1283 707 : tmp = integer_zero_node;
1284 :
1285 882 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1286 : }
1287 :
1288 : /* Pass the address of the class object. */
1289 882 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1290 882 : }
1291 :
1292 :
1293 : /* Takes a scalarized class array expression and returns the
1294 : address of a temporary scalar class object of the 'declared'
1295 : type.
1296 : OOP-TODO: This could be improved by adding code that branched on
1297 : the dynamic type being the same as the declared type. In this case
1298 : the original class expression can be passed directly.
1299 : optional_alloc_ptr is false when the dummy is neither allocatable
1300 : nor a pointer; that's relevant for the optional handling.
1301 : Set copyback to true if class container's _data and _vtab pointers
1302 : might get modified. */
1303 :
1304 : void
1305 3543 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1306 : bool elemental, bool copyback, bool optional,
1307 : bool optional_alloc_ptr)
1308 : {
1309 3543 : tree ctree;
1310 3543 : tree var;
1311 3543 : tree tmp;
1312 3543 : tree vptr;
1313 3543 : tree cond = NULL_TREE;
1314 3543 : tree slen = NULL_TREE;
1315 3543 : gfc_ref *ref;
1316 3543 : gfc_ref *class_ref;
1317 3543 : stmtblock_t block;
1318 3543 : bool full_array = false;
1319 :
1320 : /* Class transformational function results are the data field of a class
1321 : temporary and so the class expression can be obtained directly. */
1322 3543 : if (e->expr_type == EXPR_FUNCTION
1323 168 : && e->value.function.isym
1324 30 : && e->value.function.isym->transformational
1325 30 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1326 3567 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr)))
1327 : {
1328 24 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1329 24 : if (!VAR_P (parmse->expr))
1330 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1331 24 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1332 162 : return;
1333 : }
1334 :
1335 3519 : gfc_init_block (&block);
1336 :
1337 3519 : class_ref = NULL;
1338 7054 : for (ref = e->ref; ref; ref = ref->next)
1339 : {
1340 6678 : if (ref->type == REF_COMPONENT
1341 3569 : && ref->u.c.component->ts.type == BT_CLASS)
1342 6678 : class_ref = ref;
1343 :
1344 6678 : if (ref->next == NULL)
1345 : break;
1346 : }
1347 :
1348 3519 : if ((ref == NULL || class_ref == ref)
1349 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1350 3989 : && (!class_ts.u.derived->components->as
1351 379 : || class_ts.u.derived->components->as->rank != -1))
1352 : return;
1353 :
1354 : /* Test for FULL_ARRAY. */
1355 3381 : if (e->rank == 0
1356 3381 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1357 494 : || (class_ts.u.derived->components->as
1358 366 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1359 411 : full_array = true;
1360 : else
1361 2970 : gfc_is_class_array_ref (e, &full_array);
1362 :
1363 : /* The derived type needs to be converted to a temporary
1364 : CLASS object. */
1365 3381 : tmp = gfc_typenode_for_spec (&class_ts);
1366 3381 : var = gfc_create_var (tmp, "class");
1367 :
1368 : /* Set the data. */
1369 3381 : ctree = gfc_class_data_get (var);
1370 3381 : if (class_ts.u.derived->components->as
1371 3121 : && e->rank != class_ts.u.derived->components->as->rank)
1372 : {
1373 965 : if (e->rank == 0)
1374 : {
1375 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1376 : gfc_expr_attr (e));
1377 356 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1378 : gfc_get_dtype (type));
1379 :
1380 356 : tmp = gfc_class_data_get (parmse->expr);
1381 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1382 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1383 :
1384 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1385 : }
1386 : else
1387 609 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1388 : }
1389 : else
1390 : {
1391 2416 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1392 1388 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1393 1388 : TREE_TYPE (ctree), parmse->expr);
1394 2416 : gfc_add_modify (&block, ctree, parmse->expr);
1395 : }
1396 :
1397 : /* Return the data component, except in the case of scalarized array
1398 : references, where nullification of the cannot occur and so there
1399 : is no need. */
1400 3381 : if (!elemental && full_array && copyback)
1401 : {
1402 1131 : if (class_ts.u.derived->components->as
1403 1131 : && e->rank != class_ts.u.derived->components->as->rank)
1404 : {
1405 270 : if (e->rank == 0)
1406 : {
1407 102 : tmp = gfc_class_data_get (parmse->expr);
1408 204 : gfc_add_modify (&parmse->post, tmp,
1409 102 : fold_convert (TREE_TYPE (tmp),
1410 : gfc_conv_descriptor_data_get (ctree)));
1411 : }
1412 : else
1413 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1414 : true);
1415 : }
1416 : else
1417 861 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1418 : }
1419 :
1420 : /* Set the vptr. */
1421 3381 : ctree = gfc_class_vptr_get (var);
1422 :
1423 : /* The vptr is the second field of the actual argument.
1424 : First we have to find the corresponding class reference. */
1425 :
1426 3381 : tmp = NULL_TREE;
1427 3381 : if (gfc_is_class_array_function (e)
1428 3381 : && parmse->class_vptr != NULL_TREE)
1429 : tmp = parmse->class_vptr;
1430 3363 : else if (class_ref == NULL
1431 2919 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1432 : {
1433 2919 : tmp = e->symtree->n.sym->backend_decl;
1434 :
1435 2919 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1436 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1437 :
1438 2919 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1439 373 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1440 :
1441 2919 : slen = build_zero_cst (size_type_node);
1442 : }
1443 444 : else if (parmse->class_container != NULL_TREE)
1444 : /* Don't redundantly evaluate the expression if the required information
1445 : is already available. */
1446 : tmp = parmse->class_container;
1447 : else
1448 : {
1449 : /* Remove everything after the last class reference, convert the
1450 : expression and then recover its tailend once more. */
1451 18 : gfc_se tmpse;
1452 18 : ref = class_ref->next;
1453 18 : class_ref->next = NULL;
1454 18 : gfc_init_se (&tmpse, NULL);
1455 18 : gfc_conv_expr (&tmpse, e);
1456 18 : class_ref->next = ref;
1457 18 : tmp = tmpse.expr;
1458 18 : slen = tmpse.string_length;
1459 : }
1460 :
1461 3381 : gcc_assert (tmp != NULL_TREE);
1462 :
1463 : /* Dereference if needs be. */
1464 3381 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1465 321 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1466 :
1467 3381 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1468 3363 : vptr = gfc_class_vptr_get (tmp);
1469 : else
1470 : vptr = tmp;
1471 :
1472 3381 : gfc_add_modify (&block, ctree,
1473 3381 : fold_convert (TREE_TYPE (ctree), vptr));
1474 :
1475 : /* Return the vptr component, except in the case of scalarized array
1476 : references, where the dynamic type cannot change. */
1477 3381 : if (!elemental && full_array && copyback)
1478 1131 : gfc_add_modify (&parmse->post, vptr,
1479 1131 : fold_convert (TREE_TYPE (vptr), ctree));
1480 :
1481 : /* For unlimited polymorphic objects also set the _len component. */
1482 3381 : if (class_ts.type == BT_CLASS
1483 3381 : && class_ts.u.derived->components
1484 3381 : && class_ts.u.derived->components->ts.u
1485 3381 : .derived->attr.unlimited_polymorphic)
1486 : {
1487 1109 : ctree = gfc_class_len_get (var);
1488 1109 : if (UNLIMITED_POLY (e))
1489 913 : tmp = gfc_class_len_get (tmp);
1490 196 : else if (e->ts.type == BT_CHARACTER)
1491 : {
1492 0 : gcc_assert (slen != NULL_TREE);
1493 : tmp = slen;
1494 : }
1495 : else
1496 196 : tmp = build_zero_cst (size_type_node);
1497 1109 : gfc_add_modify (&parmse->pre, ctree,
1498 1109 : fold_convert (TREE_TYPE (ctree), tmp));
1499 :
1500 : /* Return the len component, except in the case of scalarized array
1501 : references, where the dynamic type cannot change. */
1502 1109 : if (!elemental && full_array && copyback
1503 440 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1504 428 : gfc_add_modify (&parmse->post, tmp,
1505 428 : fold_convert (TREE_TYPE (tmp), ctree));
1506 : }
1507 :
1508 3381 : if (optional)
1509 : {
1510 510 : tree tmp2;
1511 :
1512 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1513 : /* parmse->pre may contain some preparatory instructions for the
1514 : temporary array descriptor. Those may only be executed when the
1515 : optional argument is set, therefore add parmse->pre's instructions
1516 : to block, which is later guarded by an if (optional_arg_given). */
1517 510 : gfc_add_block_to_block (&parmse->pre, &block);
1518 510 : block.head = parmse->pre.head;
1519 510 : parmse->pre.head = NULL_TREE;
1520 510 : tmp = gfc_finish_block (&block);
1521 :
1522 510 : if (optional_alloc_ptr)
1523 102 : tmp2 = build_empty_stmt (input_location);
1524 : else
1525 : {
1526 408 : gfc_init_block (&block);
1527 :
1528 408 : tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1529 408 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1530 : null_pointer_node));
1531 408 : tmp2 = gfc_finish_block (&block);
1532 : }
1533 :
1534 510 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1535 : cond, tmp, tmp2);
1536 510 : gfc_add_expr_to_block (&parmse->pre, tmp);
1537 :
1538 510 : if (!elemental && full_array && copyback)
1539 : {
1540 30 : tmp2 = build_empty_stmt (input_location);
1541 30 : tmp = gfc_finish_block (&parmse->post);
1542 30 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1543 : cond, tmp, tmp2);
1544 30 : gfc_add_expr_to_block (&parmse->post, tmp);
1545 : }
1546 : }
1547 : else
1548 2871 : gfc_add_block_to_block (&parmse->pre, &block);
1549 :
1550 : /* Pass the address of the class object. */
1551 3381 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1552 :
1553 3381 : if (optional && optional_alloc_ptr)
1554 204 : parmse->expr = build3_loc (input_location, COND_EXPR,
1555 102 : TREE_TYPE (parmse->expr),
1556 : cond, parmse->expr,
1557 102 : fold_convert (TREE_TYPE (parmse->expr),
1558 : null_pointer_node));
1559 : }
1560 :
1561 :
1562 : /* Given a class array declaration and an index, returns the address
1563 : of the referenced element. */
1564 :
1565 : static tree
1566 712 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1567 : bool unlimited)
1568 : {
1569 712 : tree data, size, tmp, ctmp, offset, ptr;
1570 :
1571 712 : data = data_comp != NULL_TREE ? data_comp :
1572 0 : gfc_class_data_get (class_decl);
1573 712 : size = gfc_class_vtab_size_get (class_decl);
1574 :
1575 712 : if (unlimited)
1576 : {
1577 200 : tmp = fold_convert (gfc_array_index_type,
1578 : gfc_class_len_get (class_decl));
1579 200 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1580 : gfc_array_index_type, size, tmp);
1581 200 : tmp = fold_build2_loc (input_location, GT_EXPR,
1582 : logical_type_node, tmp,
1583 200 : build_zero_cst (TREE_TYPE (tmp)));
1584 200 : size = fold_build3_loc (input_location, COND_EXPR,
1585 : gfc_array_index_type, tmp, ctmp, size);
1586 : }
1587 :
1588 712 : offset = fold_build2_loc (input_location, MULT_EXPR,
1589 : gfc_array_index_type,
1590 : index, size);
1591 :
1592 712 : data = gfc_conv_descriptor_data_get (data);
1593 712 : ptr = fold_convert (pvoid_type_node, data);
1594 712 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1595 712 : return fold_convert (TREE_TYPE (data), ptr);
1596 : }
1597 :
1598 :
1599 : /* Copies one class expression to another, assuming that if either
1600 : 'to' or 'from' are arrays they are packed. Should 'from' be
1601 : NULL_TREE, the initialization expression for 'to' is used, assuming
1602 : that the _vptr is set. */
1603 :
1604 : tree
1605 756 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1606 : {
1607 756 : tree fcn;
1608 756 : tree fcn_type;
1609 756 : tree from_data;
1610 756 : tree from_len;
1611 756 : tree to_data;
1612 756 : tree to_len;
1613 756 : tree to_ref;
1614 756 : tree from_ref;
1615 756 : vec<tree, va_gc> *args;
1616 756 : tree tmp;
1617 756 : tree stdcopy;
1618 756 : tree extcopy;
1619 756 : tree index;
1620 756 : bool is_from_desc = false, is_to_class = false;
1621 :
1622 756 : args = NULL;
1623 : /* To prevent warnings on uninitialized variables. */
1624 756 : from_len = to_len = NULL_TREE;
1625 :
1626 756 : if (from != NULL_TREE)
1627 756 : fcn = gfc_class_vtab_copy_get (from);
1628 : else
1629 0 : fcn = gfc_class_vtab_copy_get (to);
1630 :
1631 756 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1632 :
1633 756 : if (from != NULL_TREE)
1634 : {
1635 756 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1636 756 : if (is_from_desc)
1637 : {
1638 0 : from_data = from;
1639 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1640 : }
1641 : else
1642 : {
1643 : /* Check that from is a class. When the class is part of a coarray,
1644 : then from is a common pointer and is to be used as is. */
1645 1512 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1646 756 : ? build_fold_indirect_ref (from) : from;
1647 1512 : from_data =
1648 756 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1649 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1650 756 : ? gfc_class_data_get (from) : from;
1651 756 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1652 : }
1653 : }
1654 : else
1655 0 : from_data = gfc_class_vtab_def_init_get (to);
1656 :
1657 756 : if (unlimited)
1658 : {
1659 159 : if (from != NULL_TREE && unlimited)
1660 159 : from_len = gfc_class_len_or_zero_get (from);
1661 : else
1662 0 : from_len = build_zero_cst (size_type_node);
1663 : }
1664 :
1665 756 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1666 : {
1667 756 : is_to_class = true;
1668 756 : to_data = gfc_class_data_get (to);
1669 756 : if (unlimited)
1670 159 : to_len = gfc_class_len_get (to);
1671 : }
1672 : else
1673 : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1674 0 : to_data = to;
1675 :
1676 756 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1677 : {
1678 356 : stmtblock_t loopbody;
1679 356 : stmtblock_t body;
1680 356 : stmtblock_t ifbody;
1681 356 : gfc_loopinfo loop;
1682 :
1683 356 : gfc_init_block (&body);
1684 356 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1685 : gfc_array_index_type, nelems,
1686 : gfc_index_one_node);
1687 356 : nelems = gfc_evaluate_now (tmp, &body);
1688 356 : index = gfc_create_var (gfc_array_index_type, "S");
1689 :
1690 356 : if (is_from_desc)
1691 : {
1692 356 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1693 : unlimited);
1694 356 : vec_safe_push (args, from_ref);
1695 : }
1696 : else
1697 0 : vec_safe_push (args, from_data);
1698 :
1699 356 : if (is_to_class)
1700 356 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1701 : else
1702 : {
1703 0 : tmp = gfc_conv_array_data (to);
1704 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1705 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1706 : gfc_build_array_ref (tmp, index, to));
1707 : }
1708 356 : vec_safe_push (args, to_ref);
1709 :
1710 : /* Add bounds check. */
1711 356 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1712 : {
1713 25 : const char *name = "<<unknown>>";
1714 25 : int dim, rank;
1715 :
1716 25 : if (DECL_P (to))
1717 0 : name = IDENTIFIER_POINTER (DECL_NAME (to));
1718 :
1719 25 : rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
1720 55 : for (dim = 1; dim <= rank; dim++)
1721 : {
1722 30 : tree from_len, to_len, cond;
1723 30 : char *msg;
1724 :
1725 30 : from_len = gfc_conv_descriptor_size (from_data, dim);
1726 30 : from_len = fold_convert (long_integer_type_node, from_len);
1727 30 : to_len = gfc_conv_descriptor_size (to_data, dim);
1728 30 : to_len = fold_convert (long_integer_type_node, to_len);
1729 30 : msg = xasprintf ("Array bound mismatch for dimension %d "
1730 : "of array '%s' (%%ld/%%ld)",
1731 : dim, name);
1732 30 : cond = fold_build2_loc (input_location, NE_EXPR,
1733 : logical_type_node, from_len, to_len);
1734 30 : gfc_trans_runtime_check (true, false, cond, &body,
1735 : NULL, msg, to_len, from_len);
1736 30 : free (msg);
1737 : }
1738 : }
1739 :
1740 356 : tmp = build_call_vec (fcn_type, fcn, args);
1741 :
1742 : /* Build the body of the loop. */
1743 356 : gfc_init_block (&loopbody);
1744 356 : gfc_add_expr_to_block (&loopbody, tmp);
1745 :
1746 : /* Build the loop and return. */
1747 356 : gfc_init_loopinfo (&loop);
1748 356 : loop.dimen = 1;
1749 356 : loop.from[0] = gfc_index_zero_node;
1750 356 : loop.loopvar[0] = index;
1751 356 : loop.to[0] = nelems;
1752 356 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1753 356 : gfc_init_block (&ifbody);
1754 356 : gfc_add_block_to_block (&ifbody, &loop.pre);
1755 356 : stdcopy = gfc_finish_block (&ifbody);
1756 : /* In initialization mode from_len is a constant zero. */
1757 356 : if (unlimited && !integer_zerop (from_len))
1758 : {
1759 100 : vec_safe_push (args, from_len);
1760 100 : vec_safe_push (args, to_len);
1761 100 : tmp = build_call_vec (fcn_type, fcn, args);
1762 : /* Build the body of the loop. */
1763 100 : gfc_init_block (&loopbody);
1764 100 : gfc_add_expr_to_block (&loopbody, tmp);
1765 :
1766 : /* Build the loop and return. */
1767 100 : gfc_init_loopinfo (&loop);
1768 100 : loop.dimen = 1;
1769 100 : loop.from[0] = gfc_index_zero_node;
1770 100 : loop.loopvar[0] = index;
1771 100 : loop.to[0] = nelems;
1772 100 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1773 100 : gfc_init_block (&ifbody);
1774 100 : gfc_add_block_to_block (&ifbody, &loop.pre);
1775 100 : extcopy = gfc_finish_block (&ifbody);
1776 :
1777 100 : tmp = fold_build2_loc (input_location, GT_EXPR,
1778 : logical_type_node, from_len,
1779 100 : build_zero_cst (TREE_TYPE (from_len)));
1780 100 : tmp = fold_build3_loc (input_location, COND_EXPR,
1781 : void_type_node, tmp, extcopy, stdcopy);
1782 100 : gfc_add_expr_to_block (&body, tmp);
1783 100 : tmp = gfc_finish_block (&body);
1784 : }
1785 : else
1786 : {
1787 256 : gfc_add_expr_to_block (&body, stdcopy);
1788 256 : tmp = gfc_finish_block (&body);
1789 : }
1790 356 : gfc_cleanup_loop (&loop);
1791 : }
1792 : else
1793 : {
1794 400 : gcc_assert (!is_from_desc);
1795 400 : vec_safe_push (args, from_data);
1796 400 : vec_safe_push (args, to_data);
1797 400 : stdcopy = build_call_vec (fcn_type, fcn, args);
1798 :
1799 : /* In initialization mode from_len is a constant zero. */
1800 400 : if (unlimited && !integer_zerop (from_len))
1801 : {
1802 59 : vec_safe_push (args, from_len);
1803 59 : vec_safe_push (args, to_len);
1804 59 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1805 59 : tmp = fold_build2_loc (input_location, GT_EXPR,
1806 : logical_type_node, from_len,
1807 59 : build_zero_cst (TREE_TYPE (from_len)));
1808 59 : tmp = fold_build3_loc (input_location, COND_EXPR,
1809 : void_type_node, tmp, extcopy, stdcopy);
1810 : }
1811 : else
1812 : tmp = stdcopy;
1813 : }
1814 :
1815 : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1816 756 : if (from == NULL_TREE)
1817 : {
1818 0 : tree cond;
1819 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1820 : logical_type_node,
1821 : from_data, null_pointer_node);
1822 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1823 : void_type_node, cond,
1824 : tmp, build_empty_stmt (input_location));
1825 : }
1826 :
1827 756 : return tmp;
1828 : }
1829 :
1830 :
1831 : static tree
1832 106 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1833 : {
1834 106 : gfc_actual_arglist *actual;
1835 106 : gfc_expr *ppc;
1836 106 : gfc_code *ppc_code;
1837 106 : tree res;
1838 :
1839 106 : actual = gfc_get_actual_arglist ();
1840 106 : actual->expr = gfc_copy_expr (rhs);
1841 106 : actual->next = gfc_get_actual_arglist ();
1842 106 : actual->next->expr = gfc_copy_expr (lhs);
1843 106 : ppc = gfc_copy_expr (obj);
1844 106 : gfc_add_vptr_component (ppc);
1845 106 : gfc_add_component_ref (ppc, "_copy");
1846 106 : ppc_code = gfc_get_code (EXEC_CALL);
1847 106 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1848 : /* Although '_copy' is set to be elemental in class.cc, it is
1849 : not staying that way. Find out why, sometime.... */
1850 106 : ppc_code->resolved_sym->attr.elemental = 1;
1851 106 : ppc_code->ext.actual = actual;
1852 106 : ppc_code->expr1 = ppc;
1853 : /* Since '_copy' is elemental, the scalarizer will take care
1854 : of arrays in gfc_trans_call. */
1855 106 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1856 106 : gfc_free_statements (ppc_code);
1857 :
1858 106 : if (UNLIMITED_POLY(obj))
1859 : {
1860 : /* Check if rhs is non-NULL. */
1861 24 : gfc_se src;
1862 24 : gfc_init_se (&src, NULL);
1863 24 : gfc_conv_expr (&src, rhs);
1864 24 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1865 24 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1866 24 : src.expr, fold_convert (TREE_TYPE (src.expr),
1867 : null_pointer_node));
1868 24 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1869 : build_empty_stmt (input_location));
1870 : }
1871 :
1872 106 : return res;
1873 : }
1874 :
1875 : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1876 : A MEMCPY is needed to copy the full data from the default initializer
1877 : of the dynamic type. */
1878 :
1879 : tree
1880 461 : gfc_trans_class_init_assign (gfc_code *code)
1881 : {
1882 461 : stmtblock_t block;
1883 461 : tree tmp;
1884 461 : bool cmp_flag = true;
1885 461 : gfc_se dst,src,memsz;
1886 461 : gfc_expr *lhs, *rhs, *sz;
1887 461 : gfc_component *cmp;
1888 461 : gfc_symbol *sym;
1889 461 : gfc_ref *ref;
1890 :
1891 461 : gfc_start_block (&block);
1892 :
1893 461 : lhs = gfc_copy_expr (code->expr1);
1894 :
1895 461 : rhs = gfc_copy_expr (code->expr1);
1896 461 : gfc_add_vptr_component (rhs);
1897 :
1898 : /* Make sure that the component backend_decls have been built, which
1899 : will not have happened if the derived types concerned have not
1900 : been referenced. */
1901 461 : gfc_get_derived_type (rhs->ts.u.derived);
1902 461 : gfc_add_def_init_component (rhs);
1903 : /* The _def_init is always scalar. */
1904 461 : rhs->rank = 0;
1905 :
1906 : /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
1907 : default initializer components NULL, use the passed value even though
1908 : F2018(8.5.10) asserts that it should considered to be undefined. This is
1909 : needed for consistency with other brands. */
1910 461 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1911 : : NULL;
1912 461 : if (code->op != EXEC_ALLOCATE
1913 400 : && sym && sym->attr.dummy
1914 400 : && sym->attr.intent == INTENT_OUT)
1915 : {
1916 400 : ref = rhs->ref;
1917 800 : while (ref && ref->next)
1918 : ref = ref->next;
1919 400 : cmp = ref->u.c.component->ts.u.derived->components;
1920 611 : for (; cmp; cmp = cmp->next)
1921 : {
1922 428 : if (cmp->initializer)
1923 : break;
1924 211 : else if (!cmp->next)
1925 146 : cmp_flag = false;
1926 : }
1927 : }
1928 :
1929 461 : if (code->expr1->ts.type == BT_CLASS
1930 438 : && CLASS_DATA (code->expr1)->attr.dimension)
1931 : {
1932 106 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1933 106 : *tmparr = *CLASS_DATA (code->expr1)->as;
1934 : /* Adding the array ref to the class expression results in correct
1935 : indexing to the dynamic type. */
1936 106 : gfc_add_full_array_ref (lhs, tmparr);
1937 106 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1938 106 : }
1939 355 : else if (cmp_flag)
1940 : {
1941 : /* Scalar initialization needs the _data component. */
1942 222 : gfc_add_data_component (lhs);
1943 222 : sz = gfc_copy_expr (code->expr1);
1944 222 : gfc_add_vptr_component (sz);
1945 222 : gfc_add_size_component (sz);
1946 :
1947 222 : gfc_init_se (&dst, NULL);
1948 222 : gfc_init_se (&src, NULL);
1949 222 : gfc_init_se (&memsz, NULL);
1950 222 : gfc_conv_expr (&dst, lhs);
1951 222 : gfc_conv_expr (&src, rhs);
1952 222 : gfc_conv_expr (&memsz, sz);
1953 222 : gfc_add_block_to_block (&block, &src.pre);
1954 222 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1955 :
1956 222 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1957 :
1958 222 : if (UNLIMITED_POLY(code->expr1))
1959 : {
1960 : /* Check if _def_init is non-NULL. */
1961 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1962 : logical_type_node, src.expr,
1963 7 : fold_convert (TREE_TYPE (src.expr),
1964 : null_pointer_node));
1965 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1966 : tmp, build_empty_stmt (input_location));
1967 : }
1968 : }
1969 : else
1970 133 : tmp = build_empty_stmt (input_location);
1971 :
1972 461 : if (code->expr1->symtree->n.sym->attr.dummy
1973 410 : && (code->expr1->symtree->n.sym->attr.optional
1974 404 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1975 : {
1976 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1977 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1978 : present, tmp,
1979 : build_empty_stmt (input_location));
1980 : }
1981 :
1982 461 : gfc_add_expr_to_block (&block, tmp);
1983 461 : gfc_free_expr (lhs);
1984 461 : gfc_free_expr (rhs);
1985 :
1986 461 : return gfc_finish_block (&block);
1987 : }
1988 :
1989 :
1990 : /* Class valued elemental function calls or class array elements arriving
1991 : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1992 : is used to ensure that the rhs dynamic type is assigned to the lhs. */
1993 :
1994 : static bool
1995 758 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1996 : {
1997 758 : tree fcn;
1998 758 : tree rse_expr;
1999 758 : tree class_data;
2000 758 : tree tmp;
2001 758 : tree zero;
2002 758 : tree cond;
2003 758 : tree final_cond;
2004 758 : stmtblock_t inner_block;
2005 758 : bool is_descriptor;
2006 758 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
2007 758 : bool not_lhs_array_type;
2008 :
2009 : /* Temporaries arising from dependencies in assignment get cast as a
2010 : character type of the dynamic size of the rhs. Use the vptr copy
2011 : for this case. */
2012 758 : tmp = TREE_TYPE (lse->expr);
2013 758 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
2014 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
2015 :
2016 : /* Use ordinary assignment if the rhs is not a call expression or
2017 : the lhs is not a class entity or an array(ie. character) type. */
2018 710 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
2019 1025 : && not_lhs_array_type)
2020 : return false;
2021 :
2022 : /* Ordinary assignment can be used if both sides are class expressions
2023 : since the dynamic type is preserved by copying the vptr. This
2024 : should only occur, where temporaries are involved. */
2025 491 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
2026 491 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
2027 : return false;
2028 :
2029 : /* Fix the class expression and the class data of the rhs. */
2030 430 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
2031 430 : || not_call_expr)
2032 : {
2033 430 : tmp = gfc_get_class_from_expr (rse->expr);
2034 430 : if (tmp == NULL_TREE)
2035 : return false;
2036 134 : rse_expr = gfc_evaluate_now (tmp, block);
2037 : }
2038 : else
2039 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
2040 :
2041 134 : class_data = gfc_class_data_get (rse_expr);
2042 :
2043 : /* Check that the rhs data is not null. */
2044 134 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
2045 134 : if (is_descriptor)
2046 134 : class_data = gfc_conv_descriptor_data_get (class_data);
2047 134 : class_data = gfc_evaluate_now (class_data, block);
2048 :
2049 134 : zero = build_int_cst (TREE_TYPE (class_data), 0);
2050 134 : cond = fold_build2_loc (input_location, NE_EXPR,
2051 : logical_type_node,
2052 : class_data, zero);
2053 :
2054 : /* Copy the rhs to the lhs. */
2055 134 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
2056 134 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2057 134 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
2058 134 : tmp = is_descriptor ? tmp : class_data;
2059 134 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
2060 : gfc_build_addr_expr (NULL, lse->expr));
2061 134 : gfc_add_expr_to_block (block, tmp);
2062 :
2063 : /* Only elemental function results need to be finalised and freed. */
2064 134 : if (not_call_expr)
2065 : return true;
2066 :
2067 : /* Finalize the class data if needed. */
2068 0 : gfc_init_block (&inner_block);
2069 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
2070 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
2071 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
2072 : logical_type_node, fcn, zero);
2073 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2074 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
2075 0 : tmp = build3_v (COND_EXPR, final_cond,
2076 : tmp, build_empty_stmt (input_location));
2077 0 : gfc_add_expr_to_block (&inner_block, tmp);
2078 :
2079 : /* Free the class data. */
2080 0 : tmp = gfc_call_free (class_data);
2081 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2082 : build_empty_stmt (input_location));
2083 0 : gfc_add_expr_to_block (&inner_block, tmp);
2084 :
2085 : /* Finish the inner block and subject it to the condition on the
2086 : class data being non-zero. */
2087 0 : tmp = gfc_finish_block (&inner_block);
2088 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2089 : build_empty_stmt (input_location));
2090 0 : gfc_add_expr_to_block (block, tmp);
2091 :
2092 0 : return true;
2093 : }
2094 :
2095 : /* End of prototype trans-class.c */
2096 :
2097 :
2098 : static void
2099 12439 : realloc_lhs_warning (bt type, bool array, locus *where)
2100 : {
2101 12439 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
2102 25 : gfc_warning (OPT_Wrealloc_lhs,
2103 : "Code for reallocating the allocatable array at %L will "
2104 : "be added", where);
2105 12414 : else if (warn_realloc_lhs_all)
2106 4 : gfc_warning (OPT_Wrealloc_lhs_all,
2107 : "Code for reallocating the allocatable variable at %L "
2108 : "will be added", where);
2109 12439 : }
2110 :
2111 :
2112 : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
2113 : gfc_expr *);
2114 :
2115 : /* Copy the scalarization loop variables. */
2116 :
2117 : static void
2118 1266712 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2119 : {
2120 1266712 : dest->ss = src->ss;
2121 1266712 : dest->loop = src->loop;
2122 1266712 : }
2123 :
2124 :
2125 : /* Initialize a simple expression holder.
2126 :
2127 : Care must be taken when multiple se are created with the same parent.
2128 : The child se must be kept in sync. The easiest way is to delay creation
2129 : of a child se until after the previous se has been translated. */
2130 :
2131 : void
2132 4572053 : gfc_init_se (gfc_se * se, gfc_se * parent)
2133 : {
2134 4572053 : memset (se, 0, sizeof (gfc_se));
2135 4572053 : gfc_init_block (&se->pre);
2136 4572053 : gfc_init_block (&se->finalblock);
2137 4572053 : gfc_init_block (&se->post);
2138 :
2139 4572053 : se->parent = parent;
2140 :
2141 4572053 : if (parent)
2142 1266712 : gfc_copy_se_loopvars (se, parent);
2143 4572053 : }
2144 :
2145 :
2146 : /* Advances to the next SS in the chain. Use this rather than setting
2147 : se->ss = se->ss->next because all the parents needs to be kept in sync.
2148 : See gfc_init_se. */
2149 :
2150 : void
2151 238223 : gfc_advance_se_ss_chain (gfc_se * se)
2152 : {
2153 238223 : gfc_se *p;
2154 :
2155 238223 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2156 :
2157 : p = se;
2158 : /* Walk down the parent chain. */
2159 626090 : while (p != NULL)
2160 : {
2161 : /* Simple consistency check. */
2162 387867 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2163 : || p->parent->ss->nested_ss == p->ss);
2164 :
2165 387867 : p->ss = p->ss->next;
2166 :
2167 387867 : p = p->parent;
2168 : }
2169 238223 : }
2170 :
2171 :
2172 : /* Ensures the result of the expression as either a temporary variable
2173 : or a constant so that it can be used repeatedly. */
2174 :
2175 : void
2176 8046 : gfc_make_safe_expr (gfc_se * se)
2177 : {
2178 8046 : tree var;
2179 :
2180 8046 : if (CONSTANT_CLASS_P (se->expr))
2181 : return;
2182 :
2183 : /* We need a temporary for this result. */
2184 208 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2185 208 : gfc_add_modify (&se->pre, var, se->expr);
2186 208 : se->expr = var;
2187 : }
2188 :
2189 :
2190 : /* Return an expression which determines if a dummy parameter is present.
2191 : Also used for arguments to procedures with multiple entry points. */
2192 :
2193 : tree
2194 11589 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2195 : {
2196 11589 : tree decl, orig_decl, cond;
2197 :
2198 11589 : gcc_assert (sym->attr.dummy);
2199 11589 : orig_decl = decl = gfc_get_symbol_decl (sym);
2200 :
2201 : /* Intrinsic scalars and derived types with VALUE attribute which are passed
2202 : by value use a hidden argument to denote the presence status. */
2203 11589 : if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
2204 : {
2205 1052 : char name[GFC_MAX_SYMBOL_LEN + 2];
2206 1052 : tree tree_name;
2207 :
2208 1052 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2209 1052 : name[0] = '.';
2210 1052 : strcpy (&name[1], sym->name);
2211 1052 : tree_name = get_identifier (name);
2212 :
2213 : /* Walk function argument list to find hidden arg. */
2214 1052 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2215 5320 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2216 5320 : if (DECL_NAME (cond) == tree_name
2217 5320 : && DECL_ARTIFICIAL (cond))
2218 : break;
2219 :
2220 1052 : gcc_assert (cond);
2221 1052 : return cond;
2222 : }
2223 :
2224 : /* Assumed-shape arrays use a local variable for the array data;
2225 : the actual PARAM_DECL is in a saved decl. As the local variable
2226 : is NULL, it can be checked instead, unless use_saved_desc is
2227 : requested. */
2228 :
2229 10537 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2230 : {
2231 822 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2232 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2233 822 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2234 : }
2235 :
2236 10537 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2237 10537 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2238 :
2239 : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2240 : as actual argument to denote absent dummies. For array descriptors,
2241 : we thus also need to check the array descriptor. For BT_CLASS, it
2242 : can also occur for scalars and F2003 due to type->class wrapping and
2243 : class->class wrapping. Note further that BT_CLASS always uses an
2244 : array descriptor for arrays, also for explicit-shape/assumed-size.
2245 : For assumed-rank arrays, no local variable is generated, hence,
2246 : the following also applies with !use_saved_desc. */
2247 :
2248 10537 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2249 7496 : && !sym->attr.allocatable
2250 6284 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2251 2296 : || (sym->ts.type == BT_CLASS
2252 1041 : && !CLASS_DATA (sym)->attr.allocatable
2253 567 : && !CLASS_DATA (sym)->attr.class_pointer))
2254 4195 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2255 6 : || sym->ts.type == BT_CLASS))
2256 : {
2257 4189 : tree tmp;
2258 :
2259 4189 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2260 1492 : || sym->as->type == AS_ASSUMED_RANK
2261 1404 : || sym->attr.codimension))
2262 3321 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2263 : {
2264 1039 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2265 1039 : if (sym->ts.type == BT_CLASS)
2266 171 : tmp = gfc_class_data_get (tmp);
2267 1039 : tmp = gfc_conv_array_data (tmp);
2268 : }
2269 3150 : else if (sym->ts.type == BT_CLASS)
2270 36 : tmp = gfc_class_data_get (decl);
2271 : else
2272 : tmp = NULL_TREE;
2273 :
2274 1075 : if (tmp != NULL_TREE)
2275 : {
2276 1075 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2277 1075 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2278 1075 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2279 : logical_type_node, cond, tmp);
2280 : }
2281 : }
2282 :
2283 : return cond;
2284 : }
2285 :
2286 :
2287 : /* Converts a missing, dummy argument into a null or zero. */
2288 :
2289 : void
2290 844 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2291 : {
2292 844 : tree present;
2293 844 : tree tmp;
2294 :
2295 844 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2296 :
2297 844 : if (kind > 0)
2298 : {
2299 : /* Create a temporary and convert it to the correct type. */
2300 54 : tmp = gfc_get_int_type (kind);
2301 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2302 : se->expr));
2303 :
2304 : /* Test for a NULL value. */
2305 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2306 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2307 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2308 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2309 : }
2310 : else
2311 : {
2312 790 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2313 : present, se->expr,
2314 790 : build_zero_cst (TREE_TYPE (se->expr)));
2315 790 : tmp = gfc_evaluate_now (tmp, &se->pre);
2316 790 : se->expr = tmp;
2317 : }
2318 :
2319 844 : if (ts.type == BT_CHARACTER)
2320 : {
2321 : /* Handle deferred-length dummies that pass the character length by
2322 : reference so that the value can be returned. */
2323 244 : if (ts.deferred && INDIRECT_REF_P (se->string_length))
2324 : {
2325 18 : tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
2326 18 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2327 : present, tmp, null_pointer_node);
2328 18 : tmp = gfc_evaluate_now (tmp, &se->pre);
2329 18 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2330 : }
2331 : else
2332 : {
2333 226 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2334 226 : tmp = fold_build3_loc (input_location, COND_EXPR,
2335 : gfc_charlen_type_node,
2336 : present, se->string_length, tmp);
2337 226 : tmp = gfc_evaluate_now (tmp, &se->pre);
2338 : }
2339 244 : se->string_length = tmp;
2340 : }
2341 844 : return;
2342 : }
2343 :
2344 :
2345 : /* Get the character length of an expression, looking through gfc_refs
2346 : if necessary. */
2347 :
2348 : tree
2349 20116 : gfc_get_expr_charlen (gfc_expr *e)
2350 : {
2351 20116 : gfc_ref *r;
2352 20116 : tree length;
2353 20116 : tree previous = NULL_TREE;
2354 20116 : gfc_se se;
2355 :
2356 20116 : gcc_assert (e->expr_type == EXPR_VARIABLE
2357 : && e->ts.type == BT_CHARACTER);
2358 :
2359 20116 : length = NULL; /* To silence compiler warning. */
2360 :
2361 20116 : if (is_subref_array (e) && e->ts.u.cl->length)
2362 : {
2363 767 : gfc_se tmpse;
2364 767 : gfc_init_se (&tmpse, NULL);
2365 767 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2366 767 : e->ts.u.cl->backend_decl = tmpse.expr;
2367 767 : return tmpse.expr;
2368 : }
2369 :
2370 : /* First candidate: if the variable is of type CHARACTER, the
2371 : expression's length could be the length of the character
2372 : variable. */
2373 19349 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2374 19061 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2375 :
2376 : /* Look through the reference chain for component references. */
2377 38829 : for (r = e->ref; r; r = r->next)
2378 : {
2379 19480 : previous = length;
2380 19480 : switch (r->type)
2381 : {
2382 288 : case REF_COMPONENT:
2383 288 : if (r->u.c.component->ts.type == BT_CHARACTER)
2384 288 : length = r->u.c.component->ts.u.cl->backend_decl;
2385 : break;
2386 :
2387 : case REF_ARRAY:
2388 : /* Do nothing. */
2389 : break;
2390 :
2391 20 : case REF_SUBSTRING:
2392 20 : gfc_init_se (&se, NULL);
2393 20 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2394 20 : length = se.expr;
2395 20 : if (r->u.ss.end)
2396 0 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2397 : else
2398 20 : se.expr = previous;
2399 20 : length = fold_build2_loc (input_location, MINUS_EXPR,
2400 : gfc_charlen_type_node,
2401 : se.expr, length);
2402 20 : length = fold_build2_loc (input_location, PLUS_EXPR,
2403 : gfc_charlen_type_node, length,
2404 : gfc_index_one_node);
2405 20 : break;
2406 :
2407 0 : default:
2408 0 : gcc_unreachable ();
2409 19480 : break;
2410 : }
2411 : }
2412 :
2413 19349 : gcc_assert (length != NULL);
2414 : return length;
2415 : }
2416 :
2417 :
2418 : /* Return for an expression the backend decl of the coarray. */
2419 :
2420 : tree
2421 2045 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2422 : {
2423 2045 : tree caf_decl;
2424 2045 : bool found = false;
2425 2045 : gfc_ref *ref;
2426 :
2427 2045 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2428 :
2429 : /* Not-implemented diagnostic. */
2430 2045 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2431 39 : && UNLIMITED_POLY (expr->symtree->n.sym)
2432 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2433 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2434 : "%L is not supported", &expr->where);
2435 :
2436 4321 : for (ref = expr->ref; ref; ref = ref->next)
2437 2276 : if (ref->type == REF_COMPONENT)
2438 : {
2439 195 : if (ref->u.c.component->ts.type == BT_CLASS
2440 0 : && UNLIMITED_POLY (ref->u.c.component)
2441 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2442 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2443 : "component at %L is not supported", &expr->where);
2444 : }
2445 :
2446 : /* Make sure the backend_decl is present before accessing it. */
2447 2045 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2448 2045 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2449 : : expr->symtree->n.sym->backend_decl;
2450 :
2451 2045 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2452 : {
2453 39 : if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2454 45 : && GFC_DECL_SAVED_DESCRIPTOR (caf_decl))
2455 6 : caf_decl = GFC_DECL_SAVED_DESCRIPTOR (caf_decl);
2456 :
2457 39 : if (expr->ref && expr->ref->type == REF_ARRAY)
2458 : {
2459 28 : caf_decl = gfc_class_data_get (caf_decl);
2460 28 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2461 : return caf_decl;
2462 : }
2463 11 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2464 2 : && GFC_DECL_TOKEN (caf_decl)
2465 13 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2466 : return caf_decl;
2467 :
2468 23 : for (ref = expr->ref; ref; ref = ref->next)
2469 : {
2470 18 : if (ref->type == REF_COMPONENT
2471 9 : && strcmp (ref->u.c.component->name, "_data") != 0)
2472 : {
2473 0 : caf_decl = gfc_class_data_get (caf_decl);
2474 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2475 : return caf_decl;
2476 : break;
2477 : }
2478 18 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2479 : break;
2480 : }
2481 : }
2482 2015 : if (expr->symtree->n.sym->attr.codimension)
2483 : return caf_decl;
2484 :
2485 : /* The following code assumes that the coarray is a component reachable via
2486 : only scalar components/variables; the Fortran standard guarantees this. */
2487 :
2488 46 : for (ref = expr->ref; ref; ref = ref->next)
2489 46 : if (ref->type == REF_COMPONENT)
2490 : {
2491 46 : gfc_component *comp = ref->u.c.component;
2492 :
2493 46 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2494 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2495 46 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2496 46 : TREE_TYPE (comp->backend_decl), caf_decl,
2497 : comp->backend_decl, NULL_TREE);
2498 46 : if (comp->ts.type == BT_CLASS)
2499 : {
2500 0 : caf_decl = gfc_class_data_get (caf_decl);
2501 0 : if (CLASS_DATA (comp)->attr.codimension)
2502 : {
2503 : found = true;
2504 : break;
2505 : }
2506 : }
2507 46 : if (comp->attr.codimension)
2508 : {
2509 : found = true;
2510 : break;
2511 : }
2512 : }
2513 46 : gcc_assert (found && caf_decl);
2514 : return caf_decl;
2515 : }
2516 :
2517 :
2518 : /* Obtain the Coarray token - and optionally also the offset. */
2519 :
2520 : void
2521 1916 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2522 : tree se_expr, gfc_expr *expr)
2523 : {
2524 1916 : tree tmp;
2525 :
2526 1916 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2527 :
2528 : /* Coarray token. */
2529 1916 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2530 545 : *token = gfc_conv_descriptor_token (caf_decl);
2531 1369 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2532 1570 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2533 6 : *token = GFC_DECL_TOKEN (caf_decl);
2534 : else
2535 : {
2536 1365 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2537 : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2538 1365 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2539 : }
2540 :
2541 1916 : if (offset == NULL)
2542 : return;
2543 :
2544 : /* Offset between the coarray base address and the address wanted. */
2545 179 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2546 179 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2547 0 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2548 0 : *offset = build_int_cst (gfc_array_index_type, 0);
2549 179 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2550 179 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2551 0 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2552 179 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2553 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2554 : else
2555 179 : *offset = build_int_cst (gfc_array_index_type, 0);
2556 :
2557 179 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2558 179 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2559 : {
2560 0 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2561 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2562 : }
2563 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2564 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2565 : else
2566 : {
2567 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2568 : tmp = se_expr;
2569 : }
2570 :
2571 179 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2572 : *offset, fold_convert (gfc_array_index_type, tmp));
2573 :
2574 179 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2575 0 : && expr->symtree->n.sym->attr.codimension
2576 0 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2577 : {
2578 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2579 0 : gfc_ref *ref = base_expr->ref;
2580 0 : gfc_se base_se;
2581 :
2582 : // Iterate through the refs until the last one.
2583 0 : while (ref->next)
2584 : ref = ref->next;
2585 :
2586 0 : if (ref->type == REF_ARRAY
2587 0 : && ref->u.ar.type != AR_FULL)
2588 : {
2589 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2590 0 : int i;
2591 0 : for (i = 0; i < ranksum; ++i)
2592 : {
2593 0 : ref->u.ar.start[i] = NULL;
2594 0 : ref->u.ar.end[i] = NULL;
2595 : }
2596 0 : ref->u.ar.type = AR_FULL;
2597 : }
2598 0 : gfc_init_se (&base_se, NULL);
2599 0 : if (gfc_caf_attr (base_expr).dimension)
2600 : {
2601 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2602 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2603 : }
2604 : else
2605 : {
2606 0 : gfc_conv_expr (&base_se, base_expr);
2607 0 : tmp = base_se.expr;
2608 : }
2609 :
2610 0 : gfc_free_expr (base_expr);
2611 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2612 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2613 0 : }
2614 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2615 0 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2616 179 : else if (INDIRECT_REF_P (caf_decl))
2617 0 : tmp = TREE_OPERAND (caf_decl, 0);
2618 : else
2619 : {
2620 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2621 : tmp = caf_decl;
2622 : }
2623 :
2624 179 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2625 : fold_convert (gfc_array_index_type, *offset),
2626 : fold_convert (gfc_array_index_type, tmp));
2627 : }
2628 :
2629 :
2630 : /* Convert the coindex of a coarray into an image index; the result is
2631 : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2632 : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2633 :
2634 : tree
2635 1627 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2636 : {
2637 1627 : gfc_ref *ref;
2638 1627 : tree lbound, ubound, extent, tmp, img_idx;
2639 1627 : gfc_se se;
2640 1627 : int i;
2641 :
2642 1658 : for (ref = e->ref; ref; ref = ref->next)
2643 1658 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2644 : break;
2645 1627 : gcc_assert (ref != NULL);
2646 :
2647 1627 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2648 95 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2649 95 : null_pointer_node);
2650 :
2651 1532 : img_idx = build_zero_cst (gfc_array_index_type);
2652 1532 : extent = build_one_cst (gfc_array_index_type);
2653 1532 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2654 624 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2655 : {
2656 318 : gfc_init_se (&se, NULL);
2657 318 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2658 318 : gfc_add_block_to_block (block, &se.pre);
2659 318 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2660 318 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2661 318 : TREE_TYPE (lbound), se.expr, lbound);
2662 318 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2663 : extent, tmp);
2664 318 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2665 318 : TREE_TYPE (tmp), img_idx, tmp);
2666 318 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2667 : {
2668 12 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2669 12 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2670 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
2671 12 : TREE_TYPE (tmp), extent, tmp);
2672 : }
2673 : }
2674 : else
2675 2468 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2676 : {
2677 1242 : gfc_init_se (&se, NULL);
2678 1242 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2679 1242 : gfc_add_block_to_block (block, &se.pre);
2680 1242 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2681 1242 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2682 1242 : TREE_TYPE (lbound), se.expr, lbound);
2683 1242 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2684 : extent, tmp);
2685 1242 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2686 : img_idx, tmp);
2687 1242 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2688 : {
2689 16 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2690 16 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2691 16 : TREE_TYPE (ubound), ubound, lbound);
2692 16 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2693 16 : tmp, build_one_cst (TREE_TYPE (tmp)));
2694 16 : extent = fold_build2_loc (input_location, MULT_EXPR,
2695 16 : TREE_TYPE (tmp), extent, tmp);
2696 : }
2697 : }
2698 1532 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2699 1532 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2700 1532 : return fold_convert (integer_type_node, img_idx);
2701 : }
2702 :
2703 :
2704 : /* For each character array constructor subexpression without a ts.u.cl->length,
2705 : replace it by its first element (if there aren't any elements, the length
2706 : should already be set to zero). */
2707 :
2708 : static void
2709 105 : flatten_array_ctors_without_strlen (gfc_expr* e)
2710 : {
2711 105 : gfc_actual_arglist* arg;
2712 105 : gfc_constructor* c;
2713 :
2714 105 : if (!e)
2715 : return;
2716 :
2717 105 : switch (e->expr_type)
2718 : {
2719 :
2720 0 : case EXPR_OP:
2721 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2722 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2723 0 : break;
2724 :
2725 0 : case EXPR_COMPCALL:
2726 : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2727 0 : gcc_unreachable ();
2728 :
2729 12 : case EXPR_FUNCTION:
2730 36 : for (arg = e->value.function.actual; arg; arg = arg->next)
2731 24 : flatten_array_ctors_without_strlen (arg->expr);
2732 : break;
2733 :
2734 0 : case EXPR_ARRAY:
2735 :
2736 : /* We've found what we're looking for. */
2737 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2738 : {
2739 0 : gfc_constructor *c;
2740 0 : gfc_expr* new_expr;
2741 :
2742 0 : gcc_assert (e->value.constructor);
2743 :
2744 0 : c = gfc_constructor_first (e->value.constructor);
2745 0 : new_expr = c->expr;
2746 0 : c->expr = NULL;
2747 :
2748 0 : flatten_array_ctors_without_strlen (new_expr);
2749 0 : gfc_replace_expr (e, new_expr);
2750 0 : break;
2751 : }
2752 :
2753 : /* Otherwise, fall through to handle constructor elements. */
2754 0 : gcc_fallthrough ();
2755 0 : case EXPR_STRUCTURE:
2756 0 : for (c = gfc_constructor_first (e->value.constructor);
2757 0 : c; c = gfc_constructor_next (c))
2758 0 : flatten_array_ctors_without_strlen (c->expr);
2759 : break;
2760 :
2761 : default:
2762 : break;
2763 :
2764 : }
2765 : }
2766 :
2767 :
2768 : /* Generate code to initialize a string length variable. Returns the
2769 : value. For array constructors, cl->length might be NULL and in this case,
2770 : the first element of the constructor is needed. expr is the original
2771 : expression so we can access it but can be NULL if this is not needed. */
2772 :
2773 : void
2774 3817 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2775 : {
2776 3817 : gfc_se se;
2777 :
2778 3817 : gfc_init_se (&se, NULL);
2779 :
2780 3817 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2781 1361 : return;
2782 :
2783 : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2784 : "flatten" array constructors by taking their first element; all elements
2785 : should be the same length or a cl->length should be present. */
2786 2549 : if (!cl->length)
2787 : {
2788 174 : gfc_expr* expr_flat;
2789 174 : if (!expr)
2790 : return;
2791 81 : expr_flat = gfc_copy_expr (expr);
2792 81 : flatten_array_ctors_without_strlen (expr_flat);
2793 81 : gfc_resolve_expr (expr_flat);
2794 81 : if (expr_flat->rank)
2795 12 : gfc_conv_expr_descriptor (&se, expr_flat);
2796 : else
2797 69 : gfc_conv_expr (&se, expr_flat);
2798 81 : if (expr_flat->expr_type != EXPR_VARIABLE)
2799 75 : gfc_add_block_to_block (pblock, &se.pre);
2800 81 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2801 81 : gfc_add_block_to_block (pblock, &se.post);
2802 81 : gfc_free_expr (expr_flat);
2803 : }
2804 : else
2805 : {
2806 : /* Convert cl->length. */
2807 2375 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2808 2375 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2809 : gfc_charlen_type_node, se.expr,
2810 2375 : build_zero_cst (TREE_TYPE (se.expr)));
2811 2375 : gfc_add_block_to_block (pblock, &se.pre);
2812 : }
2813 :
2814 2456 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2815 1540 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2816 : else
2817 916 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2818 : }
2819 :
2820 :
2821 : static void
2822 6843 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2823 : const char *name, locus *where)
2824 : {
2825 6843 : tree tmp;
2826 6843 : tree type;
2827 6843 : tree fault;
2828 6843 : gfc_se start;
2829 6843 : gfc_se end;
2830 6843 : char *msg;
2831 6843 : mpz_t length;
2832 :
2833 6843 : type = gfc_get_character_type (kind, ref->u.ss.length);
2834 6843 : type = build_pointer_type (type);
2835 :
2836 6843 : gfc_init_se (&start, se);
2837 6843 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2838 6843 : gfc_add_block_to_block (&se->pre, &start.pre);
2839 :
2840 6843 : if (integer_onep (start.expr))
2841 2317 : gfc_conv_string_parameter (se);
2842 : else
2843 : {
2844 4526 : tmp = start.expr;
2845 4526 : STRIP_NOPS (tmp);
2846 : /* Avoid multiple evaluation of substring start. */
2847 4526 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2848 1697 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2849 :
2850 : /* Change the start of the string. */
2851 4526 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2852 1194 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2853 3452 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2854 5600 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2855 1074 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2856 : tmp = se->expr;
2857 : else
2858 1066 : tmp = build_fold_indirect_ref_loc (input_location,
2859 : se->expr);
2860 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2861 4526 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2862 : {
2863 4398 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2864 4398 : se->expr = gfc_build_addr_expr (type, tmp);
2865 : }
2866 128 : else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2867 : {
2868 8 : tree diff;
2869 8 : diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr,
2870 : build_one_cst (gfc_charlen_type_node));
2871 8 : diff = fold_convert (size_type_node, diff);
2872 8 : se->expr
2873 8 : = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff);
2874 : }
2875 : }
2876 :
2877 : /* Length = end + 1 - start. */
2878 6843 : gfc_init_se (&end, se);
2879 6843 : if (ref->u.ss.end == NULL)
2880 202 : end.expr = se->string_length;
2881 : else
2882 : {
2883 6641 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2884 6641 : gfc_add_block_to_block (&se->pre, &end.pre);
2885 : }
2886 6843 : tmp = end.expr;
2887 6843 : STRIP_NOPS (tmp);
2888 6843 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2889 2299 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2890 :
2891 6843 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2892 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2893 7298 : && !gfc_contains_implied_index_p (ref->u.ss.end))
2894 : {
2895 455 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2896 : logical_type_node, start.expr,
2897 : end.expr);
2898 :
2899 : /* Check lower bound. */
2900 455 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2901 : start.expr,
2902 455 : build_one_cst (TREE_TYPE (start.expr)));
2903 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2904 : logical_type_node, nonempty, fault);
2905 455 : if (name)
2906 454 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2907 : "is less than one", name);
2908 : else
2909 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2910 : "is less than one");
2911 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2912 : fold_convert (long_integer_type_node,
2913 : start.expr));
2914 455 : free (msg);
2915 :
2916 : /* Check upper bound. */
2917 455 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2918 : end.expr, se->string_length);
2919 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2920 : logical_type_node, nonempty, fault);
2921 455 : if (name)
2922 454 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2923 : "exceeds string length (%%ld)", name);
2924 : else
2925 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2926 : "exceeds string length (%%ld)");
2927 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2928 : fold_convert (long_integer_type_node, end.expr),
2929 : fold_convert (long_integer_type_node,
2930 : se->string_length));
2931 455 : free (msg);
2932 : }
2933 :
2934 : /* Try to calculate the length from the start and end expressions. */
2935 6843 : if (ref->u.ss.end
2936 6843 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2937 : {
2938 5626 : HOST_WIDE_INT i_len;
2939 :
2940 5626 : i_len = gfc_mpz_get_hwi (length) + 1;
2941 5626 : if (i_len < 0)
2942 : i_len = 0;
2943 :
2944 5626 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2945 5626 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2946 : }
2947 : else
2948 : {
2949 1217 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2950 : fold_convert (gfc_charlen_type_node, end.expr),
2951 : fold_convert (gfc_charlen_type_node, start.expr));
2952 1217 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2953 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2954 1217 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2955 : tmp, build_int_cst (gfc_charlen_type_node, 0));
2956 : }
2957 :
2958 6843 : se->string_length = tmp;
2959 6843 : }
2960 :
2961 :
2962 : /* Convert a derived type component reference. */
2963 :
2964 : void
2965 172557 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2966 : {
2967 172557 : gfc_component *c;
2968 172557 : tree tmp;
2969 172557 : tree decl;
2970 172557 : tree field;
2971 172557 : tree context;
2972 :
2973 172557 : c = ref->u.c.component;
2974 :
2975 172557 : if (c->backend_decl == NULL_TREE
2976 6 : && ref->u.c.sym != NULL)
2977 6 : gfc_get_derived_type (ref->u.c.sym);
2978 :
2979 172557 : field = c->backend_decl;
2980 172557 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2981 172557 : decl = se->expr;
2982 172557 : context = DECL_FIELD_CONTEXT (field);
2983 :
2984 : /* Components can correspond to fields of different containing
2985 : types, as components are created without context, whereas
2986 : a concrete use of a component has the type of decl as context.
2987 : So, if the type doesn't match, we search the corresponding
2988 : FIELD_DECL in the parent type. To not waste too much time
2989 : we cache this result in norestrict_decl.
2990 : On the other hand, if the context is a UNION or a MAP (a
2991 : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2992 :
2993 172557 : if (context != TREE_TYPE (decl)
2994 172557 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2995 11961 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2996 : {
2997 11961 : tree f2 = c->norestrict_decl;
2998 20243 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2999 7682 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
3000 7682 : if (TREE_CODE (f2) == FIELD_DECL
3001 7682 : && DECL_NAME (f2) == DECL_NAME (field))
3002 : break;
3003 11961 : gcc_assert (f2);
3004 11961 : c->norestrict_decl = f2;
3005 11961 : field = f2;
3006 : }
3007 :
3008 172557 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
3009 0 : && strcmp ("_data", c->name) == 0)
3010 : {
3011 : /* Found a ref to the _data component. Store the associated ref to
3012 : the vptr in se->class_vptr. */
3013 0 : se->class_vptr = gfc_class_vptr_get (decl);
3014 : }
3015 : else
3016 172557 : se->class_vptr = NULL_TREE;
3017 :
3018 172557 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
3019 : decl, field, NULL_TREE);
3020 :
3021 172557 : se->expr = tmp;
3022 :
3023 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
3024 : strlen () conditional below. */
3025 172557 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
3026 8741 : && !c->ts.deferred
3027 5602 : && !c->attr.pdt_string)
3028 : {
3029 5428 : tmp = c->ts.u.cl->backend_decl;
3030 : /* Components must always be constant length. */
3031 5428 : gcc_assert (tmp && INTEGER_CST_P (tmp));
3032 5428 : se->string_length = tmp;
3033 : }
3034 :
3035 172557 : if (gfc_deferred_strlen (c, &field))
3036 : {
3037 3313 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
3038 3313 : TREE_TYPE (field),
3039 : decl, field, NULL_TREE);
3040 3313 : se->string_length = tmp;
3041 : }
3042 :
3043 172557 : if (((c->attr.pointer || c->attr.allocatable)
3044 100989 : && (!c->attr.dimension && !c->attr.codimension)
3045 54773 : && c->ts.type != BT_CHARACTER)
3046 119988 : || c->attr.proc_pointer)
3047 58759 : se->expr = build_fold_indirect_ref_loc (input_location,
3048 : se->expr);
3049 172557 : }
3050 :
3051 :
3052 : /* This function deals with component references to components of the
3053 : parent type for derived type extensions. */
3054 : void
3055 62443 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
3056 : {
3057 62443 : gfc_component *c;
3058 62443 : gfc_component *cmp;
3059 62443 : gfc_symbol *dt;
3060 62443 : gfc_ref parent;
3061 :
3062 62443 : dt = ref->u.c.sym;
3063 62443 : c = ref->u.c.component;
3064 :
3065 : /* Return if the component is in this type, i.e. not in the parent type. */
3066 107743 : for (cmp = dt->components; cmp; cmp = cmp->next)
3067 97551 : if (c == cmp)
3068 52251 : return;
3069 :
3070 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3071 10192 : parent.type = REF_COMPONENT;
3072 10192 : parent.next = NULL;
3073 10192 : parent.u.c.sym = dt;
3074 10192 : parent.u.c.component = dt->components;
3075 :
3076 10192 : if (dt->backend_decl == NULL)
3077 0 : gfc_get_derived_type (dt);
3078 :
3079 : /* Build the reference and call self. */
3080 10192 : gfc_conv_component_ref (se, &parent);
3081 10192 : parent.u.c.sym = dt->components->ts.u.derived;
3082 10192 : parent.u.c.component = c;
3083 10192 : conv_parent_component_references (se, &parent);
3084 : }
3085 :
3086 :
3087 : static void
3088 537 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
3089 : {
3090 537 : tree res = se->expr;
3091 :
3092 537 : switch (ref->u.i)
3093 : {
3094 259 : case INQUIRY_RE:
3095 518 : res = fold_build1_loc (input_location, REALPART_EXPR,
3096 259 : TREE_TYPE (TREE_TYPE (res)), res);
3097 259 : break;
3098 :
3099 233 : case INQUIRY_IM:
3100 466 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
3101 233 : TREE_TYPE (TREE_TYPE (res)), res);
3102 233 : break;
3103 :
3104 7 : case INQUIRY_KIND:
3105 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
3106 7 : ts->kind);
3107 7 : se->string_length = NULL_TREE;
3108 7 : break;
3109 :
3110 38 : case INQUIRY_LEN:
3111 38 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
3112 : se->string_length);
3113 38 : se->string_length = NULL_TREE;
3114 38 : break;
3115 :
3116 0 : default:
3117 0 : gcc_unreachable ();
3118 : }
3119 537 : se->expr = res;
3120 537 : }
3121 :
3122 : /* Dereference VAR where needed if it is a pointer, reference, etc.
3123 : according to Fortran semantics. */
3124 :
3125 : tree
3126 1431340 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3127 : bool is_classarray)
3128 : {
3129 1431340 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3130 : return var;
3131 287741 : if (is_CFI_desc (sym, NULL))
3132 11892 : return build_fold_indirect_ref_loc (input_location, var);
3133 :
3134 : /* Characters are entirely different from other types, they are treated
3135 : separately. */
3136 275849 : if (sym->ts.type == BT_CHARACTER)
3137 : {
3138 : /* Dereference character pointer dummy arguments
3139 : or results. */
3140 32471 : if ((sym->attr.pointer || sym->attr.allocatable
3141 18831 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3142 13976 : && (sym->attr.dummy
3143 10680 : || sym->attr.function
3144 10306 : || sym->attr.result))
3145 4334 : var = build_fold_indirect_ref_loc (input_location, var);
3146 : }
3147 243378 : else if (!sym->attr.value)
3148 : {
3149 : /* Dereference temporaries for class array dummy arguments. */
3150 168327 : if (sym->attr.dummy && is_classarray
3151 249967 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3152 : {
3153 5085 : if (!descriptor_only_p)
3154 2584 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3155 :
3156 5085 : var = build_fold_indirect_ref_loc (input_location, var);
3157 : }
3158 :
3159 : /* Dereference non-character scalar dummy arguments. */
3160 242574 : if (sym->attr.dummy && !sym->attr.dimension
3161 102917 : && !(sym->attr.codimension && sym->attr.allocatable)
3162 102851 : && (sym->ts.type != BT_CLASS
3163 19014 : || (!CLASS_DATA (sym)->attr.dimension
3164 11151 : && !(CLASS_DATA (sym)->attr.codimension
3165 283 : && CLASS_DATA (sym)->attr.allocatable))))
3166 94847 : var = build_fold_indirect_ref_loc (input_location, var);
3167 :
3168 : /* Dereference scalar hidden result. */
3169 242574 : if (flag_f2c && sym->ts.type == BT_COMPLEX
3170 286 : && (sym->attr.function || sym->attr.result)
3171 108 : && !sym->attr.dimension && !sym->attr.pointer
3172 60 : && !sym->attr.always_explicit)
3173 36 : var = build_fold_indirect_ref_loc (input_location, var);
3174 :
3175 : /* Dereference non-character, non-class pointer variables.
3176 : These must be dummies, results, or scalars. */
3177 242574 : if (!is_classarray
3178 234756 : && (sym->attr.pointer || sym->attr.allocatable
3179 186602 : || gfc_is_associate_pointer (sym)
3180 181961 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3181 316747 : && (sym->attr.dummy
3182 34967 : || sym->attr.function
3183 34043 : || sym->attr.result
3184 32949 : || (!sym->attr.dimension
3185 32944 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3186 74168 : var = build_fold_indirect_ref_loc (input_location, var);
3187 : /* Now treat the class array pointer variables accordingly. */
3188 168406 : else if (sym->ts.type == BT_CLASS
3189 19439 : && sym->attr.dummy
3190 19014 : && (CLASS_DATA (sym)->attr.dimension
3191 11151 : || CLASS_DATA (sym)->attr.codimension)
3192 8146 : && ((CLASS_DATA (sym)->as
3193 8146 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3194 7149 : || CLASS_DATA (sym)->attr.allocatable
3195 5818 : || CLASS_DATA (sym)->attr.class_pointer))
3196 2919 : var = build_fold_indirect_ref_loc (input_location, var);
3197 : /* And the case where a non-dummy, non-result, non-function,
3198 : non-allocable and non-pointer classarray is present. This case was
3199 : previously covered by the first if, but with introducing the
3200 : condition !is_classarray there, that case has to be covered
3201 : explicitly. */
3202 165487 : else if (sym->ts.type == BT_CLASS
3203 16520 : && !sym->attr.dummy
3204 425 : && !sym->attr.function
3205 425 : && !sym->attr.result
3206 425 : && (CLASS_DATA (sym)->attr.dimension
3207 4 : || CLASS_DATA (sym)->attr.codimension)
3208 425 : && (sym->assoc
3209 0 : || !CLASS_DATA (sym)->attr.allocatable)
3210 425 : && !CLASS_DATA (sym)->attr.class_pointer)
3211 425 : var = build_fold_indirect_ref_loc (input_location, var);
3212 : }
3213 :
3214 : return var;
3215 : }
3216 :
3217 : /* Return the contents of a variable. Also handles reference/pointer
3218 : variables (all Fortran pointer references are implicit). */
3219 :
3220 : static void
3221 1581531 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3222 : {
3223 1581531 : gfc_ss *ss;
3224 1581531 : gfc_ref *ref;
3225 1581531 : gfc_symbol *sym;
3226 1581531 : tree parent_decl = NULL_TREE;
3227 1581531 : int parent_flag;
3228 1581531 : bool return_value;
3229 1581531 : bool alternate_entry;
3230 1581531 : bool entry_master;
3231 1581531 : bool is_classarray;
3232 1581531 : bool first_time = true;
3233 :
3234 1581531 : sym = expr->symtree->n.sym;
3235 1581531 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3236 1581531 : ss = se->ss;
3237 1581531 : if (ss != NULL)
3238 : {
3239 130164 : gfc_ss_info *ss_info = ss->info;
3240 :
3241 : /* Check that something hasn't gone horribly wrong. */
3242 130164 : gcc_assert (ss != gfc_ss_terminator);
3243 130164 : gcc_assert (ss_info->expr == expr);
3244 :
3245 : /* A scalarized term. We already know the descriptor. */
3246 130164 : se->expr = ss_info->data.array.descriptor;
3247 130164 : se->string_length = ss_info->string_length;
3248 130164 : ref = ss_info->data.array.ref;
3249 130164 : if (ref)
3250 129846 : gcc_assert (ref->type == REF_ARRAY
3251 : && ref->u.ar.type != AR_ELEMENT);
3252 : else
3253 318 : gfc_conv_tmp_array_ref (se);
3254 : }
3255 : else
3256 : {
3257 1451367 : tree se_expr = NULL_TREE;
3258 :
3259 1451367 : se->expr = gfc_get_symbol_decl (sym);
3260 :
3261 : /* Deal with references to a parent results or entries by storing
3262 : the current_function_decl and moving to the parent_decl. */
3263 1451367 : return_value = sym->attr.function && sym->result == sym;
3264 18543 : alternate_entry = sym->attr.function && sym->attr.entry
3265 1452442 : && sym->result == sym;
3266 2902734 : entry_master = sym->attr.result
3267 14146 : && sym->ns->proc_name->attr.entry_master
3268 1451748 : && !gfc_return_by_reference (sym->ns->proc_name);
3269 1451367 : if (current_function_decl)
3270 1431387 : parent_decl = DECL_CONTEXT (current_function_decl);
3271 :
3272 1451367 : if ((se->expr == parent_decl && return_value)
3273 1451256 : || (sym->ns && sym->ns->proc_name
3274 1446372 : && parent_decl
3275 1426392 : && sym->ns->proc_name->backend_decl == parent_decl
3276 37482 : && (alternate_entry || entry_master)))
3277 : parent_flag = 1;
3278 : else
3279 1451223 : parent_flag = 0;
3280 :
3281 : /* Special case for assigning the return value of a function.
3282 : Self recursive functions must have an explicit return value. */
3283 1451367 : if (return_value && (se->expr == current_function_decl || parent_flag))
3284 10221 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3285 :
3286 : /* Similarly for alternate entry points. */
3287 1441146 : else if (alternate_entry
3288 1042 : && (sym->ns->proc_name->backend_decl == current_function_decl
3289 0 : || parent_flag))
3290 : {
3291 1042 : gfc_entry_list *el = NULL;
3292 :
3293 1609 : for (el = sym->ns->entries; el; el = el->next)
3294 1609 : if (sym == el->sym)
3295 : {
3296 1042 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3297 1042 : break;
3298 : }
3299 : }
3300 :
3301 1440104 : else if (entry_master
3302 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3303 0 : || parent_flag))
3304 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3305 :
3306 11558 : if (se_expr)
3307 11558 : se->expr = se_expr;
3308 :
3309 : /* Procedure actual arguments. Look out for temporary variables
3310 : with the same attributes as function values. */
3311 1439809 : else if (!sym->attr.temporary
3312 1439741 : && sym->attr.flavor == FL_PROCEDURE
3313 22138 : && se->expr != current_function_decl)
3314 : {
3315 22071 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3316 : {
3317 20533 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3318 20533 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3319 : }
3320 22071 : return;
3321 : }
3322 :
3323 1429296 : if (sym->ts.type == BT_CLASS
3324 70795 : && sym->attr.class_ok
3325 70553 : && sym->ts.u.derived->attr.is_class)
3326 : {
3327 26983 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3328 77793 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3329 5227 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3330 : else
3331 65326 : se->class_container = se->expr;
3332 : }
3333 :
3334 : /* Dereference the expression, where needed. */
3335 1429296 : if (se->class_container && CLASS_DATA (sym)->attr.codimension
3336 2042 : && !CLASS_DATA (sym)->attr.dimension)
3337 877 : se->expr
3338 877 : = gfc_maybe_dereference_var (sym, se->class_container,
3339 877 : se->descriptor_only, is_classarray);
3340 : else
3341 1428419 : se->expr
3342 1428419 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3343 : is_classarray);
3344 :
3345 1429296 : ref = expr->ref;
3346 : }
3347 :
3348 : /* For character variables, also get the length. */
3349 1559460 : if (sym->ts.type == BT_CHARACTER)
3350 : {
3351 : /* If the character length of an entry isn't set, get the length from
3352 : the master function instead. */
3353 164158 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3354 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3355 : else
3356 164158 : se->string_length = sym->ts.u.cl->backend_decl;
3357 164158 : gcc_assert (se->string_length);
3358 :
3359 : /* For coarray strings return the pointer to the data and not the
3360 : descriptor. */
3361 5143 : if (sym->attr.codimension && sym->attr.associate_var
3362 6 : && !se->descriptor_only
3363 164164 : && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
3364 6 : se->expr = gfc_conv_descriptor_data_get (se->expr);
3365 : }
3366 :
3367 : /* F202Y: Runtime warning that an assumed rank object is associated
3368 : with an assumed size object. */
3369 1559460 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3370 89081 : && (gfc_option.allow_std & GFC_STD_F202Y)
3371 1559694 : && expr->rank == -1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3372 : {
3373 60 : tree dim, lower, upper, cond;
3374 60 : char *msg;
3375 :
3376 60 : dim = fold_convert (signed_char_type_node,
3377 : gfc_conv_descriptor_rank (se->expr));
3378 60 : dim = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
3379 : dim, build_int_cst (signed_char_type_node, 1));
3380 60 : lower = gfc_conv_descriptor_lbound_get (se->expr, dim);
3381 60 : upper = gfc_conv_descriptor_ubound_get (se->expr, dim);
3382 :
3383 60 : msg = xasprintf ("Assumed rank object %s is associated with an "
3384 : "assumed size object", sym->name);
3385 60 : cond = fold_build2_loc (input_location, LT_EXPR,
3386 : logical_type_node, upper, lower);
3387 60 : gfc_trans_runtime_check (false, true, cond, &se->pre,
3388 : &gfc_current_locus, msg);
3389 60 : free (msg);
3390 : }
3391 :
3392 : /* Some expressions leak through that haven't been fixed up. */
3393 1559460 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3394 404 : gfc_fixup_inferred_type_refs (expr);
3395 :
3396 1559460 : gfc_typespec *ts = &sym->ts;
3397 1984551 : while (ref)
3398 : {
3399 767873 : switch (ref->type)
3400 : {
3401 598670 : case REF_ARRAY:
3402 : /* Return the descriptor if that's what we want and this is an array
3403 : section reference. */
3404 598670 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3405 : return;
3406 : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3407 : /* Return the descriptor for array pointers and allocations. */
3408 265109 : if (se->want_pointer
3409 23298 : && ref->next == NULL && (se->descriptor_only))
3410 : return;
3411 :
3412 255888 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3413 : /* Return a pointer to an element. */
3414 255888 : break;
3415 :
3416 162081 : case REF_COMPONENT:
3417 162081 : ts = &ref->u.c.component->ts;
3418 162081 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3419 5637 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3420 2968 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3421 2968 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3422 2501 : && strcmp ("_data", ref->u.c.component->name) == 0)
3423 : /* Skip the first ref of a _data component, because for class
3424 : arrays that one is already done by introducing a temporary
3425 : array descriptor. */
3426 : break;
3427 :
3428 159580 : if (ref->u.c.sym->attr.extension)
3429 52160 : conv_parent_component_references (se, ref);
3430 :
3431 159580 : gfc_conv_component_ref (se, ref);
3432 :
3433 159580 : if (ref->u.c.component->ts.type == BT_CLASS
3434 11655 : && ref->u.c.component->attr.class_ok
3435 11655 : && ref->u.c.component->ts.u.derived->attr.is_class)
3436 11655 : se->class_container = se->expr;
3437 147925 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3438 145431 : && ref->u.c.sym->attr.is_class))
3439 81549 : se->class_container = NULL_TREE;
3440 :
3441 159580 : if (!ref->next && ref->u.c.sym->attr.codimension
3442 0 : && se->want_pointer && se->descriptor_only)
3443 : return;
3444 :
3445 : break;
3446 :
3447 6585 : case REF_SUBSTRING:
3448 6585 : gfc_conv_substring (se, ref, expr->ts.kind,
3449 6585 : expr->symtree->name, &expr->where);
3450 6585 : break;
3451 :
3452 537 : case REF_INQUIRY:
3453 537 : conv_inquiry (se, ref, expr, ts);
3454 537 : break;
3455 :
3456 0 : default:
3457 0 : gcc_unreachable ();
3458 425091 : break;
3459 : }
3460 425091 : first_time = false;
3461 425091 : ref = ref->next;
3462 : }
3463 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3464 : separately. */
3465 1216678 : if (se->want_pointer)
3466 : {
3467 131795 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3468 7974 : gfc_conv_string_parameter (se);
3469 : else
3470 123821 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3471 : }
3472 : }
3473 :
3474 :
3475 : /* Unary ops are easy... Or they would be if ! was a valid op. */
3476 :
3477 : static void
3478 28698 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3479 : {
3480 28698 : gfc_se operand;
3481 28698 : tree type;
3482 :
3483 28698 : gcc_assert (expr->ts.type != BT_CHARACTER);
3484 : /* Initialize the operand. */
3485 28698 : gfc_init_se (&operand, se);
3486 28698 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3487 28698 : gfc_add_block_to_block (&se->pre, &operand.pre);
3488 :
3489 28698 : type = gfc_typenode_for_spec (&expr->ts);
3490 :
3491 : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3492 : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3493 : All other unary operators have an equivalent GIMPLE unary operator. */
3494 28698 : if (code == TRUTH_NOT_EXPR)
3495 20098 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3496 : build_int_cst (type, 0));
3497 : else
3498 8600 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3499 :
3500 28698 : }
3501 :
3502 : /* Expand power operator to optimal multiplications when a value is raised
3503 : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3504 : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3505 : Programming", 3rd Edition, 1998. */
3506 :
3507 : /* This code is mostly duplicated from expand_powi in the backend.
3508 : We establish the "optimal power tree" lookup table with the defined size.
3509 : The items in the table are the exponents used to calculate the index
3510 : exponents. Any integer n less than the value can get an "addition chain",
3511 : with the first node being one. */
3512 : #define POWI_TABLE_SIZE 256
3513 :
3514 : /* The table is from builtins.cc. */
3515 : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3516 : {
3517 : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3518 : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3519 : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3520 : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3521 : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3522 : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3523 : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3524 : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3525 : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3526 : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3527 : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3528 : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3529 : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3530 : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3531 : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3532 : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3533 : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3534 : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3535 : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3536 : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3537 : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3538 : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3539 : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3540 : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3541 : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3542 : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3543 : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3544 : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3545 : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3546 : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3547 : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3548 : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3549 : };
3550 :
3551 : /* If n is larger than lookup table's max index, we use the "window
3552 : method". */
3553 : #define POWI_WINDOW_SIZE 3
3554 :
3555 : /* Recursive function to expand the power operator. The temporary
3556 : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3557 : static tree
3558 178323 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3559 : {
3560 178323 : tree op0;
3561 178323 : tree op1;
3562 178323 : tree tmp;
3563 178323 : int digit;
3564 :
3565 178323 : if (n < POWI_TABLE_SIZE)
3566 : {
3567 137336 : if (tmpvar[n])
3568 : return tmpvar[n];
3569 :
3570 56612 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3571 56612 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3572 : }
3573 40987 : else if (n & 1)
3574 : {
3575 10015 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3576 10015 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3577 10015 : op1 = gfc_conv_powi (se, digit, tmpvar);
3578 : }
3579 : else
3580 : {
3581 30972 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3582 30972 : op1 = op0;
3583 : }
3584 :
3585 97599 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3586 97599 : tmp = gfc_evaluate_now (tmp, &se->pre);
3587 :
3588 97599 : if (n < POWI_TABLE_SIZE)
3589 56612 : tmpvar[n] = tmp;
3590 :
3591 : return tmp;
3592 : }
3593 :
3594 :
3595 : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3596 : return 1. Else return 0 and a call to runtime library functions
3597 : will have to be built. */
3598 : static int
3599 3305 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3600 : {
3601 3305 : tree cond;
3602 3305 : tree tmp;
3603 3305 : tree type;
3604 3305 : tree vartmp[POWI_TABLE_SIZE];
3605 3305 : HOST_WIDE_INT m;
3606 3305 : unsigned HOST_WIDE_INT n;
3607 3305 : int sgn;
3608 3305 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3609 :
3610 : /* If exponent is too large, we won't expand it anyway, so don't bother
3611 : with large integer values. */
3612 3305 : if (!wi::fits_shwi_p (wrhs))
3613 : return 0;
3614 :
3615 2945 : m = wrhs.to_shwi ();
3616 : /* Use the wide_int's routine to reliably get the absolute value on all
3617 : platforms. Then convert it to a HOST_WIDE_INT like above. */
3618 2945 : n = wi::abs (wrhs).to_shwi ();
3619 :
3620 2945 : type = TREE_TYPE (lhs);
3621 2945 : sgn = tree_int_cst_sgn (rhs);
3622 :
3623 2945 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3624 5890 : || optimize_size) && (m > 2 || m < -1))
3625 : return 0;
3626 :
3627 : /* rhs == 0 */
3628 1639 : if (sgn == 0)
3629 : {
3630 282 : se->expr = gfc_build_const (type, integer_one_node);
3631 282 : return 1;
3632 : }
3633 :
3634 : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3635 1357 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3636 : {
3637 220 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3638 220 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3639 220 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3640 220 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3641 :
3642 : /* If rhs is even,
3643 : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3644 220 : if ((n & 1) == 0)
3645 : {
3646 104 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3647 : logical_type_node, tmp, cond);
3648 104 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3649 : tmp, build_int_cst (type, 1),
3650 : build_int_cst (type, 0));
3651 104 : return 1;
3652 : }
3653 : /* If rhs is odd,
3654 : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3655 116 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3656 : build_int_cst (type, -1),
3657 : build_int_cst (type, 0));
3658 116 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3659 : cond, build_int_cst (type, 1), tmp);
3660 116 : return 1;
3661 : }
3662 :
3663 1137 : memset (vartmp, 0, sizeof (vartmp));
3664 1137 : vartmp[1] = lhs;
3665 1137 : if (sgn == -1)
3666 : {
3667 141 : tmp = gfc_build_const (type, integer_one_node);
3668 141 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3669 : vartmp[1]);
3670 : }
3671 :
3672 1137 : se->expr = gfc_conv_powi (se, n, vartmp);
3673 :
3674 1137 : return 1;
3675 : }
3676 :
3677 : /* Convert lhs**rhs, for constant rhs, when both are unsigned.
3678 : Method:
3679 : if (rhs == 0) ! Checked here.
3680 : return 1;
3681 : if (lhs & 1 == 1) ! odd_cnd
3682 : {
3683 : if (bit_size(rhs) < bit_size(lhs)) ! Checked here.
3684 : return lhs ** rhs;
3685 :
3686 : mask = 1 << (bit_size(a) - 1) / 2;
3687 : return lhs ** (n & rhs);
3688 : }
3689 : if (rhs > bit_size(lhs)) ! Checked here.
3690 : return 0;
3691 :
3692 : return lhs ** rhs;
3693 : */
3694 :
3695 : static int
3696 15120 : gfc_conv_cst_uint_power (gfc_se * se, tree lhs, tree rhs)
3697 : {
3698 15120 : tree type = TREE_TYPE (lhs);
3699 15120 : tree tmp, is_odd, odd_branch, even_branch;
3700 15120 : unsigned HOST_WIDE_INT lhs_prec, rhs_prec;
3701 15120 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3702 15120 : unsigned HOST_WIDE_INT n, n_odd;
3703 15120 : tree vartmp_odd[POWI_TABLE_SIZE], vartmp_even[POWI_TABLE_SIZE];
3704 :
3705 : /* Anything ** 0 is one. */
3706 15120 : if (integer_zerop (rhs))
3707 : {
3708 1800 : se->expr = build_int_cst (type, 1);
3709 1800 : return 1;
3710 : }
3711 :
3712 13320 : if (!wi::fits_uhwi_p (wrhs))
3713 : return 0;
3714 :
3715 12960 : n = wrhs.to_uhwi ();
3716 :
3717 : /* tmp = a & 1; . */
3718 12960 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3719 : lhs, build_int_cst (type, 1));
3720 12960 : is_odd = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3721 : tmp, build_int_cst (type, 1));
3722 :
3723 12960 : lhs_prec = TYPE_PRECISION (type);
3724 12960 : rhs_prec = TYPE_PRECISION (TREE_TYPE (rhs));
3725 :
3726 12960 : if (rhs_prec >= lhs_prec && lhs_prec <= HOST_BITS_PER_WIDE_INT)
3727 : {
3728 7044 : unsigned HOST_WIDE_INT mask = (HOST_WIDE_INT_1U << (lhs_prec - 1)) - 1;
3729 7044 : n_odd = n & mask;
3730 : }
3731 : else
3732 : n_odd = n;
3733 :
3734 12960 : memset (vartmp_odd, 0, sizeof (vartmp_odd));
3735 12960 : vartmp_odd[0] = build_int_cst (type, 1);
3736 12960 : vartmp_odd[1] = lhs;
3737 12960 : odd_branch = gfc_conv_powi (se, n_odd, vartmp_odd);
3738 12960 : even_branch = NULL_TREE;
3739 :
3740 12960 : if (n > lhs_prec)
3741 4260 : even_branch = build_int_cst (type, 0);
3742 : else
3743 : {
3744 8700 : if (n_odd != n)
3745 : {
3746 0 : memset (vartmp_even, 0, sizeof (vartmp_even));
3747 0 : vartmp_even[0] = build_int_cst (type, 1);
3748 0 : vartmp_even[1] = lhs;
3749 0 : even_branch = gfc_conv_powi (se, n, vartmp_even);
3750 : }
3751 : }
3752 4260 : if (even_branch != NULL_TREE)
3753 4260 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, is_odd,
3754 : odd_branch, even_branch);
3755 : else
3756 8700 : se->expr = odd_branch;
3757 :
3758 : return 1;
3759 : }
3760 :
3761 : /* Power op (**). Constant integer exponent and powers of 2 have special
3762 : handling. */
3763 :
3764 : static void
3765 49129 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3766 : {
3767 49129 : tree gfc_int4_type_node;
3768 49129 : int kind;
3769 49129 : int ikind;
3770 49129 : int res_ikind_1, res_ikind_2;
3771 49129 : gfc_se lse;
3772 49129 : gfc_se rse;
3773 49129 : tree fndecl = NULL;
3774 :
3775 49129 : gfc_init_se (&lse, se);
3776 49129 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3777 49129 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3778 49129 : gfc_add_block_to_block (&se->pre, &lse.pre);
3779 :
3780 49129 : gfc_init_se (&rse, se);
3781 49129 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3782 49129 : gfc_add_block_to_block (&se->pre, &rse.pre);
3783 :
3784 49129 : if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
3785 : {
3786 17563 : if (expr->value.op.op2->ts.type == BT_INTEGER)
3787 : {
3788 2292 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3789 20418 : return;
3790 : }
3791 15271 : else if (expr->value.op.op2->ts.type == BT_UNSIGNED)
3792 : {
3793 15120 : if (gfc_conv_cst_uint_power (se, lse.expr, rse.expr))
3794 : return;
3795 : }
3796 : }
3797 :
3798 32730 : if ((expr->value.op.op2->ts.type == BT_INTEGER
3799 31468 : || expr->value.op.op2->ts.type == BT_UNSIGNED)
3800 31862 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3801 1013 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3802 : return;
3803 :
3804 32730 : if (INTEGER_CST_P (lse.expr)
3805 15371 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE
3806 48101 : && expr->value.op.op2->ts.type == BT_INTEGER)
3807 : {
3808 251 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3809 251 : HOST_WIDE_INT v;
3810 251 : unsigned HOST_WIDE_INT w;
3811 251 : int kind, ikind, bit_size;
3812 :
3813 251 : v = wlhs.to_shwi ();
3814 251 : w = absu_hwi (v);
3815 :
3816 251 : kind = expr->value.op.op1->ts.kind;
3817 251 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3818 251 : bit_size = gfc_integer_kinds[ikind].bit_size;
3819 :
3820 251 : if (v == 1)
3821 : {
3822 : /* 1**something is always 1. */
3823 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3824 239 : return;
3825 : }
3826 216 : else if (v == -1)
3827 : {
3828 : /* (-1)**n is 1 - ((n & 1) << 1) */
3829 34 : tree type;
3830 34 : tree tmp;
3831 :
3832 34 : type = TREE_TYPE (lse.expr);
3833 34 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3834 : rse.expr, build_int_cst (type, 1));
3835 34 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3836 : tmp, build_int_cst (type, 1));
3837 34 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3838 : build_int_cst (type, 1), tmp);
3839 34 : se->expr = tmp;
3840 34 : return;
3841 : }
3842 182 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3843 : {
3844 : /* Here v is +/- 2**e. The further simplification uses
3845 : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3846 : 1<<(4*n), etc., but we have to make sure to return zero
3847 : if the number of bits is too large. */
3848 170 : tree lshift;
3849 170 : tree type;
3850 170 : tree shift;
3851 170 : tree ge;
3852 170 : tree cond;
3853 170 : tree num_bits;
3854 170 : tree cond2;
3855 170 : tree tmp1;
3856 :
3857 170 : type = TREE_TYPE (lse.expr);
3858 :
3859 170 : if (w == 2)
3860 110 : shift = rse.expr;
3861 60 : else if (w == 4)
3862 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3863 12 : TREE_TYPE (rse.expr),
3864 : rse.expr, rse.expr);
3865 : else
3866 : {
3867 : /* use popcount for fast log2(w) */
3868 48 : int e = wi::popcount (w-1);
3869 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3870 48 : TREE_TYPE (rse.expr),
3871 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3872 : rse.expr);
3873 : }
3874 :
3875 170 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3876 : build_int_cst (type, 1), shift);
3877 170 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3878 : rse.expr, build_int_cst (type, 0));
3879 170 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3880 : build_int_cst (type, 0));
3881 170 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3882 170 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3883 : rse.expr, num_bits);
3884 170 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3885 : build_int_cst (type, 0), cond);
3886 170 : if (v > 0)
3887 : {
3888 128 : se->expr = tmp1;
3889 : }
3890 : else
3891 : {
3892 : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3893 42 : tree tmp2;
3894 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3895 : rse.expr, build_int_cst (type, 1));
3896 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3897 : tmp2, build_int_cst (type, 1));
3898 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3899 : build_int_cst (type, 1), tmp2);
3900 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3901 : tmp1, tmp2);
3902 : }
3903 170 : return;
3904 : }
3905 : }
3906 : /* Handle unsigned separate from signed above, things would be too
3907 : complicated otherwise. */
3908 :
3909 32491 : if (INTEGER_CST_P (lse.expr) && expr->value.op.op1->ts.type == BT_UNSIGNED)
3910 : {
3911 15120 : gfc_expr * op1 = expr->value.op.op1;
3912 15120 : tree type;
3913 :
3914 15120 : type = TREE_TYPE (lse.expr);
3915 :
3916 15120 : if (mpz_cmp_ui (op1->value.integer, 1) == 0)
3917 : {
3918 : /* 1**something is always 1. */
3919 1260 : se->expr = build_int_cst (type, 1);
3920 1260 : return;
3921 : }
3922 :
3923 : /* Simplify 2u**x to a shift, with the value set to zero if it falls
3924 : outside the range. */
3925 26460 : if (mpz_popcount (op1->value.integer) == 1)
3926 : {
3927 2520 : tree prec_m1, lim, shift, lshift, cond, tmp;
3928 2520 : tree rtype = TREE_TYPE (rse.expr);
3929 2520 : int e = mpz_scan1 (op1->value.integer, 0);
3930 :
3931 2520 : shift = fold_build2_loc (input_location, MULT_EXPR,
3932 2520 : rtype, build_int_cst (rtype, e),
3933 : rse.expr);
3934 2520 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3935 : build_int_cst (type, 1), shift);
3936 5040 : prec_m1 = fold_build2_loc (input_location, MINUS_EXPR, rtype,
3937 2520 : build_int_cst (rtype, TYPE_PRECISION (type)),
3938 : build_int_cst (rtype, 1));
3939 2520 : lim = fold_build2_loc (input_location, TRUNC_DIV_EXPR, rtype,
3940 2520 : prec_m1, build_int_cst (rtype, e));
3941 2520 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3942 : rse.expr, lim);
3943 2520 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond,
3944 : build_int_cst (type, 0), lshift);
3945 2520 : se->expr = tmp;
3946 2520 : return;
3947 : }
3948 : }
3949 :
3950 28711 : gfc_int4_type_node = gfc_get_int_type (4);
3951 :
3952 : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3953 : library routine. But in the end, we have to convert the result back
3954 : if this case applies -- with res_ikind_K, we keep track whether operand K
3955 : falls into this case. */
3956 28711 : res_ikind_1 = -1;
3957 28711 : res_ikind_2 = -1;
3958 :
3959 28711 : kind = expr->value.op.op1->ts.kind;
3960 28711 : switch (expr->value.op.op2->ts.type)
3961 : {
3962 1023 : case BT_INTEGER:
3963 1023 : ikind = expr->value.op.op2->ts.kind;
3964 1023 : switch (ikind)
3965 : {
3966 144 : case 1:
3967 144 : case 2:
3968 144 : rse.expr = convert (gfc_int4_type_node, rse.expr);
3969 144 : res_ikind_2 = ikind;
3970 : /* Fall through. */
3971 :
3972 : case 4:
3973 : ikind = 0;
3974 : break;
3975 :
3976 : case 8:
3977 : ikind = 1;
3978 : break;
3979 :
3980 6 : case 16:
3981 6 : ikind = 2;
3982 6 : break;
3983 :
3984 0 : default:
3985 0 : gcc_unreachable ();
3986 : }
3987 1023 : switch (kind)
3988 : {
3989 0 : case 1:
3990 0 : case 2:
3991 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
3992 : {
3993 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
3994 0 : res_ikind_1 = kind;
3995 : }
3996 : else
3997 0 : gcc_unreachable ();
3998 : /* Fall through. */
3999 :
4000 : case 4:
4001 : kind = 0;
4002 : break;
4003 :
4004 : case 8:
4005 : kind = 1;
4006 : break;
4007 :
4008 6 : case 10:
4009 6 : kind = 2;
4010 6 : break;
4011 :
4012 18 : case 16:
4013 18 : kind = 3;
4014 18 : break;
4015 :
4016 0 : default:
4017 0 : gcc_unreachable ();
4018 : }
4019 :
4020 1023 : switch (expr->value.op.op1->ts.type)
4021 : {
4022 129 : case BT_INTEGER:
4023 129 : if (kind == 3) /* Case 16 was not handled properly above. */
4024 : kind = 2;
4025 129 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
4026 129 : break;
4027 :
4028 662 : case BT_REAL:
4029 : /* Use builtins for real ** int4. */
4030 662 : if (ikind == 0)
4031 : {
4032 565 : switch (kind)
4033 : {
4034 392 : case 0:
4035 392 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
4036 392 : break;
4037 :
4038 155 : case 1:
4039 155 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
4040 155 : break;
4041 :
4042 6 : case 2:
4043 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4044 6 : break;
4045 :
4046 12 : case 3:
4047 : /* Use the __builtin_powil() only if real(kind=16) is
4048 : actually the C long double type. */
4049 12 : if (!gfc_real16_is_float128)
4050 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4051 : break;
4052 :
4053 : default:
4054 : gcc_unreachable ();
4055 : }
4056 : }
4057 :
4058 : /* If we don't have a good builtin for this, go for the
4059 : library function. */
4060 553 : if (!fndecl)
4061 109 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
4062 : break;
4063 :
4064 232 : case BT_COMPLEX:
4065 232 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
4066 232 : break;
4067 :
4068 0 : default:
4069 0 : gcc_unreachable ();
4070 : }
4071 : break;
4072 :
4073 139 : case BT_REAL:
4074 139 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
4075 139 : break;
4076 :
4077 729 : case BT_COMPLEX:
4078 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
4079 729 : break;
4080 :
4081 26820 : case BT_UNSIGNED:
4082 26820 : {
4083 : /* Valid kinds for unsigned are 1, 2, 4, 8, 16. Instead of using a
4084 : large switch statement, let's just use __builtin_ctz. */
4085 26820 : int base = __builtin_ctz (expr->value.op.op1->ts.kind);
4086 26820 : int expon = __builtin_ctz (expr->value.op.op2->ts.kind);
4087 26820 : fndecl = gfor_fndecl_unsigned_pow_list[base][expon];
4088 : }
4089 26820 : break;
4090 :
4091 0 : default:
4092 0 : gcc_unreachable ();
4093 28711 : break;
4094 : }
4095 :
4096 28711 : se->expr = build_call_expr_loc (input_location,
4097 : fndecl, 2, lse.expr, rse.expr);
4098 :
4099 : /* Convert the result back if it is of wrong integer kind. */
4100 28711 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
4101 : {
4102 : /* We want the maximum of both operand kinds as result. */
4103 0 : if (res_ikind_1 < res_ikind_2)
4104 0 : res_ikind_1 = res_ikind_2;
4105 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
4106 : }
4107 : }
4108 :
4109 :
4110 : /* Generate code to allocate a string temporary. */
4111 :
4112 : tree
4113 4914 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4114 : {
4115 4914 : tree var;
4116 4914 : tree tmp;
4117 :
4118 4914 : if (gfc_can_put_var_on_stack (len))
4119 : {
4120 : /* Create a temporary variable to hold the result. */
4121 4584 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4122 2292 : TREE_TYPE (len), len,
4123 2292 : build_int_cst (TREE_TYPE (len), 1));
4124 2292 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4125 :
4126 2292 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4127 2262 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4128 : else
4129 30 : tmp = build_array_type (TREE_TYPE (type), tmp);
4130 :
4131 2292 : var = gfc_create_var (tmp, "str");
4132 2292 : var = gfc_build_addr_expr (type, var);
4133 : }
4134 : else
4135 : {
4136 : /* Allocate a temporary to hold the result. */
4137 2622 : var = gfc_create_var (type, "pstr");
4138 2622 : gcc_assert (POINTER_TYPE_P (type));
4139 2622 : tmp = TREE_TYPE (type);
4140 2622 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4141 2580 : tmp = TREE_TYPE (tmp);
4142 2622 : tmp = TYPE_SIZE_UNIT (tmp);
4143 2622 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4144 : fold_convert (size_type_node, len),
4145 : fold_convert (size_type_node, tmp));
4146 2622 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4147 2622 : gfc_add_modify (&se->pre, var, tmp);
4148 :
4149 : /* Free the temporary afterwards. */
4150 2622 : tmp = gfc_call_free (var);
4151 2622 : gfc_add_expr_to_block (&se->post, tmp);
4152 : }
4153 :
4154 4914 : return var;
4155 : }
4156 :
4157 :
4158 : /* Handle a string concatenation operation. A temporary will be allocated to
4159 : hold the result. */
4160 :
4161 : static void
4162 1281 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4163 : {
4164 1281 : gfc_se lse, rse;
4165 1281 : tree len, type, var, tmp, fndecl;
4166 :
4167 1281 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4168 : && expr->value.op.op2->ts.type == BT_CHARACTER);
4169 1281 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4170 :
4171 1281 : gfc_init_se (&lse, se);
4172 1281 : gfc_conv_expr (&lse, expr->value.op.op1);
4173 1281 : gfc_conv_string_parameter (&lse);
4174 1281 : gfc_init_se (&rse, se);
4175 1281 : gfc_conv_expr (&rse, expr->value.op.op2);
4176 1281 : gfc_conv_string_parameter (&rse);
4177 :
4178 1281 : gfc_add_block_to_block (&se->pre, &lse.pre);
4179 1281 : gfc_add_block_to_block (&se->pre, &rse.pre);
4180 :
4181 1281 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4182 1281 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4183 1281 : if (len == NULL_TREE)
4184 : {
4185 1063 : len = fold_build2_loc (input_location, PLUS_EXPR,
4186 : gfc_charlen_type_node,
4187 : fold_convert (gfc_charlen_type_node,
4188 : lse.string_length),
4189 : fold_convert (gfc_charlen_type_node,
4190 : rse.string_length));
4191 : }
4192 :
4193 1281 : type = build_pointer_type (type);
4194 :
4195 1281 : var = gfc_conv_string_tmp (se, type, len);
4196 :
4197 : /* Do the actual concatenation. */
4198 1281 : if (expr->ts.kind == 1)
4199 1190 : fndecl = gfor_fndecl_concat_string;
4200 91 : else if (expr->ts.kind == 4)
4201 91 : fndecl = gfor_fndecl_concat_string_char4;
4202 : else
4203 0 : gcc_unreachable ();
4204 :
4205 1281 : tmp = build_call_expr_loc (input_location,
4206 : fndecl, 6, len, var, lse.string_length, lse.expr,
4207 : rse.string_length, rse.expr);
4208 1281 : gfc_add_expr_to_block (&se->pre, tmp);
4209 :
4210 : /* Add the cleanup for the operands. */
4211 1281 : gfc_add_block_to_block (&se->pre, &rse.post);
4212 1281 : gfc_add_block_to_block (&se->pre, &lse.post);
4213 :
4214 1281 : se->expr = var;
4215 1281 : se->string_length = len;
4216 1281 : }
4217 :
4218 : /* Translates an op expression. Common (binary) cases are handled by this
4219 : function, others are passed on. Recursion is used in either case.
4220 : We use the fact that (op1.ts == op2.ts) (except for the power
4221 : operator **).
4222 : Operators need no special handling for scalarized expressions as long as
4223 : they call gfc_conv_simple_val to get their operands.
4224 : Character strings get special handling. */
4225 :
4226 : static void
4227 501934 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4228 : {
4229 501934 : enum tree_code code;
4230 501934 : gfc_se lse;
4231 501934 : gfc_se rse;
4232 501934 : tree tmp, type;
4233 501934 : int lop;
4234 501934 : int checkstring;
4235 :
4236 501934 : checkstring = 0;
4237 501934 : lop = 0;
4238 501934 : switch (expr->value.op.op)
4239 : {
4240 15379 : case INTRINSIC_PARENTHESES:
4241 15379 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4242 3800 : && flag_protect_parens)
4243 : {
4244 3667 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
4245 3667 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
4246 90826 : return;
4247 : }
4248 :
4249 : /* Fallthrough. */
4250 11718 : case INTRINSIC_UPLUS:
4251 11718 : gfc_conv_expr (se, expr->value.op.op1);
4252 11718 : return;
4253 :
4254 4933 : case INTRINSIC_UMINUS:
4255 4933 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4256 4933 : return;
4257 :
4258 20098 : case INTRINSIC_NOT:
4259 20098 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4260 20098 : return;
4261 :
4262 : case INTRINSIC_PLUS:
4263 : code = PLUS_EXPR;
4264 : break;
4265 :
4266 28406 : case INTRINSIC_MINUS:
4267 28406 : code = MINUS_EXPR;
4268 28406 : break;
4269 :
4270 31941 : case INTRINSIC_TIMES:
4271 31941 : code = MULT_EXPR;
4272 31941 : break;
4273 :
4274 6744 : case INTRINSIC_DIVIDE:
4275 : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
4276 : an integer or unsigned, we must round towards zero, so we use a
4277 : TRUNC_DIV_EXPR. */
4278 6744 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4279 : code = TRUNC_DIV_EXPR;
4280 : else
4281 411108 : code = RDIV_EXPR;
4282 : break;
4283 :
4284 49129 : case INTRINSIC_POWER:
4285 49129 : gfc_conv_power_op (se, expr);
4286 49129 : return;
4287 :
4288 1281 : case INTRINSIC_CONCAT:
4289 1281 : gfc_conv_concat_op (se, expr);
4290 1281 : return;
4291 :
4292 4780 : case INTRINSIC_AND:
4293 4780 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4294 : lop = 1;
4295 : break;
4296 :
4297 55810 : case INTRINSIC_OR:
4298 55810 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
4299 : lop = 1;
4300 : break;
4301 :
4302 : /* EQV and NEQV only work on logicals, but since we represent them
4303 : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4304 12602 : case INTRINSIC_EQ:
4305 12602 : case INTRINSIC_EQ_OS:
4306 12602 : case INTRINSIC_EQV:
4307 12602 : code = EQ_EXPR;
4308 12602 : checkstring = 1;
4309 12602 : lop = 1;
4310 12602 : break;
4311 :
4312 204759 : case INTRINSIC_NE:
4313 204759 : case INTRINSIC_NE_OS:
4314 204759 : case INTRINSIC_NEQV:
4315 204759 : code = NE_EXPR;
4316 204759 : checkstring = 1;
4317 204759 : lop = 1;
4318 204759 : break;
4319 :
4320 11858 : case INTRINSIC_GT:
4321 11858 : case INTRINSIC_GT_OS:
4322 11858 : code = GT_EXPR;
4323 11858 : checkstring = 1;
4324 11858 : lop = 1;
4325 11858 : break;
4326 :
4327 1661 : case INTRINSIC_GE:
4328 1661 : case INTRINSIC_GE_OS:
4329 1661 : code = GE_EXPR;
4330 1661 : checkstring = 1;
4331 1661 : lop = 1;
4332 1661 : break;
4333 :
4334 4331 : case INTRINSIC_LT:
4335 4331 : case INTRINSIC_LT_OS:
4336 4331 : code = LT_EXPR;
4337 4331 : checkstring = 1;
4338 4331 : lop = 1;
4339 4331 : break;
4340 :
4341 2590 : case INTRINSIC_LE:
4342 2590 : case INTRINSIC_LE_OS:
4343 2590 : code = LE_EXPR;
4344 2590 : checkstring = 1;
4345 2590 : lop = 1;
4346 2590 : break;
4347 :
4348 0 : case INTRINSIC_USER:
4349 0 : case INTRINSIC_ASSIGN:
4350 : /* These should be converted into function calls by the frontend. */
4351 0 : gcc_unreachable ();
4352 :
4353 0 : default:
4354 0 : fatal_error (input_location, "Unknown intrinsic op");
4355 411108 : return;
4356 : }
4357 :
4358 : /* The only exception to this is **, which is handled separately anyway. */
4359 411108 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4360 :
4361 411108 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4362 377898 : checkstring = 0;
4363 :
4364 : /* lhs */
4365 411108 : gfc_init_se (&lse, se);
4366 411108 : gfc_conv_expr (&lse, expr->value.op.op1);
4367 411108 : gfc_add_block_to_block (&se->pre, &lse.pre);
4368 :
4369 : /* rhs */
4370 411108 : gfc_init_se (&rse, se);
4371 411108 : gfc_conv_expr (&rse, expr->value.op.op2);
4372 411108 : gfc_add_block_to_block (&se->pre, &rse.pre);
4373 :
4374 411108 : if (checkstring)
4375 : {
4376 33210 : gfc_conv_string_parameter (&lse);
4377 33210 : gfc_conv_string_parameter (&rse);
4378 :
4379 66420 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4380 : rse.string_length, rse.expr,
4381 33210 : expr->value.op.op1->ts.kind,
4382 : code);
4383 33210 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4384 33210 : gfc_add_block_to_block (&lse.post, &rse.post);
4385 : }
4386 :
4387 411108 : type = gfc_typenode_for_spec (&expr->ts);
4388 :
4389 411108 : if (lop)
4390 : {
4391 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4392 298391 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4393 168162 : && expr->value.op.op1->ts.type == BT_INTEGER
4394 72413 : && expr->value.op.op1->symtree
4395 72413 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4396 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4397 :
4398 298391 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4399 71957 : && expr->value.op.op2->ts.type == BT_INTEGER
4400 12728 : && expr->value.op.op2->symtree
4401 12728 : && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
4402 12 : TREE_THIS_VOLATILE (rse.expr) = 1;
4403 :
4404 : /* The result of logical ops is always logical_type_node. */
4405 298391 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4406 : lse.expr, rse.expr);
4407 298391 : se->expr = convert (type, tmp);
4408 : }
4409 : else
4410 112717 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4411 :
4412 : /* Add the post blocks. */
4413 411108 : gfc_add_block_to_block (&se->post, &rse.post);
4414 411108 : gfc_add_block_to_block (&se->post, &lse.post);
4415 : }
4416 :
4417 : static void
4418 139 : gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
4419 : {
4420 139 : gfc_se cond_se, true_se, false_se;
4421 139 : tree condition, true_val, false_val;
4422 139 : tree type;
4423 :
4424 139 : gfc_init_se (&cond_se, se);
4425 139 : gfc_init_se (&true_se, se);
4426 139 : gfc_init_se (&false_se, se);
4427 :
4428 139 : gfc_conv_expr (&cond_se, expr->value.conditional.condition);
4429 139 : gfc_add_block_to_block (&se->pre, &cond_se.pre);
4430 139 : condition = gfc_evaluate_now (cond_se.expr, &se->pre);
4431 :
4432 139 : true_se.want_pointer = se->want_pointer;
4433 139 : gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
4434 139 : true_val = true_se.expr;
4435 139 : false_se.want_pointer = se->want_pointer;
4436 139 : gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
4437 139 : false_val = false_se.expr;
4438 :
4439 139 : if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
4440 24 : gfc_add_expr_to_block (
4441 : &se->pre,
4442 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4443 24 : true_se.pre.head != NULL_TREE
4444 6 : ? gfc_finish_block (&true_se.pre)
4445 18 : : build_empty_stmt (input_location),
4446 24 : false_se.pre.head != NULL_TREE
4447 24 : ? gfc_finish_block (&false_se.pre)
4448 0 : : build_empty_stmt (input_location)));
4449 :
4450 139 : if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
4451 6 : gfc_add_expr_to_block (
4452 : &se->post,
4453 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4454 6 : true_se.post.head != NULL_TREE
4455 0 : ? gfc_finish_block (&true_se.post)
4456 6 : : build_empty_stmt (input_location),
4457 6 : false_se.post.head != NULL_TREE
4458 6 : ? gfc_finish_block (&false_se.post)
4459 0 : : build_empty_stmt (input_location)));
4460 :
4461 139 : type = gfc_typenode_for_spec (&expr->ts);
4462 139 : if (se->want_pointer)
4463 18 : type = build_pointer_type (type);
4464 :
4465 139 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
4466 : true_val, false_val);
4467 139 : if (expr->ts.type == BT_CHARACTER)
4468 54 : se->string_length
4469 54 : = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
4470 : condition, true_se.string_length,
4471 : false_se.string_length);
4472 139 : }
4473 :
4474 : /* If a string's length is one, we convert it to a single character. */
4475 :
4476 : tree
4477 137990 : gfc_string_to_single_character (tree len, tree str, int kind)
4478 : {
4479 :
4480 137990 : if (len == NULL
4481 137990 : || !tree_fits_uhwi_p (len)
4482 253382 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4483 : return NULL_TREE;
4484 :
4485 115340 : if (TREE_INT_CST_LOW (len) == 1)
4486 : {
4487 22201 : str = fold_convert (gfc_get_pchar_type (kind), str);
4488 22201 : return build_fold_indirect_ref_loc (input_location, str);
4489 : }
4490 :
4491 93139 : if (kind == 1
4492 75769 : && TREE_CODE (str) == ADDR_EXPR
4493 65130 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4494 46861 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4495 28481 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4496 28481 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4497 28481 : && TREE_INT_CST_LOW (len) > 1
4498 119864 : && TREE_INT_CST_LOW (len)
4499 : == (unsigned HOST_WIDE_INT)
4500 26725 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4501 : {
4502 26725 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4503 26725 : ret = build_fold_indirect_ref_loc (input_location, ret);
4504 26725 : if (TREE_CODE (ret) == INTEGER_CST)
4505 : {
4506 26725 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4507 26725 : int i, length = TREE_STRING_LENGTH (string_cst);
4508 26725 : const char *ptr = TREE_STRING_POINTER (string_cst);
4509 :
4510 39878 : for (i = 1; i < length; i++)
4511 39205 : if (ptr[i] != ' ')
4512 : return NULL_TREE;
4513 :
4514 : return ret;
4515 : }
4516 : }
4517 :
4518 : return NULL_TREE;
4519 : }
4520 :
4521 :
4522 : static void
4523 172 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4524 : {
4525 172 : gcc_assert (expr);
4526 :
4527 : /* We used to modify the tree here. Now it is done earlier in
4528 : the front-end, so we only check it here to avoid regressions. */
4529 172 : if (sym->backend_decl)
4530 : {
4531 67 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4532 67 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4533 67 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4534 67 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4535 : }
4536 :
4537 : /* If we have a constant character expression, make it into an
4538 : integer of type C char. */
4539 172 : if ((*expr)->expr_type == EXPR_CONSTANT)
4540 : {
4541 166 : gfc_typespec ts;
4542 166 : gfc_clear_ts (&ts);
4543 :
4544 332 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4545 166 : (*expr)->value.character.string[0]);
4546 166 : gfc_replace_expr (*expr, tmp);
4547 : }
4548 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4549 : {
4550 6 : if ((*expr)->ref == NULL)
4551 : {
4552 6 : se->expr = gfc_string_to_single_character
4553 6 : (integer_one_node,
4554 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4555 : gfc_get_symbol_decl
4556 6 : ((*expr)->symtree->n.sym)),
4557 : (*expr)->ts.kind);
4558 : }
4559 : else
4560 : {
4561 0 : gfc_conv_variable (se, *expr);
4562 0 : se->expr = gfc_string_to_single_character
4563 0 : (integer_one_node,
4564 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4565 : se->expr),
4566 0 : (*expr)->ts.kind);
4567 : }
4568 : }
4569 172 : }
4570 :
4571 : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4572 : if STR is a string literal, otherwise return -1. */
4573 :
4574 : static int
4575 31438 : gfc_optimize_len_trim (tree len, tree str, int kind)
4576 : {
4577 31438 : if (kind == 1
4578 26396 : && TREE_CODE (str) == ADDR_EXPR
4579 23067 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4580 14811 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4581 9389 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4582 9389 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4583 9389 : && tree_fits_uhwi_p (len)
4584 9389 : && tree_to_uhwi (len) >= 1
4585 31438 : && tree_to_uhwi (len)
4586 9345 : == (unsigned HOST_WIDE_INT)
4587 9345 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4588 : {
4589 9345 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4590 9345 : folded = build_fold_indirect_ref_loc (input_location, folded);
4591 9345 : if (TREE_CODE (folded) == INTEGER_CST)
4592 : {
4593 9345 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4594 9345 : int length = TREE_STRING_LENGTH (string_cst);
4595 9345 : const char *ptr = TREE_STRING_POINTER (string_cst);
4596 :
4597 14254 : for (; length > 0; length--)
4598 14254 : if (ptr[length - 1] != ' ')
4599 : break;
4600 :
4601 : return length;
4602 : }
4603 : }
4604 : return -1;
4605 : }
4606 :
4607 : /* Helper to build a call to memcmp. */
4608 :
4609 : static tree
4610 12703 : build_memcmp_call (tree s1, tree s2, tree n)
4611 : {
4612 12703 : tree tmp;
4613 :
4614 12703 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4615 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4616 : else
4617 12703 : s1 = fold_convert (pvoid_type_node, s1);
4618 :
4619 12703 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4620 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4621 : else
4622 12703 : s2 = fold_convert (pvoid_type_node, s2);
4623 :
4624 12703 : n = fold_convert (size_type_node, n);
4625 :
4626 12703 : tmp = build_call_expr_loc (input_location,
4627 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4628 : 3, s1, s2, n);
4629 :
4630 12703 : return fold_convert (integer_type_node, tmp);
4631 : }
4632 :
4633 : /* Compare two strings. If they are all single characters, the result is the
4634 : subtraction of them. Otherwise, we build a library call. */
4635 :
4636 : tree
4637 33309 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4638 : enum tree_code code)
4639 : {
4640 33309 : tree sc1;
4641 33309 : tree sc2;
4642 33309 : tree fndecl;
4643 :
4644 33309 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4645 33309 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4646 :
4647 33309 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4648 33309 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4649 :
4650 33309 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4651 : {
4652 : /* Deal with single character specially. */
4653 4755 : sc1 = fold_convert (integer_type_node, sc1);
4654 4755 : sc2 = fold_convert (integer_type_node, sc2);
4655 4755 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4656 4755 : sc1, sc2);
4657 : }
4658 :
4659 28554 : if ((code == EQ_EXPR || code == NE_EXPR)
4660 27992 : && optimize
4661 23578 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4662 : {
4663 : /* If one string is a string literal with LEN_TRIM longer
4664 : than the length of the second string, the strings
4665 : compare unequal. */
4666 15719 : int len = gfc_optimize_len_trim (len1, str1, kind);
4667 15719 : if (len > 0 && compare_tree_int (len2, len) < 0)
4668 0 : return integer_one_node;
4669 15719 : len = gfc_optimize_len_trim (len2, str2, kind);
4670 15719 : if (len > 0 && compare_tree_int (len1, len) < 0)
4671 0 : return integer_one_node;
4672 : }
4673 :
4674 : /* We can compare via memcpy if the strings are known to be equal
4675 : in length and they are
4676 : - kind=1
4677 : - kind=4 and the comparison is for (in)equality. */
4678 :
4679 19019 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4680 18681 : && tree_int_cst_equal (len1, len2)
4681 41317 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4682 : {
4683 12703 : tree tmp;
4684 12703 : tree chartype;
4685 :
4686 12703 : chartype = gfc_get_char_type (kind);
4687 12703 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4688 12703 : fold_convert (TREE_TYPE(len1),
4689 : TYPE_SIZE_UNIT(chartype)),
4690 : len1);
4691 12703 : return build_memcmp_call (str1, str2, tmp);
4692 : }
4693 :
4694 : /* Build a call for the comparison. */
4695 15851 : if (kind == 1)
4696 13008 : fndecl = gfor_fndecl_compare_string;
4697 2843 : else if (kind == 4)
4698 2843 : fndecl = gfor_fndecl_compare_string_char4;
4699 : else
4700 0 : gcc_unreachable ();
4701 :
4702 15851 : return build_call_expr_loc (input_location, fndecl, 4,
4703 15851 : len1, str1, len2, str2);
4704 : }
4705 :
4706 :
4707 : /* Return the backend_decl for a procedure pointer component. */
4708 :
4709 : static tree
4710 1891 : get_proc_ptr_comp (gfc_expr *e)
4711 : {
4712 1891 : gfc_se comp_se;
4713 1891 : gfc_expr *e2;
4714 1891 : expr_t old_type;
4715 :
4716 1891 : gfc_init_se (&comp_se, NULL);
4717 1891 : e2 = gfc_copy_expr (e);
4718 : /* We have to restore the expr type later so that gfc_free_expr frees
4719 : the exact same thing that was allocated.
4720 : TODO: This is ugly. */
4721 1891 : old_type = e2->expr_type;
4722 1891 : e2->expr_type = EXPR_VARIABLE;
4723 1891 : gfc_conv_expr (&comp_se, e2);
4724 1891 : e2->expr_type = old_type;
4725 1891 : gfc_free_expr (e2);
4726 1891 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4727 : }
4728 :
4729 :
4730 : /* Convert a typebound function reference from a class object. */
4731 : static void
4732 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4733 : {
4734 80 : gfc_ref *ref;
4735 80 : tree var;
4736 :
4737 80 : if (!VAR_P (base_object))
4738 : {
4739 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4740 0 : gfc_add_modify (&se->pre, var, base_object);
4741 : }
4742 80 : se->expr = gfc_class_vptr_get (base_object);
4743 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4744 80 : ref = expr->ref;
4745 308 : while (ref && ref->next)
4746 : ref = ref->next;
4747 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4748 80 : if (ref->u.c.sym->attr.extension)
4749 0 : conv_parent_component_references (se, ref);
4750 80 : gfc_conv_component_ref (se, ref);
4751 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4752 80 : }
4753 :
4754 : static tree
4755 126229 : get_builtin_fn (gfc_symbol * sym)
4756 : {
4757 126229 : if (!gfc_option.disable_omp_is_initial_device
4758 126225 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4759 613 : && !strcmp (sym->name, "omp_is_initial_device"))
4760 23 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4761 :
4762 126206 : if (!gfc_option.disable_omp_get_initial_device
4763 126199 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4764 4118 : && !strcmp (sym->name, "omp_get_initial_device"))
4765 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4766 :
4767 126177 : if (!gfc_option.disable_omp_get_num_devices
4768 126170 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4769 4089 : && !strcmp (sym->name, "omp_get_num_devices"))
4770 80 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4771 :
4772 126097 : if (!gfc_option.disable_acc_on_device
4773 125917 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4774 1163 : && !strcmp (sym->name, "acc_on_device_h"))
4775 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4776 :
4777 : return NULL_TREE;
4778 : }
4779 :
4780 : static tree
4781 522 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4782 : {
4783 522 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4784 :
4785 522 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4786 : /* In Fortran omp_is_initial_device returns logical(4)
4787 : but the builtin uses 'int'. */
4788 23 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4789 :
4790 499 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4791 : {
4792 : /* Likewise for the return type; additionally, the argument it a
4793 : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4794 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4795 390 : CALL_EXPR_ARG (fn_call, 0));
4796 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4797 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4798 : }
4799 : return fn_call;
4800 : }
4801 :
4802 : static void
4803 128924 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4804 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4805 : {
4806 128924 : tree tmp;
4807 :
4808 128924 : if (gfc_is_proc_ptr_comp (expr))
4809 1891 : tmp = get_proc_ptr_comp (expr);
4810 127033 : else if (sym->attr.dummy)
4811 : {
4812 804 : tmp = gfc_get_symbol_decl (sym);
4813 804 : if (sym->attr.proc_pointer)
4814 83 : tmp = build_fold_indirect_ref_loc (input_location,
4815 : tmp);
4816 804 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4817 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4818 : }
4819 : else
4820 : {
4821 126229 : if (!sym->backend_decl)
4822 31494 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4823 :
4824 126229 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4825 522 : *is_builtin = true;
4826 : else
4827 : {
4828 125707 : TREE_USED (sym->backend_decl) = 1;
4829 125707 : tmp = sym->backend_decl;
4830 : }
4831 :
4832 126229 : if (sym->attr.cray_pointee)
4833 : {
4834 : /* TODO - make the cray pointee a pointer to a procedure,
4835 : assign the pointer to it and use it for the call. This
4836 : will do for now! */
4837 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4838 19 : gfc_get_symbol_decl (sym->cp_pointer));
4839 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4840 : }
4841 :
4842 126229 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4843 : {
4844 125650 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4845 125650 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4846 : }
4847 : }
4848 128924 : se->expr = tmp;
4849 128924 : }
4850 :
4851 :
4852 : /* Initialize MAPPING. */
4853 :
4854 : void
4855 129041 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4856 : {
4857 129041 : mapping->syms = NULL;
4858 129041 : mapping->charlens = NULL;
4859 129041 : }
4860 :
4861 :
4862 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4863 :
4864 : void
4865 129041 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4866 : {
4867 129041 : gfc_interface_sym_mapping *sym;
4868 129041 : gfc_interface_sym_mapping *nextsym;
4869 129041 : gfc_charlen *cl;
4870 129041 : gfc_charlen *nextcl;
4871 :
4872 169233 : for (sym = mapping->syms; sym; sym = nextsym)
4873 : {
4874 40192 : nextsym = sym->next;
4875 40192 : sym->new_sym->n.sym->formal = NULL;
4876 40192 : gfc_free_symbol (sym->new_sym->n.sym);
4877 40192 : gfc_free_expr (sym->expr);
4878 40192 : free (sym->new_sym);
4879 40192 : free (sym);
4880 : }
4881 133610 : for (cl = mapping->charlens; cl; cl = nextcl)
4882 : {
4883 4569 : nextcl = cl->next;
4884 4569 : gfc_free_expr (cl->length);
4885 4569 : free (cl);
4886 : }
4887 129041 : }
4888 :
4889 :
4890 : /* Return a copy of gfc_charlen CL. Add the returned structure to
4891 : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4892 :
4893 : static gfc_charlen *
4894 4569 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4895 : gfc_charlen * cl)
4896 : {
4897 4569 : gfc_charlen *new_charlen;
4898 :
4899 4569 : new_charlen = gfc_get_charlen ();
4900 4569 : new_charlen->next = mapping->charlens;
4901 4569 : new_charlen->length = gfc_copy_expr (cl->length);
4902 :
4903 4569 : mapping->charlens = new_charlen;
4904 4569 : return new_charlen;
4905 : }
4906 :
4907 :
4908 : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4909 : array variable that can be used as the actual argument for dummy
4910 : argument SYM. Add any initialization code to BLOCK. PACKED is as
4911 : for gfc_get_nodesc_array_type and DATA points to the first element
4912 : in the passed array. */
4913 :
4914 : static tree
4915 8376 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4916 : gfc_packed packed, tree data, tree len)
4917 : {
4918 8376 : tree type;
4919 8376 : tree var;
4920 :
4921 8376 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4922 58 : type = gfc_get_character_type_len (sym->ts.kind, len);
4923 : else
4924 8318 : type = gfc_typenode_for_spec (&sym->ts);
4925 8376 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4926 8352 : !sym->attr.target && !sym->attr.pointer
4927 16728 : && !sym->attr.proc_pointer);
4928 :
4929 8376 : var = gfc_create_var (type, "ifm");
4930 8376 : gfc_add_modify (block, var, fold_convert (type, data));
4931 :
4932 8376 : return var;
4933 : }
4934 :
4935 :
4936 : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4937 : and offset of descriptorless array type TYPE given that it has the same
4938 : size as DESC. Add any set-up code to BLOCK. */
4939 :
4940 : static void
4941 8106 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4942 : {
4943 8106 : int n;
4944 8106 : tree dim;
4945 8106 : tree offset;
4946 8106 : tree tmp;
4947 :
4948 8106 : offset = gfc_index_zero_node;
4949 9182 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4950 : {
4951 1076 : dim = gfc_rank_cst[n];
4952 1076 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4953 1076 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4954 : {
4955 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
4956 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
4957 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
4958 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
4959 : }
4960 1075 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4961 : {
4962 1075 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4963 : gfc_array_index_type,
4964 : gfc_conv_descriptor_ubound_get (desc, dim),
4965 : gfc_conv_descriptor_lbound_get (desc, dim));
4966 3225 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4967 : gfc_array_index_type,
4968 1075 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4969 1075 : tmp = gfc_evaluate_now (tmp, block);
4970 1075 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4971 : }
4972 4304 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4973 1076 : GFC_TYPE_ARRAY_LBOUND (type, n),
4974 1076 : GFC_TYPE_ARRAY_STRIDE (type, n));
4975 1076 : offset = fold_build2_loc (input_location, MINUS_EXPR,
4976 : gfc_array_index_type, offset, tmp);
4977 : }
4978 8106 : offset = gfc_evaluate_now (offset, block);
4979 8106 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
4980 8106 : }
4981 :
4982 :
4983 : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4984 : in SE. The caller may still use se->expr and se->string_length after
4985 : calling this function. */
4986 :
4987 : void
4988 40192 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4989 : gfc_symbol * sym, gfc_se * se,
4990 : gfc_expr *expr)
4991 : {
4992 40192 : gfc_interface_sym_mapping *sm;
4993 40192 : tree desc;
4994 40192 : tree tmp;
4995 40192 : tree value;
4996 40192 : gfc_symbol *new_sym;
4997 40192 : gfc_symtree *root;
4998 40192 : gfc_symtree *new_symtree;
4999 :
5000 : /* Create a new symbol to represent the actual argument. */
5001 40192 : new_sym = gfc_new_symbol (sym->name, NULL);
5002 40192 : new_sym->ts = sym->ts;
5003 40192 : new_sym->as = gfc_copy_array_spec (sym->as);
5004 40192 : new_sym->attr.referenced = 1;
5005 40192 : new_sym->attr.dimension = sym->attr.dimension;
5006 40192 : new_sym->attr.contiguous = sym->attr.contiguous;
5007 40192 : new_sym->attr.codimension = sym->attr.codimension;
5008 40192 : new_sym->attr.pointer = sym->attr.pointer;
5009 40192 : new_sym->attr.allocatable = sym->attr.allocatable;
5010 40192 : new_sym->attr.flavor = sym->attr.flavor;
5011 40192 : new_sym->attr.function = sym->attr.function;
5012 :
5013 : /* Ensure that the interface is available and that
5014 : descriptors are passed for array actual arguments. */
5015 40192 : if (sym->attr.flavor == FL_PROCEDURE)
5016 : {
5017 36 : new_sym->formal = expr->symtree->n.sym->formal;
5018 36 : new_sym->attr.always_explicit
5019 36 : = expr->symtree->n.sym->attr.always_explicit;
5020 : }
5021 :
5022 : /* Create a fake symtree for it. */
5023 40192 : root = NULL;
5024 40192 : new_symtree = gfc_new_symtree (&root, sym->name);
5025 40192 : new_symtree->n.sym = new_sym;
5026 40192 : gcc_assert (new_symtree == root);
5027 :
5028 : /* Create a dummy->actual mapping. */
5029 40192 : sm = XCNEW (gfc_interface_sym_mapping);
5030 40192 : sm->next = mapping->syms;
5031 40192 : sm->old = sym;
5032 40192 : sm->new_sym = new_symtree;
5033 40192 : sm->expr = gfc_copy_expr (expr);
5034 40192 : mapping->syms = sm;
5035 :
5036 : /* Stabilize the argument's value. */
5037 40192 : if (!sym->attr.function && se)
5038 40094 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5039 :
5040 40192 : if (sym->ts.type == BT_CHARACTER)
5041 : {
5042 : /* Create a copy of the dummy argument's length. */
5043 2785 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
5044 2785 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
5045 :
5046 : /* If the length is specified as "*", record the length that
5047 : the caller is passing. We should use the callee's length
5048 : in all other cases. */
5049 2785 : if (!new_sym->ts.u.cl->length && se)
5050 : {
5051 2557 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5052 2557 : new_sym->ts.u.cl->backend_decl = se->string_length;
5053 : }
5054 : }
5055 :
5056 40178 : if (!se)
5057 62 : return;
5058 :
5059 : /* Use the passed value as-is if the argument is a function. */
5060 40130 : if (sym->attr.flavor == FL_PROCEDURE)
5061 36 : value = se->expr;
5062 :
5063 : /* If the argument is a pass-by-value scalar, use the value as is. */
5064 40094 : else if (!sym->attr.dimension && sym->attr.value)
5065 78 : value = se->expr;
5066 :
5067 : /* If the argument is either a string or a pointer to a string,
5068 : convert it to a boundless character type. */
5069 40016 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5070 : {
5071 1216 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5072 1216 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5073 1216 : tmp = build_pointer_type (tmp);
5074 1216 : if (sym->attr.pointer)
5075 126 : value = build_fold_indirect_ref_loc (input_location,
5076 : se->expr);
5077 : else
5078 1090 : value = se->expr;
5079 1216 : value = fold_convert (tmp, value);
5080 : }
5081 :
5082 : /* If the argument is a scalar, a pointer to an array or an allocatable,
5083 : dereference it. */
5084 38800 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5085 28927 : value = build_fold_indirect_ref_loc (input_location,
5086 : se->expr);
5087 :
5088 : /* For character(*), use the actual argument's descriptor. */
5089 9873 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5090 1497 : value = build_fold_indirect_ref_loc (input_location,
5091 : se->expr);
5092 :
5093 : /* If the argument is an array descriptor, use it to determine
5094 : information about the actual argument's shape. */
5095 8376 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5096 8376 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5097 : {
5098 : /* Get the actual argument's descriptor. */
5099 8106 : desc = build_fold_indirect_ref_loc (input_location,
5100 : se->expr);
5101 :
5102 : /* Create the replacement variable. */
5103 8106 : tmp = gfc_conv_descriptor_data_get (desc);
5104 8106 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5105 : PACKED_NO, tmp,
5106 : se->string_length);
5107 :
5108 : /* Use DESC to work out the upper bounds, strides and offset. */
5109 8106 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5110 : }
5111 : else
5112 : /* Otherwise we have a packed array. */
5113 270 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5114 : PACKED_FULL, se->expr,
5115 : se->string_length);
5116 :
5117 40130 : new_sym->backend_decl = value;
5118 : }
5119 :
5120 :
5121 : /* Called once all dummy argument mappings have been added to MAPPING,
5122 : but before the mapping is used to evaluate expressions. Pre-evaluate
5123 : the length of each argument, adding any initialization code to PRE and
5124 : any finalization code to POST. */
5125 :
5126 : static void
5127 129004 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5128 : stmtblock_t * pre, stmtblock_t * post)
5129 : {
5130 129004 : gfc_interface_sym_mapping *sym;
5131 129004 : gfc_expr *expr;
5132 129004 : gfc_se se;
5133 :
5134 169134 : for (sym = mapping->syms; sym; sym = sym->next)
5135 40130 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5136 2771 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5137 : {
5138 214 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5139 214 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5140 214 : gfc_init_se (&se, NULL);
5141 214 : gfc_conv_expr (&se, expr);
5142 214 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5143 214 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5144 214 : gfc_add_block_to_block (pre, &se.pre);
5145 214 : gfc_add_block_to_block (post, &se.post);
5146 :
5147 214 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5148 : }
5149 129004 : }
5150 :
5151 :
5152 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5153 : constructor C. */
5154 :
5155 : static void
5156 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5157 : gfc_constructor_base base)
5158 : {
5159 47 : gfc_constructor *c;
5160 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5161 : {
5162 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5163 381 : if (c->iterator)
5164 : {
5165 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5166 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5167 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5168 : }
5169 : }
5170 47 : }
5171 :
5172 :
5173 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5174 : reference REF. */
5175 :
5176 : static void
5177 12459 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5178 : gfc_ref * ref)
5179 : {
5180 12459 : int n;
5181 :
5182 13902 : for (; ref; ref = ref->next)
5183 1443 : switch (ref->type)
5184 : {
5185 : case REF_ARRAY:
5186 2873 : for (n = 0; n < ref->u.ar.dimen; n++)
5187 : {
5188 1632 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5189 1632 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5190 1632 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5191 : }
5192 : break;
5193 :
5194 : case REF_COMPONENT:
5195 : case REF_INQUIRY:
5196 : break;
5197 :
5198 43 : case REF_SUBSTRING:
5199 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5200 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5201 43 : break;
5202 : }
5203 12459 : }
5204 :
5205 :
5206 : /* Convert intrinsic function calls into result expressions. */
5207 :
5208 : static bool
5209 2184 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5210 : {
5211 2184 : gfc_symbol *sym;
5212 2184 : gfc_expr *new_expr;
5213 2184 : gfc_expr *arg1;
5214 2184 : gfc_expr *arg2;
5215 2184 : int d, dup;
5216 :
5217 2184 : arg1 = expr->value.function.actual->expr;
5218 2184 : if (expr->value.function.actual->next)
5219 2063 : arg2 = expr->value.function.actual->next->expr;
5220 : else
5221 : arg2 = NULL;
5222 :
5223 2184 : sym = arg1->symtree->n.sym;
5224 :
5225 2184 : if (sym->attr.dummy)
5226 : return false;
5227 :
5228 2160 : new_expr = NULL;
5229 :
5230 2160 : switch (expr->value.function.isym->id)
5231 : {
5232 929 : case GFC_ISYM_LEN:
5233 : /* TODO figure out why this condition is necessary. */
5234 929 : if (sym->attr.function
5235 43 : && (arg1->ts.u.cl->length == NULL
5236 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5237 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5238 : return false;
5239 :
5240 886 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5241 886 : break;
5242 :
5243 228 : case GFC_ISYM_LEN_TRIM:
5244 228 : new_expr = gfc_copy_expr (arg1);
5245 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5246 :
5247 228 : if (!new_expr)
5248 : return false;
5249 :
5250 228 : gfc_replace_expr (arg1, new_expr);
5251 228 : return true;
5252 :
5253 588 : case GFC_ISYM_SIZE:
5254 588 : if (!sym->as || sym->as->rank == 0)
5255 : return false;
5256 :
5257 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5258 : {
5259 360 : dup = mpz_get_si (arg2->value.integer);
5260 360 : d = dup - 1;
5261 : }
5262 : else
5263 : {
5264 530 : dup = sym->as->rank;
5265 530 : d = 0;
5266 : }
5267 :
5268 542 : for (; d < dup; d++)
5269 : {
5270 530 : gfc_expr *tmp;
5271 :
5272 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5273 : {
5274 518 : gfc_free_expr (new_expr);
5275 518 : return false;
5276 : }
5277 :
5278 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5279 : gfc_get_int_expr (gfc_default_integer_kind,
5280 : NULL, 1));
5281 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5282 12 : if (new_expr)
5283 0 : new_expr = gfc_multiply (new_expr, tmp);
5284 : else
5285 : new_expr = tmp;
5286 : }
5287 : break;
5288 :
5289 44 : case GFC_ISYM_LBOUND:
5290 44 : case GFC_ISYM_UBOUND:
5291 : /* TODO These implementations of lbound and ubound do not limit if
5292 : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5293 :
5294 44 : if (!sym->as || sym->as->rank == 0)
5295 : return false;
5296 :
5297 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5298 38 : d = mpz_get_si (arg2->value.integer) - 1;
5299 : else
5300 : return false;
5301 :
5302 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5303 : {
5304 23 : if (sym->as->lower[d])
5305 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5306 : }
5307 : else
5308 : {
5309 15 : if (sym->as->upper[d])
5310 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5311 : }
5312 : break;
5313 :
5314 : default:
5315 : break;
5316 : }
5317 :
5318 1307 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5319 1307 : if (!new_expr)
5320 : return false;
5321 :
5322 113 : gfc_replace_expr (expr, new_expr);
5323 113 : return true;
5324 : }
5325 :
5326 :
5327 : static void
5328 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5329 : gfc_interface_mapping * mapping)
5330 : {
5331 24 : gfc_formal_arglist *f;
5332 24 : gfc_actual_arglist *actual;
5333 :
5334 24 : actual = expr->value.function.actual;
5335 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5336 :
5337 72 : for (; f && actual; f = f->next, actual = actual->next)
5338 : {
5339 24 : if (!actual->expr)
5340 0 : continue;
5341 :
5342 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5343 : }
5344 :
5345 24 : if (map_expr->symtree->n.sym->attr.dimension)
5346 : {
5347 6 : int d;
5348 6 : gfc_array_spec *as;
5349 :
5350 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5351 :
5352 18 : for (d = 0; d < as->rank; d++)
5353 : {
5354 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5355 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5356 : }
5357 :
5358 6 : expr->value.function.esym->as = as;
5359 : }
5360 :
5361 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5362 : {
5363 0 : expr->value.function.esym->ts.u.cl->length
5364 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5365 :
5366 0 : gfc_apply_interface_mapping_to_expr (mapping,
5367 0 : expr->value.function.esym->ts.u.cl->length);
5368 : }
5369 24 : }
5370 :
5371 :
5372 : /* EXPR is a copy of an expression that appeared in the interface
5373 : associated with MAPPING. Walk it recursively looking for references to
5374 : dummy arguments that MAPPING maps to actual arguments. Replace each such
5375 : reference with a reference to the associated actual argument. */
5376 :
5377 : static void
5378 20884 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5379 : gfc_expr * expr)
5380 : {
5381 22437 : gfc_interface_sym_mapping *sym;
5382 22437 : gfc_actual_arglist *actual;
5383 :
5384 22437 : if (!expr)
5385 : return;
5386 :
5387 : /* Copying an expression does not copy its length, so do that here. */
5388 12459 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5389 : {
5390 1784 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5391 1784 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5392 : }
5393 :
5394 : /* Apply the mapping to any references. */
5395 12459 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5396 :
5397 : /* ...and to the expression's symbol, if it has one. */
5398 : /* TODO Find out why the condition on expr->symtree had to be moved into
5399 : the loop rather than being outside it, as originally. */
5400 29666 : for (sym = mapping->syms; sym; sym = sym->next)
5401 17207 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5402 : {
5403 3346 : if (sym->new_sym->n.sym->backend_decl)
5404 3302 : expr->symtree = sym->new_sym;
5405 44 : else if (sym->expr)
5406 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5407 : }
5408 :
5409 : /* ...and to subexpressions in expr->value. */
5410 12459 : switch (expr->expr_type)
5411 : {
5412 : case EXPR_VARIABLE:
5413 : case EXPR_CONSTANT:
5414 : case EXPR_NULL:
5415 : case EXPR_SUBSTRING:
5416 : break;
5417 :
5418 1553 : case EXPR_OP:
5419 1553 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5420 1553 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5421 1553 : break;
5422 :
5423 0 : case EXPR_CONDITIONAL:
5424 0 : gfc_apply_interface_mapping_to_expr (mapping,
5425 0 : expr->value.conditional.true_expr);
5426 0 : gfc_apply_interface_mapping_to_expr (mapping,
5427 0 : expr->value.conditional.false_expr);
5428 0 : break;
5429 :
5430 2927 : case EXPR_FUNCTION:
5431 9388 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5432 6461 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5433 :
5434 2927 : if (expr->value.function.esym == NULL
5435 2614 : && expr->value.function.isym != NULL
5436 2602 : && expr->value.function.actual
5437 2601 : && expr->value.function.actual->expr
5438 2601 : && expr->value.function.actual->expr->symtree
5439 5111 : && gfc_map_intrinsic_function (expr, mapping))
5440 : break;
5441 :
5442 6094 : for (sym = mapping->syms; sym; sym = sym->next)
5443 3508 : if (sym->old == expr->value.function.esym)
5444 : {
5445 24 : expr->value.function.esym = sym->new_sym->n.sym;
5446 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5447 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5448 : }
5449 : break;
5450 :
5451 47 : case EXPR_ARRAY:
5452 47 : case EXPR_STRUCTURE:
5453 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5454 47 : break;
5455 :
5456 0 : case EXPR_COMPCALL:
5457 0 : case EXPR_PPC:
5458 0 : case EXPR_UNKNOWN:
5459 0 : gcc_unreachable ();
5460 : break;
5461 : }
5462 :
5463 : return;
5464 : }
5465 :
5466 :
5467 : /* Evaluate interface expression EXPR using MAPPING. Store the result
5468 : in SE. */
5469 :
5470 : void
5471 3944 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5472 : gfc_se * se, gfc_expr * expr)
5473 : {
5474 3944 : expr = gfc_copy_expr (expr);
5475 3944 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5476 3944 : gfc_conv_expr (se, expr);
5477 3944 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5478 3944 : gfc_free_expr (expr);
5479 3944 : }
5480 :
5481 :
5482 : /* Returns a reference to a temporary array into which a component of
5483 : an actual argument derived type array is copied and then returned
5484 : after the function call. */
5485 : void
5486 2408 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5487 : sym_intent intent, bool formal_ptr,
5488 : const gfc_symbol *fsym, const char *proc_name,
5489 : gfc_symbol *sym, bool check_contiguous)
5490 : {
5491 2408 : gfc_se lse;
5492 2408 : gfc_se rse;
5493 2408 : gfc_ss *lss;
5494 2408 : gfc_ss *rss;
5495 2408 : gfc_loopinfo loop;
5496 2408 : gfc_loopinfo loop2;
5497 2408 : gfc_array_info *info;
5498 2408 : tree offset;
5499 2408 : tree tmp_index;
5500 2408 : tree tmp;
5501 2408 : tree base_type;
5502 2408 : tree size;
5503 2408 : stmtblock_t body;
5504 2408 : int n;
5505 2408 : int dimen;
5506 2408 : gfc_se work_se;
5507 2408 : gfc_se *parmse;
5508 2408 : bool pass_optional;
5509 2408 : bool readonly;
5510 :
5511 2408 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5512 :
5513 2397 : if (pass_optional || check_contiguous)
5514 : {
5515 1359 : gfc_init_se (&work_se, NULL);
5516 1359 : parmse = &work_se;
5517 : }
5518 : else
5519 : parmse = se;
5520 :
5521 2408 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5522 : {
5523 : /* We will create a temporary array, so let us warn. */
5524 868 : char * msg;
5525 :
5526 868 : if (fsym && proc_name)
5527 868 : msg = xasprintf ("An array temporary was created for argument "
5528 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5529 : else
5530 0 : msg = xasprintf ("An array temporary was created");
5531 :
5532 868 : tmp = build_int_cst (logical_type_node, 1);
5533 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5534 : &expr->where, msg);
5535 868 : free (msg);
5536 : }
5537 :
5538 2408 : gfc_init_se (&lse, NULL);
5539 2408 : gfc_init_se (&rse, NULL);
5540 :
5541 : /* Walk the argument expression. */
5542 2408 : rss = gfc_walk_expr (expr);
5543 :
5544 2408 : gcc_assert (rss != gfc_ss_terminator);
5545 :
5546 : /* Initialize the scalarizer. */
5547 2408 : gfc_init_loopinfo (&loop);
5548 2408 : gfc_add_ss_to_loop (&loop, rss);
5549 :
5550 : /* Calculate the bounds of the scalarization. */
5551 2408 : gfc_conv_ss_startstride (&loop);
5552 :
5553 : /* Build an ss for the temporary. */
5554 2408 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5555 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5556 :
5557 2408 : base_type = gfc_typenode_for_spec (&expr->ts);
5558 2408 : if (GFC_ARRAY_TYPE_P (base_type)
5559 2408 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5560 0 : base_type = gfc_get_element_type (base_type);
5561 :
5562 2408 : if (expr->ts.type == BT_CLASS)
5563 121 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5564 :
5565 3572 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5566 1164 : ? expr->ts.u.cl->backend_decl
5567 : : NULL),
5568 : loop.dimen);
5569 :
5570 2408 : parmse->string_length = loop.temp_ss->info->string_length;
5571 :
5572 : /* Associate the SS with the loop. */
5573 2408 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5574 :
5575 : /* Setup the scalarizing loops. */
5576 2408 : gfc_conv_loop_setup (&loop, &expr->where);
5577 :
5578 : /* Pass the temporary descriptor back to the caller. */
5579 2408 : info = &loop.temp_ss->info->data.array;
5580 2408 : parmse->expr = info->descriptor;
5581 :
5582 : /* Setup the gfc_se structures. */
5583 2408 : gfc_copy_loopinfo_to_se (&lse, &loop);
5584 2408 : gfc_copy_loopinfo_to_se (&rse, &loop);
5585 :
5586 2408 : rse.ss = rss;
5587 2408 : lse.ss = loop.temp_ss;
5588 2408 : gfc_mark_ss_chain_used (rss, 1);
5589 2408 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5590 :
5591 : /* Start the scalarized loop body. */
5592 2408 : gfc_start_scalarized_body (&loop, &body);
5593 :
5594 : /* Translate the expression. */
5595 2408 : gfc_conv_expr (&rse, expr);
5596 :
5597 2408 : gfc_conv_tmp_array_ref (&lse);
5598 :
5599 2408 : if (intent != INTENT_OUT)
5600 : {
5601 2370 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5602 2370 : gfc_add_expr_to_block (&body, tmp);
5603 2370 : gcc_assert (rse.ss == gfc_ss_terminator);
5604 2370 : gfc_trans_scalarizing_loops (&loop, &body);
5605 : }
5606 : else
5607 : {
5608 : /* Make sure that the temporary declaration survives by merging
5609 : all the loop declarations into the current context. */
5610 85 : for (n = 0; n < loop.dimen; n++)
5611 : {
5612 47 : gfc_merge_block_scope (&body);
5613 47 : body = loop.code[loop.order[n]];
5614 : }
5615 38 : gfc_merge_block_scope (&body);
5616 : }
5617 :
5618 : /* Add the post block after the second loop, so that any
5619 : freeing of allocated memory is done at the right time. */
5620 2408 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5621 :
5622 : /**********Copy the temporary back again.*********/
5623 :
5624 2408 : gfc_init_se (&lse, NULL);
5625 2408 : gfc_init_se (&rse, NULL);
5626 :
5627 : /* Walk the argument expression. */
5628 2408 : lss = gfc_walk_expr (expr);
5629 2408 : rse.ss = loop.temp_ss;
5630 2408 : lse.ss = lss;
5631 :
5632 : /* Initialize the scalarizer. */
5633 2408 : gfc_init_loopinfo (&loop2);
5634 2408 : gfc_add_ss_to_loop (&loop2, lss);
5635 :
5636 2408 : dimen = rse.ss->dimen;
5637 :
5638 : /* Skip the write-out loop for this case. */
5639 2408 : if (gfc_is_class_array_function (expr))
5640 13 : goto class_array_fcn;
5641 :
5642 : /* Calculate the bounds of the scalarization. */
5643 2395 : gfc_conv_ss_startstride (&loop2);
5644 :
5645 : /* Setup the scalarizing loops. */
5646 2395 : gfc_conv_loop_setup (&loop2, &expr->where);
5647 :
5648 2395 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5649 2395 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5650 :
5651 2395 : gfc_mark_ss_chain_used (lss, 1);
5652 2395 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5653 :
5654 : /* Declare the variable to hold the temporary offset and start the
5655 : scalarized loop body. */
5656 2395 : offset = gfc_create_var (gfc_array_index_type, NULL);
5657 2395 : gfc_start_scalarized_body (&loop2, &body);
5658 :
5659 : /* Build the offsets for the temporary from the loop variables. The
5660 : temporary array has lbounds of zero and strides of one in all
5661 : dimensions, so this is very simple. The offset is only computed
5662 : outside the innermost loop, so the overall transfer could be
5663 : optimized further. */
5664 2395 : info = &rse.ss->info->data.array;
5665 :
5666 2395 : tmp_index = gfc_index_zero_node;
5667 3745 : for (n = dimen - 1; n > 0; n--)
5668 : {
5669 1350 : tree tmp_str;
5670 1350 : tmp = rse.loop->loopvar[n];
5671 1350 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5672 : tmp, rse.loop->from[n]);
5673 1350 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5674 : tmp, tmp_index);
5675 :
5676 2700 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5677 : gfc_array_index_type,
5678 1350 : rse.loop->to[n-1], rse.loop->from[n-1]);
5679 1350 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5680 : gfc_array_index_type,
5681 : tmp_str, gfc_index_one_node);
5682 :
5683 1350 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5684 : gfc_array_index_type, tmp, tmp_str);
5685 : }
5686 :
5687 4790 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5688 : gfc_array_index_type,
5689 2395 : tmp_index, rse.loop->from[0]);
5690 2395 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5691 :
5692 4790 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5693 : gfc_array_index_type,
5694 2395 : rse.loop->loopvar[0], offset);
5695 :
5696 : /* Now use the offset for the reference. */
5697 2395 : tmp = build_fold_indirect_ref_loc (input_location,
5698 : info->data);
5699 2395 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5700 :
5701 2395 : if (expr->ts.type == BT_CHARACTER)
5702 1164 : rse.string_length = expr->ts.u.cl->backend_decl;
5703 :
5704 2395 : gfc_conv_expr (&lse, expr);
5705 :
5706 2395 : gcc_assert (lse.ss == gfc_ss_terminator);
5707 :
5708 2395 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
5709 2395 : gfc_add_expr_to_block (&body, tmp);
5710 :
5711 : /* Generate the copying loops. */
5712 2395 : gfc_trans_scalarizing_loops (&loop2, &body);
5713 :
5714 : /* Wrap the whole thing up by adding the second loop to the post-block
5715 : and following it by the post-block of the first loop. In this way,
5716 : if the temporary needs freeing, it is done after use!
5717 : If input expr is read-only, e.g. a PARAMETER array, copying back
5718 : modified values is undefined behavior. */
5719 4790 : readonly = (expr->expr_type == EXPR_VARIABLE
5720 2341 : && expr->symtree
5721 4736 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5722 :
5723 2395 : if ((intent != INTENT_IN) && !readonly)
5724 : {
5725 1166 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5726 1166 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5727 : }
5728 :
5729 1229 : class_array_fcn:
5730 :
5731 2408 : gfc_add_block_to_block (&parmse->post, &loop.post);
5732 :
5733 2408 : gfc_cleanup_loop (&loop);
5734 2408 : gfc_cleanup_loop (&loop2);
5735 :
5736 : /* Pass the string length to the argument expression. */
5737 2408 : if (expr->ts.type == BT_CHARACTER)
5738 1164 : parmse->string_length = expr->ts.u.cl->backend_decl;
5739 :
5740 : /* Determine the offset for pointer formal arguments and set the
5741 : lbounds to one. */
5742 2408 : if (formal_ptr)
5743 : {
5744 18 : size = gfc_index_one_node;
5745 18 : offset = gfc_index_zero_node;
5746 36 : for (n = 0; n < dimen; n++)
5747 : {
5748 18 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5749 : gfc_rank_cst[n]);
5750 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5751 : gfc_array_index_type, tmp,
5752 : gfc_index_one_node);
5753 18 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5754 : parmse->expr,
5755 : gfc_rank_cst[n],
5756 : tmp);
5757 18 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5758 : parmse->expr,
5759 : gfc_rank_cst[n],
5760 : gfc_index_one_node);
5761 18 : size = gfc_evaluate_now (size, &parmse->pre);
5762 18 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5763 : gfc_array_index_type,
5764 : offset, size);
5765 18 : offset = gfc_evaluate_now (offset, &parmse->pre);
5766 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5767 : gfc_array_index_type,
5768 18 : rse.loop->to[n], rse.loop->from[n]);
5769 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5770 : gfc_array_index_type,
5771 : tmp, gfc_index_one_node);
5772 18 : size = fold_build2_loc (input_location, MULT_EXPR,
5773 : gfc_array_index_type, size, tmp);
5774 : }
5775 :
5776 18 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5777 : offset);
5778 : }
5779 :
5780 : /* We want either the address for the data or the address of the descriptor,
5781 : depending on the mode of passing array arguments. */
5782 2408 : if (g77)
5783 437 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5784 : else
5785 1971 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5786 :
5787 : /* Basically make this into
5788 :
5789 : if (present)
5790 : {
5791 : if (contiguous)
5792 : {
5793 : pointer = a;
5794 : }
5795 : else
5796 : {
5797 : parmse->pre();
5798 : pointer = parmse->expr;
5799 : }
5800 : }
5801 : else
5802 : pointer = NULL;
5803 :
5804 : foo (pointer);
5805 : if (present && !contiguous)
5806 : se->post();
5807 :
5808 : */
5809 :
5810 2408 : if (pass_optional || check_contiguous)
5811 : {
5812 1359 : tree type;
5813 1359 : stmtblock_t else_block;
5814 1359 : tree pre_stmts, post_stmts;
5815 1359 : tree pointer;
5816 1359 : tree else_stmt;
5817 1359 : tree present_var = NULL_TREE;
5818 1359 : tree cont_var = NULL_TREE;
5819 1359 : tree post_cond;
5820 :
5821 1359 : type = TREE_TYPE (parmse->expr);
5822 1359 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5823 1027 : type = TREE_TYPE (type);
5824 1359 : pointer = gfc_create_var (type, "arg_ptr");
5825 :
5826 1359 : if (check_contiguous)
5827 : {
5828 1359 : gfc_se cont_se, array_se;
5829 1359 : stmtblock_t if_block, else_block;
5830 1359 : tree if_stmt, else_stmt;
5831 1359 : mpz_t size;
5832 1359 : bool size_set;
5833 :
5834 1359 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5835 :
5836 : /* If the size is known to be one at compile-time, set
5837 : cont_var to true unconditionally. This may look
5838 : inelegant, but we're only doing this during
5839 : optimization, so the statements will be optimized away,
5840 : and this saves complexity here. */
5841 :
5842 1359 : size_set = gfc_array_size (expr, &size);
5843 1359 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5844 : {
5845 6 : gfc_add_modify (&se->pre, cont_var,
5846 : build_one_cst (boolean_type_node));
5847 : }
5848 : else
5849 : {
5850 : /* cont_var = is_contiguous (expr); . */
5851 1353 : gfc_init_se (&cont_se, parmse);
5852 1353 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5853 1353 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5854 1353 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5855 1353 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5856 : }
5857 :
5858 1359 : if (size_set)
5859 1145 : mpz_clear (size);
5860 :
5861 : /* arrayse->expr = descriptor of a. */
5862 1359 : gfc_init_se (&array_se, se);
5863 1359 : gfc_conv_expr_descriptor (&array_se, expr);
5864 1359 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5865 1359 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5866 :
5867 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5868 1359 : gfc_init_block (&if_block);
5869 1359 : if (GFC_DESCRIPTOR_TYPE_P (type))
5870 1027 : gfc_add_modify (&if_block, pointer, array_se.expr);
5871 : else
5872 : {
5873 332 : tmp = gfc_conv_array_data (array_se.expr);
5874 332 : tmp = fold_convert (type, tmp);
5875 332 : gfc_add_modify (&if_block, pointer, tmp);
5876 : }
5877 1359 : if_stmt = gfc_finish_block (&if_block);
5878 :
5879 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5880 1359 : gfc_init_block (&else_block);
5881 1359 : gfc_add_block_to_block (&else_block, &parmse->pre);
5882 1691 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5883 1359 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5884 : : parmse->expr);
5885 1359 : gfc_add_modify (&else_block, pointer, tmp);
5886 1359 : else_stmt = gfc_finish_block (&else_block);
5887 :
5888 : /* And put the above into an if statement. */
5889 1359 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5890 : gfc_likely (cont_var,
5891 : PRED_FORTRAN_CONTIGUOUS),
5892 : if_stmt, else_stmt);
5893 : }
5894 : else
5895 : {
5896 : /* pointer = pramse->expr; . */
5897 0 : gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5898 0 : pre_stmts = gfc_finish_block (&parmse->pre);
5899 : }
5900 :
5901 1359 : if (pass_optional)
5902 : {
5903 11 : present_var = gfc_create_var (boolean_type_node, "present");
5904 :
5905 : /* present_var = present(sym); . */
5906 11 : tmp = gfc_conv_expr_present (sym);
5907 11 : tmp = fold_convert (boolean_type_node, tmp);
5908 11 : gfc_add_modify (&se->pre, present_var, tmp);
5909 :
5910 : /* else_stmt = { pointer = NULL; } . */
5911 11 : gfc_init_block (&else_block);
5912 11 : if (GFC_DESCRIPTOR_TYPE_P (type))
5913 0 : gfc_conv_descriptor_data_set (&else_block, pointer,
5914 : null_pointer_node);
5915 : else
5916 11 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5917 11 : else_stmt = gfc_finish_block (&else_block);
5918 :
5919 11 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5920 : gfc_likely (present_var,
5921 : PRED_FORTRAN_ABSENT_DUMMY),
5922 : pre_stmts, else_stmt);
5923 11 : gfc_add_expr_to_block (&se->pre, tmp);
5924 : }
5925 : else
5926 1348 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5927 :
5928 1359 : post_stmts = gfc_finish_block (&parmse->post);
5929 :
5930 : /* Put together the post stuff, plus the optional
5931 : deallocation. */
5932 1359 : if (check_contiguous)
5933 : {
5934 : /* !cont_var. */
5935 1359 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5936 : cont_var,
5937 : build_zero_cst (boolean_type_node));
5938 1359 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5939 :
5940 1359 : if (pass_optional)
5941 : {
5942 11 : tree present_likely = gfc_likely (present_var,
5943 : PRED_FORTRAN_ABSENT_DUMMY);
5944 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5945 : boolean_type_node, present_likely,
5946 : tmp);
5947 : }
5948 : else
5949 : post_cond = tmp;
5950 : }
5951 : else
5952 : {
5953 0 : gcc_assert (pass_optional);
5954 : post_cond = present_var;
5955 : }
5956 :
5957 1359 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5958 : post_stmts, build_empty_stmt (input_location));
5959 1359 : gfc_add_expr_to_block (&se->post, tmp);
5960 1359 : if (GFC_DESCRIPTOR_TYPE_P (type))
5961 : {
5962 1027 : type = TREE_TYPE (parmse->expr);
5963 1027 : if (POINTER_TYPE_P (type))
5964 : {
5965 1027 : pointer = gfc_build_addr_expr (type, pointer);
5966 1027 : if (pass_optional)
5967 : {
5968 0 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5969 0 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
5970 : tmp, pointer,
5971 : fold_convert (type,
5972 : null_pointer_node));
5973 : }
5974 : }
5975 : else
5976 0 : gcc_assert (!pass_optional);
5977 : }
5978 1359 : se->expr = pointer;
5979 : }
5980 :
5981 2408 : return;
5982 : }
5983 :
5984 :
5985 : /* Generate the code for argument list functions. */
5986 :
5987 : static void
5988 5822 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5989 : {
5990 : /* Pass by value for g77 %VAL(arg), pass the address
5991 : indirectly for %LOC, else by reference. Thus %REF
5992 : is a "do-nothing" and %LOC is the same as an F95
5993 : pointer. */
5994 5822 : if (strcmp (name, "%VAL") == 0)
5995 5810 : gfc_conv_expr (se, expr);
5996 12 : else if (strcmp (name, "%LOC") == 0)
5997 : {
5998 6 : gfc_conv_expr_reference (se, expr);
5999 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
6000 : }
6001 6 : else if (strcmp (name, "%REF") == 0)
6002 6 : gfc_conv_expr_reference (se, expr);
6003 : else
6004 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
6005 5822 : }
6006 :
6007 :
6008 : /* This function tells whether the middle-end representation of the expression
6009 : E given as input may point to data otherwise accessible through a variable
6010 : (sub-)reference.
6011 : It is assumed that the only expressions that may alias are variables,
6012 : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
6013 : may alias.
6014 : This function is used to decide whether freeing an expression's allocatable
6015 : components is safe or should be avoided.
6016 :
6017 : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
6018 : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
6019 : is necessary because for array constructors, aliasing depends on how
6020 : the array is used:
6021 : - If E is an array constructor used as argument to an elemental procedure,
6022 : the array, which is generated through shallow copy by the scalarizer,
6023 : is used directly and can alias the expressions it was copied from.
6024 : - If E is an array constructor used as argument to a non-elemental
6025 : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
6026 : the array as in the previous case, but then that array is used
6027 : to initialize a new descriptor through deep copy. There is no alias
6028 : possible in that case.
6029 : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
6030 : above. */
6031 :
6032 : static bool
6033 7557 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6034 : {
6035 7557 : gfc_constructor *c;
6036 :
6037 7557 : if (e->expr_type == EXPR_VARIABLE)
6038 : return true;
6039 544 : else if (e->expr_type == EXPR_FUNCTION)
6040 : {
6041 161 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
6042 :
6043 161 : if (proc_ifc->result != NULL
6044 161 : && ((proc_ifc->result->ts.type == BT_CLASS
6045 25 : && proc_ifc->result->ts.u.derived->attr.is_class
6046 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
6047 161 : || proc_ifc->result->attr.pointer))
6048 : return true;
6049 : else
6050 : return false;
6051 : }
6052 383 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6053 : return false;
6054 :
6055 79 : for (c = gfc_constructor_first (e->value.constructor);
6056 233 : c; c = gfc_constructor_next (c))
6057 189 : if (c->expr
6058 189 : && expr_may_alias_variables (c->expr, array_may_alias))
6059 : return true;
6060 :
6061 : return false;
6062 : }
6063 :
6064 :
6065 : /* A helper function to set the dtype for unallocated or unassociated
6066 : entities. */
6067 :
6068 : static void
6069 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6070 : {
6071 891 : tree tmp;
6072 891 : tree desc;
6073 891 : tree cond;
6074 891 : tree type;
6075 891 : stmtblock_t block;
6076 :
6077 : /* TODO Figure out how to handle optional dummies. */
6078 891 : if (e && e->expr_type == EXPR_VARIABLE
6079 807 : && e->symtree->n.sym->attr.optional)
6080 108 : return;
6081 :
6082 819 : desc = parmse->expr;
6083 819 : if (desc == NULL_TREE)
6084 : return;
6085 :
6086 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6087 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6088 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6089 192 : desc = gfc_class_data_get (desc);
6090 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6091 : return;
6092 :
6093 783 : gfc_init_block (&block);
6094 783 : tmp = gfc_conv_descriptor_data_get (desc);
6095 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6096 : logical_type_node, tmp,
6097 783 : build_int_cst (TREE_TYPE (tmp), 0));
6098 783 : tmp = gfc_conv_descriptor_dtype (desc);
6099 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6100 1566 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6101 783 : TREE_TYPE (tmp), tmp,
6102 : gfc_get_dtype_rank_type (e->rank, type));
6103 783 : gfc_add_expr_to_block (&block, tmp);
6104 783 : cond = build3_v (COND_EXPR, cond,
6105 : gfc_finish_block (&block),
6106 : build_empty_stmt (input_location));
6107 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6108 : }
6109 :
6110 :
6111 :
6112 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6113 : ISO_Fortran_binding array descriptors. */
6114 :
6115 : static void
6116 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6117 : {
6118 6537 : stmtblock_t block, block2;
6119 6537 : tree cfi, gfc, tmp, tmp2;
6120 6537 : tree present = NULL;
6121 6537 : tree gfc_strlen = NULL;
6122 6537 : tree rank;
6123 6537 : gfc_se se;
6124 :
6125 6537 : if (fsym->attr.optional
6126 1094 : && e->expr_type == EXPR_VARIABLE
6127 1094 : && e->symtree->n.sym->attr.optional)
6128 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6129 :
6130 6537 : gfc_init_block (&block);
6131 :
6132 : /* Convert original argument to a tree. */
6133 6537 : gfc_init_se (&se, NULL);
6134 6537 : if (e->rank == 0)
6135 : {
6136 687 : se.want_pointer = 1;
6137 687 : gfc_conv_expr (&se, e);
6138 687 : gfc = se.expr;
6139 : }
6140 : else
6141 : {
6142 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6143 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6144 : length assumed-length/assumed-size CHARACTER array. This only
6145 : applies if the actual argument is a "variable"; if it's some
6146 : non-lvalue expression, we are going to evaluate it to a
6147 : temporary below anyway. */
6148 5850 : se.force_no_tmp = 1;
6149 5850 : if ((fsym->attr.contiguous
6150 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6151 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6152 937 : || fsym->as->type == AS_EXPLICIT)))
6153 2023 : && !gfc_is_simply_contiguous (e, false, true)
6154 6883 : && gfc_expr_is_variable (e))
6155 : {
6156 1027 : bool optional = fsym->attr.optional;
6157 1027 : fsym->attr.optional = 0;
6158 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6159 1027 : fsym->attr.pointer, fsym,
6160 1027 : fsym->ns->proc_name->name, NULL,
6161 : /* check_contiguous= */ true);
6162 1027 : fsym->attr.optional = optional;
6163 : }
6164 : else
6165 4823 : gfc_conv_expr_descriptor (&se, e);
6166 5850 : gfc = se.expr;
6167 : /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
6168 : elem_len = sizeof(dt) and base_addr = dt(lb) instead.
6169 : gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
6170 : While sm is fine as it uses span*stride and not elem_len. */
6171 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6172 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6173 4823 : else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
6174 12 : gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
6175 : }
6176 6537 : if (e->ts.type == BT_CHARACTER)
6177 : {
6178 3409 : if (se.string_length)
6179 : gfc_strlen = se.string_length;
6180 883 : else if (e->ts.u.cl->backend_decl)
6181 : gfc_strlen = e->ts.u.cl->backend_decl;
6182 : else
6183 0 : gcc_unreachable ();
6184 : }
6185 6537 : gfc_add_block_to_block (&block, &se.pre);
6186 :
6187 : /* Create array descriptor and set version, rank, attribute, type. */
6188 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6189 : ? GFC_MAX_DIMENSIONS : e->rank,
6190 : false), "cfi");
6191 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6192 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6193 : {
6194 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6195 2338 : tmp = build_pointer_type (tmp);
6196 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6197 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6198 : }
6199 : else
6200 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6201 :
6202 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6203 6537 : gfc_add_modify (&block, tmp,
6204 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6205 6537 : if (e->rank < 0)
6206 305 : rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
6207 : else
6208 6232 : rank = build_int_cst (signed_char_type_node, e->rank);
6209 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6210 6537 : gfc_add_modify (&block, tmp, rank);
6211 6537 : int itype = CFI_type_other;
6212 6537 : if (e->ts.f90_type == BT_VOID)
6213 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6214 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6215 : else
6216 : {
6217 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6218 1 : e->ts = fsym->ts;
6219 6441 : switch (e->ts.type)
6220 : {
6221 2296 : case BT_INTEGER:
6222 2296 : case BT_LOGICAL:
6223 2296 : case BT_REAL:
6224 2296 : case BT_COMPLEX:
6225 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6226 2296 : break;
6227 3410 : case BT_CHARACTER:
6228 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6229 3410 : break;
6230 : case BT_DERIVED:
6231 6537 : itype = CFI_type_struct;
6232 : break;
6233 0 : case BT_VOID:
6234 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6235 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6236 : break;
6237 : case BT_ASSUMED:
6238 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6239 : break;
6240 1 : case BT_CLASS:
6241 1 : if (fsym->ts.type == BT_ASSUMED)
6242 : {
6243 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6244 : // type specifier is assumed-type and is an unlimited polymorphic
6245 : // entity." The actual argument _data component is passed.
6246 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6247 : break;
6248 : }
6249 : else
6250 0 : gcc_unreachable ();
6251 :
6252 0 : case BT_UNSIGNED:
6253 0 : gfc_internal_error ("Unsigned not yet implemented");
6254 :
6255 0 : case BT_PROCEDURE:
6256 0 : case BT_HOLLERITH:
6257 0 : case BT_UNION:
6258 0 : case BT_BOZ:
6259 0 : case BT_UNKNOWN:
6260 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6261 0 : gcc_unreachable ();
6262 : }
6263 : }
6264 :
6265 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6266 6537 : gfc_add_modify (&block, tmp,
6267 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6268 :
6269 6537 : int attr = CFI_attribute_other;
6270 6537 : if (fsym->attr.pointer)
6271 : attr = CFI_attribute_pointer;
6272 5774 : else if (fsym->attr.allocatable)
6273 433 : attr = CFI_attribute_allocatable;
6274 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6275 6537 : gfc_add_modify (&block, tmp,
6276 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6277 :
6278 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6279 : That is very sensible for undefined pointers, but the C code might assume
6280 : that the pointer retains the value, in particular, if it was NULL. */
6281 6537 : if (e->rank == 0)
6282 : {
6283 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6284 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6285 : }
6286 : else
6287 : {
6288 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6289 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6290 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6291 : }
6292 :
6293 : /* Set elem_len if known - must be before the next if block.
6294 : Note that allocatable implies 'len=:'. */
6295 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6296 : {
6297 : /* Length is known at compile time; use 'block' for it. */
6298 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6299 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6300 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6301 : }
6302 :
6303 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6304 91 : goto done;
6305 :
6306 : /* When allocatable + intent out, free the cfi descriptor. */
6307 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6308 : {
6309 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6310 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6311 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6312 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6313 90 : gfc_add_modify (&block, tmp,
6314 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6315 90 : goto done;
6316 : }
6317 :
6318 : /* If not unallocated/unassociated. */
6319 6356 : gfc_init_block (&block2);
6320 :
6321 : /* Set elem_len, which may be only known at run time. */
6322 6356 : if (e->ts.type == BT_CHARACTER
6323 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6324 : {
6325 3408 : gcc_assert (gfc_strlen);
6326 3409 : tmp = gfc_strlen;
6327 3409 : if (e->ts.kind != 1)
6328 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6329 : gfc_charlen_type_node, tmp,
6330 : build_int_cst (gfc_charlen_type_node,
6331 1117 : e->ts.kind));
6332 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6333 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6334 : }
6335 2947 : else if (e->ts.type == BT_ASSUMED)
6336 : {
6337 54 : tmp = gfc_conv_descriptor_elem_len (gfc);
6338 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6339 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6340 : }
6341 :
6342 6356 : if (e->ts.type == BT_ASSUMED)
6343 : {
6344 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6345 : an CFI descriptor. Use the type in the descriptor as it provide
6346 : mode information. (Quality of implementation feature.) */
6347 54 : tree cond;
6348 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6349 54 : tree type = fold_convert (TREE_TYPE (ctype),
6350 : gfc_conv_descriptor_type (gfc));
6351 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6352 : gfc_conv_descriptor_elem_len (gfc));
6353 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6354 54 : kind, build_int_cst (TREE_TYPE (type),
6355 : CFI_type_kind_shift));
6356 :
6357 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6358 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6359 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6360 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6361 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6362 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6363 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6364 : ctype,
6365 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6366 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6367 : tmp, tmp2);
6368 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6369 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6370 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6371 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6372 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6373 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6374 : tmp, tmp2);
6375 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6376 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6377 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6378 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6379 54 : tmp = build_int_cst (TREE_TYPE (type),
6380 : CFI_type_from_type_kind (CFI_type_Character, 1));
6381 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6382 : ctype, tmp);
6383 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6384 : tmp, tmp2);
6385 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6386 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6387 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6388 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6389 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6390 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6391 54 : build_int_cst (TREE_TYPE (type),
6392 : CFI_type_Complex));
6393 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6394 : ctype, tmp);
6395 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6396 : tmp, tmp2);
6397 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6398 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6399 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6400 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6401 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6402 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6403 : cond, tmp);
6404 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6405 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6406 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6407 : cond, tmp);
6408 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6409 : type, kind);
6410 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6411 : ctype, tmp);
6412 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6413 : tmp, tmp2);
6414 54 : gfc_add_expr_to_block (&block2, tmp2);
6415 : }
6416 :
6417 6356 : if (e->rank != 0)
6418 : {
6419 : /* Loop: for (i = 0; i < rank; ++i). */
6420 5735 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6421 : /* Loop body. */
6422 5735 : stmtblock_t loop_body;
6423 5735 : gfc_init_block (&loop_body);
6424 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6425 : ? gfc->dim[i].lbound : 0 */
6426 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6427 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6428 : else
6429 5087 : tmp = gfc_index_zero_node;
6430 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6431 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6432 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6433 : gfc_conv_descriptor_ubound_get (gfc, idx),
6434 : gfc_conv_descriptor_lbound_get (gfc, idx));
6435 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6436 : tmp, gfc_index_one_node);
6437 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6438 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6439 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6440 : gfc_conv_descriptor_stride_get (gfc, idx),
6441 : gfc_conv_descriptor_span_get (gfc));
6442 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6443 :
6444 : /* Generate loop. */
6445 11470 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6446 5735 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6447 : gfc_finish_block (&loop_body));
6448 :
6449 5735 : if (e->expr_type == EXPR_VARIABLE
6450 5573 : && e->ref
6451 5573 : && e->ref->u.ar.type == AR_FULL
6452 2732 : && e->symtree->n.sym->attr.dummy
6453 988 : && e->symtree->n.sym->as
6454 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6455 : {
6456 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6457 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6458 : }
6459 : }
6460 :
6461 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6462 : {
6463 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6464 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6465 : tmp, null_pointer_node);
6466 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6467 : build_empty_stmt (input_location));
6468 1015 : gfc_add_expr_to_block (&block, tmp);
6469 : }
6470 : else
6471 5341 : gfc_add_block_to_block (&block, &block2);
6472 :
6473 :
6474 6537 : done:
6475 6537 : if (present)
6476 : {
6477 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6478 103 : TREE_TYPE (parmse->expr),
6479 : present, parmse->expr, null_pointer_node);
6480 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6481 : build_empty_stmt (input_location));
6482 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6483 : }
6484 : else
6485 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6486 :
6487 6537 : gfc_init_block (&block);
6488 :
6489 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6490 1196 : || fsym->attr.intent == INTENT_IN)
6491 5550 : goto post_call;
6492 :
6493 987 : gfc_init_block (&block2);
6494 987 : if (e->rank == 0)
6495 : {
6496 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6497 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6498 : }
6499 : else
6500 : {
6501 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6502 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6503 :
6504 559 : if (fsym->attr.allocatable)
6505 : {
6506 : /* gfc->span = cfi->elem_len. */
6507 252 : tmp = fold_convert (gfc_array_index_type,
6508 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6509 : }
6510 : else
6511 : {
6512 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6513 : ? cfi->dim[0].sm : cfi->elem_len). */
6514 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6515 307 : tmp2 = fold_convert (gfc_array_index_type,
6516 : gfc_get_cfi_desc_elem_len (cfi));
6517 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6518 : gfc_array_index_type, tmp, tmp2);
6519 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6520 : tmp, gfc_index_zero_node);
6521 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6522 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6523 : }
6524 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6525 :
6526 : /* Calculate offset + set lbound, ubound and stride. */
6527 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6528 : /* Loop: for (i = 0; i < rank; ++i). */
6529 559 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6530 : /* Loop body. */
6531 559 : stmtblock_t loop_body;
6532 559 : gfc_init_block (&loop_body);
6533 : /* gfc->dim[i].lbound = ... */
6534 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6535 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6536 :
6537 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6538 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6539 : gfc_conv_descriptor_lbound_get (gfc, idx),
6540 : gfc_index_one_node);
6541 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6542 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6543 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6544 :
6545 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6546 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6547 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6548 : gfc_array_index_type, tmp,
6549 : fold_convert (gfc_array_index_type,
6550 : gfc_get_cfi_desc_elem_len (cfi)));
6551 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6552 :
6553 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6554 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6555 : gfc_conv_descriptor_stride_get (gfc, idx),
6556 : gfc_conv_descriptor_lbound_get (gfc, idx));
6557 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6558 : gfc_conv_descriptor_offset_get (gfc), tmp);
6559 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6560 : /* Generate loop. */
6561 1118 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6562 559 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6563 : gfc_finish_block (&loop_body));
6564 : }
6565 :
6566 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6567 : {
6568 60 : tmp = fold_convert (gfc_charlen_type_node,
6569 : gfc_get_cfi_desc_elem_len (cfi));
6570 60 : if (e->ts.kind != 1)
6571 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6572 : gfc_charlen_type_node, tmp,
6573 : build_int_cst (gfc_charlen_type_node,
6574 24 : e->ts.kind));
6575 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6576 : }
6577 :
6578 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6579 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6580 : tmp, null_pointer_node);
6581 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6582 : build_empty_stmt (input_location));
6583 987 : gfc_add_expr_to_block (&block, tmp);
6584 :
6585 6537 : post_call:
6586 6537 : gfc_add_block_to_block (&block, &se.post);
6587 6537 : if (present && block.head)
6588 : {
6589 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6590 : build_empty_stmt (input_location));
6591 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6592 : }
6593 6531 : else if (block.head)
6594 1564 : gfc_add_block_to_block (&parmse->post, &block);
6595 6537 : }
6596 :
6597 :
6598 : /* Create "conditional temporary" to handle scalar dummy variables with the
6599 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6600 : as fallback. Does not handle CLASS. */
6601 :
6602 : static void
6603 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6604 : {
6605 234 : tree temp;
6606 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6607 234 : gcc_assert (e->rank == 0);
6608 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6609 234 : TREE_STATIC (temp) = 1;
6610 234 : TREE_CONSTANT (temp) = 1;
6611 234 : TREE_READONLY (temp) = 1;
6612 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6613 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6614 234 : TREE_TYPE (parmse->expr),
6615 : cond, parmse->expr, temp);
6616 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6617 234 : }
6618 :
6619 :
6620 : /* Returns true if the type specified in TS is a character type whose length
6621 : is constant. Otherwise returns false. */
6622 :
6623 : static bool
6624 21968 : gfc_const_length_character_type_p (gfc_typespec *ts)
6625 : {
6626 21968 : return (ts->type == BT_CHARACTER
6627 467 : && ts->u.cl
6628 467 : && ts->u.cl->length
6629 467 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6630 22435 : && ts->u.cl->length->ts.type == BT_INTEGER);
6631 : }
6632 :
6633 :
6634 : /* Helper function for the handling of (currently) scalar dummy variables
6635 : with the VALUE attribute. Argument parmse should already be set up. */
6636 : static void
6637 22401 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6638 : vec<tree, va_gc> *& optionalargs)
6639 : {
6640 22401 : tree tmp;
6641 :
6642 22401 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6643 :
6644 22401 : if (IS_PDT (e))
6645 : {
6646 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6647 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6648 6 : gfc_add_expr_to_block (&parmse->pre,
6649 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6650 : parmse->expr, tmp,
6651 : e->rank, 0));
6652 6 : parmse->expr = tmp;
6653 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6654 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6655 6 : return;
6656 : }
6657 :
6658 : /* Absent actual argument for optional scalar dummy. */
6659 22395 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6660 : {
6661 : /* For scalar arguments with VALUE attribute which are passed by
6662 : value, pass "0" and a hidden argument for the optional status. */
6663 427 : if (fsym->ts.type == BT_CHARACTER)
6664 : {
6665 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6666 : zero. */
6667 90 : parmse->expr = null_pointer_node;
6668 90 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6669 : }
6670 337 : else if (gfc_bt_struct (fsym->ts.type)
6671 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6672 : {
6673 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6674 : are pointers and passed as such below. */
6675 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6676 24 : TREE_CONSTANT (temp) = 1;
6677 24 : TREE_READONLY (temp) = 1;
6678 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6679 24 : parmse->expr = temp;
6680 24 : }
6681 : else
6682 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6683 : integer_zero_node);
6684 427 : vec_safe_push (optionalargs, boolean_false_node);
6685 :
6686 427 : return;
6687 : }
6688 :
6689 : /* Truncate a too long constant character actual argument. */
6690 21968 : if (gfc_const_length_character_type_p (&fsym->ts)
6691 467 : && e->expr_type == EXPR_CONSTANT
6692 22051 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6693 : e->value.character.length) < 0)
6694 : {
6695 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6696 :
6697 : /* Truncate actual string argument. */
6698 17 : gfc_conv_expr (parmse, e);
6699 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6700 17 : e->value.character.string);
6701 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6702 :
6703 17 : if (flen == 1)
6704 : {
6705 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6706 14 : gfc_conv_string_parameter (parmse);
6707 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6708 : e->ts.kind);
6709 : }
6710 :
6711 : /* Indicate value,optional scalar dummy argument as present. */
6712 17 : if (fsym->attr.optional)
6713 1 : vec_safe_push (optionalargs, boolean_true_node);
6714 17 : return;
6715 : }
6716 :
6717 : /* gfortran argument passing conventions:
6718 : actual arguments to CHARACTER(len=1),VALUE
6719 : dummy arguments are actually passed by value.
6720 : Strings are truncated to length 1. */
6721 21951 : if (gfc_length_one_character_type_p (&fsym->ts))
6722 : {
6723 378 : if (e->expr_type == EXPR_CONSTANT
6724 54 : && e->value.character.length > 1)
6725 : {
6726 0 : e->value.character.length = 1;
6727 0 : gfc_conv_expr (parmse, e);
6728 : }
6729 :
6730 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6731 378 : gfc_conv_string_parameter (parmse);
6732 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6733 : e->ts.kind);
6734 : /* Truncate resulting string to length 1. */
6735 378 : parmse->string_length = slen1;
6736 : }
6737 :
6738 21951 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6739 : {
6740 : /* F2018:15.5.2.12 Argument presence and
6741 : restrictions on arguments not present. */
6742 823 : if (e->expr_type == EXPR_VARIABLE
6743 650 : && e->rank == 0
6744 1419 : && (gfc_expr_attr (e).allocatable
6745 482 : || gfc_expr_attr (e).pointer))
6746 : {
6747 198 : gfc_se argse;
6748 198 : tree cond;
6749 198 : gfc_init_se (&argse, NULL);
6750 198 : argse.want_pointer = 1;
6751 198 : gfc_conv_expr (&argse, e);
6752 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6753 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6754 : argse.expr, cond);
6755 198 : if (e->symtree->n.sym->attr.dummy)
6756 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6757 : logical_type_node,
6758 : gfc_conv_expr_present (e->symtree->n.sym),
6759 : cond);
6760 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
6761 : /* Create "conditional temporary". */
6762 198 : conv_cond_temp (parmse, e, cond);
6763 : }
6764 625 : else if (e->expr_type != EXPR_VARIABLE
6765 452 : || !e->symtree->n.sym->attr.optional
6766 260 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6767 365 : vec_safe_push (optionalargs, boolean_true_node);
6768 : else
6769 : {
6770 260 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6771 260 : if (gfc_bt_struct (fsym->ts.type)
6772 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6773 36 : conv_cond_temp (parmse, e, tmp);
6774 224 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6775 84 : parmse->expr
6776 168 : = fold_build3_loc (input_location, COND_EXPR,
6777 84 : TREE_TYPE (parmse->expr),
6778 : tmp, parmse->expr,
6779 84 : fold_convert (TREE_TYPE (parmse->expr),
6780 : integer_zero_node));
6781 :
6782 520 : vec_safe_push (optionalargs,
6783 260 : fold_convert (boolean_type_node, tmp));
6784 : }
6785 : }
6786 : }
6787 :
6788 :
6789 : /* Helper function for the handling of NULL() actual arguments associated with
6790 : non-optional dummy variables. Argument parmse should already be set up. */
6791 : static void
6792 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
6793 : {
6794 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
6795 :
6796 : /* Obtain the character length for a NULL() actual with a character
6797 : MOLD argument. Otherwise substitute a suitable dummy length.
6798 : Here we handle only non-optional dummies of non-bind(c) procedures. */
6799 426 : if (fsym->ts.type == BT_CHARACTER)
6800 : {
6801 216 : if (e->ts.type == BT_CHARACTER
6802 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
6803 : {
6804 : /* MOLD is present. Substitute a temporary character NULL pointer.
6805 : For an assumed-rank dummy we need a descriptor that passes the
6806 : correct rank. */
6807 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
6808 : {
6809 54 : tree rank;
6810 54 : tree tmp = parmse->expr;
6811 54 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6812 54 : rank = gfc_conv_descriptor_rank (tmp);
6813 54 : gfc_add_modify (&parmse->pre, rank,
6814 54 : build_int_cst (TREE_TYPE (rank), e->rank));
6815 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6816 54 : }
6817 : else
6818 : {
6819 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
6820 108 : gfc_add_modify (&parmse->pre, tmp,
6821 108 : build_zero_cst (TREE_TYPE (tmp)));
6822 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6823 : }
6824 :
6825 : /* Ensure that a usable length is available. */
6826 162 : if (parmse->string_length == NULL_TREE)
6827 : {
6828 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
6829 :
6830 162 : if (ts->u.cl->length != NULL
6831 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6832 108 : gfc_conv_const_charlen (ts->u.cl);
6833 :
6834 162 : if (ts->u.cl->backend_decl)
6835 162 : parmse->string_length = ts->u.cl->backend_decl;
6836 : }
6837 : }
6838 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
6839 : {
6840 : /* MOLD is not present. Pass length of associated dummy character
6841 : argument if constant, or zero. */
6842 54 : if (fsym->ts.u.cl->length != NULL
6843 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6844 : {
6845 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
6846 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
6847 : }
6848 : else
6849 : {
6850 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
6851 : "slen");
6852 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
6853 : build_zero_cst (gfc_charlen_type_node));
6854 : }
6855 : }
6856 : }
6857 210 : else if (fsym->ts.type == BT_DERIVED)
6858 : {
6859 210 : if (e->ts.type != BT_UNKNOWN)
6860 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
6861 : For an assumed-rank dummy we provide a descriptor that passes
6862 : the correct rank. */
6863 : {
6864 138 : tree rank;
6865 138 : tree tmp = parmse->expr;
6866 :
6867 138 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, gfc_expr_attr (e));
6868 138 : rank = gfc_conv_descriptor_rank (tmp);
6869 138 : gfc_add_modify (&parmse->pre, rank,
6870 138 : build_int_cst (TREE_TYPE (rank), e->rank));
6871 138 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6872 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6873 : }
6874 : else
6875 : /* MOLD is not present. Use attributes from dummy argument, which is
6876 : not allowed to be assumed-rank. */
6877 : {
6878 72 : int dummy_rank;
6879 72 : tree tmp = parmse->expr;
6880 :
6881 72 : if ((fsym->attr.allocatable || fsym->attr.pointer)
6882 72 : && fsym->attr.intent == INTENT_UNKNOWN)
6883 36 : fsym->attr.intent = INTENT_IN;
6884 72 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6885 72 : dummy_rank = fsym->as ? fsym->as->rank : 0;
6886 24 : if (dummy_rank > 0)
6887 : {
6888 24 : tree rank = gfc_conv_descriptor_rank (tmp);
6889 24 : gfc_add_modify (&parmse->pre, rank,
6890 24 : build_int_cst (TREE_TYPE (rank), dummy_rank));
6891 : }
6892 72 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6893 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6894 : }
6895 : }
6896 426 : }
6897 :
6898 :
6899 : /* Generate code for a procedure call. Note can return se->post != NULL.
6900 : If se->direct_byref is set then se->expr contains the return parameter.
6901 : Return nonzero, if the call has alternate specifiers.
6902 : 'expr' is only needed for procedure pointer components. */
6903 :
6904 : int
6905 134751 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6906 : gfc_actual_arglist * args, gfc_expr * expr,
6907 : vec<tree, va_gc> *append_args)
6908 : {
6909 134751 : gfc_interface_mapping mapping;
6910 134751 : vec<tree, va_gc> *arglist;
6911 134751 : vec<tree, va_gc> *retargs;
6912 134751 : tree tmp;
6913 134751 : tree fntype;
6914 134751 : gfc_se parmse;
6915 134751 : gfc_array_info *info;
6916 134751 : int byref;
6917 134751 : int parm_kind;
6918 134751 : tree type;
6919 134751 : tree var;
6920 134751 : tree len;
6921 134751 : tree base_object;
6922 134751 : vec<tree, va_gc> *stringargs;
6923 134751 : vec<tree, va_gc> *optionalargs;
6924 134751 : tree result = NULL;
6925 134751 : gfc_formal_arglist *formal;
6926 134751 : gfc_actual_arglist *arg;
6927 134751 : int has_alternate_specifier = 0;
6928 134751 : bool need_interface_mapping;
6929 134751 : bool is_builtin;
6930 134751 : bool callee_alloc;
6931 134751 : bool ulim_copy;
6932 134751 : gfc_typespec ts;
6933 134751 : gfc_charlen cl;
6934 134751 : gfc_expr *e;
6935 134751 : gfc_symbol *fsym;
6936 134751 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6937 134751 : gfc_component *comp = NULL;
6938 134751 : int arglen;
6939 134751 : unsigned int argc;
6940 134751 : tree arg1_cntnr = NULL_TREE;
6941 134751 : arglist = NULL;
6942 134751 : retargs = NULL;
6943 134751 : stringargs = NULL;
6944 134751 : optionalargs = NULL;
6945 134751 : var = NULL_TREE;
6946 134751 : len = NULL_TREE;
6947 134751 : gfc_clear_ts (&ts);
6948 134751 : gfc_intrinsic_sym *isym = expr && expr->rank ?
6949 : expr->value.function.isym : NULL;
6950 :
6951 134751 : comp = gfc_get_proc_ptr_comp (expr);
6952 :
6953 269502 : bool elemental_proc = (comp
6954 2020 : && comp->ts.interface
6955 1966 : && comp->ts.interface->attr.elemental)
6956 1827 : || (comp && comp->attr.elemental)
6957 136578 : || sym->attr.elemental;
6958 :
6959 134751 : if (se->ss != NULL)
6960 : {
6961 24617 : if (!elemental_proc)
6962 : {
6963 21298 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
6964 21298 : if (se->ss->info->useflags)
6965 : {
6966 5747 : gcc_assert ((!comp && gfc_return_by_reference (sym)
6967 : && sym->result->attr.dimension)
6968 : || (comp && comp->attr.dimension)
6969 : || gfc_is_class_array_function (expr));
6970 5747 : gcc_assert (se->loop != NULL);
6971 : /* Access the previously obtained result. */
6972 5747 : gfc_conv_tmp_array_ref (se);
6973 5747 : return 0;
6974 : }
6975 : }
6976 18870 : info = &se->ss->info->data.array;
6977 : }
6978 : else
6979 : info = NULL;
6980 :
6981 129004 : stmtblock_t post, clobbers, dealloc_blk;
6982 129004 : gfc_init_block (&post);
6983 129004 : gfc_init_block (&clobbers);
6984 129004 : gfc_init_block (&dealloc_blk);
6985 129004 : gfc_init_interface_mapping (&mapping);
6986 129004 : if (!comp)
6987 : {
6988 127033 : formal = gfc_sym_get_dummy_args (sym);
6989 127033 : need_interface_mapping = sym->attr.dimension ||
6990 111734 : (sym->ts.type == BT_CHARACTER
6991 3118 : && sym->ts.u.cl->length
6992 2379 : && sym->ts.u.cl->length->expr_type
6993 : != EXPR_CONSTANT);
6994 : }
6995 : else
6996 : {
6997 1971 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
6998 1971 : need_interface_mapping = comp->attr.dimension ||
6999 1902 : (comp->ts.type == BT_CHARACTER
7000 229 : && comp->ts.u.cl->length
7001 220 : && comp->ts.u.cl->length->expr_type
7002 : != EXPR_CONSTANT);
7003 : }
7004 :
7005 129004 : base_object = NULL_TREE;
7006 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7007 : is the third and fourth argument to such a function call a value
7008 : denoting the number of elements to copy (i.e., most of the time the
7009 : length of a deferred length string). */
7010 258008 : ulim_copy = (formal == NULL)
7011 31545 : && UNLIMITED_POLY (sym)
7012 129083 : && comp && (strcmp ("_copy", comp->name) == 0);
7013 :
7014 : /* Scan for allocatable actual arguments passed to allocatable dummy
7015 : arguments with INTENT(OUT). As the corresponding actual arguments are
7016 : deallocated before execution of the procedure, we evaluate actual
7017 : argument expressions to avoid problems with possible dependencies. */
7018 129004 : bool force_eval_args = false;
7019 129004 : gfc_formal_arglist *tmp_formal;
7020 397076 : for (arg = args, tmp_formal = formal; arg != NULL;
7021 234781 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7022 : {
7023 268572 : e = arg->expr;
7024 268572 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7025 255198 : if (e && fsym
7026 223334 : && e->expr_type == EXPR_VARIABLE
7027 97723 : && fsym->attr.intent == INTENT_OUT
7028 6281 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7029 6281 : ? CLASS_DATA (fsym)->attr.allocatable
7030 4753 : : fsym->attr.allocatable)
7031 500 : && e->symtree
7032 500 : && e->symtree->n.sym
7033 523770 : && gfc_variable_attr (e, NULL).allocatable)
7034 : {
7035 : force_eval_args = true;
7036 : break;
7037 : }
7038 : }
7039 :
7040 : /* Evaluate the arguments. */
7041 397978 : for (arg = args, argc = 0; arg != NULL;
7042 268974 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7043 : {
7044 268974 : bool finalized = false;
7045 268974 : tree derived_array = NULL_TREE;
7046 268974 : symbol_attribute *attr;
7047 :
7048 268974 : e = arg->expr;
7049 268974 : fsym = formal ? formal->sym : NULL;
7050 504657 : parm_kind = MISSING;
7051 :
7052 235683 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7053 : : fsym->attr)
7054 : : nullptr;
7055 : /* If the procedure requires an explicit interface, the actual
7056 : argument is passed according to the corresponding formal
7057 : argument. If the corresponding formal argument is a POINTER,
7058 : ALLOCATABLE or assumed shape, we do not use g77's calling
7059 : convention, and pass the address of the array descriptor
7060 : instead. Otherwise we use g77's calling convention, in other words
7061 : pass the array data pointer without descriptor. */
7062 235630 : bool nodesc_arg = fsym != NULL
7063 235630 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7064 226583 : && fsym->as
7065 40059 : && fsym->as->type != AS_ASSUMED_SHAPE
7066 24620 : && fsym->as->type != AS_ASSUMED_RANK;
7067 268974 : if (comp)
7068 2718 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7069 : else
7070 266256 : nodesc_arg
7071 : = nodesc_arg
7072 266256 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7073 :
7074 : /* Class array expressions are sometimes coming completely unadorned
7075 : with either arrayspec or _data component. Correct that here.
7076 : OOP-TODO: Move this to the frontend. */
7077 268974 : if (e && e->expr_type == EXPR_VARIABLE
7078 111809 : && !e->ref
7079 51248 : && e->ts.type == BT_CLASS
7080 2601 : && (CLASS_DATA (e)->attr.codimension
7081 2601 : || CLASS_DATA (e)->attr.dimension))
7082 : {
7083 0 : gfc_typespec temp_ts = e->ts;
7084 0 : gfc_add_class_array_ref (e);
7085 0 : e->ts = temp_ts;
7086 : }
7087 :
7088 268974 : if (e == NULL
7089 255594 : || (e->expr_type == EXPR_NULL
7090 745 : && fsym
7091 745 : && fsym->attr.value
7092 72 : && fsym->attr.optional
7093 72 : && !fsym->attr.dimension
7094 72 : && fsym->ts.type != BT_CLASS))
7095 : {
7096 13452 : if (se->ignore_optional)
7097 : {
7098 : /* Some intrinsics have already been resolved to the correct
7099 : parameters. */
7100 422 : continue;
7101 : }
7102 13254 : else if (arg->label)
7103 : {
7104 224 : has_alternate_specifier = 1;
7105 224 : continue;
7106 : }
7107 : else
7108 : {
7109 13030 : gfc_init_se (&parmse, NULL);
7110 :
7111 : /* For scalar arguments with VALUE attribute which are passed by
7112 : value, pass "0" and a hidden argument gives the optional
7113 : status. */
7114 13030 : if (fsym && fsym->attr.optional && fsym->attr.value
7115 427 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7116 : {
7117 427 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7118 : }
7119 : else
7120 : {
7121 : /* Pass a NULL pointer for an absent arg. */
7122 12603 : parmse.expr = null_pointer_node;
7123 :
7124 : /* Is it an absent character dummy? */
7125 12603 : bool absent_char = false;
7126 12603 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7127 :
7128 : /* Fall back to inferred type only if no formal. */
7129 12603 : if (fsym)
7130 11545 : absent_char = (fsym->ts.type == BT_CHARACTER);
7131 1058 : else if (dummy_arg)
7132 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7133 : == BT_CHARACTER);
7134 12603 : if (absent_char)
7135 1115 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7136 : 0);
7137 : }
7138 : }
7139 : }
7140 255522 : else if (e->expr_type == EXPR_NULL
7141 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7142 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7143 293 : && fsym->ts.type == BT_DERIVED)
7144 : {
7145 210 : gfc_init_se (&parmse, NULL);
7146 210 : gfc_conv_expr_reference (&parmse, e);
7147 210 : conv_null_actual (&parmse, e, fsym);
7148 : }
7149 255312 : else if (arg->expr->expr_type == EXPR_NULL
7150 463 : && fsym && !fsym->attr.pointer
7151 163 : && (fsym->ts.type != BT_CLASS
7152 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7153 : {
7154 : /* Pass a NULL pointer to denote an absent arg. */
7155 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7156 : && (fsym->ts.type != BT_CLASS
7157 : || !CLASS_DATA (fsym)->attr.allocatable));
7158 163 : gfc_init_se (&parmse, NULL);
7159 163 : parmse.expr = null_pointer_node;
7160 163 : if (fsym->ts.type == BT_CHARACTER)
7161 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7162 : }
7163 255149 : else if (fsym && fsym->ts.type == BT_CLASS
7164 10827 : && e->ts.type == BT_DERIVED)
7165 : {
7166 : /* The derived type needs to be converted to a temporary
7167 : CLASS object. */
7168 4365 : gfc_init_se (&parmse, se);
7169 4365 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7170 4365 : fsym->attr.optional
7171 1008 : && e->expr_type == EXPR_VARIABLE
7172 5373 : && e->symtree->n.sym->attr.optional,
7173 4365 : CLASS_DATA (fsym)->attr.class_pointer
7174 4365 : || CLASS_DATA (fsym)->attr.allocatable,
7175 : sym->name, &derived_array);
7176 : }
7177 218920 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7178 906 : && e->ts.type != BT_PROCEDURE
7179 882 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7180 12 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7181 : {
7182 : /* The intrinsic type needs to be converted to a temporary
7183 : CLASS object for the unlimited polymorphic formal. */
7184 882 : gfc_find_vtab (&e->ts);
7185 882 : gfc_init_se (&parmse, se);
7186 882 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7187 :
7188 : }
7189 249902 : else if (se->ss && se->ss->info->useflags)
7190 : {
7191 5567 : gfc_ss *ss;
7192 :
7193 5567 : ss = se->ss;
7194 :
7195 : /* An elemental function inside a scalarized loop. */
7196 5567 : gfc_init_se (&parmse, se);
7197 5567 : parm_kind = ELEMENTAL;
7198 :
7199 : /* When no fsym is present, ulim_copy is set and this is a third or
7200 : fourth argument, use call-by-value instead of by reference to
7201 : hand the length properties to the copy routine (i.e., most of the
7202 : time this will be a call to a __copy_character_* routine where the
7203 : third and fourth arguments are the lengths of a deferred length
7204 : char array). */
7205 5567 : if ((fsym && fsym->attr.value)
7206 5333 : || (ulim_copy && (argc == 2 || argc == 3)))
7207 234 : gfc_conv_expr (&parmse, e);
7208 5333 : else if (e->expr_type == EXPR_ARRAY)
7209 : {
7210 306 : gfc_conv_expr (&parmse, e);
7211 306 : if (e->ts.type != BT_CHARACTER)
7212 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7213 : }
7214 : else
7215 5027 : gfc_conv_expr_reference (&parmse, e);
7216 :
7217 5567 : if (e->ts.type == BT_CHARACTER && !e->rank
7218 174 : && e->expr_type == EXPR_FUNCTION)
7219 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7220 : parmse.expr);
7221 :
7222 5517 : if (fsym && fsym->ts.type == BT_DERIVED
7223 6943 : && gfc_is_class_container_ref (e))
7224 : {
7225 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7226 :
7227 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7228 24 : && e->symtree->n.sym->attr.optional)
7229 : {
7230 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7231 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7232 0 : TREE_TYPE (parmse.expr),
7233 : cond, parmse.expr,
7234 0 : fold_convert (TREE_TYPE (parmse.expr),
7235 : null_pointer_node));
7236 : }
7237 : }
7238 :
7239 : /* Scalar dummy arguments of intrinsic type or derived type with
7240 : VALUE attribute. */
7241 5567 : if (fsym
7242 5517 : && fsym->attr.value
7243 234 : && fsym->ts.type != BT_CLASS)
7244 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7245 :
7246 : /* If we are passing an absent array as optional dummy to an
7247 : elemental procedure, make sure that we pass NULL when the data
7248 : pointer is NULL. We need this extra conditional because of
7249 : scalarization which passes arrays elements to the procedure,
7250 : ignoring the fact that the array can be absent/unallocated/... */
7251 5333 : else if (ss->info->can_be_null_ref
7252 415 : && ss->info->type != GFC_SS_REFERENCE)
7253 : {
7254 193 : tree descriptor_data;
7255 :
7256 193 : descriptor_data = ss->info->data.array.data;
7257 193 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7258 : descriptor_data,
7259 193 : fold_convert (TREE_TYPE (descriptor_data),
7260 : null_pointer_node));
7261 193 : parmse.expr
7262 386 : = fold_build3_loc (input_location, COND_EXPR,
7263 193 : TREE_TYPE (parmse.expr),
7264 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7265 193 : fold_convert (TREE_TYPE (parmse.expr),
7266 : null_pointer_node),
7267 : parmse.expr);
7268 : }
7269 :
7270 : /* The scalarizer does not repackage the reference to a class
7271 : array - instead it returns a pointer to the data element. */
7272 5567 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7273 162 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7274 162 : fsym->attr.intent != INTENT_IN
7275 162 : && (CLASS_DATA (fsym)->attr.class_pointer
7276 12 : || CLASS_DATA (fsym)->attr.allocatable),
7277 162 : fsym->attr.optional
7278 0 : && e->expr_type == EXPR_VARIABLE
7279 162 : && e->symtree->n.sym->attr.optional,
7280 162 : CLASS_DATA (fsym)->attr.class_pointer
7281 162 : || CLASS_DATA (fsym)->attr.allocatable);
7282 : }
7283 : else
7284 : {
7285 244335 : bool scalar;
7286 244335 : gfc_ss *argss;
7287 :
7288 244335 : gfc_init_se (&parmse, NULL);
7289 :
7290 : /* Check whether the expression is a scalar or not; we cannot use
7291 : e->rank as it can be nonzero for functions arguments. */
7292 244335 : argss = gfc_walk_expr (e);
7293 244335 : scalar = argss == gfc_ss_terminator;
7294 244335 : if (!scalar)
7295 59710 : gfc_free_ss_chain (argss);
7296 :
7297 : /* Special handling for passing scalar polymorphic coarrays;
7298 : otherwise one passes "class->_data.data" instead of "&class". */
7299 244335 : if (e->rank == 0 && e->ts.type == BT_CLASS
7300 3548 : && fsym && fsym->ts.type == BT_CLASS
7301 3126 : && CLASS_DATA (fsym)->attr.codimension
7302 55 : && !CLASS_DATA (fsym)->attr.dimension)
7303 : {
7304 55 : gfc_add_class_array_ref (e);
7305 55 : parmse.want_coarray = 1;
7306 55 : scalar = false;
7307 : }
7308 :
7309 : /* A scalar or transformational function. */
7310 244335 : if (scalar)
7311 : {
7312 184570 : if (e->expr_type == EXPR_VARIABLE
7313 54698 : && e->symtree->n.sym->attr.cray_pointee
7314 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7315 : {
7316 : /* The Cray pointer needs to be converted to a pointer to
7317 : a type given by the expression. */
7318 6 : gfc_conv_expr (&parmse, e);
7319 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7320 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7321 6 : parmse.expr = convert (type, tmp);
7322 : }
7323 :
7324 184564 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7325 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7326 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7327 :
7328 183877 : else if (fsym && fsym->attr.value)
7329 : {
7330 21912 : if (fsym->ts.type == BT_CHARACTER
7331 543 : && fsym->ts.is_c_interop
7332 181 : && fsym->ns->proc_name != NULL
7333 181 : && fsym->ns->proc_name->attr.is_bind_c)
7334 : {
7335 172 : parmse.expr = NULL;
7336 172 : conv_scalar_char_value (fsym, &parmse, &e);
7337 172 : if (parmse.expr == NULL)
7338 166 : gfc_conv_expr (&parmse, e);
7339 : }
7340 : else
7341 : {
7342 21740 : gfc_conv_expr (&parmse, e);
7343 21740 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7344 : }
7345 : }
7346 :
7347 161965 : else if (arg->name && arg->name[0] == '%')
7348 : /* Argument list functions %VAL, %LOC and %REF are signalled
7349 : through arg->name. */
7350 5822 : conv_arglist_function (&parmse, arg->expr, arg->name);
7351 156143 : else if ((e->expr_type == EXPR_FUNCTION)
7352 8183 : && ((e->value.function.esym
7353 2152 : && e->value.function.esym->result->attr.pointer)
7354 8088 : || (!e->value.function.esym
7355 6031 : && e->symtree->n.sym->attr.pointer))
7356 95 : && fsym && fsym->attr.target)
7357 : /* Make sure the function only gets called once. */
7358 8 : gfc_conv_expr_reference (&parmse, e);
7359 156135 : else if (e->expr_type == EXPR_FUNCTION
7360 8175 : && e->symtree->n.sym->result
7361 7140 : && e->symtree->n.sym->result != e->symtree->n.sym
7362 136 : && e->symtree->n.sym->result->attr.proc_pointer)
7363 : {
7364 : /* Functions returning procedure pointers. */
7365 18 : gfc_conv_expr (&parmse, e);
7366 18 : if (fsym && fsym->attr.proc_pointer)
7367 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7368 : }
7369 :
7370 : else
7371 : {
7372 156117 : bool defer_to_dealloc_blk = false;
7373 156117 : if (e->ts.type == BT_CLASS && fsym
7374 3481 : && fsym->ts.type == BT_CLASS
7375 3059 : && (!CLASS_DATA (fsym)->as
7376 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7377 2703 : && CLASS_DATA (e)->attr.codimension)
7378 : {
7379 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7380 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7381 48 : gfc_add_class_array_ref (e);
7382 48 : parmse.want_coarray = 1;
7383 48 : gfc_conv_expr_reference (&parmse, e);
7384 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7385 48 : fsym->attr.optional
7386 48 : && e->expr_type == EXPR_VARIABLE);
7387 : }
7388 156069 : else if (e->ts.type == BT_CLASS && fsym
7389 3433 : && fsym->ts.type == BT_CLASS
7390 3011 : && !CLASS_DATA (fsym)->as
7391 2655 : && !CLASS_DATA (e)->as
7392 2545 : && strcmp (fsym->ts.u.derived->name,
7393 : e->ts.u.derived->name))
7394 : {
7395 1622 : type = gfc_typenode_for_spec (&fsym->ts);
7396 1622 : var = gfc_create_var (type, fsym->name);
7397 1622 : gfc_conv_expr (&parmse, e);
7398 1622 : if (fsym->attr.optional
7399 153 : && e->expr_type == EXPR_VARIABLE
7400 153 : && e->symtree->n.sym->attr.optional)
7401 : {
7402 66 : stmtblock_t block;
7403 66 : tree cond;
7404 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7405 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7406 : logical_type_node, tmp,
7407 66 : fold_convert (TREE_TYPE (tmp),
7408 : null_pointer_node));
7409 66 : gfc_start_block (&block);
7410 66 : gfc_add_modify (&block, var,
7411 : fold_build1_loc (input_location,
7412 : VIEW_CONVERT_EXPR,
7413 : type, parmse.expr));
7414 66 : gfc_add_expr_to_block (&parmse.pre,
7415 : fold_build3_loc (input_location,
7416 : COND_EXPR, void_type_node,
7417 : cond, gfc_finish_block (&block),
7418 : build_empty_stmt (input_location)));
7419 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7420 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7421 66 : TREE_TYPE (parmse.expr),
7422 : cond, parmse.expr,
7423 66 : fold_convert (TREE_TYPE (parmse.expr),
7424 : null_pointer_node));
7425 66 : }
7426 : else
7427 : {
7428 : /* Since the internal representation of unlimited
7429 : polymorphic expressions includes an extra field
7430 : that other class objects do not, a cast to the
7431 : formal type does not work. */
7432 1556 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7433 : {
7434 91 : tree efield;
7435 :
7436 : /* Evaluate arguments just once, when they have
7437 : side effects. */
7438 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7439 : {
7440 25 : tree cldata, zero;
7441 :
7442 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7443 : &parmse.pre);
7444 :
7445 : /* Prevent memory leak, when old component
7446 : was allocated already. */
7447 25 : cldata = gfc_class_data_get (parmse.expr);
7448 25 : zero = build_int_cst (TREE_TYPE (cldata),
7449 : 0);
7450 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7451 : logical_type_node,
7452 : cldata, zero);
7453 25 : tmp = build3_v (COND_EXPR, tmp,
7454 : gfc_call_free (cldata),
7455 : build_empty_stmt (
7456 : input_location));
7457 25 : gfc_add_expr_to_block (&parmse.finalblock,
7458 : tmp);
7459 25 : gfc_add_modify (&parmse.finalblock,
7460 : cldata, zero);
7461 : }
7462 :
7463 : /* Set the _data field. */
7464 91 : tmp = gfc_class_data_get (var);
7465 91 : efield = fold_convert (TREE_TYPE (tmp),
7466 : gfc_class_data_get (parmse.expr));
7467 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7468 :
7469 : /* Set the _vptr field. */
7470 91 : tmp = gfc_class_vptr_get (var);
7471 91 : efield = fold_convert (TREE_TYPE (tmp),
7472 : gfc_class_vptr_get (parmse.expr));
7473 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7474 :
7475 : /* Set the _len field. */
7476 91 : tmp = gfc_class_len_get (var);
7477 91 : gfc_add_modify (&parmse.pre, tmp,
7478 91 : build_int_cst (TREE_TYPE (tmp), 0));
7479 91 : }
7480 : else
7481 : {
7482 1465 : tmp = fold_build1_loc (input_location,
7483 : VIEW_CONVERT_EXPR,
7484 : type, parmse.expr);
7485 1465 : gfc_add_modify (&parmse.pre, var, tmp);
7486 1556 : ;
7487 : }
7488 1556 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7489 : }
7490 : }
7491 : else
7492 : {
7493 154447 : gfc_conv_expr_reference (&parmse, e);
7494 :
7495 154447 : gfc_symbol *dsym = fsym;
7496 154447 : gfc_dummy_arg *dummy;
7497 :
7498 : /* Use associated dummy as fallback for formal
7499 : argument if there is no explicit interface. */
7500 154447 : if (dsym == NULL
7501 27403 : && (dummy = arg->associated_dummy)
7502 24884 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7503 177928 : && dummy->u.non_intrinsic->sym)
7504 : dsym = dummy->u.non_intrinsic->sym;
7505 :
7506 154447 : if (dsym
7507 150525 : && dsym->attr.intent == INTENT_OUT
7508 3222 : && !dsym->attr.allocatable
7509 3080 : && !dsym->attr.pointer
7510 3062 : && e->expr_type == EXPR_VARIABLE
7511 3061 : && e->ref == NULL
7512 2952 : && e->symtree
7513 2952 : && e->symtree->n.sym
7514 2952 : && !e->symtree->n.sym->attr.dimension
7515 2952 : && e->ts.type != BT_CHARACTER
7516 2850 : && e->ts.type != BT_CLASS
7517 2620 : && (e->ts.type != BT_DERIVED
7518 492 : || (dsym->ts.type == BT_DERIVED
7519 492 : && e->ts.u.derived == dsym->ts.u.derived
7520 : /* Types with allocatable components are
7521 : excluded from clobbering because we need
7522 : the unclobbered pointers to free the
7523 : allocatable components in the callee.
7524 : Same goes for finalizable types or types
7525 : with finalizable components, we need to
7526 : pass the unclobbered values to the
7527 : finalization routines.
7528 : For parameterized types, it's less clear
7529 : but they may not have a constant size
7530 : so better exclude them in any case. */
7531 477 : && !e->ts.u.derived->attr.alloc_comp
7532 351 : && !e->ts.u.derived->attr.pdt_type
7533 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7534 156884 : && !sym->attr.elemental)
7535 : {
7536 1104 : tree var;
7537 1104 : var = build_fold_indirect_ref_loc (input_location,
7538 : parmse.expr);
7539 1104 : tree clobber = build_clobber (TREE_TYPE (var));
7540 1104 : gfc_add_modify (&clobbers, var, clobber);
7541 : }
7542 : }
7543 : /* Catch base objects that are not variables. */
7544 156117 : if (e->ts.type == BT_CLASS
7545 3481 : && e->expr_type != EXPR_VARIABLE
7546 306 : && expr && e == expr->base_expr)
7547 80 : base_object = build_fold_indirect_ref_loc (input_location,
7548 : parmse.expr);
7549 :
7550 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7551 : allocated on entry, it must be deallocated. */
7552 128714 : if (fsym && fsym->attr.intent == INTENT_OUT
7553 3151 : && (fsym->attr.allocatable
7554 3009 : || (fsym->ts.type == BT_CLASS
7555 259 : && CLASS_DATA (fsym)->attr.allocatable))
7556 156408 : && !is_CFI_desc (fsym, NULL))
7557 : {
7558 291 : stmtblock_t block;
7559 291 : tree ptr;
7560 :
7561 291 : defer_to_dealloc_blk = true;
7562 :
7563 291 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7564 : &parmse.pre);
7565 :
7566 291 : if (parmse.class_container != NULL_TREE)
7567 156 : parmse.class_container
7568 156 : = gfc_evaluate_data_ref_now (parmse.class_container,
7569 : &parmse.pre);
7570 :
7571 291 : gfc_init_block (&block);
7572 291 : ptr = parmse.expr;
7573 291 : if (e->ts.type == BT_CLASS)
7574 156 : ptr = gfc_class_data_get (ptr);
7575 :
7576 291 : tree cls = parmse.class_container;
7577 291 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7578 : NULL_TREE, true,
7579 : e, e->ts, cls);
7580 291 : gfc_add_expr_to_block (&block, tmp);
7581 291 : gfc_add_modify (&block, ptr,
7582 291 : fold_convert (TREE_TYPE (ptr),
7583 : null_pointer_node));
7584 :
7585 291 : if (fsym->ts.type == BT_CLASS)
7586 149 : gfc_reset_vptr (&block, nullptr,
7587 : build_fold_indirect_ref (parmse.expr),
7588 149 : fsym->ts.u.derived);
7589 :
7590 291 : if (fsym->attr.optional
7591 42 : && e->expr_type == EXPR_VARIABLE
7592 42 : && e->symtree->n.sym->attr.optional)
7593 : {
7594 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7595 : void_type_node,
7596 18 : gfc_conv_expr_present (e->symtree->n.sym),
7597 : gfc_finish_block (&block),
7598 : build_empty_stmt (input_location));
7599 : }
7600 : else
7601 273 : tmp = gfc_finish_block (&block);
7602 :
7603 291 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7604 : }
7605 :
7606 : /* A class array element needs converting back to be a
7607 : class object, if the formal argument is a class object. */
7608 156117 : if (fsym && fsym->ts.type == BT_CLASS
7609 3083 : && e->ts.type == BT_CLASS
7610 3059 : && ((CLASS_DATA (fsym)->as
7611 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7612 2703 : || CLASS_DATA (e)->attr.dimension))
7613 : {
7614 466 : gfc_se class_se = parmse;
7615 466 : gfc_init_block (&class_se.pre);
7616 466 : gfc_init_block (&class_se.post);
7617 :
7618 466 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7619 466 : fsym->attr.intent != INTENT_IN
7620 466 : && (CLASS_DATA (fsym)->attr.class_pointer
7621 267 : || CLASS_DATA (fsym)->attr.allocatable),
7622 466 : fsym->attr.optional
7623 198 : && e->expr_type == EXPR_VARIABLE
7624 664 : && e->symtree->n.sym->attr.optional,
7625 466 : CLASS_DATA (fsym)->attr.class_pointer
7626 466 : || CLASS_DATA (fsym)->attr.allocatable);
7627 :
7628 466 : parmse.expr = class_se.expr;
7629 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7630 466 : ? &dealloc_blk
7631 : : &parmse.pre;
7632 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7633 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7634 : }
7635 :
7636 128714 : if (fsym && (fsym->ts.type == BT_DERIVED
7637 116914 : || fsym->ts.type == BT_ASSUMED)
7638 12667 : && e->ts.type == BT_CLASS
7639 410 : && !CLASS_DATA (e)->attr.dimension
7640 374 : && !CLASS_DATA (e)->attr.codimension)
7641 : {
7642 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7643 : /* The result is a class temporary, whose _data component
7644 : must be freed to avoid a memory leak. */
7645 374 : if (e->expr_type == EXPR_FUNCTION
7646 23 : && CLASS_DATA (e)->attr.allocatable)
7647 : {
7648 19 : tree zero;
7649 :
7650 : /* Finalize the expression. */
7651 19 : gfc_finalize_tree_expr (&parmse, NULL,
7652 : gfc_expr_attr (e), e->rank);
7653 19 : gfc_add_block_to_block (&parmse.post,
7654 : &parmse.finalblock);
7655 :
7656 : /* Then free the class _data. */
7657 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7658 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7659 : logical_type_node,
7660 : parmse.expr, zero);
7661 19 : tmp = build3_v (COND_EXPR, tmp,
7662 : gfc_call_free (parmse.expr),
7663 : build_empty_stmt (input_location));
7664 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7665 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7666 : }
7667 : }
7668 :
7669 : /* Wrap scalar variable in a descriptor. We need to convert
7670 : the address of a pointer back to the pointer itself before,
7671 : we can assign it to the data field. */
7672 :
7673 128714 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7674 1314 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7675 : {
7676 1242 : tmp = parmse.expr;
7677 1242 : if (TREE_CODE (tmp) == ADDR_EXPR)
7678 736 : tmp = TREE_OPERAND (tmp, 0);
7679 1242 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7680 : fsym->attr);
7681 1242 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
7682 : parmse.expr);
7683 : }
7684 127472 : else if (fsym && e->expr_type != EXPR_NULL
7685 127174 : && ((fsym->attr.pointer
7686 1740 : && fsym->attr.flavor != FL_PROCEDURE)
7687 125440 : || (fsym->attr.proc_pointer
7688 157 : && !(e->expr_type == EXPR_VARIABLE
7689 157 : && e->symtree->n.sym->attr.dummy))
7690 125295 : || (fsym->attr.proc_pointer
7691 12 : && e->expr_type == EXPR_VARIABLE
7692 12 : && gfc_is_proc_ptr_comp (e))
7693 125289 : || (fsym->attr.allocatable
7694 1039 : && fsym->attr.flavor != FL_PROCEDURE)))
7695 : {
7696 : /* Scalar pointer dummy args require an extra level of
7697 : indirection. The null pointer already contains
7698 : this level of indirection. */
7699 2918 : parm_kind = SCALAR_POINTER;
7700 2918 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7701 : }
7702 : }
7703 : }
7704 59765 : else if (e->ts.type == BT_CLASS
7705 2669 : && fsym && fsym->ts.type == BT_CLASS
7706 2323 : && (CLASS_DATA (fsym)->attr.dimension
7707 55 : || CLASS_DATA (fsym)->attr.codimension))
7708 : {
7709 : /* Pass a class array. */
7710 2323 : gfc_conv_expr_descriptor (&parmse, e);
7711 2323 : bool defer_to_dealloc_blk = false;
7712 :
7713 2323 : if (fsym->attr.optional
7714 798 : && e->expr_type == EXPR_VARIABLE
7715 798 : && e->symtree->n.sym->attr.optional)
7716 : {
7717 438 : stmtblock_t block;
7718 :
7719 438 : gfc_init_block (&block);
7720 438 : gfc_add_block_to_block (&block, &parmse.pre);
7721 :
7722 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
7723 : void_type_node,
7724 438 : gfc_conv_expr_present (e->symtree->n.sym),
7725 : gfc_finish_block (&block),
7726 : build_empty_stmt (input_location));
7727 :
7728 438 : gfc_add_expr_to_block (&parmse.pre, t);
7729 : }
7730 :
7731 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7732 : allocated on entry, it must be deallocated. */
7733 2323 : if (fsym->attr.intent == INTENT_OUT
7734 141 : && CLASS_DATA (fsym)->attr.allocatable)
7735 : {
7736 110 : stmtblock_t block;
7737 110 : tree ptr;
7738 :
7739 : /* In case the data reference to deallocate is dependent on
7740 : its own content, save the resulting pointer to a variable
7741 : and only use that variable from now on, before the
7742 : expression becomes invalid. */
7743 110 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7744 : &parmse.pre);
7745 :
7746 110 : if (parmse.class_container != NULL_TREE)
7747 110 : parmse.class_container
7748 110 : = gfc_evaluate_data_ref_now (parmse.class_container,
7749 : &parmse.pre);
7750 :
7751 110 : gfc_init_block (&block);
7752 110 : ptr = parmse.expr;
7753 110 : ptr = gfc_class_data_get (ptr);
7754 :
7755 110 : tree cls = parmse.class_container;
7756 110 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
7757 : NULL_TREE, NULL_TREE,
7758 : NULL_TREE, true, e,
7759 : GFC_CAF_COARRAY_NOCOARRAY,
7760 : cls);
7761 110 : gfc_add_expr_to_block (&block, tmp);
7762 110 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7763 : void_type_node, ptr,
7764 : null_pointer_node);
7765 110 : gfc_add_expr_to_block (&block, tmp);
7766 110 : gfc_reset_vptr (&block, e, parmse.class_container);
7767 :
7768 110 : if (fsym->attr.optional
7769 30 : && e->expr_type == EXPR_VARIABLE
7770 30 : && (!e->ref
7771 30 : || (e->ref->type == REF_ARRAY
7772 0 : && e->ref->u.ar.type != AR_FULL))
7773 0 : && e->symtree->n.sym->attr.optional)
7774 : {
7775 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7776 : void_type_node,
7777 0 : gfc_conv_expr_present (e->symtree->n.sym),
7778 : gfc_finish_block (&block),
7779 : build_empty_stmt (input_location));
7780 : }
7781 : else
7782 110 : tmp = gfc_finish_block (&block);
7783 :
7784 110 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7785 110 : defer_to_dealloc_blk = true;
7786 : }
7787 :
7788 2323 : gfc_se class_se = parmse;
7789 2323 : gfc_init_block (&class_se.pre);
7790 2323 : gfc_init_block (&class_se.post);
7791 :
7792 : /* The conversion does not repackage the reference to a class
7793 : array - _data descriptor. */
7794 2323 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7795 2323 : fsym->attr.intent != INTENT_IN
7796 2323 : && (CLASS_DATA (fsym)->attr.class_pointer
7797 1193 : || CLASS_DATA (fsym)->attr.allocatable),
7798 2323 : fsym->attr.optional
7799 798 : && e->expr_type == EXPR_VARIABLE
7800 3121 : && e->symtree->n.sym->attr.optional,
7801 2323 : CLASS_DATA (fsym)->attr.class_pointer
7802 2323 : || CLASS_DATA (fsym)->attr.allocatable);
7803 :
7804 2323 : parmse.expr = class_se.expr;
7805 2213 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7806 2323 : ? &dealloc_blk
7807 : : &parmse.pre;
7808 2323 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7809 2323 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7810 2323 : }
7811 : else
7812 : {
7813 : /* If the argument is a function call that may not create
7814 : a temporary for the result, we have to check that we
7815 : can do it, i.e. that there is no alias between this
7816 : argument and another one. */
7817 57442 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7818 : {
7819 358 : gfc_expr *iarg;
7820 358 : sym_intent intent;
7821 :
7822 358 : if (fsym != NULL)
7823 349 : intent = fsym->attr.intent;
7824 : else
7825 : intent = INTENT_UNKNOWN;
7826 :
7827 358 : if (gfc_check_fncall_dependency (e, intent, sym, args,
7828 : NOT_ELEMENTAL))
7829 21 : parmse.force_tmp = 1;
7830 :
7831 358 : iarg = e->value.function.actual->expr;
7832 :
7833 : /* Temporary needed if aliasing due to host association. */
7834 358 : if (sym->attr.contained
7835 114 : && !sym->attr.pure
7836 114 : && !sym->attr.implicit_pure
7837 36 : && !sym->attr.use_assoc
7838 36 : && iarg->expr_type == EXPR_VARIABLE
7839 36 : && sym->ns == iarg->symtree->n.sym->ns)
7840 36 : parmse.force_tmp = 1;
7841 :
7842 : /* Ditto within module. */
7843 358 : if (sym->attr.use_assoc
7844 6 : && !sym->attr.pure
7845 6 : && !sym->attr.implicit_pure
7846 0 : && iarg->expr_type == EXPR_VARIABLE
7847 0 : && sym->module == iarg->symtree->n.sym->module)
7848 0 : parmse.force_tmp = 1;
7849 : }
7850 :
7851 : /* Special case for assumed-rank arrays: when passing an
7852 : argument to a nonallocatable/nonpointer dummy, the bounds have
7853 : to be reset as otherwise a last-dim ubound of -1 is
7854 : indistinguishable from an assumed-size array in the callee. */
7855 57442 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
7856 34472 : && fsym->as->type == AS_ASSUMED_RANK
7857 11839 : && e->rank != -1
7858 11550 : && e->expr_type == EXPR_VARIABLE
7859 11109 : && ((fsym->ts.type == BT_CLASS
7860 0 : && !CLASS_DATA (fsym)->attr.class_pointer
7861 0 : && !CLASS_DATA (fsym)->attr.allocatable)
7862 11109 : || (fsym->ts.type != BT_CLASS
7863 11109 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
7864 : {
7865 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7866 10566 : gfc_ref *ref;
7867 10812 : for (ref = e->ref; ref->next; ref = ref->next)
7868 : {
7869 318 : if (ref->next->type == REF_INQUIRY)
7870 : break;
7871 270 : if (ref->type == REF_ARRAY
7872 24 : && ref->u.ar.type != AR_ELEMENT)
7873 : break;
7874 10566 : };
7875 10566 : if (ref->u.ar.type == AR_FULL
7876 9840 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
7877 9720 : ref->u.ar.type = AR_SECTION;
7878 : }
7879 :
7880 57442 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7881 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7882 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7883 :
7884 51592 : else if (e->expr_type == EXPR_VARIABLE
7885 40236 : && is_subref_array (e)
7886 52368 : && !(fsym && fsym->attr.pointer))
7887 : /* The actual argument is a component reference to an
7888 : array of derived types. In this case, the argument
7889 : is converted to a temporary, which is passed and then
7890 : written back after the procedure call. */
7891 523 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7892 481 : fsym ? fsym->attr.intent : INTENT_INOUT,
7893 523 : fsym && fsym->attr.pointer);
7894 :
7895 51069 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
7896 345 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
7897 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
7898 : /* An assumed size class actual argument being passed to
7899 : a 'no descriptor' formal argument just requires the
7900 : data pointer to be passed. For class dummy arguments
7901 : this is stored in the symbol backend decl.. */
7902 6 : parmse.expr = e->symtree->n.sym->backend_decl;
7903 :
7904 51063 : else if (gfc_is_class_array_ref (e, NULL)
7905 51063 : && fsym && fsym->ts.type == BT_DERIVED)
7906 : /* The actual argument is a component reference to an
7907 : array of derived types. In this case, the argument
7908 : is converted to a temporary, which is passed and then
7909 : written back after the procedure call.
7910 : OOP-TODO: Insert code so that if the dynamic type is
7911 : the same as the declared type, copy-in/copy-out does
7912 : not occur. */
7913 108 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7914 108 : fsym->attr.intent,
7915 108 : fsym->attr.pointer);
7916 :
7917 50955 : else if (gfc_is_class_array_function (e)
7918 50955 : && fsym && fsym->ts.type == BT_DERIVED)
7919 : /* See previous comment. For function actual argument,
7920 : the write out is not needed so the intent is set as
7921 : intent in. */
7922 : {
7923 13 : e->must_finalize = 1;
7924 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7925 13 : INTENT_IN, fsym->attr.pointer);
7926 : }
7927 47381 : else if (fsym && fsym->attr.contiguous
7928 60 : && (fsym->attr.target
7929 1677 : ? gfc_is_not_contiguous (e)
7930 1617 : : !gfc_is_simply_contiguous (e, false, true))
7931 52934 : && gfc_expr_is_variable (e))
7932 : {
7933 303 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7934 303 : fsym->attr.intent,
7935 303 : fsym->attr.pointer);
7936 : }
7937 : else
7938 : /* This is where we introduce a temporary to store the
7939 : result of a non-lvalue array expression. */
7940 50639 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
7941 : sym->name, NULL);
7942 :
7943 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7944 : allocated on entry, it must be deallocated.
7945 : CFI descriptors are handled elsewhere. */
7946 53839 : if (fsym && fsym->attr.allocatable
7947 1747 : && fsym->attr.intent == INTENT_OUT
7948 57217 : && !is_CFI_desc (fsym, NULL))
7949 : {
7950 157 : if (fsym->ts.type == BT_DERIVED
7951 45 : && fsym->ts.u.derived->attr.alloc_comp)
7952 : {
7953 : // deallocate the components first
7954 9 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
7955 : parmse.expr, e->rank);
7956 : /* But check whether dummy argument is optional. */
7957 9 : if (tmp != NULL_TREE
7958 9 : && fsym->attr.optional
7959 6 : && e->expr_type == EXPR_VARIABLE
7960 6 : && e->symtree->n.sym->attr.optional)
7961 : {
7962 6 : tree present;
7963 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
7964 6 : tmp = build3_v (COND_EXPR, present, tmp,
7965 : build_empty_stmt (input_location));
7966 : }
7967 9 : if (tmp != NULL_TREE)
7968 9 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7969 : }
7970 :
7971 157 : tmp = parmse.expr;
7972 : /* With bind(C), the actual argument is replaced by a bind-C
7973 : descriptor; in this case, the data component arrives here,
7974 : which shall not be dereferenced, but still freed and
7975 : nullified. */
7976 157 : if (TREE_TYPE(tmp) != pvoid_type_node)
7977 157 : tmp = build_fold_indirect_ref_loc (input_location,
7978 : parmse.expr);
7979 157 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7980 : NULL_TREE, NULL_TREE, true,
7981 : e,
7982 : GFC_CAF_COARRAY_NOCOARRAY);
7983 157 : if (fsym->attr.optional
7984 48 : && e->expr_type == EXPR_VARIABLE
7985 48 : && e->symtree->n.sym->attr.optional)
7986 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
7987 : void_type_node,
7988 24 : gfc_conv_expr_present (e->symtree->n.sym),
7989 : tmp, build_empty_stmt (input_location));
7990 157 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7991 : }
7992 : }
7993 : }
7994 : /* Special case for an assumed-rank dummy argument. */
7995 268552 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
7996 55641 : && (fsym->ts.type == BT_CLASS
7997 55641 : ? (CLASS_DATA (fsym)->as
7998 4300 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7999 51341 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8000 : {
8001 12689 : if (fsym->ts.type == BT_CLASS
8002 12689 : ? (CLASS_DATA (fsym)->attr.class_pointer
8003 1055 : || CLASS_DATA (fsym)->attr.allocatable)
8004 11634 : : (fsym->attr.pointer || fsym->attr.allocatable))
8005 : {
8006 : /* Unallocated allocatable arrays and unassociated pointer
8007 : arrays need their dtype setting if they are argument
8008 : associated with assumed rank dummies to set the rank. */
8009 891 : set_dtype_for_unallocated (&parmse, e);
8010 : }
8011 11798 : else if (e->expr_type == EXPR_VARIABLE
8012 11319 : && e->symtree->n.sym->attr.dummy
8013 698 : && (e->ts.type == BT_CLASS
8014 891 : ? (e->ref && e->ref->next
8015 193 : && e->ref->next->type == REF_ARRAY
8016 193 : && e->ref->next->u.ar.type == AR_FULL
8017 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8018 505 : : (e->ref && e->ref->type == REF_ARRAY
8019 505 : && e->ref->u.ar.type == AR_FULL
8020 733 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8021 : {
8022 : /* Assumed-size actual to assumed-rank dummy requires
8023 : dim[rank-1].ubound = -1. */
8024 180 : tree minus_one;
8025 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8026 180 : if (fsym->ts.type == BT_CLASS)
8027 60 : tmp = gfc_class_data_get (tmp);
8028 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8029 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8030 180 : gfc_rank_cst[e->rank - 1],
8031 : minus_one);
8032 : }
8033 : }
8034 :
8035 : /* The case with fsym->attr.optional is that of a user subroutine
8036 : with an interface indicating an optional argument. When we call
8037 : an intrinsic subroutine, however, fsym is NULL, but we might still
8038 : have an optional argument, so we proceed to the substitution
8039 : just in case. Arguments passed to bind(c) procedures via CFI
8040 : descriptors are handled elsewhere. */
8041 255594 : if (e && (fsym == NULL || fsym->attr.optional)
8042 328935 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8043 : {
8044 : /* If an optional argument is itself an optional dummy argument,
8045 : check its presence and substitute a null if absent. This is
8046 : only needed when passing an array to an elemental procedure
8047 : as then array elements are accessed - or no NULL pointer is
8048 : allowed and a "1" or "0" should be passed if not present.
8049 : When passing a non-array-descriptor full array to a
8050 : non-array-descriptor dummy, no check is needed. For
8051 : array-descriptor actual to array-descriptor dummy, see
8052 : PR 41911 for why a check has to be inserted.
8053 : fsym == NULL is checked as intrinsics required the descriptor
8054 : but do not always set fsym.
8055 : Also, it is necessary to pass a NULL pointer to library routines
8056 : which usually ignore optional arguments, so they can handle
8057 : these themselves. */
8058 59289 : if (e->expr_type == EXPR_VARIABLE
8059 26413 : && e->symtree->n.sym->attr.optional
8060 2421 : && (((e->rank != 0 && elemental_proc)
8061 2246 : || e->representation.length || e->ts.type == BT_CHARACTER
8062 2020 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8063 1910 : || (e->rank != 0
8064 1070 : && (fsym == NULL
8065 1034 : || (fsym->as
8066 272 : && (fsym->as->type == AS_ASSUMED_SHAPE
8067 235 : || fsym->as->type == AS_ASSUMED_RANK
8068 117 : || fsym->as->type == AS_DEFERRED)))))
8069 1685 : || se->ignore_optional))
8070 764 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8071 764 : e->representation.length);
8072 : }
8073 :
8074 : /* Make the class container for the first argument available with class
8075 : valued transformational functions. */
8076 268552 : if (argc == 0 && e && e->ts.type == BT_CLASS
8077 4922 : && isym && isym->transformational
8078 84 : && se->ss && se->ss->info)
8079 : {
8080 84 : arg1_cntnr = parmse.expr;
8081 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8082 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8083 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8084 84 : se->ss->info->class_container = arg1_cntnr;
8085 : }
8086 :
8087 : /* Obtain the character length of an assumed character length procedure
8088 : from the typespec of the actual argument. */
8089 268552 : if (e
8090 255594 : && parmse.string_length == NULL_TREE
8091 220169 : && e->ts.type == BT_PROCEDURE
8092 1875 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8093 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8094 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8095 : {
8096 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8097 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8098 : }
8099 :
8100 268552 : if (fsym && e)
8101 : {
8102 : /* Obtain the character length for a NULL() actual with a character
8103 : MOLD argument. Otherwise substitute a suitable dummy length.
8104 : Here we handle non-optional dummies of non-bind(c) procedures. */
8105 223730 : if (e->expr_type == EXPR_NULL
8106 745 : && fsym->ts.type == BT_CHARACTER
8107 296 : && !fsym->attr.optional
8108 223948 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8109 216 : conv_null_actual (&parmse, e, fsym);
8110 : }
8111 :
8112 : /* If any actual argument of the procedure is allocatable and passed
8113 : to an allocatable dummy with INTENT(OUT), we conservatively
8114 : evaluate actual argument expressions before deallocations are
8115 : performed and the procedure is executed. May create temporaries.
8116 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8117 255594 : if (e && fsym && force_eval_args
8118 1103 : && fsym->attr.intent != INTENT_OUT
8119 268961 : && !gfc_is_constant_expr (e))
8120 268 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8121 :
8122 268552 : if (fsym && need_interface_mapping && e)
8123 40130 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8124 :
8125 268552 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8126 268552 : gfc_add_block_to_block (&post, &parmse.post);
8127 268552 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8128 :
8129 : /* Allocated allocatable components of derived types must be
8130 : deallocated for non-variable scalars, array arguments to elemental
8131 : procedures, and array arguments with descriptor to non-elemental
8132 : procedures. As bounds information for descriptorless arrays is no
8133 : longer available here, they are dealt with in trans-array.cc
8134 : (gfc_conv_array_parameter). */
8135 255594 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8136 27612 : && e->ts.u.derived->attr.alloc_comp
8137 7500 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8138 275920 : && !expr_may_alias_variables (e, elemental_proc))
8139 : {
8140 354 : int parm_rank;
8141 : /* It is known the e returns a structure type with at least one
8142 : allocatable component. When e is a function, ensure that the
8143 : function is called once only by using a temporary variable. */
8144 354 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8145 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8146 : parmse.expr, &se->pre);
8147 :
8148 354 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8149 140 : tmp = parmse.expr;
8150 : else
8151 214 : tmp = build_fold_indirect_ref_loc (input_location,
8152 : parmse.expr);
8153 :
8154 354 : parm_rank = e->rank;
8155 354 : switch (parm_kind)
8156 : {
8157 : case (ELEMENTAL):
8158 : case (SCALAR):
8159 354 : parm_rank = 0;
8160 : break;
8161 :
8162 0 : case (SCALAR_POINTER):
8163 0 : tmp = build_fold_indirect_ref_loc (input_location,
8164 : tmp);
8165 0 : break;
8166 : }
8167 :
8168 354 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8169 : {
8170 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8171 : Therefore, class actuals can be handled correctly but derived
8172 : types passed to class formals need the _data component. */
8173 82 : tmp = gfc_class_data_get (tmp);
8174 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8175 : {
8176 56 : if (UNLIMITED_POLY (fsym))
8177 : {
8178 12 : tree type = gfc_typenode_for_spec (&e->ts);
8179 12 : type = build_pointer_type (type);
8180 12 : tmp = fold_convert (type, tmp);
8181 : }
8182 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8183 : }
8184 : }
8185 :
8186 354 : if (e->expr_type == EXPR_OP
8187 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8188 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8189 : {
8190 24 : tree local_tmp;
8191 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8192 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8193 : parm_rank, 0);
8194 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8195 : }
8196 :
8197 : /* Items of array expressions passed to a polymorphic formal arguments
8198 : create their own clean up, so prevent double free. */
8199 354 : if (!finalized && !e->must_finalize
8200 353 : && !(e->expr_type == EXPR_ARRAY && fsym
8201 74 : && fsym->ts.type == BT_CLASS))
8202 : {
8203 333 : bool scalar_res_outside_loop;
8204 987 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8205 151 : && parm_rank == 0
8206 472 : && parmse.loop;
8207 :
8208 : /* Scalars passed to an assumed rank argument are converted to
8209 : a descriptor. Obtain the data field before deallocating any
8210 : allocatable components. */
8211 292 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8212 588 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8213 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8214 :
8215 333 : if (scalar_res_outside_loop)
8216 : {
8217 : /* Go through the ss chain to find the argument and use
8218 : the stored value. */
8219 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8220 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8221 60 : if (tmp_ss->info
8222 48 : && tmp_ss->info->expr == e
8223 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8224 : {
8225 18 : tmp = tmp_ss->info->data.scalar.value;
8226 18 : break;
8227 : }
8228 : }
8229 :
8230 333 : STRIP_NOPS (tmp);
8231 :
8232 333 : if (derived_array != NULL_TREE)
8233 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8234 : derived_array,
8235 : parm_rank);
8236 333 : else if ((e->ts.type == BT_CLASS
8237 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8238 333 : || e->ts.type == BT_DERIVED)
8239 333 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8240 : parm_rank, 0, true);
8241 0 : else if (e->ts.type == BT_CLASS)
8242 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8243 : tmp, parm_rank);
8244 :
8245 333 : if (scalar_res_outside_loop)
8246 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8247 : else
8248 303 : gfc_prepend_expr_to_block (&post, tmp);
8249 : }
8250 : }
8251 :
8252 : /* Add argument checking of passing an unallocated/NULL actual to
8253 : a nonallocatable/nonpointer dummy. */
8254 :
8255 268552 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8256 : {
8257 6546 : symbol_attribute attr;
8258 6546 : char *msg;
8259 6546 : tree cond;
8260 6546 : tree tmp;
8261 6546 : symbol_attribute fsym_attr;
8262 :
8263 6546 : if (fsym)
8264 : {
8265 6385 : if (fsym->ts.type == BT_CLASS)
8266 : {
8267 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8268 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8269 : }
8270 : else
8271 6064 : fsym_attr = fsym->attr;
8272 : }
8273 :
8274 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8275 4094 : attr = gfc_expr_attr (e);
8276 : else
8277 6081 : goto end_pointer_check;
8278 :
8279 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8280 : allocatable to an optional dummy, cf. 12.5.2.12. */
8281 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8282 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8283 1032 : goto end_pointer_check;
8284 :
8285 3062 : if (attr.optional)
8286 : {
8287 : /* If the actual argument is an optional pointer/allocatable and
8288 : the formal argument takes an nonpointer optional value,
8289 : it is invalid to pass a non-present argument on, even
8290 : though there is no technical reason for this in gfortran.
8291 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8292 60 : tree present, null_ptr, type;
8293 :
8294 60 : if (attr.allocatable
8295 0 : && (fsym == NULL || !fsym_attr.allocatable))
8296 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8297 : "allocated or not present",
8298 0 : e->symtree->n.sym->name);
8299 60 : else if (attr.pointer
8300 12 : && (fsym == NULL || !fsym_attr.pointer))
8301 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8302 : "associated or not present",
8303 12 : e->symtree->n.sym->name);
8304 48 : else if (attr.proc_pointer && !e->value.function.actual
8305 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8306 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8307 : "associated or not present",
8308 0 : e->symtree->n.sym->name);
8309 : else
8310 48 : goto end_pointer_check;
8311 :
8312 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8313 12 : type = TREE_TYPE (present);
8314 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8315 : logical_type_node, present,
8316 : fold_convert (type,
8317 : null_pointer_node));
8318 12 : type = TREE_TYPE (parmse.expr);
8319 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8320 : logical_type_node, parmse.expr,
8321 : fold_convert (type,
8322 : null_pointer_node));
8323 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8324 : logical_type_node, present, null_ptr);
8325 : }
8326 : else
8327 : {
8328 3002 : if (attr.allocatable
8329 256 : && (fsym == NULL || !fsym_attr.allocatable))
8330 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8331 190 : "allocated", e->symtree->n.sym->name);
8332 2812 : else if (attr.pointer
8333 272 : && (fsym == NULL || !fsym_attr.pointer))
8334 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8335 184 : "associated", e->symtree->n.sym->name);
8336 2628 : else if (attr.proc_pointer && !e->value.function.actual
8337 80 : && (fsym == NULL
8338 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8339 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8340 79 : "associated", e->symtree->n.sym->name);
8341 : else
8342 2549 : goto end_pointer_check;
8343 :
8344 453 : tmp = parmse.expr;
8345 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8346 : {
8347 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8348 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8349 76 : tmp = gfc_class_data_get (tmp);
8350 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8351 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8352 : }
8353 :
8354 : /* If the argument is passed by value, we need to strip the
8355 : INDIRECT_REF. */
8356 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8357 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8358 :
8359 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8360 : logical_type_node, tmp,
8361 453 : fold_convert (TREE_TYPE (tmp),
8362 : null_pointer_node));
8363 : }
8364 :
8365 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8366 : msg);
8367 465 : free (msg);
8368 : }
8369 262006 : end_pointer_check:
8370 :
8371 : /* Deferred length dummies pass the character length by reference
8372 : so that the value can be returned. */
8373 268552 : if (parmse.string_length && fsym && fsym->ts.deferred)
8374 : {
8375 794 : if (INDIRECT_REF_P (parmse.string_length))
8376 : {
8377 : /* In chains of functions/procedure calls the string_length already
8378 : is a pointer to the variable holding the length. Therefore
8379 : remove the deref on call. */
8380 90 : tmp = parmse.string_length;
8381 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8382 : }
8383 : else
8384 : {
8385 704 : tmp = parmse.string_length;
8386 704 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8387 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8388 704 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8389 : }
8390 :
8391 794 : if (e && e->expr_type == EXPR_VARIABLE
8392 637 : && fsym->attr.allocatable
8393 367 : && e->ts.u.cl->backend_decl
8394 367 : && VAR_P (e->ts.u.cl->backend_decl))
8395 : {
8396 283 : if (INDIRECT_REF_P (tmp))
8397 0 : tmp = TREE_OPERAND (tmp, 0);
8398 283 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8399 : fold_convert (gfc_charlen_type_node, tmp));
8400 : }
8401 : }
8402 :
8403 : /* Character strings are passed as two parameters, a length and a
8404 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8405 : An unlimited polymorphic formal argument likewise does not
8406 : need the length. */
8407 268552 : if (parmse.string_length != NULL_TREE
8408 36823 : && !sym->attr.is_bind_c
8409 36127 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8410 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8411 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8412 30247 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8413 30138 : && !(fsym && UNLIMITED_POLY (fsym)))
8414 35837 : vec_safe_push (stringargs, parmse.string_length);
8415 :
8416 : /* When calling __copy for character expressions to unlimited
8417 : polymorphic entities, the dst argument needs a string length. */
8418 51450 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8419 5321 : && startswith (sym->name, "__vtab_CHARACTER")
8420 0 : && arg->next && arg->next->expr
8421 0 : && (arg->next->expr->ts.type == BT_DERIVED
8422 0 : || arg->next->expr->ts.type == BT_CLASS)
8423 268552 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8424 0 : vec_safe_push (stringargs, parmse.string_length);
8425 :
8426 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8427 : pass the token and the offset as additional arguments. */
8428 268552 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8429 122 : && attr->codimension && !attr->allocatable)
8430 : {
8431 : /* Token and offset. */
8432 5 : vec_safe_push (stringargs, null_pointer_node);
8433 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8434 5 : gcc_assert (fsym->attr.optional);
8435 : }
8436 235625 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8437 145 : && !attr->allocatable)
8438 : {
8439 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8440 123 : tree offset, tmp2;
8441 :
8442 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8443 123 : caf_type = TREE_TYPE (caf_decl);
8444 123 : if (POINTER_TYPE_P (caf_type)
8445 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8446 3 : caf_desc = TREE_TYPE (caf_type);
8447 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8448 : caf_desc = caf_type;
8449 :
8450 51 : if (caf_desc
8451 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8452 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8453 : {
8454 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8455 54 : ? build_fold_indirect_ref (caf_decl)
8456 : : caf_decl;
8457 51 : tmp = gfc_conv_descriptor_token (tmp);
8458 : }
8459 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8460 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8461 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8462 : else
8463 : {
8464 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8465 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8466 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8467 : }
8468 :
8469 123 : vec_safe_push (stringargs, tmp);
8470 :
8471 123 : if (caf_desc
8472 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8473 51 : offset = build_int_cst (gfc_array_index_type, 0);
8474 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8475 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8476 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8477 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8478 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8479 : else
8480 60 : offset = build_int_cst (gfc_array_index_type, 0);
8481 :
8482 123 : if (caf_desc)
8483 : {
8484 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8485 54 : ? build_fold_indirect_ref (caf_decl)
8486 : : caf_decl;
8487 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8488 : }
8489 : else
8490 : {
8491 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8492 72 : tmp = caf_decl;
8493 : }
8494 :
8495 108 : tmp2 = fsym->ts.type == BT_CLASS
8496 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8497 123 : if ((fsym->ts.type != BT_CLASS
8498 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8499 59 : || fsym->as->type == AS_ASSUMED_RANK))
8500 74 : || (fsym->ts.type == BT_CLASS
8501 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8502 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8503 : {
8504 54 : if (fsym->ts.type == BT_CLASS)
8505 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8506 : else
8507 : {
8508 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8509 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8510 : }
8511 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8512 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8513 : }
8514 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8515 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8516 : else
8517 : {
8518 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8519 : }
8520 :
8521 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8522 : gfc_array_index_type,
8523 : fold_convert (gfc_array_index_type, tmp2),
8524 : fold_convert (gfc_array_index_type, tmp));
8525 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8526 : gfc_array_index_type, offset, tmp);
8527 :
8528 123 : vec_safe_push (stringargs, offset);
8529 : }
8530 :
8531 268552 : vec_safe_push (arglist, parmse.expr);
8532 : }
8533 :
8534 129004 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8535 129004 : gfc_add_block_to_block (&se->pre, &clobbers);
8536 129004 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8537 :
8538 129004 : if (comp)
8539 1971 : ts = comp->ts;
8540 127033 : else if (sym->ts.type == BT_CLASS)
8541 849 : ts = CLASS_DATA (sym)->ts;
8542 : else
8543 126184 : ts = sym->ts;
8544 :
8545 129004 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8546 186 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8547 128818 : else if (ts.type == BT_CHARACTER)
8548 : {
8549 4982 : if (ts.u.cl->length == NULL)
8550 : {
8551 : /* Assumed character length results are not allowed by C418 of the 2003
8552 : standard and are trapped in resolve.cc; except in the case of SPREAD
8553 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8554 : we take the character length of the first argument for the result.
8555 : For dummies, we have to look through the formal argument list for
8556 : this function and use the character length found there.
8557 : Likewise, we handle the case of deferred-length character dummy
8558 : arguments to intrinsics that determine the characteristics of
8559 : the result, which cannot be deferred-length. */
8560 2300 : if (expr->value.function.isym)
8561 1701 : ts.deferred = false;
8562 2300 : if (ts.deferred)
8563 592 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8564 1708 : else if (!sym->attr.dummy)
8565 1701 : cl.backend_decl = (*stringargs)[0];
8566 : else
8567 : {
8568 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8569 26 : for (; formal; formal = formal->next)
8570 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8571 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8572 : }
8573 2300 : len = cl.backend_decl;
8574 : }
8575 : else
8576 : {
8577 2682 : tree tmp;
8578 :
8579 : /* Calculate the length of the returned string. */
8580 2682 : gfc_init_se (&parmse, NULL);
8581 2682 : if (need_interface_mapping)
8582 1867 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8583 : else
8584 815 : gfc_conv_expr (&parmse, ts.u.cl->length);
8585 2682 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8586 2682 : gfc_add_block_to_block (&se->post, &parmse.post);
8587 2682 : tmp = parmse.expr;
8588 : /* TODO: It would be better to have the charlens as
8589 : gfc_charlen_type_node already when the interface is
8590 : created instead of converting it here (see PR 84615). */
8591 2682 : tmp = fold_build2_loc (input_location, MAX_EXPR,
8592 : gfc_charlen_type_node,
8593 : fold_convert (gfc_charlen_type_node, tmp),
8594 : build_zero_cst (gfc_charlen_type_node));
8595 2682 : cl.backend_decl = tmp;
8596 : }
8597 :
8598 : /* Set up a charlen structure for it. */
8599 4982 : cl.next = NULL;
8600 4982 : cl.length = NULL;
8601 4982 : ts.u.cl = &cl;
8602 :
8603 4982 : len = cl.backend_decl;
8604 : }
8605 :
8606 1971 : byref = (comp && (comp->attr.dimension
8607 1902 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
8608 129004 : || (!comp && gfc_return_by_reference (sym));
8609 :
8610 18590 : if (byref)
8611 : {
8612 18590 : if (se->direct_byref)
8613 : {
8614 : /* Sometimes, too much indirection can be applied; e.g. for
8615 : function_result = array_valued_recursive_function. */
8616 6962 : if (TREE_TYPE (TREE_TYPE (se->expr))
8617 6962 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
8618 6980 : && GFC_DESCRIPTOR_TYPE_P
8619 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
8620 18 : se->expr = build_fold_indirect_ref_loc (input_location,
8621 : se->expr);
8622 :
8623 : /* If the lhs of an assignment x = f(..) is allocatable and
8624 : f2003 is allowed, we must do the automatic reallocation.
8625 : TODO - deal with intrinsics, without using a temporary. */
8626 6962 : if (flag_realloc_lhs
8627 6887 : && se->ss && se->ss->loop_chain
8628 167 : && se->ss->loop_chain->is_alloc_lhs
8629 167 : && !expr->value.function.isym
8630 167 : && sym->result->as != NULL)
8631 : {
8632 : /* Evaluate the bounds of the result, if known. */
8633 167 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
8634 : sym->result->as);
8635 :
8636 : /* Perform the automatic reallocation. */
8637 167 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
8638 : expr, NULL);
8639 167 : gfc_add_expr_to_block (&se->pre, tmp);
8640 :
8641 : /* Pass the temporary as the first argument. */
8642 167 : result = info->descriptor;
8643 : }
8644 : else
8645 6795 : result = build_fold_indirect_ref_loc (input_location,
8646 : se->expr);
8647 6962 : vec_safe_push (retargs, se->expr);
8648 : }
8649 11628 : else if (comp && comp->attr.dimension)
8650 : {
8651 66 : gcc_assert (se->loop && info);
8652 :
8653 : /* Set the type of the array. vtable charlens are not always reliable.
8654 : Use the interface, if possible. */
8655 66 : if (comp->ts.type == BT_CHARACTER
8656 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
8657 1 : && comp->ts.interface && comp->ts.interface->result)
8658 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
8659 : else
8660 65 : tmp = gfc_typenode_for_spec (&comp->ts);
8661 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
8662 :
8663 : /* Evaluate the bounds of the result, if known. */
8664 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
8665 :
8666 : /* If the lhs of an assignment x = f(..) is allocatable and
8667 : f2003 is allowed, we must not generate the function call
8668 : here but should just send back the results of the mapping.
8669 : This is signalled by the function ss being flagged. */
8670 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8671 : {
8672 0 : gfc_free_interface_mapping (&mapping);
8673 0 : return has_alternate_specifier;
8674 : }
8675 :
8676 : /* Create a temporary to store the result. In case the function
8677 : returns a pointer, the temporary will be a shallow copy and
8678 : mustn't be deallocated. */
8679 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
8680 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8681 : tmp, NULL_TREE, false,
8682 : !comp->attr.pointer, callee_alloc,
8683 66 : &se->ss->info->expr->where);
8684 :
8685 : /* Pass the temporary as the first argument. */
8686 66 : result = info->descriptor;
8687 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8688 66 : vec_safe_push (retargs, tmp);
8689 : }
8690 11333 : else if (!comp && sym->result->attr.dimension)
8691 : {
8692 8340 : gcc_assert (se->loop && info);
8693 :
8694 : /* Set the type of the array. */
8695 8340 : tmp = gfc_typenode_for_spec (&ts);
8696 8340 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
8697 8340 : gcc_assert (se->ss->dimen == se->loop->dimen);
8698 :
8699 : /* Evaluate the bounds of the result, if known. */
8700 8340 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
8701 :
8702 : /* If the lhs of an assignment x = f(..) is allocatable and
8703 : f2003 is allowed, we must not generate the function call
8704 : here but should just send back the results of the mapping.
8705 : This is signalled by the function ss being flagged. */
8706 8340 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8707 : {
8708 0 : gfc_free_interface_mapping (&mapping);
8709 0 : return has_alternate_specifier;
8710 : }
8711 :
8712 : /* Create a temporary to store the result. In case the function
8713 : returns a pointer, the temporary will be a shallow copy and
8714 : mustn't be deallocated. */
8715 8340 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
8716 8340 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8717 : tmp, NULL_TREE, false,
8718 : !sym->attr.pointer, callee_alloc,
8719 8340 : &se->ss->info->expr->where);
8720 :
8721 : /* Pass the temporary as the first argument. */
8722 8340 : result = info->descriptor;
8723 8340 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8724 8340 : vec_safe_push (retargs, tmp);
8725 : }
8726 3222 : else if (ts.type == BT_CHARACTER)
8727 : {
8728 : /* Pass the string length. */
8729 3161 : type = gfc_get_character_type (ts.kind, ts.u.cl);
8730 3161 : type = build_pointer_type (type);
8731 :
8732 : /* Emit a DECL_EXPR for the VLA type. */
8733 3161 : tmp = TREE_TYPE (type);
8734 3161 : if (TYPE_SIZE (tmp)
8735 3161 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
8736 : {
8737 1922 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
8738 1922 : DECL_ARTIFICIAL (tmp) = 1;
8739 1922 : DECL_IGNORED_P (tmp) = 1;
8740 1922 : tmp = fold_build1_loc (input_location, DECL_EXPR,
8741 1922 : TREE_TYPE (tmp), tmp);
8742 1922 : gfc_add_expr_to_block (&se->pre, tmp);
8743 : }
8744 :
8745 : /* Return an address to a char[0:len-1]* temporary for
8746 : character pointers. */
8747 3161 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8748 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8749 : {
8750 635 : var = gfc_create_var (type, "pstr");
8751 :
8752 635 : if ((!comp && sym->attr.allocatable)
8753 21 : || (comp && comp->attr.allocatable))
8754 : {
8755 348 : gfc_add_modify (&se->pre, var,
8756 348 : fold_convert (TREE_TYPE (var),
8757 : null_pointer_node));
8758 348 : tmp = gfc_call_free (var);
8759 348 : gfc_add_expr_to_block (&se->post, tmp);
8760 : }
8761 :
8762 : /* Provide an address expression for the function arguments. */
8763 635 : var = gfc_build_addr_expr (NULL_TREE, var);
8764 : }
8765 : else
8766 2526 : var = gfc_conv_string_tmp (se, type, len);
8767 :
8768 3161 : vec_safe_push (retargs, var);
8769 : }
8770 : else
8771 : {
8772 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
8773 :
8774 61 : type = gfc_get_complex_type (ts.kind);
8775 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
8776 61 : vec_safe_push (retargs, var);
8777 : }
8778 :
8779 : /* Add the string length to the argument list. */
8780 18590 : if (ts.type == BT_CHARACTER && ts.deferred)
8781 : {
8782 592 : tmp = len;
8783 592 : if (!VAR_P (tmp))
8784 0 : tmp = gfc_evaluate_now (len, &se->pre);
8785 592 : TREE_STATIC (tmp) = 1;
8786 592 : gfc_add_modify (&se->pre, tmp,
8787 592 : build_int_cst (TREE_TYPE (tmp), 0));
8788 592 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8789 592 : vec_safe_push (retargs, tmp);
8790 : }
8791 17998 : else if (ts.type == BT_CHARACTER)
8792 4390 : vec_safe_push (retargs, len);
8793 : }
8794 :
8795 129004 : gfc_free_interface_mapping (&mapping);
8796 :
8797 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
8798 240311 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
8799 154290 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
8800 129004 : vec_safe_reserve (retargs, arglen);
8801 :
8802 : /* Add the return arguments. */
8803 129004 : vec_safe_splice (retargs, arglist);
8804 :
8805 : /* Add the hidden present status for optional+value to the arguments. */
8806 129004 : vec_safe_splice (retargs, optionalargs);
8807 :
8808 : /* Add the hidden string length parameters to the arguments. */
8809 129004 : vec_safe_splice (retargs, stringargs);
8810 :
8811 : /* We may want to append extra arguments here. This is used e.g. for
8812 : calls to libgfortran_matmul_??, which need extra information. */
8813 129004 : vec_safe_splice (retargs, append_args);
8814 :
8815 129004 : arglist = retargs;
8816 :
8817 : /* Generate the actual call. */
8818 129004 : is_builtin = false;
8819 129004 : if (base_object == NULL_TREE)
8820 128924 : conv_function_val (se, &is_builtin, sym, expr, args);
8821 : else
8822 80 : conv_base_obj_fcn_val (se, base_object, expr);
8823 :
8824 : /* If there are alternate return labels, function type should be
8825 : integer. Can't modify the type in place though, since it can be shared
8826 : with other functions. For dummy arguments, the typing is done to
8827 : this result, even if it has to be repeated for each call. */
8828 129004 : if (has_alternate_specifier
8829 129004 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
8830 : {
8831 7 : if (!sym->attr.dummy)
8832 : {
8833 0 : TREE_TYPE (sym->backend_decl)
8834 0 : = build_function_type (integer_type_node,
8835 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
8836 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
8837 : }
8838 : else
8839 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
8840 : }
8841 :
8842 129004 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
8843 129004 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
8844 :
8845 129004 : if (is_builtin)
8846 522 : se->expr = update_builtin_function (se->expr, sym);
8847 :
8848 : /* Allocatable scalar function results must be freed and nullified
8849 : after use. This necessitates the creation of a temporary to
8850 : hold the result to prevent duplicate calls. */
8851 129004 : symbol_attribute attr = comp ? comp->attr : sym->attr;
8852 129004 : bool allocatable = attr.allocatable && !attr.dimension;
8853 132150 : gfc_symbol *der = comp ?
8854 1971 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
8855 : :
8856 127033 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
8857 3146 : bool finalizable = der != NULL && der->ns->proc_name
8858 6289 : && gfc_is_finalizable (der, NULL);
8859 :
8860 129004 : if (!byref && finalizable)
8861 182 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8862 :
8863 129004 : if (!byref && sym->ts.type != BT_CHARACTER
8864 110228 : && allocatable && !finalizable)
8865 : {
8866 230 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
8867 230 : gfc_add_modify (&se->pre, tmp, se->expr);
8868 230 : se->expr = tmp;
8869 230 : tmp = gfc_call_free (tmp);
8870 230 : gfc_add_expr_to_block (&post, tmp);
8871 230 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
8872 : }
8873 :
8874 : /* If we have a pointer function, but we don't want a pointer, e.g.
8875 : something like
8876 : x = f()
8877 : where f is pointer valued, we have to dereference the result. */
8878 129004 : if (!se->want_pointer && !byref
8879 109824 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8880 1629 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
8881 450 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8882 :
8883 : /* f2c calling conventions require a scalar default real function to
8884 : return a double precision result. Convert this back to default
8885 : real. We only care about the cases that can happen in Fortran 77.
8886 : */
8887 129004 : if (flag_f2c && sym->ts.type == BT_REAL
8888 97 : && sym->ts.kind == gfc_default_real_kind
8889 73 : && !sym->attr.pointer
8890 54 : && !sym->attr.allocatable
8891 42 : && !sym->attr.always_explicit)
8892 42 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
8893 :
8894 : /* A pure function may still have side-effects - it may modify its
8895 : parameters. */
8896 129004 : TREE_SIDE_EFFECTS (se->expr) = 1;
8897 : #if 0
8898 : if (!sym->attr.pure)
8899 : TREE_SIDE_EFFECTS (se->expr) = 1;
8900 : #endif
8901 :
8902 129004 : if (byref)
8903 : {
8904 : /* Add the function call to the pre chain. There is no expression. */
8905 18590 : gfc_add_expr_to_block (&se->pre, se->expr);
8906 18590 : se->expr = NULL_TREE;
8907 :
8908 18590 : if (!se->direct_byref)
8909 : {
8910 11628 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
8911 : {
8912 8406 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
8913 : {
8914 : /* Check the data pointer hasn't been modified. This would
8915 : happen in a function returning a pointer. */
8916 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
8917 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
8918 : logical_type_node,
8919 : tmp, info->data);
8920 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
8921 : gfc_msg_fault);
8922 : }
8923 8406 : se->expr = info->descriptor;
8924 : /* Bundle in the string length. */
8925 8406 : se->string_length = len;
8926 :
8927 8406 : if (finalizable)
8928 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8929 : }
8930 3222 : else if (ts.type == BT_CHARACTER)
8931 : {
8932 : /* Dereference for character pointer results. */
8933 3161 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8934 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8935 635 : se->expr = build_fold_indirect_ref_loc (input_location, var);
8936 : else
8937 2526 : se->expr = var;
8938 :
8939 3161 : se->string_length = len;
8940 : }
8941 : else
8942 : {
8943 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
8944 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
8945 : }
8946 : }
8947 : }
8948 :
8949 : /* Associate the rhs class object's meta-data with the result, when the
8950 : result is a temporary. */
8951 111312 : if (args && args->expr && args->expr->ts.type == BT_CLASS
8952 4922 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
8953 129036 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
8954 : {
8955 32 : gfc_se parmse;
8956 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
8957 :
8958 32 : gfc_init_se (&parmse, NULL);
8959 32 : parmse.data_not_needed = 1;
8960 32 : gfc_conv_expr (&parmse, class_expr);
8961 32 : if (!DECL_LANG_SPECIFIC (result))
8962 32 : gfc_allocate_lang_decl (result);
8963 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
8964 32 : gfc_free_expr (class_expr);
8965 : /* -fcheck= can add diagnostic code, which has to be placed before
8966 : the call. */
8967 32 : if (parmse.pre.head != NULL)
8968 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
8969 32 : gcc_assert (parmse.post.head == NULL_TREE);
8970 : }
8971 :
8972 : /* Follow the function call with the argument post block. */
8973 129004 : if (byref)
8974 : {
8975 18590 : gfc_add_block_to_block (&se->pre, &post);
8976 :
8977 : /* Transformational functions of derived types with allocatable
8978 : components must have the result allocatable components copied when the
8979 : argument is actually given. This is unnecessry for REDUCE because the
8980 : wrapper for the OPERATION function takes care of this. */
8981 18590 : arg = expr->value.function.actual;
8982 18590 : if (result && arg && expr->rank
8983 14557 : && isym && isym->transformational
8984 12988 : && isym->id != GFC_ISYM_REDUCE
8985 12862 : && arg->expr
8986 12802 : && arg->expr->ts.type == BT_DERIVED
8987 229 : && arg->expr->ts.u.derived->attr.alloc_comp)
8988 : {
8989 36 : tree tmp2;
8990 : /* Copy the allocatable components. We have to use a
8991 : temporary here to prevent source allocatable components
8992 : from being corrupted. */
8993 36 : tmp2 = gfc_evaluate_now (result, &se->pre);
8994 36 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
8995 : result, tmp2, expr->rank, 0);
8996 36 : gfc_add_expr_to_block (&se->pre, tmp);
8997 36 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
8998 : expr->rank);
8999 36 : gfc_add_expr_to_block (&se->pre, tmp);
9000 :
9001 : /* Finally free the temporary's data field. */
9002 36 : tmp = gfc_conv_descriptor_data_get (tmp2);
9003 36 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9004 : NULL_TREE, NULL_TREE, true,
9005 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9006 36 : gfc_add_expr_to_block (&se->pre, tmp);
9007 : }
9008 : }
9009 : else
9010 : {
9011 : /* For a function with a class array result, save the result as
9012 : a temporary, set the info fields needed by the scalarizer and
9013 : call the finalization function of the temporary. Note that the
9014 : nullification of allocatable components needed by the result
9015 : is done in gfc_trans_assignment_1. */
9016 34344 : if (expr && (gfc_is_class_array_function (expr)
9017 34022 : || gfc_is_alloc_class_scalar_function (expr))
9018 841 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9019 111243 : && expr->must_finalize)
9020 : {
9021 : /* TODO Eliminate the doubling of temporaries. This
9022 : one is necessary to ensure no memory leakage. */
9023 321 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9024 :
9025 : /* Finalize the result, if necessary. */
9026 642 : attr = expr->value.function.esym
9027 321 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9028 14 : : CLASS_DATA (expr)->attr;
9029 321 : if (!((gfc_is_class_array_function (expr)
9030 108 : || gfc_is_alloc_class_scalar_function (expr))
9031 321 : && attr.pointer))
9032 276 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9033 : }
9034 110414 : gfc_add_block_to_block (&se->post, &post);
9035 : }
9036 :
9037 : return has_alternate_specifier;
9038 : }
9039 :
9040 :
9041 : /* Fill a character string with spaces. */
9042 :
9043 : static tree
9044 30377 : fill_with_spaces (tree start, tree type, tree size)
9045 : {
9046 30377 : stmtblock_t block, loop;
9047 30377 : tree i, el, exit_label, cond, tmp;
9048 :
9049 : /* For a simple char type, we can call memset(). */
9050 30377 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9051 50166 : return build_call_expr_loc (input_location,
9052 : builtin_decl_explicit (BUILT_IN_MEMSET),
9053 : 3, start,
9054 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9055 25083 : lang_hooks.to_target_charset (' ')),
9056 : fold_convert (size_type_node, size));
9057 :
9058 : /* Otherwise, we use a loop:
9059 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9060 : *el = (type) ' ';
9061 : */
9062 :
9063 : /* Initialize variables. */
9064 5294 : gfc_init_block (&block);
9065 5294 : i = gfc_create_var (sizetype, "i");
9066 5294 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9067 5294 : el = gfc_create_var (build_pointer_type (type), "el");
9068 5294 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9069 5294 : exit_label = gfc_build_label_decl (NULL_TREE);
9070 5294 : TREE_USED (exit_label) = 1;
9071 :
9072 :
9073 : /* Loop body. */
9074 5294 : gfc_init_block (&loop);
9075 :
9076 : /* Exit condition. */
9077 5294 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9078 : build_zero_cst (sizetype));
9079 5294 : tmp = build1_v (GOTO_EXPR, exit_label);
9080 5294 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9081 : build_empty_stmt (input_location));
9082 5294 : gfc_add_expr_to_block (&loop, tmp);
9083 :
9084 : /* Assignment. */
9085 5294 : gfc_add_modify (&loop,
9086 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9087 5294 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9088 :
9089 : /* Increment loop variables. */
9090 5294 : gfc_add_modify (&loop, i,
9091 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9092 5294 : TYPE_SIZE_UNIT (type)));
9093 5294 : gfc_add_modify (&loop, el,
9094 : fold_build_pointer_plus_loc (input_location,
9095 5294 : el, TYPE_SIZE_UNIT (type)));
9096 :
9097 : /* Making the loop... actually loop! */
9098 5294 : tmp = gfc_finish_block (&loop);
9099 5294 : tmp = build1_v (LOOP_EXPR, tmp);
9100 5294 : gfc_add_expr_to_block (&block, tmp);
9101 :
9102 : /* The exit label. */
9103 5294 : tmp = build1_v (LABEL_EXPR, exit_label);
9104 5294 : gfc_add_expr_to_block (&block, tmp);
9105 :
9106 :
9107 5294 : return gfc_finish_block (&block);
9108 : }
9109 :
9110 :
9111 : /* Generate code to copy a string. */
9112 :
9113 : void
9114 35479 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9115 : int dkind, tree slength, tree src, int skind)
9116 : {
9117 35479 : tree tmp, dlen, slen;
9118 35479 : tree dsc;
9119 35479 : tree ssc;
9120 35479 : tree cond;
9121 35479 : tree cond2;
9122 35479 : tree tmp2;
9123 35479 : tree tmp3;
9124 35479 : tree tmp4;
9125 35479 : tree chartype;
9126 35479 : stmtblock_t tempblock;
9127 :
9128 35479 : gcc_assert (dkind == skind);
9129 :
9130 35479 : if (slength != NULL_TREE)
9131 : {
9132 35479 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9133 35479 : ssc = gfc_string_to_single_character (slen, src, skind);
9134 : }
9135 : else
9136 : {
9137 0 : slen = build_one_cst (gfc_charlen_type_node);
9138 0 : ssc = src;
9139 : }
9140 :
9141 35479 : if (dlength != NULL_TREE)
9142 : {
9143 35479 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9144 35479 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9145 : }
9146 : else
9147 : {
9148 0 : dlen = build_one_cst (gfc_charlen_type_node);
9149 0 : dsc = dest;
9150 : }
9151 :
9152 : /* Assign directly if the types are compatible. */
9153 35479 : if (dsc != NULL_TREE && ssc != NULL_TREE
9154 35479 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9155 : {
9156 5102 : gfc_add_modify (block, dsc, ssc);
9157 5102 : return;
9158 : }
9159 :
9160 : /* The string copy algorithm below generates code like
9161 :
9162 : if (destlen > 0)
9163 : {
9164 : if (srclen < destlen)
9165 : {
9166 : memmove (dest, src, srclen);
9167 : // Pad with spaces.
9168 : memset (&dest[srclen], ' ', destlen - srclen);
9169 : }
9170 : else
9171 : {
9172 : // Truncate if too long.
9173 : memmove (dest, src, destlen);
9174 : }
9175 : }
9176 : */
9177 :
9178 : /* Do nothing if the destination length is zero. */
9179 30377 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9180 30377 : build_zero_cst (TREE_TYPE (dlen)));
9181 :
9182 : /* For non-default character kinds, we have to multiply the string
9183 : length by the base type size. */
9184 30377 : chartype = gfc_get_char_type (dkind);
9185 30377 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9186 : slen,
9187 30377 : fold_convert (TREE_TYPE (slen),
9188 : TYPE_SIZE_UNIT (chartype)));
9189 30377 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9190 : dlen,
9191 30377 : fold_convert (TREE_TYPE (dlen),
9192 : TYPE_SIZE_UNIT (chartype)));
9193 :
9194 30377 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9195 30329 : dest = fold_convert (pvoid_type_node, dest);
9196 : else
9197 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9198 :
9199 30377 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9200 30373 : src = fold_convert (pvoid_type_node, src);
9201 : else
9202 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9203 :
9204 : /* Truncate string if source is too long. */
9205 30377 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9206 : dlen);
9207 :
9208 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9209 30377 : if (!CONSTANT_CLASS_P (cond2))
9210 : {
9211 9308 : dest = gfc_evaluate_now (dest, block);
9212 9308 : src = gfc_evaluate_now (src, block);
9213 : }
9214 :
9215 : /* Copy and pad with spaces. */
9216 30377 : tmp3 = build_call_expr_loc (input_location,
9217 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9218 : 3, dest, src,
9219 : fold_convert (size_type_node, slen));
9220 :
9221 : /* Wstringop-overflow appears at -O3 even though this warning is not
9222 : explicitly available in fortran nor can it be switched off. If the
9223 : source length is a constant, its negative appears as a very large
9224 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9225 : the result of the MINUS_EXPR suppresses this spurious warning. */
9226 30377 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9227 30377 : TREE_TYPE(dlen), dlen, slen);
9228 30377 : if (slength && TREE_CONSTANT (slength))
9229 26860 : tmp = gfc_evaluate_now (tmp, block);
9230 :
9231 30377 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9232 30377 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9233 :
9234 30377 : gfc_init_block (&tempblock);
9235 30377 : gfc_add_expr_to_block (&tempblock, tmp3);
9236 30377 : gfc_add_expr_to_block (&tempblock, tmp4);
9237 30377 : tmp3 = gfc_finish_block (&tempblock);
9238 :
9239 : /* The truncated memmove if the slen >= dlen. */
9240 30377 : tmp2 = build_call_expr_loc (input_location,
9241 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9242 : 3, dest, src,
9243 : fold_convert (size_type_node, dlen));
9244 :
9245 : /* The whole copy_string function is there. */
9246 30377 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9247 : tmp3, tmp2);
9248 30377 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9249 : build_empty_stmt (input_location));
9250 30377 : gfc_add_expr_to_block (block, tmp);
9251 : }
9252 :
9253 :
9254 : /* Translate a statement function.
9255 : The value of a statement function reference is obtained by evaluating the
9256 : expression using the values of the actual arguments for the values of the
9257 : corresponding dummy arguments. */
9258 :
9259 : static void
9260 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9261 : {
9262 269 : gfc_symbol *sym;
9263 269 : gfc_symbol *fsym;
9264 269 : gfc_formal_arglist *fargs;
9265 269 : gfc_actual_arglist *args;
9266 269 : gfc_se lse;
9267 269 : gfc_se rse;
9268 269 : gfc_saved_var *saved_vars;
9269 269 : tree *temp_vars;
9270 269 : tree type;
9271 269 : tree tmp;
9272 269 : int n;
9273 :
9274 269 : sym = expr->symtree->n.sym;
9275 269 : args = expr->value.function.actual;
9276 269 : gfc_init_se (&lse, NULL);
9277 269 : gfc_init_se (&rse, NULL);
9278 :
9279 269 : n = 0;
9280 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9281 458 : n++;
9282 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9283 269 : temp_vars = XCNEWVEC (tree, n);
9284 :
9285 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9286 458 : fargs = fargs->next, n++)
9287 : {
9288 : /* Each dummy shall be specified, explicitly or implicitly, to be
9289 : scalar. */
9290 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9291 458 : fsym = fargs->sym;
9292 :
9293 458 : if (fsym->ts.type == BT_CHARACTER)
9294 : {
9295 : /* Copy string arguments. */
9296 48 : tree arglen;
9297 :
9298 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9299 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9300 :
9301 : /* Create a temporary to hold the value. */
9302 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9303 1 : fsym->ts.u.cl->backend_decl
9304 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9305 :
9306 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9307 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9308 :
9309 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9310 :
9311 48 : gfc_conv_expr (&rse, args->expr);
9312 48 : gfc_conv_string_parameter (&rse);
9313 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9314 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9315 :
9316 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9317 : rse.string_length, rse.expr, fsym->ts.kind);
9318 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9319 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9320 : }
9321 : else
9322 : {
9323 : /* For everything else, just evaluate the expression. */
9324 :
9325 : /* Create a temporary to hold the value. */
9326 410 : type = gfc_typenode_for_spec (&fsym->ts);
9327 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9328 :
9329 410 : gfc_conv_expr (&lse, args->expr);
9330 :
9331 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9332 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9333 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9334 : }
9335 :
9336 458 : args = args->next;
9337 : }
9338 :
9339 : /* Use the temporary variables in place of the real ones. */
9340 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9341 458 : fargs = fargs->next, n++)
9342 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9343 :
9344 269 : gfc_conv_expr (se, sym->value);
9345 :
9346 269 : if (sym->ts.type == BT_CHARACTER)
9347 : {
9348 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9349 :
9350 : /* Force the expression to the correct length. */
9351 55 : if (!INTEGER_CST_P (se->string_length)
9352 101 : || tree_int_cst_lt (se->string_length,
9353 46 : sym->ts.u.cl->backend_decl))
9354 : {
9355 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9356 31 : tmp = gfc_create_var (type, sym->name);
9357 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9358 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9359 : sym->ts.kind, se->string_length, se->expr,
9360 : sym->ts.kind);
9361 31 : se->expr = tmp;
9362 : }
9363 55 : se->string_length = sym->ts.u.cl->backend_decl;
9364 : }
9365 :
9366 : /* Restore the original variables. */
9367 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9368 458 : fargs = fargs->next, n++)
9369 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9370 269 : free (temp_vars);
9371 269 : free (saved_vars);
9372 269 : }
9373 :
9374 :
9375 : /* Translate a function expression. */
9376 :
9377 : static void
9378 307424 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9379 : {
9380 307424 : gfc_symbol *sym;
9381 :
9382 307424 : if (expr->value.function.isym)
9383 : {
9384 257314 : gfc_conv_intrinsic_function (se, expr);
9385 257314 : return;
9386 : }
9387 :
9388 : /* expr.value.function.esym is the resolved (specific) function symbol for
9389 : most functions. However this isn't set for dummy procedures. */
9390 50110 : sym = expr->value.function.esym;
9391 50110 : if (!sym)
9392 1613 : sym = expr->symtree->n.sym;
9393 :
9394 : /* The IEEE_ARITHMETIC functions are caught here. */
9395 50110 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9396 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9397 : return;
9398 :
9399 : /* We distinguish statement functions from general functions to improve
9400 : runtime performance. */
9401 37653 : if (sym->attr.proc == PROC_ST_FUNCTION)
9402 : {
9403 269 : gfc_conv_statement_function (se, expr);
9404 269 : return;
9405 : }
9406 :
9407 37384 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9408 : NULL);
9409 : }
9410 :
9411 :
9412 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9413 :
9414 : static bool
9415 39100 : is_zero_initializer_p (gfc_expr * expr)
9416 : {
9417 39100 : if (expr->expr_type != EXPR_CONSTANT)
9418 : return false;
9419 :
9420 : /* We ignore constants with prescribed memory representations for now. */
9421 11354 : if (expr->representation.string)
9422 : return false;
9423 :
9424 11336 : switch (expr->ts.type)
9425 : {
9426 5218 : case BT_INTEGER:
9427 5218 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9428 :
9429 4817 : case BT_REAL:
9430 4817 : return mpfr_zero_p (expr->value.real)
9431 4817 : && MPFR_SIGN (expr->value.real) >= 0;
9432 :
9433 925 : case BT_LOGICAL:
9434 925 : return expr->value.logical == 0;
9435 :
9436 242 : case BT_COMPLEX:
9437 242 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9438 154 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9439 154 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9440 384 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9441 :
9442 : default:
9443 : break;
9444 : }
9445 : return false;
9446 : }
9447 :
9448 :
9449 : static void
9450 35160 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9451 : {
9452 35160 : gfc_ss *ss;
9453 :
9454 35160 : ss = se->ss;
9455 35160 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9456 35160 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9457 :
9458 35160 : gfc_conv_tmp_array_ref (se);
9459 35160 : }
9460 :
9461 :
9462 : /* Build a static initializer. EXPR is the expression for the initial value.
9463 : The other parameters describe the variable of the component being
9464 : initialized. EXPR may be null. */
9465 :
9466 : tree
9467 139370 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9468 : bool array, bool pointer, bool procptr)
9469 : {
9470 139370 : gfc_se se;
9471 :
9472 139370 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9473 44535 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9474 165 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9475 57 : return build_constructor (type, NULL);
9476 :
9477 139313 : if (!(expr || pointer || procptr))
9478 : return NULL_TREE;
9479 :
9480 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9481 : (these are the only two iso_c_binding derived types that can be
9482 : used as initialization expressions). If so, we need to modify
9483 : the 'expr' to be that for a (void *). */
9484 131007 : if (expr != NULL && expr->ts.type == BT_DERIVED
9485 40351 : && expr->ts.is_iso_c && expr->ts.u.derived)
9486 : {
9487 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9488 4 : return build_constructor (type, NULL);
9489 182 : else if (POINTER_TYPE_P (type))
9490 182 : return build_int_cst (type, 0);
9491 : else
9492 0 : gcc_unreachable ();
9493 : }
9494 :
9495 130821 : if (array && !procptr)
9496 : {
9497 8579 : tree ctor;
9498 : /* Arrays need special handling. */
9499 8579 : if (pointer)
9500 773 : ctor = gfc_build_null_descriptor (type);
9501 : /* Special case assigning an array to zero. */
9502 7806 : else if (is_zero_initializer_p (expr))
9503 217 : ctor = build_constructor (type, NULL);
9504 : else
9505 7589 : ctor = gfc_conv_array_initializer (type, expr);
9506 8579 : TREE_STATIC (ctor) = 1;
9507 8579 : return ctor;
9508 : }
9509 122242 : else if (pointer || procptr)
9510 : {
9511 59316 : if (ts->type == BT_CLASS && !procptr)
9512 : {
9513 1725 : gfc_init_se (&se, NULL);
9514 1725 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9515 1725 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9516 1725 : TREE_STATIC (se.expr) = 1;
9517 1725 : return se.expr;
9518 : }
9519 57591 : else if (!expr || expr->expr_type == EXPR_NULL)
9520 31110 : return fold_convert (type, null_pointer_node);
9521 : else
9522 : {
9523 26481 : gfc_init_se (&se, NULL);
9524 26481 : se.want_pointer = 1;
9525 26481 : gfc_conv_expr (&se, expr);
9526 26481 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9527 : return se.expr;
9528 : }
9529 : }
9530 : else
9531 : {
9532 62926 : switch (ts->type)
9533 : {
9534 18843 : case_bt_struct:
9535 18843 : case BT_CLASS:
9536 18843 : gfc_init_se (&se, NULL);
9537 18843 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9538 749 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9539 : else
9540 18094 : gfc_conv_structure (&se, expr, 1);
9541 18843 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9542 18843 : TREE_STATIC (se.expr) = 1;
9543 18843 : return se.expr;
9544 :
9545 2669 : case BT_CHARACTER:
9546 2669 : if (expr->expr_type == EXPR_CONSTANT)
9547 : {
9548 2668 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9549 2668 : TREE_STATIC (ctor) = 1;
9550 2668 : return ctor;
9551 : }
9552 :
9553 : /* Fallthrough. */
9554 41415 : default:
9555 41415 : gfc_init_se (&se, NULL);
9556 41415 : gfc_conv_constant (&se, expr);
9557 41415 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9558 : return se.expr;
9559 : }
9560 : }
9561 : }
9562 :
9563 : static tree
9564 950 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9565 : {
9566 950 : gfc_se rse;
9567 950 : gfc_se lse;
9568 950 : gfc_ss *rss;
9569 950 : gfc_ss *lss;
9570 950 : gfc_array_info *lss_array;
9571 950 : stmtblock_t body;
9572 950 : stmtblock_t block;
9573 950 : gfc_loopinfo loop;
9574 950 : int n;
9575 950 : tree tmp;
9576 :
9577 950 : gfc_start_block (&block);
9578 :
9579 : /* Initialize the scalarizer. */
9580 950 : gfc_init_loopinfo (&loop);
9581 :
9582 950 : gfc_init_se (&lse, NULL);
9583 950 : gfc_init_se (&rse, NULL);
9584 :
9585 : /* Walk the rhs. */
9586 950 : rss = gfc_walk_expr (expr);
9587 950 : if (rss == gfc_ss_terminator)
9588 : /* The rhs is scalar. Add a ss for the expression. */
9589 208 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
9590 :
9591 : /* Create a SS for the destination. */
9592 950 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
9593 : GFC_SS_COMPONENT);
9594 950 : lss_array = &lss->info->data.array;
9595 950 : lss_array->shape = gfc_get_shape (cm->as->rank);
9596 950 : lss_array->descriptor = dest;
9597 950 : lss_array->data = gfc_conv_array_data (dest);
9598 950 : lss_array->offset = gfc_conv_array_offset (dest);
9599 1957 : for (n = 0; n < cm->as->rank; n++)
9600 : {
9601 1007 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
9602 1007 : lss_array->stride[n] = gfc_index_one_node;
9603 :
9604 1007 : mpz_init (lss_array->shape[n]);
9605 1007 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
9606 1007 : cm->as->lower[n]->value.integer);
9607 1007 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
9608 : }
9609 :
9610 : /* Associate the SS with the loop. */
9611 950 : gfc_add_ss_to_loop (&loop, lss);
9612 950 : gfc_add_ss_to_loop (&loop, rss);
9613 :
9614 : /* Calculate the bounds of the scalarization. */
9615 950 : gfc_conv_ss_startstride (&loop);
9616 :
9617 : /* Setup the scalarizing loops. */
9618 950 : gfc_conv_loop_setup (&loop, &expr->where);
9619 :
9620 : /* Setup the gfc_se structures. */
9621 950 : gfc_copy_loopinfo_to_se (&lse, &loop);
9622 950 : gfc_copy_loopinfo_to_se (&rse, &loop);
9623 :
9624 950 : rse.ss = rss;
9625 950 : gfc_mark_ss_chain_used (rss, 1);
9626 950 : lse.ss = lss;
9627 950 : gfc_mark_ss_chain_used (lss, 1);
9628 :
9629 : /* Start the scalarized loop body. */
9630 950 : gfc_start_scalarized_body (&loop, &body);
9631 :
9632 950 : gfc_conv_tmp_array_ref (&lse);
9633 950 : if (cm->ts.type == BT_CHARACTER)
9634 176 : lse.string_length = cm->ts.u.cl->backend_decl;
9635 :
9636 950 : gfc_conv_expr (&rse, expr);
9637 :
9638 950 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
9639 950 : gfc_add_expr_to_block (&body, tmp);
9640 :
9641 950 : gcc_assert (rse.ss == gfc_ss_terminator);
9642 :
9643 : /* Generate the copying loops. */
9644 950 : gfc_trans_scalarizing_loops (&loop, &body);
9645 :
9646 : /* Wrap the whole thing up. */
9647 950 : gfc_add_block_to_block (&block, &loop.pre);
9648 950 : gfc_add_block_to_block (&block, &loop.post);
9649 :
9650 950 : gcc_assert (lss_array->shape != NULL);
9651 950 : gfc_free_shape (&lss_array->shape, cm->as->rank);
9652 950 : gfc_cleanup_loop (&loop);
9653 :
9654 950 : return gfc_finish_block (&block);
9655 : }
9656 :
9657 :
9658 : static stmtblock_t *final_block;
9659 : static tree
9660 1226 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
9661 : gfc_expr * expr)
9662 : {
9663 1226 : gfc_se se;
9664 1226 : stmtblock_t block;
9665 1226 : tree offset;
9666 1226 : int n;
9667 1226 : tree tmp;
9668 1226 : tree tmp2;
9669 1226 : gfc_array_spec *as;
9670 1226 : gfc_expr *arg = NULL;
9671 :
9672 1226 : gfc_start_block (&block);
9673 1226 : gfc_init_se (&se, NULL);
9674 :
9675 : /* Get the descriptor for the expressions. */
9676 1226 : se.want_pointer = 0;
9677 1226 : gfc_conv_expr_descriptor (&se, expr);
9678 1226 : gfc_add_block_to_block (&block, &se.pre);
9679 1226 : gfc_add_modify (&block, dest, se.expr);
9680 1226 : if (cm->ts.type == BT_CHARACTER
9681 1226 : && gfc_deferred_strlen (cm, &tmp))
9682 : {
9683 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
9684 30 : TREE_TYPE (tmp),
9685 30 : TREE_OPERAND (dest, 0),
9686 : tmp, NULL_TREE);
9687 30 : gfc_add_modify (&block, tmp,
9688 30 : fold_convert (TREE_TYPE (tmp),
9689 : se.string_length));
9690 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
9691 : "slen");
9692 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
9693 : }
9694 :
9695 : /* Deal with arrays of derived types with allocatable components. */
9696 1226 : if (gfc_bt_struct (cm->ts.type)
9697 187 : && cm->ts.u.derived->attr.alloc_comp)
9698 : // TODO: Fix caf_mode
9699 107 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
9700 : se.expr, dest,
9701 107 : cm->as->rank, 0);
9702 1119 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
9703 36 : && CLASS_DATA(cm)->attr.allocatable)
9704 : {
9705 36 : if (cm->ts.u.derived->attr.alloc_comp)
9706 : // TODO: Fix caf_mode
9707 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
9708 : se.expr, dest,
9709 : expr->rank, 0);
9710 : else
9711 : {
9712 36 : tmp = TREE_TYPE (dest);
9713 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9714 : tmp, expr->rank, NULL_TREE);
9715 : }
9716 : }
9717 1083 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9718 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9719 : gfc_typenode_for_spec (&cm->ts),
9720 30 : cm->as->rank, NULL_TREE);
9721 : else
9722 1053 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9723 1053 : TREE_TYPE(cm->backend_decl),
9724 1053 : cm->as->rank, NULL_TREE);
9725 :
9726 :
9727 1226 : gfc_add_expr_to_block (&block, tmp);
9728 1226 : gfc_add_block_to_block (&block, &se.post);
9729 :
9730 1226 : if (final_block && !cm->attr.allocatable
9731 96 : && expr->expr_type == EXPR_ARRAY)
9732 : {
9733 96 : tree data_ptr;
9734 96 : data_ptr = gfc_conv_descriptor_data_get (dest);
9735 96 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
9736 96 : }
9737 1130 : else if (final_block && cm->attr.allocatable)
9738 120 : gfc_add_block_to_block (final_block, &se.finalblock);
9739 :
9740 1226 : if (expr->expr_type != EXPR_VARIABLE)
9741 1105 : gfc_conv_descriptor_data_set (&block, se.expr,
9742 : null_pointer_node);
9743 :
9744 : /* We need to know if the argument of a conversion function is a
9745 : variable, so that the correct lower bound can be used. */
9746 1226 : if (expr->expr_type == EXPR_FUNCTION
9747 56 : && expr->value.function.isym
9748 44 : && expr->value.function.isym->conversion
9749 44 : && expr->value.function.actual->expr
9750 44 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
9751 44 : arg = expr->value.function.actual->expr;
9752 :
9753 : /* Obtain the array spec of full array references. */
9754 44 : if (arg)
9755 44 : as = gfc_get_full_arrayspec_from_expr (arg);
9756 : else
9757 1182 : as = gfc_get_full_arrayspec_from_expr (expr);
9758 :
9759 : /* Shift the lbound and ubound of temporaries to being unity,
9760 : rather than zero, based. Always calculate the offset. */
9761 1226 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
9762 1226 : offset = gfc_conv_descriptor_offset_get (dest);
9763 1226 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
9764 :
9765 2508 : for (n = 0; n < expr->rank; n++)
9766 : {
9767 1282 : tree span;
9768 1282 : tree lbound;
9769 :
9770 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
9771 : TODO It looks as if gfc_conv_expr_descriptor should return
9772 : the correct bounds and that the following should not be
9773 : necessary. This would simplify gfc_conv_intrinsic_bound
9774 : as well. */
9775 1282 : if (as && as->lower[n])
9776 : {
9777 80 : gfc_se lbse;
9778 80 : gfc_init_se (&lbse, NULL);
9779 80 : gfc_conv_expr (&lbse, as->lower[n]);
9780 80 : gfc_add_block_to_block (&block, &lbse.pre);
9781 80 : lbound = gfc_evaluate_now (lbse.expr, &block);
9782 80 : }
9783 1202 : else if (as && arg)
9784 : {
9785 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
9786 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
9787 : gfc_rank_cst[n]);
9788 : }
9789 1168 : else if (as)
9790 64 : lbound = gfc_conv_descriptor_lbound_get (dest,
9791 : gfc_rank_cst[n]);
9792 : else
9793 1104 : lbound = gfc_index_one_node;
9794 :
9795 1282 : lbound = fold_convert (gfc_array_index_type, lbound);
9796 :
9797 : /* Shift the bounds and set the offset accordingly. */
9798 1282 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
9799 1282 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9800 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
9801 1282 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9802 : span, lbound);
9803 1282 : gfc_conv_descriptor_ubound_set (&block, dest,
9804 : gfc_rank_cst[n], tmp);
9805 1282 : gfc_conv_descriptor_lbound_set (&block, dest,
9806 : gfc_rank_cst[n], lbound);
9807 :
9808 1282 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9809 : gfc_conv_descriptor_lbound_get (dest,
9810 : gfc_rank_cst[n]),
9811 : gfc_conv_descriptor_stride_get (dest,
9812 : gfc_rank_cst[n]));
9813 1282 : gfc_add_modify (&block, tmp2, tmp);
9814 1282 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9815 : offset, tmp2);
9816 1282 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
9817 : }
9818 :
9819 1226 : if (arg)
9820 : {
9821 : /* If a conversion expression has a null data pointer
9822 : argument, nullify the allocatable component. */
9823 44 : tree non_null_expr;
9824 44 : tree null_expr;
9825 :
9826 44 : if (arg->symtree->n.sym->attr.allocatable
9827 12 : || arg->symtree->n.sym->attr.pointer)
9828 : {
9829 32 : non_null_expr = gfc_finish_block (&block);
9830 32 : gfc_start_block (&block);
9831 32 : gfc_conv_descriptor_data_set (&block, dest,
9832 : null_pointer_node);
9833 32 : null_expr = gfc_finish_block (&block);
9834 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
9835 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
9836 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9837 32 : return build3_v (COND_EXPR, tmp,
9838 : null_expr, non_null_expr);
9839 : }
9840 : }
9841 :
9842 1194 : return gfc_finish_block (&block);
9843 : }
9844 :
9845 :
9846 : /* Allocate or reallocate scalar component, as necessary. */
9847 :
9848 : static void
9849 397 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
9850 : gfc_component *cm, gfc_expr *expr2,
9851 : tree slen)
9852 : {
9853 397 : tree tmp;
9854 397 : tree ptr;
9855 397 : tree size;
9856 397 : tree size_in_bytes;
9857 397 : tree lhs_cl_size = NULL_TREE;
9858 397 : gfc_se se;
9859 :
9860 397 : if (!comp)
9861 0 : return;
9862 :
9863 397 : if (!expr2 || expr2->rank)
9864 : return;
9865 :
9866 397 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9867 :
9868 397 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9869 : {
9870 139 : gcc_assert (expr2->ts.type == BT_CHARACTER);
9871 139 : size = expr2->ts.u.cl->backend_decl;
9872 139 : if (!size || !VAR_P (size))
9873 139 : size = gfc_create_var (TREE_TYPE (slen), "slen");
9874 139 : gfc_add_modify (block, size, slen);
9875 :
9876 139 : gfc_deferred_strlen (cm, &tmp);
9877 139 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
9878 : gfc_charlen_type_node,
9879 139 : TREE_OPERAND (comp, 0),
9880 : tmp, NULL_TREE);
9881 :
9882 139 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
9883 139 : tmp = TYPE_SIZE_UNIT (tmp);
9884 278 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9885 139 : TREE_TYPE (tmp), tmp,
9886 139 : fold_convert (TREE_TYPE (tmp), size));
9887 : }
9888 258 : else if (cm->ts.type == BT_CLASS)
9889 : {
9890 102 : if (expr2->ts.type != BT_CLASS)
9891 : {
9892 102 : if (expr2->ts.type == BT_CHARACTER)
9893 : {
9894 24 : gfc_init_se (&se, NULL);
9895 24 : gfc_conv_expr (&se, expr2);
9896 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
9897 24 : size = fold_build2_loc (input_location, MULT_EXPR,
9898 : gfc_charlen_type_node,
9899 : se.string_length, size);
9900 24 : size = fold_convert (size_type_node, size);
9901 : }
9902 : else
9903 : {
9904 78 : if (expr2->ts.type == BT_DERIVED)
9905 48 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
9906 : else
9907 30 : tmp = gfc_typenode_for_spec (&expr2->ts);
9908 78 : size = TYPE_SIZE_UNIT (tmp);
9909 : }
9910 : }
9911 : else
9912 : {
9913 0 : gfc_expr *e2vtab;
9914 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
9915 0 : gfc_add_vptr_component (e2vtab);
9916 0 : gfc_add_size_component (e2vtab);
9917 0 : gfc_init_se (&se, NULL);
9918 0 : gfc_conv_expr (&se, e2vtab);
9919 0 : gfc_add_block_to_block (block, &se.pre);
9920 0 : size = fold_convert (size_type_node, se.expr);
9921 0 : gfc_free_expr (e2vtab);
9922 : }
9923 : size_in_bytes = size;
9924 : }
9925 : else
9926 : {
9927 : /* Otherwise use the length in bytes of the rhs. */
9928 156 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
9929 156 : size_in_bytes = size;
9930 : }
9931 :
9932 397 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9933 : size_in_bytes, size_one_node);
9934 :
9935 397 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
9936 : {
9937 0 : tmp = build_call_expr_loc (input_location,
9938 : builtin_decl_explicit (BUILT_IN_CALLOC),
9939 : 2, build_one_cst (size_type_node),
9940 : size_in_bytes);
9941 0 : tmp = fold_convert (TREE_TYPE (comp), tmp);
9942 0 : gfc_add_modify (block, comp, tmp);
9943 : }
9944 : else
9945 : {
9946 397 : tmp = build_call_expr_loc (input_location,
9947 : builtin_decl_explicit (BUILT_IN_MALLOC),
9948 : 1, size_in_bytes);
9949 397 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
9950 102 : ptr = gfc_class_data_get (comp);
9951 : else
9952 : ptr = comp;
9953 397 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
9954 397 : gfc_add_modify (block, ptr, tmp);
9955 : }
9956 :
9957 397 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9958 : /* Update the lhs character length. */
9959 139 : gfc_add_modify (block, lhs_cl_size,
9960 139 : fold_convert (TREE_TYPE (lhs_cl_size), size));
9961 : }
9962 :
9963 :
9964 : /* Assign a single component of a derived type constructor. */
9965 :
9966 : static tree
9967 28947 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
9968 : gfc_expr * expr, bool init)
9969 : {
9970 28947 : gfc_se se;
9971 28947 : gfc_se lse;
9972 28947 : stmtblock_t block;
9973 28947 : tree tmp;
9974 28947 : tree vtab;
9975 :
9976 28947 : gfc_start_block (&block);
9977 :
9978 28947 : if (cm->attr.pointer || cm->attr.proc_pointer)
9979 : {
9980 : /* Only care about pointers here, not about allocatables. */
9981 2634 : gfc_init_se (&se, NULL);
9982 : /* Pointer component. */
9983 2634 : if ((cm->attr.dimension || cm->attr.codimension)
9984 670 : && !cm->attr.proc_pointer)
9985 : {
9986 : /* Array pointer. */
9987 654 : if (expr->expr_type == EXPR_NULL)
9988 648 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9989 : else
9990 : {
9991 6 : se.direct_byref = 1;
9992 6 : se.expr = dest;
9993 6 : gfc_conv_expr_descriptor (&se, expr);
9994 6 : gfc_add_block_to_block (&block, &se.pre);
9995 6 : gfc_add_block_to_block (&block, &se.post);
9996 : }
9997 : }
9998 : else
9999 : {
10000 : /* Scalar pointers. */
10001 1980 : se.want_pointer = 1;
10002 1980 : gfc_conv_expr (&se, expr);
10003 1980 : gfc_add_block_to_block (&block, &se.pre);
10004 :
10005 1980 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10006 12 : && expr->symtree->n.sym->attr.dummy)
10007 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10008 :
10009 1980 : gfc_add_modify (&block, dest,
10010 1980 : fold_convert (TREE_TYPE (dest), se.expr));
10011 1980 : gfc_add_block_to_block (&block, &se.post);
10012 : }
10013 : }
10014 26313 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10015 : {
10016 : /* NULL initialization for CLASS components. */
10017 922 : tmp = gfc_trans_structure_assign (dest,
10018 : gfc_class_initializer (&cm->ts, expr),
10019 : false);
10020 922 : gfc_add_expr_to_block (&block, tmp);
10021 : }
10022 25391 : else if ((cm->attr.dimension || cm->attr.codimension)
10023 : && !cm->attr.proc_pointer)
10024 : {
10025 4765 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10026 : {
10027 2625 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10028 2625 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10029 2 : gfc_add_modify (&block, gfc_conv_descriptor_token (dest),
10030 : null_pointer_node);
10031 : }
10032 2140 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10033 : {
10034 1190 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10035 1190 : gfc_add_expr_to_block (&block, tmp);
10036 : }
10037 : else
10038 : {
10039 950 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10040 950 : gfc_add_expr_to_block (&block, tmp);
10041 : }
10042 : }
10043 20626 : else if (cm->ts.type == BT_CLASS
10044 144 : && CLASS_DATA (cm)->attr.dimension
10045 36 : && CLASS_DATA (cm)->attr.allocatable
10046 36 : && expr->ts.type == BT_DERIVED)
10047 : {
10048 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10049 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10050 36 : tmp = gfc_class_vptr_get (dest);
10051 36 : gfc_add_modify (&block, tmp,
10052 36 : fold_convert (TREE_TYPE (tmp), vtab));
10053 36 : tmp = gfc_class_data_get (dest);
10054 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10055 36 : gfc_add_expr_to_block (&block, tmp);
10056 : }
10057 20590 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10058 1751 : && (init
10059 1624 : || (cm->ts.type == BT_CHARACTER
10060 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10061 : {
10062 : /* NULL initialization for allocatable components.
10063 : Deferred-length character is dealt with later. */
10064 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10065 : null_pointer_node));
10066 : }
10067 20439 : else if (init && (cm->attr.allocatable
10068 13430 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10069 108 : && expr->ts.type != BT_CLASS)))
10070 : {
10071 397 : tree size;
10072 :
10073 397 : gfc_init_se (&se, NULL);
10074 397 : gfc_conv_expr (&se, expr);
10075 :
10076 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10077 : if (!cm->attr.dimension) part above. */
10078 397 : gfc_add_block_to_block (&block, &se.pre);
10079 : /* Take care about non-array allocatable components here. The alloc_*
10080 : routine below is motivated by the alloc_scalar_allocatable_for_
10081 : assignment() routine, but with the realloc portions removed and
10082 : different input. */
10083 397 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10084 : se.string_length);
10085 :
10086 397 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10087 0 : && expr->symtree->n.sym->attr.dummy)
10088 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10089 :
10090 397 : if (cm->ts.type == BT_CLASS)
10091 : {
10092 102 : tmp = gfc_class_data_get (dest);
10093 102 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10094 102 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10095 102 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10096 102 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10097 102 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10098 : }
10099 : else
10100 295 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10101 :
10102 : /* For deferred strings insert a memcpy. */
10103 397 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10104 : {
10105 139 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10106 139 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10107 : ? se.string_length
10108 0 : : expr->ts.u.cl->backend_decl);
10109 139 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10110 139 : gfc_add_expr_to_block (&block, tmp);
10111 : }
10112 258 : else if (cm->ts.type == BT_CLASS)
10113 : {
10114 : /* Fix the expression for memcpy. */
10115 102 : if (expr->expr_type != EXPR_VARIABLE)
10116 72 : se.expr = gfc_evaluate_now (se.expr, &block);
10117 :
10118 102 : if (expr->ts.type == BT_CHARACTER)
10119 : {
10120 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10121 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10122 : gfc_charlen_type_node,
10123 : se.string_length, size);
10124 24 : size = fold_convert (size_type_node, size);
10125 : }
10126 : else
10127 78 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10128 :
10129 : /* Now copy the expression to the constructor component _data. */
10130 102 : gfc_add_expr_to_block (&block,
10131 : gfc_build_memcpy_call (tmp, se.expr, size));
10132 :
10133 : /* Fill the unlimited polymorphic _len field. */
10134 102 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10135 : {
10136 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10137 24 : gfc_add_modify (&block, tmp,
10138 24 : fold_convert (TREE_TYPE (tmp),
10139 : se.string_length));
10140 : }
10141 : }
10142 : else
10143 156 : gfc_add_modify (&block, tmp,
10144 156 : fold_convert (TREE_TYPE (tmp), se.expr));
10145 397 : gfc_add_block_to_block (&block, &se.post);
10146 397 : }
10147 20042 : else if (expr->ts.type == BT_UNION)
10148 : {
10149 13 : tree tmp;
10150 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10151 : /* We mark that the entire union should be initialized with a contrived
10152 : EXPR_NULL expression at the beginning. */
10153 13 : if (c != NULL && c->n.component == NULL
10154 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10155 : {
10156 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10157 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10158 6 : gfc_add_expr_to_block (&block, tmp);
10159 6 : c = gfc_constructor_next (c);
10160 : }
10161 : /* The following constructor expression, if any, represents a specific
10162 : map intializer, as given by the user. */
10163 13 : if (c != NULL && c->expr != NULL)
10164 : {
10165 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10166 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10167 6 : gfc_add_expr_to_block (&block, tmp);
10168 : }
10169 : }
10170 20029 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10171 : {
10172 3111 : if (expr->expr_type != EXPR_STRUCTURE)
10173 : {
10174 452 : tree dealloc = NULL_TREE;
10175 452 : gfc_init_se (&se, NULL);
10176 452 : gfc_conv_expr (&se, expr);
10177 452 : gfc_add_block_to_block (&block, &se.pre);
10178 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10179 : expression in a temporary variable and deallocate the allocatable
10180 : components. Then we can the copy the expression to the result. */
10181 452 : if (cm->ts.u.derived->attr.alloc_comp
10182 330 : && expr->expr_type != EXPR_VARIABLE)
10183 : {
10184 300 : se.expr = gfc_evaluate_now (se.expr, &block);
10185 300 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10186 : expr->rank);
10187 : }
10188 452 : gfc_add_modify (&block, dest,
10189 452 : fold_convert (TREE_TYPE (dest), se.expr));
10190 452 : if (cm->ts.u.derived->attr.alloc_comp
10191 330 : && expr->expr_type != EXPR_NULL)
10192 : {
10193 : // TODO: Fix caf_mode
10194 48 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10195 : dest, expr->rank, 0);
10196 48 : gfc_add_expr_to_block (&block, tmp);
10197 48 : if (dealloc != NULL_TREE)
10198 18 : gfc_add_expr_to_block (&block, dealloc);
10199 : }
10200 452 : gfc_add_block_to_block (&block, &se.post);
10201 : }
10202 : else
10203 : {
10204 : /* Nested constructors. */
10205 2659 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10206 2659 : gfc_add_expr_to_block (&block, tmp);
10207 : }
10208 : }
10209 16918 : else if (gfc_deferred_strlen (cm, &tmp))
10210 : {
10211 125 : tree strlen;
10212 125 : strlen = tmp;
10213 125 : gcc_assert (strlen);
10214 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10215 125 : TREE_TYPE (strlen),
10216 125 : TREE_OPERAND (dest, 0),
10217 : strlen, NULL_TREE);
10218 :
10219 125 : if (expr->expr_type == EXPR_NULL)
10220 : {
10221 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10222 107 : gfc_add_modify (&block, dest, tmp);
10223 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10224 107 : gfc_add_modify (&block, strlen, tmp);
10225 : }
10226 : else
10227 : {
10228 18 : tree size;
10229 18 : gfc_init_se (&se, NULL);
10230 18 : gfc_conv_expr (&se, expr);
10231 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10232 18 : size = fold_convert (size_type_node, size);
10233 18 : tmp = build_call_expr_loc (input_location,
10234 : builtin_decl_explicit (BUILT_IN_MALLOC),
10235 : 1, size);
10236 18 : gfc_add_modify (&block, dest,
10237 18 : fold_convert (TREE_TYPE (dest), tmp));
10238 18 : gfc_add_modify (&block, strlen,
10239 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10240 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10241 18 : gfc_add_expr_to_block (&block, tmp);
10242 : }
10243 : }
10244 16793 : else if (!cm->attr.artificial)
10245 : {
10246 : /* Scalar component (excluding deferred parameters). */
10247 16678 : gfc_init_se (&se, NULL);
10248 16678 : gfc_init_se (&lse, NULL);
10249 :
10250 16678 : gfc_conv_expr (&se, expr);
10251 16678 : if (cm->ts.type == BT_CHARACTER)
10252 1051 : lse.string_length = cm->ts.u.cl->backend_decl;
10253 16678 : lse.expr = dest;
10254 16678 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10255 16678 : gfc_add_expr_to_block (&block, tmp);
10256 : }
10257 28947 : return gfc_finish_block (&block);
10258 : }
10259 :
10260 : /* Assign a derived type constructor to a variable. */
10261 :
10262 : tree
10263 20134 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10264 : {
10265 20134 : gfc_constructor *c;
10266 20134 : gfc_component *cm;
10267 20134 : stmtblock_t block;
10268 20134 : tree field;
10269 20134 : tree tmp;
10270 20134 : gfc_se se;
10271 :
10272 20134 : gfc_start_block (&block);
10273 :
10274 20134 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10275 172 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10276 9 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10277 : {
10278 172 : gfc_se lse;
10279 :
10280 172 : gfc_init_se (&se, NULL);
10281 172 : gfc_init_se (&lse, NULL);
10282 172 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10283 172 : lse.expr = dest;
10284 172 : gfc_add_modify (&block, lse.expr,
10285 172 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10286 :
10287 172 : return gfc_finish_block (&block);
10288 : }
10289 :
10290 : /* Make sure that the derived type has been completely built. */
10291 19962 : if (!expr->ts.u.derived->backend_decl
10292 19962 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10293 : {
10294 224 : tmp = gfc_typenode_for_spec (&expr->ts);
10295 224 : gcc_assert (tmp);
10296 : }
10297 :
10298 19962 : cm = expr->ts.u.derived->components;
10299 :
10300 :
10301 19962 : if (coarray)
10302 223 : gfc_init_se (&se, NULL);
10303 :
10304 19962 : for (c = gfc_constructor_first (expr->value.constructor);
10305 52011 : c; c = gfc_constructor_next (c), cm = cm->next)
10306 : {
10307 : /* Skip absent members in default initializers. */
10308 32049 : if (!c->expr && !cm->attr.allocatable)
10309 3102 : continue;
10310 :
10311 : /* Register the component with the caf-lib before it is initialized.
10312 : Register only allocatable components, that are not coarray'ed
10313 : components (%comp[*]). Only register when the constructor is the
10314 : null-expression. */
10315 28947 : if (coarray && !cm->attr.codimension
10316 573 : && (cm->attr.allocatable || cm->attr.pointer)
10317 177 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10318 : {
10319 175 : tree token, desc, size;
10320 350 : bool is_array = cm->ts.type == BT_CLASS
10321 175 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10322 :
10323 175 : field = cm->backend_decl;
10324 175 : field = fold_build3_loc (input_location, COMPONENT_REF,
10325 175 : TREE_TYPE (field), dest, field, NULL_TREE);
10326 175 : if (cm->ts.type == BT_CLASS)
10327 0 : field = gfc_class_data_get (field);
10328 :
10329 175 : token
10330 : = is_array
10331 175 : ? gfc_conv_descriptor_token (field)
10332 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10333 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10334 52 : gfc_comp_caf_token (cm), NULL_TREE);
10335 :
10336 175 : if (is_array)
10337 : {
10338 : /* The _caf_register routine looks at the rank of the array
10339 : descriptor to decide whether the data registered is an array
10340 : or not. */
10341 123 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10342 123 : : cm->as->rank;
10343 : /* When the rank is not known just set a positive rank, which
10344 : suffices to recognize the data as array. */
10345 123 : if (rank < 0)
10346 0 : rank = 1;
10347 123 : size = build_zero_cst (size_type_node);
10348 123 : desc = field;
10349 123 : gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
10350 123 : build_int_cst (signed_char_type_node, rank));
10351 : }
10352 : else
10353 : {
10354 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10355 52 : cm->ts.type == BT_CLASS
10356 52 : ? CLASS_DATA (cm)->attr
10357 : : cm->attr);
10358 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10359 : }
10360 175 : gfc_add_block_to_block (&block, &se.pre);
10361 175 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10362 : 7, size, build_int_cst (
10363 : integer_type_node,
10364 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10365 : gfc_build_addr_expr (pvoid_type_node,
10366 : token),
10367 : gfc_build_addr_expr (NULL_TREE, desc),
10368 : null_pointer_node, null_pointer_node,
10369 : integer_zero_node);
10370 175 : gfc_add_expr_to_block (&block, tmp);
10371 : }
10372 28947 : field = cm->backend_decl;
10373 28947 : gcc_assert(field);
10374 28947 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10375 : dest, field, NULL_TREE);
10376 28947 : if (!c->expr)
10377 : {
10378 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10379 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10380 0 : gfc_free_expr (e);
10381 : }
10382 : else
10383 28947 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10384 28947 : gfc_add_expr_to_block (&block, tmp);
10385 : }
10386 19962 : return gfc_finish_block (&block);
10387 : }
10388 :
10389 : static void
10390 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10391 : gfc_component *un, gfc_expr *init)
10392 : {
10393 21 : gfc_constructor *ctor;
10394 :
10395 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
10396 : return;
10397 :
10398 21 : ctor = gfc_constructor_first (init->value.constructor);
10399 :
10400 21 : if (ctor == NULL || ctor->expr == NULL)
10401 : return;
10402 :
10403 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
10404 :
10405 : /* If we have an 'initialize all' constructor, do it first. */
10406 21 : if (ctor->expr->expr_type == EXPR_NULL)
10407 : {
10408 9 : tree union_type = TREE_TYPE (un->backend_decl);
10409 9 : tree val = build_constructor (union_type, NULL);
10410 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10411 9 : ctor = gfc_constructor_next (ctor);
10412 : }
10413 :
10414 : /* Add the map initializer on top. */
10415 21 : if (ctor != NULL && ctor->expr != NULL)
10416 : {
10417 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
10418 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
10419 12 : TREE_TYPE (un->backend_decl),
10420 12 : un->attr.dimension, un->attr.pointer,
10421 12 : un->attr.proc_pointer);
10422 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10423 : }
10424 : }
10425 :
10426 : /* Build an expression for a constructor. If init is nonzero then
10427 : this is part of a static variable initializer. */
10428 :
10429 : void
10430 38519 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
10431 : {
10432 38519 : gfc_constructor *c;
10433 38519 : gfc_component *cm;
10434 38519 : tree val;
10435 38519 : tree type;
10436 38519 : tree tmp;
10437 38519 : vec<constructor_elt, va_gc> *v = NULL;
10438 :
10439 38519 : gcc_assert (se->ss == NULL);
10440 38519 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10441 38519 : type = gfc_typenode_for_spec (&expr->ts);
10442 :
10443 38519 : if (!init)
10444 : {
10445 15809 : if (IS_PDT (expr) && expr->must_finalize)
10446 234 : final_block = &se->finalblock;
10447 :
10448 : /* Create a temporary variable and fill it in. */
10449 15809 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
10450 : /* The symtree in expr is NULL, if the code to generate is for
10451 : initializing the static members only. */
10452 31618 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
10453 15809 : se->want_coarray);
10454 15809 : gfc_add_expr_to_block (&se->pre, tmp);
10455 15809 : final_block = NULL;
10456 15809 : return;
10457 : }
10458 :
10459 22710 : cm = expr->ts.u.derived->components;
10460 :
10461 22710 : for (c = gfc_constructor_first (expr->value.constructor);
10462 119801 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
10463 : {
10464 : /* Skip absent members in default initializers and allocatable
10465 : components. Although the latter have a default initializer
10466 : of EXPR_NULL,... by default, the static nullify is not needed
10467 : since this is done every time we come into scope. */
10468 97091 : if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
10469 8340 : continue;
10470 :
10471 88751 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
10472 51363 : && strcmp (cm->name, "_extends") == 0
10473 1284 : && cm->initializer->symtree)
10474 : {
10475 1284 : tree vtab;
10476 1284 : gfc_symbol *vtabs;
10477 1284 : vtabs = cm->initializer->symtree->n.sym;
10478 1284 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
10479 1284 : vtab = unshare_expr_without_location (vtab);
10480 1284 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
10481 1284 : }
10482 87467 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
10483 : {
10484 9704 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
10485 9704 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10486 : fold_convert (TREE_TYPE (cm->backend_decl),
10487 : val));
10488 9704 : }
10489 77763 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
10490 402 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10491 : fold_convert (TREE_TYPE (cm->backend_decl),
10492 402 : integer_zero_node));
10493 77361 : else if (cm->ts.type == BT_UNION)
10494 21 : gfc_conv_union_initializer (v, cm, c->expr);
10495 : else
10496 : {
10497 77340 : val = gfc_conv_initializer (c->expr, &cm->ts,
10498 77340 : TREE_TYPE (cm->backend_decl),
10499 : cm->attr.dimension, cm->attr.pointer,
10500 77340 : cm->attr.proc_pointer);
10501 77340 : val = unshare_expr_without_location (val);
10502 :
10503 : /* Append it to the constructor list. */
10504 174431 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
10505 : }
10506 : }
10507 :
10508 22710 : se->expr = build_constructor (type, v);
10509 22710 : if (init)
10510 22710 : TREE_CONSTANT (se->expr) = 1;
10511 : }
10512 :
10513 :
10514 : /* Translate a substring expression. */
10515 :
10516 : static void
10517 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
10518 : {
10519 258 : gfc_ref *ref;
10520 :
10521 258 : ref = expr->ref;
10522 :
10523 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
10524 :
10525 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
10526 258 : expr->value.character.length,
10527 258 : expr->value.character.string);
10528 :
10529 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
10530 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
10531 :
10532 258 : if (ref)
10533 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
10534 258 : }
10535 :
10536 :
10537 : /* Entry point for expression translation. Evaluates a scalar quantity.
10538 : EXPR is the expression to be translated, and SE is the state structure if
10539 : called from within the scalarized. */
10540 :
10541 : void
10542 3603974 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
10543 : {
10544 3603974 : gfc_ss *ss;
10545 :
10546 3603974 : ss = se->ss;
10547 3603974 : if (ss && ss->info->expr == expr
10548 234152 : && (ss->info->type == GFC_SS_SCALAR
10549 : || ss->info->type == GFC_SS_REFERENCE))
10550 : {
10551 39840 : gfc_ss_info *ss_info;
10552 :
10553 39840 : ss_info = ss->info;
10554 : /* Substitute a scalar expression evaluated outside the scalarization
10555 : loop. */
10556 39840 : se->expr = ss_info->data.scalar.value;
10557 39840 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
10558 826 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
10559 :
10560 39840 : se->string_length = ss_info->string_length;
10561 39840 : gfc_advance_se_ss_chain (se);
10562 39840 : return;
10563 : }
10564 :
10565 : /* We need to convert the expressions for the iso_c_binding derived types.
10566 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
10567 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
10568 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
10569 : updated to be an integer with a kind equal to the size of a (void *). */
10570 3564134 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
10571 15837 : && expr->ts.u.derived->attr.is_bind_c)
10572 : {
10573 15000 : if (expr->expr_type == EXPR_VARIABLE
10574 10701 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
10575 10701 : || expr->symtree->n.sym->intmod_sym_id
10576 : == ISOCBINDING_NULL_FUNPTR))
10577 : {
10578 : /* Set expr_type to EXPR_NULL, which will result in
10579 : null_pointer_node being used below. */
10580 0 : expr->expr_type = EXPR_NULL;
10581 : }
10582 : else
10583 : {
10584 : /* Update the type/kind of the expression to be what the new
10585 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
10586 15000 : expr->ts.type = BT_INTEGER;
10587 15000 : expr->ts.f90_type = BT_VOID;
10588 15000 : expr->ts.kind = gfc_index_integer_kind;
10589 : }
10590 : }
10591 :
10592 3564134 : gfc_fix_class_refs (expr);
10593 :
10594 3564134 : switch (expr->expr_type)
10595 : {
10596 501934 : case EXPR_OP:
10597 501934 : gfc_conv_expr_op (se, expr);
10598 501934 : break;
10599 :
10600 139 : case EXPR_CONDITIONAL:
10601 139 : gfc_conv_conditional_expr (se, expr);
10602 139 : break;
10603 :
10604 300545 : case EXPR_FUNCTION:
10605 300545 : gfc_conv_function_expr (se, expr);
10606 300545 : break;
10607 :
10608 1124575 : case EXPR_CONSTANT:
10609 1124575 : gfc_conv_constant (se, expr);
10610 1124575 : break;
10611 :
10612 1581531 : case EXPR_VARIABLE:
10613 1581531 : gfc_conv_variable (se, expr);
10614 1581531 : break;
10615 :
10616 4183 : case EXPR_NULL:
10617 4183 : se->expr = null_pointer_node;
10618 4183 : break;
10619 :
10620 258 : case EXPR_SUBSTRING:
10621 258 : gfc_conv_substring_expr (se, expr);
10622 258 : break;
10623 :
10624 15809 : case EXPR_STRUCTURE:
10625 15809 : gfc_conv_structure (se, expr, 0);
10626 : /* F2008 4.5.6.3 para 5: If an executable construct references a
10627 : structure constructor or array constructor, the entity created by
10628 : the constructor is finalized after execution of the innermost
10629 : executable construct containing the reference. This, in fact,
10630 : was later deleted by the Combined Techical Corrigenda 1 TO 4 for
10631 : fortran 2008 (f08/0011). */
10632 15809 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
10633 15809 : && !(gfc_option.allow_std & GFC_STD_GNU)
10634 139 : && expr->must_finalize
10635 15821 : && gfc_may_be_finalized (expr->ts))
10636 : {
10637 12 : locus loc;
10638 12 : gfc_locus_from_location (&loc, input_location);
10639 12 : gfc_warning (0, "The structure constructor at %L has been"
10640 : " finalized. This feature was removed by f08/0011."
10641 : " Use -std=f2018 or -std=gnu to eliminate the"
10642 : " finalization.", &loc);
10643 12 : symbol_attribute attr;
10644 12 : attr.allocatable = attr.pointer = 0;
10645 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
10646 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
10647 : }
10648 : break;
10649 :
10650 35160 : case EXPR_ARRAY:
10651 35160 : gfc_conv_array_constructor_expr (se, expr);
10652 35160 : gfc_add_block_to_block (&se->post, &se->finalblock);
10653 35160 : break;
10654 :
10655 0 : default:
10656 0 : gcc_unreachable ();
10657 3603974 : break;
10658 : }
10659 : }
10660 :
10661 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
10662 : of an assignment. */
10663 : void
10664 366064 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
10665 : {
10666 366064 : gfc_conv_expr (se, expr);
10667 : /* All numeric lvalues should have empty post chains. If not we need to
10668 : figure out a way of rewriting an lvalue so that it has no post chain. */
10669 366064 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
10670 366064 : }
10671 :
10672 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
10673 : numeric expressions. Used for scalar values where inserting cleanup code
10674 : is inconvenient. */
10675 : void
10676 1021327 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
10677 : {
10678 1021327 : tree val;
10679 :
10680 1021327 : gcc_assert (expr->ts.type != BT_CHARACTER);
10681 1021327 : gfc_conv_expr (se, expr);
10682 1021327 : if (se->post.head)
10683 : {
10684 2462 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
10685 2462 : gfc_add_modify (&se->pre, val, se->expr);
10686 2462 : se->expr = val;
10687 2462 : gfc_add_block_to_block (&se->pre, &se->post);
10688 : }
10689 1021327 : }
10690 :
10691 : /* Helper to translate an expression and convert it to a particular type. */
10692 : void
10693 287173 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
10694 : {
10695 287173 : gfc_conv_expr_val (se, expr);
10696 287173 : se->expr = convert (type, se->expr);
10697 287173 : }
10698 :
10699 :
10700 : /* Converts an expression so that it can be passed by reference. Scalar
10701 : values only. */
10702 :
10703 : void
10704 225009 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
10705 : {
10706 225009 : gfc_ss *ss;
10707 225009 : tree var;
10708 :
10709 225009 : ss = se->ss;
10710 225009 : if (ss && ss->info->expr == expr
10711 7566 : && ss->info->type == GFC_SS_REFERENCE)
10712 : {
10713 : /* Returns a reference to the scalar evaluated outside the loop
10714 : for this case. */
10715 907 : gfc_conv_expr (se, expr);
10716 :
10717 907 : if (expr->ts.type == BT_CHARACTER
10718 114 : && expr->expr_type != EXPR_FUNCTION)
10719 102 : gfc_conv_string_parameter (se);
10720 : else
10721 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10722 :
10723 907 : return;
10724 : }
10725 :
10726 224102 : if (expr->ts.type == BT_CHARACTER)
10727 : {
10728 49412 : gfc_conv_expr (se, expr);
10729 49412 : gfc_conv_string_parameter (se);
10730 49412 : return;
10731 : }
10732 :
10733 174690 : if (expr->expr_type == EXPR_VARIABLE)
10734 : {
10735 69077 : se->want_pointer = 1;
10736 69077 : gfc_conv_expr (se, expr);
10737 69077 : if (se->post.head)
10738 : {
10739 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10740 0 : gfc_add_modify (&se->pre, var, se->expr);
10741 0 : gfc_add_block_to_block (&se->pre, &se->post);
10742 0 : se->expr = var;
10743 : }
10744 69077 : return;
10745 : }
10746 :
10747 105613 : if (expr->expr_type == EXPR_CONDITIONAL)
10748 : {
10749 18 : se->want_pointer = 1;
10750 18 : gfc_conv_expr (se, expr);
10751 18 : return;
10752 : }
10753 :
10754 105595 : if (expr->expr_type == EXPR_FUNCTION
10755 13406 : && ((expr->value.function.esym
10756 2075 : && expr->value.function.esym->result
10757 2074 : && expr->value.function.esym->result->attr.pointer
10758 71 : && !expr->value.function.esym->result->attr.dimension)
10759 13341 : || (!expr->value.function.esym && !expr->ref
10760 11225 : && expr->symtree->n.sym->attr.pointer
10761 0 : && !expr->symtree->n.sym->attr.dimension)))
10762 : {
10763 65 : se->want_pointer = 1;
10764 65 : gfc_conv_expr (se, expr);
10765 65 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10766 65 : gfc_add_modify (&se->pre, var, se->expr);
10767 65 : se->expr = var;
10768 65 : return;
10769 : }
10770 :
10771 105530 : gfc_conv_expr (se, expr);
10772 :
10773 : /* Create a temporary var to hold the value. */
10774 105530 : if (TREE_CONSTANT (se->expr))
10775 : {
10776 : tree tmp = se->expr;
10777 83707 : STRIP_TYPE_NOPS (tmp);
10778 83707 : var = build_decl (input_location,
10779 83707 : CONST_DECL, NULL, TREE_TYPE (tmp));
10780 83707 : DECL_INITIAL (var) = tmp;
10781 83707 : TREE_STATIC (var) = 1;
10782 83707 : pushdecl (var);
10783 : }
10784 : else
10785 : {
10786 21823 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10787 21823 : gfc_add_modify (&se->pre, var, se->expr);
10788 : }
10789 :
10790 105530 : if (!expr->must_finalize)
10791 105434 : gfc_add_block_to_block (&se->pre, &se->post);
10792 :
10793 : /* Take the address of that value. */
10794 105530 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
10795 : }
10796 :
10797 :
10798 : /* Get the _len component for an unlimited polymorphic expression. */
10799 :
10800 : static tree
10801 1786 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
10802 : {
10803 1786 : gfc_se se;
10804 1786 : gfc_ref *ref = expr->ref;
10805 :
10806 1786 : gfc_init_se (&se, NULL);
10807 3686 : while (ref && ref->next)
10808 : ref = ref->next;
10809 1786 : gfc_add_len_component (expr);
10810 1786 : gfc_conv_expr (&se, expr);
10811 1786 : gfc_add_block_to_block (block, &se.pre);
10812 1786 : gcc_assert (se.post.head == NULL_TREE);
10813 1786 : if (ref)
10814 : {
10815 262 : gfc_free_ref_list (ref->next);
10816 262 : ref->next = NULL;
10817 : }
10818 : else
10819 : {
10820 1524 : gfc_free_ref_list (expr->ref);
10821 1524 : expr->ref = NULL;
10822 : }
10823 1786 : return se.expr;
10824 : }
10825 :
10826 :
10827 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
10828 : statement-list outside of the scalarizer-loop. When code is generated, that
10829 : depends on the scalarized expression, it is added to RSE.PRE.
10830 : Returns le's _vptr tree and when set the len expressions in to_lenp and
10831 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
10832 : expression. */
10833 :
10834 : static tree
10835 4480 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
10836 : gfc_expr * re, gfc_se *rse,
10837 : tree * to_lenp, tree * from_lenp,
10838 : tree * from_vptrp)
10839 : {
10840 4480 : gfc_se se;
10841 4480 : gfc_expr * vptr_expr;
10842 4480 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
10843 4480 : bool set_vptr = false, temp_rhs = false;
10844 4480 : stmtblock_t *pre = block;
10845 4480 : tree class_expr = NULL_TREE;
10846 4480 : tree from_vptr = NULL_TREE;
10847 :
10848 : /* Create a temporary for complicated expressions. */
10849 4480 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
10850 1255 : && rse->expr != NULL_TREE)
10851 : {
10852 1255 : if (!DECL_P (rse->expr))
10853 : {
10854 402 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10855 37 : class_expr = gfc_get_class_from_expr (rse->expr);
10856 :
10857 402 : if (rse->loop)
10858 159 : pre = &rse->loop->pre;
10859 : else
10860 243 : pre = &rse->pre;
10861 :
10862 402 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
10863 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
10864 : else
10865 365 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
10866 :
10867 402 : rse->expr = tmp;
10868 : }
10869 : else
10870 853 : pre = &rse->pre;
10871 :
10872 : temp_rhs = true;
10873 : }
10874 :
10875 : /* Get the _vptr for the left-hand side expression. */
10876 4480 : gfc_init_se (&se, NULL);
10877 4480 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
10878 4480 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
10879 : {
10880 : /* Care about _len for unlimited polymorphic entities. */
10881 4462 : if (UNLIMITED_POLY (vptr_expr)
10882 3444 : || (vptr_expr->ts.type == BT_DERIVED
10883 2436 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10884 1502 : to_len = trans_get_upoly_len (block, vptr_expr);
10885 4462 : gfc_add_vptr_component (vptr_expr);
10886 4462 : set_vptr = true;
10887 : }
10888 : else
10889 18 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10890 4480 : se.want_pointer = 1;
10891 4480 : gfc_conv_expr (&se, vptr_expr);
10892 4480 : gfc_free_expr (vptr_expr);
10893 4480 : gfc_add_block_to_block (block, &se.pre);
10894 4480 : gcc_assert (se.post.head == NULL_TREE);
10895 4480 : lhs_vptr = se.expr;
10896 4480 : STRIP_NOPS (lhs_vptr);
10897 :
10898 : /* Set the _vptr only when the left-hand side of the assignment is a
10899 : class-object. */
10900 4480 : if (set_vptr)
10901 : {
10902 : /* Get the vptr from the rhs expression only, when it is variable.
10903 : Functions are expected to be assigned to a temporary beforehand. */
10904 3093 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
10905 5225 : ? gfc_find_and_cut_at_last_class_ref (re)
10906 : : NULL;
10907 763 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
10908 : {
10909 763 : if (to_len != NULL_TREE)
10910 : {
10911 : /* Get the _len information from the rhs. */
10912 299 : if (UNLIMITED_POLY (vptr_expr)
10913 : || (vptr_expr->ts.type == BT_DERIVED
10914 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10915 272 : from_len = trans_get_upoly_len (block, vptr_expr);
10916 : }
10917 763 : gfc_add_vptr_component (vptr_expr);
10918 : }
10919 : else
10920 : {
10921 3699 : if (re->expr_type == EXPR_VARIABLE
10922 2330 : && DECL_P (re->symtree->n.sym->backend_decl)
10923 2330 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
10924 821 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
10925 3766 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
10926 : re->symtree->n.sym->backend_decl))))
10927 : {
10928 43 : vptr_expr = NULL;
10929 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
10930 : re->symtree->n.sym->backend_decl));
10931 43 : if (to_len && UNLIMITED_POLY (re))
10932 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
10933 : re->symtree->n.sym->backend_decl));
10934 : }
10935 3656 : else if (temp_rhs && re->ts.type == BT_CLASS)
10936 : {
10937 213 : vptr_expr = NULL;
10938 213 : if (class_expr)
10939 : tmp = class_expr;
10940 176 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10941 0 : tmp = gfc_get_class_from_expr (rse->expr);
10942 : else
10943 : tmp = rse->expr;
10944 :
10945 213 : se.expr = gfc_class_vptr_get (tmp);
10946 213 : from_vptr = se.expr;
10947 213 : if (UNLIMITED_POLY (re))
10948 73 : from_len = gfc_class_len_get (tmp);
10949 :
10950 : }
10951 3443 : else if (re->expr_type != EXPR_NULL)
10952 : /* Only when rhs is non-NULL use its declared type for vptr
10953 : initialisation. */
10954 3317 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
10955 : else
10956 : /* When the rhs is NULL use the vtab of lhs' declared type. */
10957 126 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10958 : }
10959 :
10960 4279 : if (vptr_expr)
10961 : {
10962 4206 : gfc_init_se (&se, NULL);
10963 4206 : se.want_pointer = 1;
10964 4206 : gfc_conv_expr (&se, vptr_expr);
10965 4206 : gfc_free_expr (vptr_expr);
10966 4206 : gfc_add_block_to_block (block, &se.pre);
10967 4206 : gcc_assert (se.post.head == NULL_TREE);
10968 4206 : from_vptr = se.expr;
10969 : }
10970 4462 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
10971 : se.expr));
10972 :
10973 4462 : if (to_len != NULL_TREE)
10974 : {
10975 : /* The _len component needs to be set. Figure how to get the
10976 : value of the right-hand side. */
10977 1502 : if (from_len == NULL_TREE)
10978 : {
10979 1157 : if (rse->string_length != NULL_TREE)
10980 : from_len = rse->string_length;
10981 711 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
10982 : {
10983 0 : gfc_init_se (&se, NULL);
10984 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
10985 0 : gfc_add_block_to_block (block, &se.pre);
10986 0 : gcc_assert (se.post.head == NULL_TREE);
10987 0 : from_len = gfc_evaluate_now (se.expr, block);
10988 : }
10989 : else
10990 711 : from_len = build_zero_cst (gfc_charlen_type_node);
10991 : }
10992 1502 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
10993 : from_len));
10994 : }
10995 : }
10996 :
10997 : /* Return the _len and _vptr trees only, when requested. */
10998 4480 : if (to_lenp)
10999 3280 : *to_lenp = to_len;
11000 4480 : if (from_lenp)
11001 3280 : *from_lenp = from_len;
11002 4480 : if (from_vptrp)
11003 3280 : *from_vptrp = from_vptr;
11004 4480 : return lhs_vptr;
11005 : }
11006 :
11007 :
11008 : /* Assign tokens for pointer components. */
11009 :
11010 : static void
11011 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11012 : gfc_expr *expr2)
11013 : {
11014 12 : symbol_attribute lhs_attr, rhs_attr;
11015 12 : tree tmp, lhs_tok, rhs_tok;
11016 : /* Flag to indicated component refs on the rhs. */
11017 12 : bool rhs_cr;
11018 :
11019 12 : lhs_attr = gfc_caf_attr (expr1);
11020 12 : if (expr2->expr_type != EXPR_NULL)
11021 : {
11022 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11023 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11024 : {
11025 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11026 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11027 :
11028 4 : if (rhs_cr)
11029 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11030 : else
11031 : {
11032 4 : tree caf_decl;
11033 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11034 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11035 : NULL_TREE, NULL);
11036 : }
11037 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11038 : lhs_tok,
11039 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11040 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11041 : }
11042 : }
11043 4 : else if (lhs_attr.codimension)
11044 : {
11045 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11046 4 : if (!lhs_tok)
11047 : {
11048 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11049 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11050 : }
11051 : else
11052 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11053 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11054 : lhs_tok, null_pointer_node);
11055 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11056 : }
11057 12 : }
11058 :
11059 :
11060 : /* Do everything that is needed for a CLASS function expr2. */
11061 :
11062 : static tree
11063 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11064 : gfc_expr *expr1, gfc_expr *expr2)
11065 : {
11066 18 : tree expr1_vptr = NULL_TREE;
11067 18 : tree tmp;
11068 :
11069 18 : gfc_conv_function_expr (rse, expr2);
11070 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11071 :
11072 18 : if (expr1->ts.type != BT_CLASS)
11073 12 : rse->expr = gfc_class_data_get (rse->expr);
11074 : else
11075 : {
11076 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11077 : expr2, rse,
11078 : NULL, NULL, NULL);
11079 6 : gfc_add_block_to_block (block, &rse->pre);
11080 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11081 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11082 :
11083 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11084 6 : fold_convert (TREE_TYPE (expr1_vptr),
11085 : gfc_class_vptr_get (tmp)));
11086 6 : rse->expr = gfc_class_data_get (tmp);
11087 : }
11088 :
11089 18 : return expr1_vptr;
11090 : }
11091 :
11092 :
11093 : tree
11094 10080 : gfc_trans_pointer_assign (gfc_code * code)
11095 : {
11096 10080 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11097 : }
11098 :
11099 :
11100 : /* Generate code for a pointer assignment. */
11101 :
11102 : tree
11103 10135 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11104 : {
11105 10135 : gfc_se lse;
11106 10135 : gfc_se rse;
11107 10135 : stmtblock_t block;
11108 10135 : tree desc;
11109 10135 : tree tmp;
11110 10135 : tree expr1_vptr = NULL_TREE;
11111 10135 : bool scalar, non_proc_ptr_assign;
11112 10135 : gfc_ss *ss;
11113 :
11114 10135 : gfc_start_block (&block);
11115 :
11116 10135 : gfc_init_se (&lse, NULL);
11117 :
11118 : /* Usually testing whether this is not a proc pointer assignment. */
11119 10135 : non_proc_ptr_assign
11120 10135 : = !(gfc_expr_attr (expr1).proc_pointer
11121 1179 : && ((expr2->expr_type == EXPR_VARIABLE
11122 947 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11123 282 : || expr2->expr_type == EXPR_NULL));
11124 :
11125 : /* Check whether the expression is a scalar or not; we cannot use
11126 : expr1->rank as it can be nonzero for proc pointers. */
11127 10135 : ss = gfc_walk_expr (expr1);
11128 10135 : scalar = ss == gfc_ss_terminator;
11129 10135 : if (!scalar)
11130 4359 : gfc_free_ss_chain (ss);
11131 :
11132 10135 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11133 90 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11134 : {
11135 66 : gfc_add_data_component (expr2);
11136 : /* The following is required as gfc_add_data_component doesn't
11137 : update ts.type if there is a trailing REF_ARRAY. */
11138 66 : expr2->ts.type = BT_DERIVED;
11139 : }
11140 :
11141 10135 : if (scalar)
11142 : {
11143 : /* Scalar pointers. */
11144 5776 : lse.want_pointer = 1;
11145 5776 : gfc_conv_expr (&lse, expr1);
11146 5776 : gfc_init_se (&rse, NULL);
11147 5776 : rse.want_pointer = 1;
11148 5776 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11149 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11150 : else
11151 5770 : gfc_conv_expr (&rse, expr2);
11152 :
11153 5776 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11154 : {
11155 765 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11156 : NULL, NULL);
11157 765 : lse.expr = gfc_class_data_get (lse.expr);
11158 : }
11159 :
11160 5776 : if (expr1->symtree->n.sym->attr.proc_pointer
11161 850 : && expr1->symtree->n.sym->attr.dummy)
11162 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11163 : lse.expr);
11164 :
11165 5776 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11166 47 : && expr2->symtree->n.sym->attr.dummy)
11167 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11168 : rse.expr);
11169 :
11170 5776 : gfc_add_block_to_block (&block, &lse.pre);
11171 5776 : gfc_add_block_to_block (&block, &rse.pre);
11172 :
11173 : /* Check character lengths if character expression. The test is only
11174 : really added if -fbounds-check is enabled. Exclude deferred
11175 : character length lefthand sides. */
11176 954 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11177 780 : && !expr1->ts.deferred
11178 365 : && !expr1->symtree->n.sym->attr.proc_pointer
11179 6134 : && !gfc_is_proc_ptr_comp (expr1))
11180 : {
11181 339 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11182 339 : gcc_assert (lse.string_length && rse.string_length);
11183 339 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11184 : lse.string_length, rse.string_length,
11185 : &block);
11186 : }
11187 :
11188 : /* The assignment to an deferred character length sets the string
11189 : length to that of the rhs. */
11190 5776 : if (expr1->ts.deferred)
11191 : {
11192 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11193 413 : gfc_add_modify (&block, lse.string_length,
11194 413 : fold_convert (TREE_TYPE (lse.string_length),
11195 : rse.string_length));
11196 117 : else if (lse.string_length != NULL)
11197 115 : gfc_add_modify (&block, lse.string_length,
11198 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11199 : }
11200 :
11201 5776 : gfc_add_modify (&block, lse.expr,
11202 5776 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11203 :
11204 5776 : if (flag_coarray == GFC_FCOARRAY_LIB)
11205 : {
11206 335 : if (expr1->ref)
11207 : /* Also set the tokens for pointer components in derived typed
11208 : coarrays. */
11209 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11210 323 : else if (gfc_caf_attr (expr1).codimension)
11211 : {
11212 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11213 :
11214 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11215 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11216 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11217 : NULL_TREE, expr1);
11218 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11219 : NULL_TREE, expr2);
11220 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11221 : }
11222 : }
11223 :
11224 5776 : gfc_add_block_to_block (&block, &rse.post);
11225 5776 : gfc_add_block_to_block (&block, &lse.post);
11226 : }
11227 : else
11228 : {
11229 4359 : gfc_ref* remap;
11230 4359 : bool rank_remap;
11231 4359 : tree strlen_lhs;
11232 4359 : tree strlen_rhs = NULL_TREE;
11233 :
11234 : /* Array pointer. Find the last reference on the LHS and if it is an
11235 : array section ref, we're dealing with bounds remapping. In this case,
11236 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11237 : not see it and process the bounds remapping afterwards explicitly. */
11238 14043 : for (remap = expr1->ref; remap; remap = remap->next)
11239 5704 : if (!remap->next && remap->type == REF_ARRAY
11240 4359 : && remap->u.ar.type == AR_SECTION)
11241 : break;
11242 4359 : rank_remap = (remap && remap->u.ar.end[0]);
11243 :
11244 379 : if (remap && expr2->expr_type == EXPR_NULL)
11245 : {
11246 2 : gfc_error ("If bounds remapping is specified at %L, "
11247 : "the pointer target shall not be NULL", &expr1->where);
11248 2 : return NULL_TREE;
11249 : }
11250 :
11251 4357 : gfc_init_se (&lse, NULL);
11252 4357 : if (remap)
11253 377 : lse.descriptor_only = 1;
11254 4357 : gfc_conv_expr_descriptor (&lse, expr1);
11255 4357 : strlen_lhs = lse.string_length;
11256 4357 : desc = lse.expr;
11257 :
11258 4357 : if (expr2->expr_type == EXPR_NULL)
11259 : {
11260 : /* Just set the data pointer to null. */
11261 680 : gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
11262 : }
11263 3677 : else if (rank_remap)
11264 : {
11265 : /* If we are rank-remapping, just get the RHS's descriptor and
11266 : process this later on. */
11267 254 : gfc_init_se (&rse, NULL);
11268 254 : rse.direct_byref = 1;
11269 254 : rse.byref_noassign = 1;
11270 :
11271 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11272 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11273 : expr1, expr2);
11274 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11275 : {
11276 : tree bound[GFC_MAX_DIMENSIONS];
11277 : int i;
11278 :
11279 26 : for (i = 0; i < expr2->rank; i++)
11280 13 : bound[i] = NULL_TREE;
11281 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11282 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11283 : bound, bound, 0,
11284 : GFC_ARRAY_POINTER_CONT, false);
11285 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11286 13 : rse.descriptor_only = 0;
11287 13 : rse.expr = tmp;
11288 13 : rse.direct_byref = 1;
11289 13 : gfc_conv_expr_descriptor (&rse, expr2);
11290 13 : strlen_rhs = rse.string_length;
11291 13 : rse.expr = tmp;
11292 : }
11293 : else
11294 : {
11295 229 : gfc_conv_expr_descriptor (&rse, expr2);
11296 229 : strlen_rhs = rse.string_length;
11297 229 : if (expr1->ts.type == BT_CLASS)
11298 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11299 : expr2, &rse,
11300 : NULL, NULL,
11301 : NULL);
11302 : }
11303 : }
11304 3423 : else if (expr2->expr_type == EXPR_VARIABLE)
11305 : {
11306 : /* Assign directly to the LHS's descriptor. */
11307 3291 : lse.descriptor_only = 0;
11308 3291 : lse.direct_byref = 1;
11309 3291 : gfc_conv_expr_descriptor (&lse, expr2);
11310 3291 : strlen_rhs = lse.string_length;
11311 3291 : gfc_init_se (&rse, NULL);
11312 :
11313 3291 : if (expr1->ts.type == BT_CLASS)
11314 : {
11315 356 : rse.expr = NULL_TREE;
11316 356 : rse.string_length = strlen_rhs;
11317 356 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11318 : NULL, NULL, NULL);
11319 : }
11320 :
11321 3291 : if (remap == NULL)
11322 : {
11323 : /* If the target is not a whole array, use the target array
11324 : reference for remap. */
11325 6755 : for (remap = expr2->ref; remap; remap = remap->next)
11326 3737 : if (remap->type == REF_ARRAY
11327 3228 : && remap->u.ar.type == AR_FULL
11328 2536 : && remap->next)
11329 : break;
11330 : }
11331 : }
11332 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11333 : {
11334 25 : gfc_init_se (&rse, NULL);
11335 25 : rse.want_pointer = 1;
11336 25 : gfc_conv_function_expr (&rse, expr2);
11337 25 : if (expr1->ts.type != BT_CLASS)
11338 : {
11339 12 : rse.expr = gfc_class_data_get (rse.expr);
11340 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11341 : }
11342 : else
11343 : {
11344 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11345 : expr2, &rse, NULL,
11346 : NULL, NULL);
11347 13 : gfc_add_block_to_block (&block, &rse.pre);
11348 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11349 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11350 :
11351 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11352 13 : fold_convert (TREE_TYPE (expr1_vptr),
11353 : gfc_class_vptr_get (tmp)));
11354 13 : rse.expr = gfc_class_data_get (tmp);
11355 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11356 : }
11357 : }
11358 : else
11359 : {
11360 : /* Assign to a temporary descriptor and then copy that
11361 : temporary to the pointer. */
11362 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11363 107 : lse.descriptor_only = 0;
11364 107 : lse.expr = tmp;
11365 107 : lse.direct_byref = 1;
11366 107 : gfc_conv_expr_descriptor (&lse, expr2);
11367 107 : strlen_rhs = lse.string_length;
11368 107 : gfc_add_modify (&lse.pre, desc, tmp);
11369 : }
11370 :
11371 4357 : if (expr1->ts.type == BT_CHARACTER
11372 596 : && expr1->ts.deferred)
11373 : {
11374 338 : gfc_symbol *psym = expr1->symtree->n.sym;
11375 338 : tmp = NULL_TREE;
11376 338 : if (psym->ts.type == BT_CHARACTER
11377 337 : && psym->ts.u.cl->backend_decl)
11378 337 : tmp = psym->ts.u.cl->backend_decl;
11379 1 : else if (expr1->ts.u.cl->backend_decl
11380 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11381 0 : tmp = expr1->ts.u.cl->backend_decl;
11382 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11383 : {
11384 1 : gfc_ref *ref = expr1->ref;
11385 3 : for (;ref; ref = ref->next)
11386 : {
11387 2 : if (ref->type == REF_COMPONENT
11388 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11389 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11390 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11391 1 : TREE_TYPE (tmp),
11392 1 : TREE_OPERAND (lse.expr, 0),
11393 : tmp, NULL_TREE);
11394 : }
11395 : }
11396 :
11397 338 : gcc_assert (tmp);
11398 :
11399 338 : if (expr2->expr_type != EXPR_NULL)
11400 326 : gfc_add_modify (&block, tmp,
11401 326 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
11402 : else
11403 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
11404 : }
11405 :
11406 4357 : gfc_add_block_to_block (&block, &lse.pre);
11407 4357 : if (rank_remap)
11408 254 : gfc_add_block_to_block (&block, &rse.pre);
11409 :
11410 : /* If we do bounds remapping, update LHS descriptor accordingly. */
11411 4357 : if (remap)
11412 : {
11413 527 : int dim;
11414 527 : gcc_assert (remap->u.ar.dimen == expr1->rank);
11415 :
11416 : /* Always set dtype. */
11417 527 : tree dtype = gfc_conv_descriptor_dtype (desc);
11418 527 : tmp = gfc_get_dtype (TREE_TYPE (desc));
11419 527 : gfc_add_modify (&block, dtype, tmp);
11420 :
11421 : /* For unlimited polymorphic LHS use elem_len from RHS. */
11422 527 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11423 : {
11424 60 : tree elem_len;
11425 60 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11426 60 : elem_len = fold_convert (gfc_array_index_type, tmp);
11427 60 : elem_len = gfc_evaluate_now (elem_len, &block);
11428 60 : tmp = gfc_conv_descriptor_elem_len (desc);
11429 60 : gfc_add_modify (&block, tmp,
11430 60 : fold_convert (TREE_TYPE (tmp), elem_len));
11431 : }
11432 :
11433 527 : if (rank_remap)
11434 : {
11435 : /* Do rank remapping. We already have the RHS's descriptor
11436 : converted in rse and now have to build the correct LHS
11437 : descriptor for it. */
11438 :
11439 254 : tree data, span;
11440 254 : tree offs, stride;
11441 254 : tree lbound, ubound;
11442 :
11443 : /* Copy data pointer. */
11444 254 : data = gfc_conv_descriptor_data_get (rse.expr);
11445 254 : gfc_conv_descriptor_data_set (&block, desc, data);
11446 :
11447 : /* Copy the span. */
11448 254 : if (VAR_P (rse.expr)
11449 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
11450 12 : span = gfc_conv_descriptor_span_get (rse.expr);
11451 : else
11452 : {
11453 242 : tmp = TREE_TYPE (rse.expr);
11454 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
11455 242 : span = fold_convert (gfc_array_index_type, tmp);
11456 : }
11457 254 : gfc_conv_descriptor_span_set (&block, desc, span);
11458 :
11459 : /* Copy offset but adjust it such that it would correspond
11460 : to a lbound of zero. */
11461 254 : if (expr2->rank == -1)
11462 42 : gfc_conv_descriptor_offset_set (&block, desc,
11463 : gfc_index_zero_node);
11464 : else
11465 : {
11466 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
11467 654 : for (dim = 0; dim < expr2->rank; ++dim)
11468 : {
11469 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11470 : gfc_rank_cst[dim]);
11471 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
11472 : gfc_rank_cst[dim]);
11473 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11474 : gfc_array_index_type, stride,
11475 : lbound);
11476 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
11477 : gfc_array_index_type, offs, tmp);
11478 : }
11479 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11480 : }
11481 : /* Set the bounds as declared for the LHS and calculate strides as
11482 : well as another offset update accordingly. */
11483 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11484 : gfc_rank_cst[0]);
11485 641 : for (dim = 0; dim < expr1->rank; ++dim)
11486 : {
11487 387 : gfc_se lower_se;
11488 387 : gfc_se upper_se;
11489 :
11490 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
11491 :
11492 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
11493 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
11494 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
11495 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
11496 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
11497 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
11498 :
11499 : /* Convert declared bounds. */
11500 387 : gfc_init_se (&lower_se, NULL);
11501 387 : gfc_init_se (&upper_se, NULL);
11502 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
11503 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
11504 :
11505 387 : gfc_add_block_to_block (&block, &lower_se.pre);
11506 387 : gfc_add_block_to_block (&block, &upper_se.pre);
11507 :
11508 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
11509 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
11510 :
11511 387 : lbound = gfc_evaluate_now (lbound, &block);
11512 387 : ubound = gfc_evaluate_now (ubound, &block);
11513 :
11514 387 : gfc_add_block_to_block (&block, &lower_se.post);
11515 387 : gfc_add_block_to_block (&block, &upper_se.post);
11516 :
11517 : /* Set bounds in descriptor. */
11518 387 : gfc_conv_descriptor_lbound_set (&block, desc,
11519 : gfc_rank_cst[dim], lbound);
11520 387 : gfc_conv_descriptor_ubound_set (&block, desc,
11521 : gfc_rank_cst[dim], ubound);
11522 :
11523 : /* Set stride. */
11524 387 : stride = gfc_evaluate_now (stride, &block);
11525 387 : gfc_conv_descriptor_stride_set (&block, desc,
11526 : gfc_rank_cst[dim], stride);
11527 :
11528 : /* Update offset. */
11529 387 : offs = gfc_conv_descriptor_offset_get (desc);
11530 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11531 : gfc_array_index_type, lbound, stride);
11532 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
11533 : gfc_array_index_type, offs, tmp);
11534 387 : offs = gfc_evaluate_now (offs, &block);
11535 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11536 :
11537 : /* Update stride. */
11538 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11539 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
11540 : gfc_array_index_type, stride, tmp);
11541 : }
11542 : }
11543 : else
11544 : {
11545 : /* Bounds remapping. Just shift the lower bounds. */
11546 :
11547 273 : gcc_assert (expr1->rank == expr2->rank);
11548 :
11549 654 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
11550 : {
11551 381 : gfc_se lbound_se;
11552 :
11553 381 : gcc_assert (!remap->u.ar.end[dim]);
11554 381 : gfc_init_se (&lbound_se, NULL);
11555 381 : if (remap->u.ar.start[dim])
11556 : {
11557 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
11558 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
11559 : }
11560 : else
11561 : /* This remap arises from a target that is not a whole
11562 : array. The start expressions will be NULL but we need
11563 : the lbounds to be one. */
11564 156 : lbound_se.expr = gfc_index_one_node;
11565 381 : gfc_conv_shift_descriptor_lbound (&block, desc,
11566 : dim, lbound_se.expr);
11567 381 : gfc_add_block_to_block (&block, &lbound_se.post);
11568 : }
11569 : }
11570 : }
11571 :
11572 : /* If rank remapping was done, check with -fcheck=bounds that
11573 : the target is at least as large as the pointer. */
11574 4357 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
11575 72 : && expr2->rank != -1)
11576 : {
11577 54 : tree lsize, rsize;
11578 54 : tree fault;
11579 54 : const char* msg;
11580 :
11581 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
11582 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
11583 :
11584 54 : lsize = gfc_evaluate_now (lsize, &block);
11585 54 : rsize = gfc_evaluate_now (rsize, &block);
11586 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11587 : rsize, lsize);
11588 :
11589 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
11590 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
11591 : msg, rsize, lsize);
11592 : }
11593 :
11594 : /* Check string lengths if applicable. The check is only really added
11595 : to the output code if -fbounds-check is enabled. */
11596 4357 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
11597 : {
11598 530 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11599 530 : gcc_assert (strlen_lhs && strlen_rhs);
11600 530 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11601 : strlen_lhs, strlen_rhs, &block);
11602 : }
11603 :
11604 4357 : gfc_add_block_to_block (&block, &lse.post);
11605 4357 : if (rank_remap)
11606 254 : gfc_add_block_to_block (&block, &rse.post);
11607 : }
11608 :
11609 10133 : return gfc_finish_block (&block);
11610 : }
11611 :
11612 :
11613 : /* Makes sure se is suitable for passing as a function string parameter. */
11614 : /* TODO: Need to check all callers of this function. It may be abused. */
11615 :
11616 : void
11617 241492 : gfc_conv_string_parameter (gfc_se * se)
11618 : {
11619 241492 : tree type;
11620 :
11621 241492 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
11622 241492 : && integer_onep (se->string_length))
11623 : {
11624 667 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11625 667 : return;
11626 : }
11627 :
11628 240825 : if (TREE_CODE (se->expr) == STRING_CST)
11629 : {
11630 100162 : type = TREE_TYPE (TREE_TYPE (se->expr));
11631 100162 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11632 100162 : return;
11633 : }
11634 :
11635 140663 : if (TREE_CODE (se->expr) == COND_EXPR)
11636 : {
11637 482 : tree cond = TREE_OPERAND (se->expr, 0);
11638 482 : tree lhs = TREE_OPERAND (se->expr, 1);
11639 482 : tree rhs = TREE_OPERAND (se->expr, 2);
11640 :
11641 482 : gfc_se lse, rse;
11642 482 : gfc_init_se (&lse, NULL);
11643 482 : gfc_init_se (&rse, NULL);
11644 :
11645 482 : lse.expr = lhs;
11646 482 : lse.string_length = se->string_length;
11647 482 : gfc_conv_string_parameter (&lse);
11648 :
11649 482 : rse.expr = rhs;
11650 482 : rse.string_length = se->string_length;
11651 482 : gfc_conv_string_parameter (&rse);
11652 :
11653 482 : se->expr
11654 482 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
11655 : cond, lse.expr, rse.expr);
11656 : }
11657 :
11658 140663 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
11659 55169 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
11660 140759 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
11661 : {
11662 85590 : type = TREE_TYPE (se->expr);
11663 85590 : if (TREE_CODE (se->expr) != INDIRECT_REF)
11664 80540 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11665 : else
11666 : {
11667 5050 : if (TREE_CODE (type) == ARRAY_TYPE)
11668 5050 : type = TREE_TYPE (type);
11669 5050 : type = gfc_get_character_type_len_for_eltype (type,
11670 : se->string_length);
11671 5050 : type = build_pointer_type (type);
11672 5050 : se->expr = gfc_build_addr_expr (type, se->expr);
11673 : }
11674 : }
11675 :
11676 140663 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
11677 : }
11678 :
11679 :
11680 : /* Generate code for assignment of scalar variables. Includes character
11681 : strings and derived types with allocatable components.
11682 : If you know that the LHS has no allocations, set dealloc to false.
11683 :
11684 : DEEP_COPY has no effect if the typespec TS is not a derived type with
11685 : allocatable components. Otherwise, if it is set, an explicit copy of each
11686 : allocatable component is made. This is necessary as a simple copy of the
11687 : whole object would copy array descriptors as is, so that the lhs's
11688 : allocatable components would point to the rhs's after the assignment.
11689 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
11690 : necessary if the rhs is a non-pointer function, as the allocatable components
11691 : are not accessible by other means than the function's result after the
11692 : function has returned. It is even more subtle when temporaries are involved,
11693 : as the two following examples show:
11694 : 1. When we evaluate an array constructor, a temporary is created. Thus
11695 : there is theoretically no alias possible. However, no deep copy is
11696 : made for this temporary, so that if the constructor is made of one or
11697 : more variable with allocatable components, those components still point
11698 : to the variable's: DEEP_COPY should be set for the assignment from the
11699 : temporary to the lhs in that case.
11700 : 2. When assigning a scalar to an array, we evaluate the scalar value out
11701 : of the loop, store it into a temporary variable, and assign from that.
11702 : In that case, deep copying when assigning to the temporary would be a
11703 : waste of resources; however deep copies should happen when assigning from
11704 : the temporary to each array element: again DEEP_COPY should be set for
11705 : the assignment from the temporary to the lhs. */
11706 :
11707 : tree
11708 333774 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
11709 : bool deep_copy, bool dealloc, bool in_coarray,
11710 : bool assoc_assign)
11711 : {
11712 333774 : stmtblock_t block;
11713 333774 : tree tmp;
11714 333774 : tree cond;
11715 :
11716 333774 : gfc_init_block (&block);
11717 :
11718 333774 : if (ts.type == BT_CHARACTER)
11719 : {
11720 33071 : tree rlen = NULL;
11721 33071 : tree llen = NULL;
11722 :
11723 33071 : if (lse->string_length != NULL_TREE)
11724 : {
11725 33071 : gfc_conv_string_parameter (lse);
11726 33071 : gfc_add_block_to_block (&block, &lse->pre);
11727 33071 : llen = lse->string_length;
11728 : }
11729 :
11730 33071 : if (rse->string_length != NULL_TREE)
11731 : {
11732 33071 : gfc_conv_string_parameter (rse);
11733 33071 : gfc_add_block_to_block (&block, &rse->pre);
11734 33071 : rlen = rse->string_length;
11735 : }
11736 :
11737 33071 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
11738 : rse->expr, ts.kind);
11739 : }
11740 300703 : else if (gfc_bt_struct (ts.type)
11741 18468 : && (ts.u.derived->attr.alloc_comp
11742 12172 : || (deep_copy && ts.u.derived->attr.pdt_type)))
11743 : {
11744 6589 : tree tmp_var = NULL_TREE;
11745 6589 : cond = NULL_TREE;
11746 :
11747 : /* Are the rhs and the lhs the same? */
11748 6589 : if (deep_copy)
11749 : {
11750 3967 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11751 : gfc_build_addr_expr (NULL_TREE, lse->expr),
11752 : gfc_build_addr_expr (NULL_TREE, rse->expr));
11753 3967 : cond = gfc_evaluate_now (cond, &lse->pre);
11754 : }
11755 :
11756 : /* Deallocate the lhs allocated components as long as it is not
11757 : the same as the rhs. This must be done following the assignment
11758 : to prevent deallocating data that could be used in the rhs
11759 : expression. */
11760 6589 : if (dealloc)
11761 : {
11762 1833 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
11763 1833 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
11764 1833 : 0, gfc_may_be_finalized (ts));
11765 1833 : if (deep_copy)
11766 774 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11767 : tmp);
11768 1833 : gfc_add_expr_to_block (&lse->post, tmp);
11769 : }
11770 :
11771 6589 : gfc_add_block_to_block (&block, &rse->pre);
11772 :
11773 : /* Skip finalization for self-assignment. */
11774 6589 : if (deep_copy && lse->finalblock.head)
11775 : {
11776 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11777 : gfc_finish_block (&lse->finalblock));
11778 24 : gfc_add_expr_to_block (&block, tmp);
11779 : }
11780 : else
11781 6565 : gfc_add_block_to_block (&block, &lse->finalblock);
11782 :
11783 6589 : gfc_add_block_to_block (&block, &lse->pre);
11784 :
11785 6589 : gfc_add_modify (&block, lse->expr,
11786 6589 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11787 :
11788 : /* Restore pointer address of coarray components. */
11789 6589 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
11790 : {
11791 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
11792 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11793 : tmp);
11794 5 : gfc_add_expr_to_block (&block, tmp);
11795 : }
11796 :
11797 : /* Do a deep copy if the rhs is a variable, if it is not the
11798 : same as the lhs. */
11799 6589 : if (deep_copy)
11800 : {
11801 3967 : int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11802 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
11803 3967 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
11804 : caf_mode);
11805 3967 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11806 : tmp);
11807 3967 : gfc_add_expr_to_block (&block, tmp);
11808 : }
11809 : }
11810 294114 : else if (gfc_bt_struct (ts.type))
11811 : {
11812 11879 : gfc_add_block_to_block (&block, &rse->pre);
11813 11879 : gfc_add_block_to_block (&block, &lse->finalblock);
11814 11879 : gfc_add_block_to_block (&block, &lse->pre);
11815 11879 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11816 11879 : TREE_TYPE (lse->expr), rse->expr);
11817 11879 : gfc_add_modify (&block, lse->expr, tmp);
11818 : }
11819 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
11820 282235 : else if (ts.type == BT_CLASS)
11821 : {
11822 758 : gfc_add_block_to_block (&block, &lse->pre);
11823 758 : gfc_add_block_to_block (&block, &rse->pre);
11824 758 : gfc_add_block_to_block (&block, &lse->finalblock);
11825 :
11826 758 : if (!trans_scalar_class_assign (&block, lse, rse))
11827 : {
11828 : /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
11829 : for the lhs which ensures that class data rhs cast as a string assigns
11830 : correctly. */
11831 624 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11832 624 : TREE_TYPE (rse->expr), lse->expr);
11833 624 : gfc_add_modify (&block, tmp, rse->expr);
11834 : }
11835 : }
11836 281477 : else if (ts.type != BT_CLASS)
11837 : {
11838 281477 : gfc_add_block_to_block (&block, &lse->pre);
11839 281477 : gfc_add_block_to_block (&block, &rse->pre);
11840 :
11841 281477 : if (in_coarray)
11842 : {
11843 833 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
11844 : {
11845 0 : gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr),
11846 0 : TYPE_LANG_SPECIFIC (
11847 : TREE_TYPE (TREE_TYPE (rse->expr)))
11848 : ->caf_token);
11849 : }
11850 833 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
11851 0 : lse->expr = gfc_conv_array_data (lse->expr);
11852 273 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
11853 833 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
11854 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
11855 : }
11856 281477 : gfc_add_modify (&block, lse->expr,
11857 281477 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11858 : }
11859 :
11860 333774 : gfc_add_block_to_block (&block, &lse->post);
11861 333774 : gfc_add_block_to_block (&block, &rse->post);
11862 :
11863 333774 : return gfc_finish_block (&block);
11864 : }
11865 :
11866 :
11867 : /* There are quite a lot of restrictions on the optimisation in using an
11868 : array function assign without a temporary. */
11869 :
11870 : static bool
11871 14403 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
11872 : {
11873 14403 : gfc_ref * ref;
11874 14403 : bool seen_array_ref;
11875 14403 : bool c = false;
11876 14403 : gfc_symbol *sym = expr1->symtree->n.sym;
11877 :
11878 : /* Play it safe with class functions assigned to a derived type. */
11879 14403 : if (gfc_is_class_array_function (expr2)
11880 14403 : && expr1->ts.type == BT_DERIVED)
11881 : return true;
11882 :
11883 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
11884 14379 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
11885 : return true;
11886 :
11887 : /* Elemental functions are scalarized so that they don't need a
11888 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
11889 : they would need special treatment in gfc_trans_arrayfunc_assign. */
11890 8482 : if (expr2->value.function.esym != NULL
11891 1529 : && expr2->value.function.esym->attr.elemental)
11892 : return true;
11893 :
11894 : /* Need a temporary if rhs is not FULL or a contiguous section. */
11895 8135 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
11896 : return true;
11897 :
11898 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
11899 7891 : if (gfc_ref_needs_temporary_p (expr1->ref))
11900 : return true;
11901 :
11902 : /* Functions returning pointers or allocatables need temporaries. */
11903 7879 : if (gfc_expr_attr (expr2).pointer
11904 7879 : || gfc_expr_attr (expr2).allocatable)
11905 382 : return true;
11906 :
11907 : /* Character array functions need temporaries unless the
11908 : character lengths are the same. */
11909 7497 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
11910 : {
11911 562 : if (UNLIMITED_POLY (expr1))
11912 : return true;
11913 :
11914 556 : if (expr1->ts.u.cl->length == NULL
11915 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11916 : return true;
11917 :
11918 493 : if (expr2->ts.u.cl->length == NULL
11919 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11920 : return true;
11921 :
11922 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
11923 475 : expr2->ts.u.cl->length->value.integer) != 0)
11924 : return true;
11925 : }
11926 :
11927 : /* Check that no LHS component references appear during an array
11928 : reference. This is needed because we do not have the means to
11929 : span any arbitrary stride with an array descriptor. This check
11930 : is not needed for the rhs because the function result has to be
11931 : a complete type. */
11932 7404 : seen_array_ref = false;
11933 14808 : for (ref = expr1->ref; ref; ref = ref->next)
11934 : {
11935 7417 : if (ref->type == REF_ARRAY)
11936 : seen_array_ref= true;
11937 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
11938 : return true;
11939 : }
11940 :
11941 : /* Check for a dependency. */
11942 7391 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
11943 : expr2->value.function.esym,
11944 : expr2->value.function.actual,
11945 : NOT_ELEMENTAL))
11946 : return true;
11947 :
11948 : /* If we have reached here with an intrinsic function, we do not
11949 : need a temporary except in the particular case that reallocation
11950 : on assignment is active and the lhs is allocatable and a target,
11951 : or a pointer which may be a subref pointer. FIXME: The last
11952 : condition can go away when we use span in the intrinsics
11953 : directly.*/
11954 6954 : if (expr2->value.function.isym)
11955 6112 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
11956 12311 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
11957 :
11958 : /* If the LHS is a dummy, we need a temporary if it is not
11959 : INTENT(OUT). */
11960 767 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
11961 : return true;
11962 :
11963 : /* If the lhs has been host_associated, is in common, a pointer or is
11964 : a target and the function is not using a RESULT variable, aliasing
11965 : can occur and a temporary is needed. */
11966 761 : if ((sym->attr.host_assoc
11967 707 : || sym->attr.in_common
11968 701 : || sym->attr.pointer
11969 695 : || sym->attr.cray_pointee
11970 695 : || sym->attr.target)
11971 66 : && expr2->symtree != NULL
11972 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
11973 : return true;
11974 :
11975 : /* A PURE function can unconditionally be called without a temporary. */
11976 719 : if (expr2->value.function.esym != NULL
11977 694 : && expr2->value.function.esym->attr.pure)
11978 : return false;
11979 :
11980 : /* Implicit_pure functions are those which could legally be declared
11981 : to be PURE. */
11982 691 : if (expr2->value.function.esym != NULL
11983 666 : && expr2->value.function.esym->attr.implicit_pure)
11984 : return false;
11985 :
11986 408 : if (!sym->attr.use_assoc
11987 408 : && !sym->attr.in_common
11988 408 : && !sym->attr.pointer
11989 402 : && !sym->attr.target
11990 402 : && !sym->attr.cray_pointee
11991 402 : && expr2->value.function.esym)
11992 : {
11993 : /* A temporary is not needed if the function is not contained and
11994 : the variable is local or host associated and not a pointer or
11995 : a target. */
11996 377 : if (!expr2->value.function.esym->attr.contained)
11997 : return false;
11998 :
11999 : /* A temporary is not needed if the lhs has never been host
12000 : associated and the procedure is contained. */
12001 146 : else if (!sym->attr.host_assoc)
12002 : return false;
12003 :
12004 : /* A temporary is not needed if the variable is local and not
12005 : a pointer, a target or a result. */
12006 6 : if (sym->ns->parent
12007 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12008 : return false;
12009 : }
12010 :
12011 : /* Default to temporary use. */
12012 : return true;
12013 : }
12014 :
12015 :
12016 : /* Provide the loop info so that the lhs descriptor can be built for
12017 : reallocatable assignments from extrinsic function calls. */
12018 :
12019 : static void
12020 167 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12021 : gfc_loopinfo *loop)
12022 : {
12023 : /* Signal that the function call should not be made by
12024 : gfc_conv_loop_setup. */
12025 167 : se->ss->is_alloc_lhs = 1;
12026 167 : gfc_init_loopinfo (loop);
12027 167 : gfc_add_ss_to_loop (loop, *ss);
12028 167 : gfc_add_ss_to_loop (loop, se->ss);
12029 167 : gfc_conv_ss_startstride (loop);
12030 167 : gfc_conv_loop_setup (loop, where);
12031 167 : gfc_copy_loopinfo_to_se (se, loop);
12032 167 : gfc_add_block_to_block (&se->pre, &loop->pre);
12033 167 : gfc_add_block_to_block (&se->pre, &loop->post);
12034 167 : se->ss->is_alloc_lhs = 0;
12035 167 : }
12036 :
12037 :
12038 : /* For assignment to a reallocatable lhs from intrinsic functions,
12039 : replace the se.expr (ie. the result) with a temporary descriptor.
12040 : Null the data field so that the library allocates space for the
12041 : result. Free the data of the original descriptor after the function,
12042 : in case it appears in an argument expression and transfer the
12043 : result to the original descriptor. */
12044 :
12045 : static void
12046 2120 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12047 : {
12048 2120 : tree desc;
12049 2120 : tree res_desc;
12050 2120 : tree tmp;
12051 2120 : tree offset;
12052 2120 : tree zero_cond;
12053 2120 : tree not_same_shape;
12054 2120 : stmtblock_t shape_block;
12055 2120 : int n;
12056 :
12057 : /* Use the allocation done by the library. Substitute the lhs
12058 : descriptor with a copy, whose data field is nulled.*/
12059 2120 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12060 2120 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12061 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12062 :
12063 : /* Unallocated, the descriptor does not have a dtype. */
12064 2120 : tmp = gfc_conv_descriptor_dtype (desc);
12065 2120 : if (dtype != NULL_TREE)
12066 13 : gfc_add_modify (&se->pre, tmp, dtype);
12067 : else
12068 2107 : gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12069 :
12070 2120 : res_desc = gfc_evaluate_now (desc, &se->pre);
12071 2120 : gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
12072 2120 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12073 :
12074 : /* Free the lhs after the function call and copy the result data to
12075 : the lhs descriptor. */
12076 2120 : tmp = gfc_conv_descriptor_data_get (desc);
12077 2120 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12078 : logical_type_node, tmp,
12079 2120 : build_int_cst (TREE_TYPE (tmp), 0));
12080 2120 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12081 2120 : tmp = gfc_call_free (tmp);
12082 2120 : gfc_add_expr_to_block (&se->post, tmp);
12083 :
12084 2120 : tmp = gfc_conv_descriptor_data_get (res_desc);
12085 2120 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12086 :
12087 : /* Check that the shapes are the same between lhs and expression.
12088 : The evaluation of the shape is done in 'shape_block' to avoid
12089 : unitialized warnings from the lhs bounds. */
12090 2120 : not_same_shape = boolean_false_node;
12091 2120 : gfc_start_block (&shape_block);
12092 6826 : for (n = 0 ; n < rank; n++)
12093 : {
12094 4706 : tree tmp1;
12095 4706 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12096 4706 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12097 4706 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12098 : gfc_array_index_type, tmp, tmp1);
12099 4706 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12100 4706 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12101 : gfc_array_index_type, tmp, tmp1);
12102 4706 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12103 4706 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12104 : gfc_array_index_type, tmp, tmp1);
12105 4706 : tmp = fold_build2_loc (input_location, NE_EXPR,
12106 : logical_type_node, tmp,
12107 : gfc_index_zero_node);
12108 4706 : tmp = gfc_evaluate_now (tmp, &shape_block);
12109 4706 : if (n == 0)
12110 : not_same_shape = tmp;
12111 : else
12112 2586 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12113 : logical_type_node, tmp,
12114 : not_same_shape);
12115 : }
12116 :
12117 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12118 : shapes being different. */
12119 2120 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12120 : zero_cond, not_same_shape);
12121 2120 : gfc_add_modify (&shape_block, zero_cond, tmp);
12122 2120 : tmp = gfc_finish_block (&shape_block);
12123 2120 : tmp = build3_v (COND_EXPR, zero_cond,
12124 : build_empty_stmt (input_location), tmp);
12125 2120 : gfc_add_expr_to_block (&se->post, tmp);
12126 :
12127 : /* Now reset the bounds returned from the function call to bounds based
12128 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12129 : of 'variable and 'expr' are different. Set the offset accordingly. */
12130 2120 : offset = gfc_index_zero_node;
12131 6826 : for (n = 0 ; n < rank; n++)
12132 : {
12133 4706 : tree lbound;
12134 :
12135 4706 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12136 4706 : lbound = fold_build3_loc (input_location, COND_EXPR,
12137 : gfc_array_index_type, zero_cond,
12138 : gfc_index_one_node, lbound);
12139 4706 : lbound = gfc_evaluate_now (lbound, &se->post);
12140 :
12141 4706 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12142 4706 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12143 : gfc_array_index_type, tmp, lbound);
12144 4706 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12145 : gfc_rank_cst[n], lbound);
12146 4706 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12147 : gfc_rank_cst[n], tmp);
12148 :
12149 : /* Set stride and accumulate the offset. */
12150 4706 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12151 4706 : gfc_conv_descriptor_stride_set (&se->post, desc,
12152 : gfc_rank_cst[n], tmp);
12153 4706 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12154 : gfc_array_index_type, lbound, tmp);
12155 4706 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12156 : gfc_array_index_type, offset, tmp);
12157 4706 : offset = gfc_evaluate_now (offset, &se->post);
12158 : }
12159 :
12160 2120 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12161 2120 : }
12162 :
12163 :
12164 :
12165 : /* Try to translate array(:) = func (...), where func is a transformational
12166 : array function, without using a temporary. Returns NULL if this isn't the
12167 : case. */
12168 :
12169 : static tree
12170 14403 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12171 : {
12172 14403 : gfc_se se;
12173 14403 : gfc_ss *ss = NULL;
12174 14403 : gfc_component *comp = NULL;
12175 14403 : gfc_loopinfo loop;
12176 14403 : tree tmp;
12177 14403 : tree lhs;
12178 14403 : gfc_se final_se;
12179 14403 : gfc_symbol *sym = expr1->symtree->n.sym;
12180 14403 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12181 :
12182 14403 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12183 : return NULL;
12184 :
12185 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12186 : functions. */
12187 6836 : comp = gfc_get_proc_ptr_comp (expr2);
12188 :
12189 6836 : if (!(expr2->value.function.isym
12190 682 : || (comp && comp->attr.dimension)
12191 682 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12192 682 : && expr2->value.function.esym->result->attr.dimension)))
12193 0 : return NULL;
12194 :
12195 6836 : gfc_init_se (&se, NULL);
12196 6836 : gfc_start_block (&se.pre);
12197 6836 : se.want_pointer = 1;
12198 :
12199 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12200 : backend decl, stash the original away for the finalization so that the
12201 : value used is that before the assignment. This is necessary because
12202 : evaluation of the rhs expression using direct by reference can change
12203 : the value. However, the standard mandates that the finalization must occur
12204 : after evaluation of the rhs. */
12205 6836 : gfc_init_se (&final_se, NULL);
12206 :
12207 6836 : if (finalizable)
12208 : {
12209 33 : tmp = sym->backend_decl;
12210 33 : lhs = sym->backend_decl;
12211 33 : if (INDIRECT_REF_P (tmp))
12212 0 : tmp = TREE_OPERAND (tmp, 0);
12213 33 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12214 33 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12215 33 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12216 : {
12217 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12218 : expr1->rank, 0);
12219 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12220 : }
12221 : }
12222 :
12223 33 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12224 : {
12225 33 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12226 33 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12227 : }
12228 :
12229 6836 : if (finalizable)
12230 33 : sym->backend_decl = lhs;
12231 :
12232 6836 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12233 :
12234 6836 : if (expr1->ts.type == BT_DERIVED
12235 234 : && expr1->ts.u.derived->attr.alloc_comp)
12236 : {
12237 80 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12238 80 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12239 : expr1->rank);
12240 80 : gfc_add_expr_to_block (&se.pre, tmp);
12241 : }
12242 :
12243 6836 : se.direct_byref = 1;
12244 6836 : se.ss = gfc_walk_expr (expr2);
12245 6836 : gcc_assert (se.ss != gfc_ss_terminator);
12246 :
12247 : /* Since this is a direct by reference call, references to the lhs can be
12248 : used for finalization of the function result just as long as the blocks
12249 : from final_se are added at the right time. */
12250 6836 : gfc_init_se (&final_se, NULL);
12251 6836 : if (finalizable && expr2->value.function.esym)
12252 : {
12253 20 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12254 20 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12255 20 : expr2->value.function.esym->attr,
12256 : expr2->rank);
12257 : }
12258 :
12259 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12260 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12261 : Clearly, this cannot be done for an allocatable function result, since
12262 : the shape of the result is unknown and, in any case, the function must
12263 : correctly take care of the reallocation internally. For intrinsic
12264 : calls, the array data is freed and the library takes care of allocation.
12265 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12266 : to the library. */
12267 6836 : if (flag_realloc_lhs
12268 6761 : && gfc_is_reallocatable_lhs (expr1)
12269 9123 : && !gfc_expr_attr (expr1).codimension
12270 2287 : && !gfc_is_coindexed (expr1)
12271 9123 : && !(expr2->value.function.esym
12272 167 : && expr2->value.function.esym->result->attr.allocatable))
12273 : {
12274 2287 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12275 :
12276 2287 : if (!expr2->value.function.isym)
12277 : {
12278 167 : ss = gfc_walk_expr (expr1);
12279 167 : gcc_assert (ss != gfc_ss_terminator);
12280 :
12281 167 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12282 167 : ss->is_alloc_lhs = 1;
12283 : }
12284 : else
12285 : {
12286 2120 : tree dtype = NULL_TREE;
12287 2120 : tree type = gfc_typenode_for_spec (&expr2->ts);
12288 2120 : if (expr1->ts.type == BT_CLASS)
12289 : {
12290 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12291 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12292 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12293 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12294 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12295 : }
12296 2120 : fcncall_realloc_result (&se, expr1->rank, dtype);
12297 : }
12298 : }
12299 :
12300 6836 : gfc_conv_function_expr (&se, expr2);
12301 :
12302 : /* Fix the result. */
12303 6836 : gfc_add_block_to_block (&se.pre, &se.post);
12304 6836 : if (finalizable)
12305 33 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12306 :
12307 : /* Do the finalization, including final calls from function arguments. */
12308 33 : if (finalizable)
12309 : {
12310 33 : gfc_add_block_to_block (&se.pre, &final_se.post);
12311 33 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12312 33 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12313 : }
12314 :
12315 6836 : if (ss)
12316 167 : gfc_cleanup_loop (&loop);
12317 : else
12318 6669 : gfc_free_ss_chain (se.ss);
12319 :
12320 6836 : return gfc_finish_block (&se.pre);
12321 : }
12322 :
12323 :
12324 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12325 : can't be done. */
12326 :
12327 : static tree
12328 3929 : gfc_trans_zero_assign (gfc_expr * expr)
12329 : {
12330 3929 : tree dest, len, type;
12331 3929 : tree tmp;
12332 3929 : gfc_symbol *sym;
12333 :
12334 3929 : sym = expr->symtree->n.sym;
12335 3929 : dest = gfc_get_symbol_decl (sym);
12336 :
12337 3929 : type = TREE_TYPE (dest);
12338 3929 : if (POINTER_TYPE_P (type))
12339 248 : type = TREE_TYPE (type);
12340 3929 : if (GFC_ARRAY_TYPE_P (type))
12341 : {
12342 : /* Determine the length of the array. */
12343 2752 : len = GFC_TYPE_ARRAY_SIZE (type);
12344 2752 : if (!len || TREE_CODE (len) != INTEGER_CST)
12345 : return NULL_TREE;
12346 : }
12347 1177 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12348 1177 : && gfc_is_simply_contiguous (expr, false, false))
12349 : {
12350 1077 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12351 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12352 1077 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12353 1077 : dest = gfc_conv_descriptor_data_get (dest);
12354 : }
12355 : else
12356 100 : return NULL_TREE;
12357 :
12358 : /* If we are zeroing a local array avoid taking its address by emitting
12359 : a = {} instead. */
12360 3650 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12361 2531 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12362 2531 : dest, build_constructor (TREE_TYPE (dest),
12363 2531 : NULL));
12364 :
12365 : /* Multiply len by element size. */
12366 1119 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12367 1119 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12368 : len, fold_convert (gfc_array_index_type, tmp));
12369 :
12370 : /* Convert arguments to the correct types. */
12371 1119 : dest = fold_convert (pvoid_type_node, dest);
12372 1119 : len = fold_convert (size_type_node, len);
12373 :
12374 : /* Construct call to __builtin_memset. */
12375 1119 : tmp = build_call_expr_loc (input_location,
12376 : builtin_decl_explicit (BUILT_IN_MEMSET),
12377 : 3, dest, integer_zero_node, len);
12378 1119 : return fold_convert (void_type_node, tmp);
12379 : }
12380 :
12381 :
12382 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
12383 : that constructs the call to __builtin_memcpy. */
12384 :
12385 : tree
12386 7780 : gfc_build_memcpy_call (tree dst, tree src, tree len)
12387 : {
12388 7780 : tree tmp;
12389 :
12390 : /* Convert arguments to the correct types. */
12391 7780 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
12392 7521 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
12393 : else
12394 259 : dst = fold_convert (pvoid_type_node, dst);
12395 :
12396 7780 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
12397 7420 : src = gfc_build_addr_expr (pvoid_type_node, src);
12398 : else
12399 360 : src = fold_convert (pvoid_type_node, src);
12400 :
12401 7780 : len = fold_convert (size_type_node, len);
12402 :
12403 : /* Construct call to __builtin_memcpy. */
12404 7780 : tmp = build_call_expr_loc (input_location,
12405 : builtin_decl_explicit (BUILT_IN_MEMCPY),
12406 : 3, dst, src, len);
12407 7780 : return fold_convert (void_type_node, tmp);
12408 : }
12409 :
12410 :
12411 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
12412 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
12413 : source/rhs, both are gfc_full_array_ref_p which have been checked for
12414 : dependencies. */
12415 :
12416 : static tree
12417 2591 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
12418 : {
12419 2591 : tree dst, dlen, dtype;
12420 2591 : tree src, slen, stype;
12421 2591 : tree tmp;
12422 :
12423 2591 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12424 2591 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
12425 :
12426 2591 : dtype = TREE_TYPE (dst);
12427 2591 : if (POINTER_TYPE_P (dtype))
12428 253 : dtype = TREE_TYPE (dtype);
12429 2591 : stype = TREE_TYPE (src);
12430 2591 : if (POINTER_TYPE_P (stype))
12431 281 : stype = TREE_TYPE (stype);
12432 :
12433 2591 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
12434 : return NULL_TREE;
12435 :
12436 : /* Determine the lengths of the arrays. */
12437 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
12438 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
12439 : return NULL_TREE;
12440 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12441 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12442 : dlen, fold_convert (gfc_array_index_type, tmp));
12443 :
12444 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
12445 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
12446 : return NULL_TREE;
12447 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
12448 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12449 : slen, fold_convert (gfc_array_index_type, tmp));
12450 :
12451 : /* Sanity check that they are the same. This should always be
12452 : the case, as we should already have checked for conformance. */
12453 1486 : if (!tree_int_cst_equal (slen, dlen))
12454 : return NULL_TREE;
12455 :
12456 1486 : return gfc_build_memcpy_call (dst, src, dlen);
12457 : }
12458 :
12459 :
12460 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
12461 : this can't be done. EXPR1 is the destination/lhs for which
12462 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
12463 :
12464 : static tree
12465 7959 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
12466 : {
12467 7959 : unsigned HOST_WIDE_INT nelem;
12468 7959 : tree dst, dtype;
12469 7959 : tree src, stype;
12470 7959 : tree len;
12471 7959 : tree tmp;
12472 :
12473 7959 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
12474 7959 : if (nelem == 0)
12475 : return NULL_TREE;
12476 :
12477 6624 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12478 6624 : dtype = TREE_TYPE (dst);
12479 6624 : if (POINTER_TYPE_P (dtype))
12480 258 : dtype = TREE_TYPE (dtype);
12481 6624 : if (!GFC_ARRAY_TYPE_P (dtype))
12482 : return NULL_TREE;
12483 :
12484 : /* Determine the lengths of the array. */
12485 5810 : len = GFC_TYPE_ARRAY_SIZE (dtype);
12486 5810 : if (!len || TREE_CODE (len) != INTEGER_CST)
12487 : return NULL_TREE;
12488 :
12489 : /* Confirm that the constructor is the same size. */
12490 5712 : if (compare_tree_int (len, nelem) != 0)
12491 : return NULL_TREE;
12492 :
12493 5712 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12494 5712 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
12495 : fold_convert (gfc_array_index_type, tmp));
12496 :
12497 5712 : stype = gfc_typenode_for_spec (&expr2->ts);
12498 5712 : src = gfc_build_constant_array_constructor (expr2, stype);
12499 :
12500 5712 : return gfc_build_memcpy_call (dst, src, len);
12501 : }
12502 :
12503 :
12504 : /* Tells whether the expression is to be treated as a variable reference. */
12505 :
12506 : bool
12507 310436 : gfc_expr_is_variable (gfc_expr *expr)
12508 : {
12509 310696 : gfc_expr *arg;
12510 310696 : gfc_component *comp;
12511 310696 : gfc_symbol *func_ifc;
12512 :
12513 310696 : if (expr->expr_type == EXPR_VARIABLE)
12514 : return true;
12515 :
12516 276218 : arg = gfc_get_noncopying_intrinsic_argument (expr);
12517 276218 : if (arg)
12518 : {
12519 260 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
12520 : return gfc_expr_is_variable (arg);
12521 : }
12522 :
12523 : /* A data-pointer-returning function should be considered as a variable
12524 : too. */
12525 275958 : if (expr->expr_type == EXPR_FUNCTION
12526 36519 : && expr->ref == NULL)
12527 : {
12528 36144 : if (expr->value.function.isym != NULL)
12529 : return false;
12530 :
12531 9429 : if (expr->value.function.esym != NULL)
12532 : {
12533 9420 : func_ifc = expr->value.function.esym;
12534 9420 : goto found_ifc;
12535 : }
12536 9 : gcc_assert (expr->symtree);
12537 9 : func_ifc = expr->symtree->n.sym;
12538 9 : goto found_ifc;
12539 : }
12540 :
12541 239814 : comp = gfc_get_proc_ptr_comp (expr);
12542 239814 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
12543 375 : && comp)
12544 : {
12545 273 : func_ifc = comp->ts.interface;
12546 273 : goto found_ifc;
12547 : }
12548 :
12549 239541 : if (expr->expr_type == EXPR_COMPCALL)
12550 : {
12551 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
12552 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
12553 0 : goto found_ifc;
12554 : }
12555 :
12556 : return false;
12557 :
12558 9702 : found_ifc:
12559 9702 : gcc_assert (func_ifc->attr.function
12560 : && func_ifc->result != NULL);
12561 9702 : return func_ifc->result->attr.pointer;
12562 : }
12563 :
12564 :
12565 : /* Is the lhs OK for automatic reallocation? */
12566 :
12567 : static bool
12568 263278 : is_scalar_reallocatable_lhs (gfc_expr *expr)
12569 : {
12570 263278 : gfc_ref * ref;
12571 :
12572 : /* An allocatable variable with no reference. */
12573 263278 : if (expr->symtree->n.sym->attr.allocatable
12574 6724 : && !expr->ref)
12575 : return true;
12576 :
12577 : /* All that can be left are allocatable components. However, we do
12578 : not check for allocatable components here because the expression
12579 : could be an allocatable component of a pointer component. */
12580 260538 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
12581 238406 : && expr->symtree->n.sym->ts.type != BT_CLASS)
12582 : return false;
12583 :
12584 : /* Find an allocatable component ref last. */
12585 39265 : for (ref = expr->ref; ref; ref = ref->next)
12586 16209 : if (ref->type == REF_COMPONENT
12587 12013 : && !ref->next
12588 9303 : && ref->u.c.component->attr.allocatable)
12589 : return true;
12590 :
12591 : return false;
12592 : }
12593 :
12594 :
12595 : /* Allocate or reallocate scalar lhs, as necessary. */
12596 :
12597 : static void
12598 3562 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
12599 : tree string_length,
12600 : gfc_expr *expr1,
12601 : gfc_expr *expr2)
12602 :
12603 : {
12604 3562 : tree cond;
12605 3562 : tree tmp;
12606 3562 : tree size;
12607 3562 : tree size_in_bytes;
12608 3562 : tree jump_label1;
12609 3562 : tree jump_label2;
12610 3562 : gfc_se lse;
12611 3562 : gfc_ref *ref;
12612 :
12613 3562 : if (!expr1 || expr1->rank)
12614 0 : return;
12615 :
12616 3562 : if (!expr2 || expr2->rank)
12617 : return;
12618 :
12619 4992 : for (ref = expr1->ref; ref; ref = ref->next)
12620 1430 : if (ref->type == REF_SUBSTRING)
12621 : return;
12622 :
12623 3562 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
12624 :
12625 : /* Since this is a scalar lhs, we can afford to do this. That is,
12626 : there is no risk of side effects being repeated. */
12627 3562 : gfc_init_se (&lse, NULL);
12628 3562 : lse.want_pointer = 1;
12629 3562 : gfc_conv_expr (&lse, expr1);
12630 :
12631 3562 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12632 3562 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12633 :
12634 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
12635 3562 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
12636 3562 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
12637 : lse.expr, tmp);
12638 3562 : tmp = build3_v (COND_EXPR, cond,
12639 : build1_v (GOTO_EXPR, jump_label1),
12640 : build_empty_stmt (input_location));
12641 3562 : gfc_add_expr_to_block (block, tmp);
12642 :
12643 3562 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12644 : {
12645 : /* Use the rhs string length and the lhs element size. Note that 'size' is
12646 : used below for the string-length comparison, only. */
12647 1490 : size = string_length;
12648 1490 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12649 2980 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
12650 1490 : TREE_TYPE (tmp), tmp,
12651 1490 : fold_convert (TREE_TYPE (tmp), size));
12652 : }
12653 : else
12654 : {
12655 : /* Otherwise use the length in bytes of the rhs. */
12656 2072 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
12657 2072 : size_in_bytes = size;
12658 : }
12659 :
12660 3562 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12661 : size_in_bytes, size_one_node);
12662 :
12663 3562 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
12664 : {
12665 32 : tree caf_decl, token;
12666 32 : gfc_se caf_se;
12667 32 : symbol_attribute attr;
12668 :
12669 32 : gfc_clear_attr (&attr);
12670 32 : gfc_init_se (&caf_se, NULL);
12671 :
12672 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
12673 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
12674 : NULL);
12675 32 : gfc_add_block_to_block (block, &caf_se.pre);
12676 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
12677 : gfc_build_addr_expr (NULL_TREE, token),
12678 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
12679 : expr1, 1);
12680 : }
12681 3530 : else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
12682 : {
12683 49 : tmp = build_call_expr_loc (input_location,
12684 : builtin_decl_explicit (BUILT_IN_CALLOC),
12685 : 2, build_one_cst (size_type_node),
12686 : size_in_bytes);
12687 49 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12688 49 : gfc_add_modify (block, lse.expr, tmp);
12689 : }
12690 : else
12691 : {
12692 3481 : tmp = build_call_expr_loc (input_location,
12693 : builtin_decl_explicit (BUILT_IN_MALLOC),
12694 : 1, size_in_bytes);
12695 3481 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12696 3481 : gfc_add_modify (block, lse.expr, tmp);
12697 : }
12698 :
12699 3562 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12700 : {
12701 : /* Deferred characters need checking for lhs and rhs string
12702 : length. Other deferred parameter variables will have to
12703 : come here too. */
12704 1490 : tmp = build1_v (GOTO_EXPR, jump_label2);
12705 1490 : gfc_add_expr_to_block (block, tmp);
12706 : }
12707 3562 : tmp = build1_v (LABEL_EXPR, jump_label1);
12708 3562 : gfc_add_expr_to_block (block, tmp);
12709 :
12710 : /* For a deferred length character, reallocate if lengths of lhs and
12711 : rhs are different. */
12712 3562 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12713 : {
12714 1490 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12715 : lse.string_length,
12716 1490 : fold_convert (TREE_TYPE (lse.string_length),
12717 : size));
12718 : /* Jump past the realloc if the lengths are the same. */
12719 1490 : tmp = build3_v (COND_EXPR, cond,
12720 : build1_v (GOTO_EXPR, jump_label2),
12721 : build_empty_stmt (input_location));
12722 1490 : gfc_add_expr_to_block (block, tmp);
12723 1490 : tmp = build_call_expr_loc (input_location,
12724 : builtin_decl_explicit (BUILT_IN_REALLOC),
12725 : 2, fold_convert (pvoid_type_node, lse.expr),
12726 : size_in_bytes);
12727 1490 : tree omp_cond = NULL_TREE;
12728 1490 : if (flag_openmp_allocators)
12729 : {
12730 1 : tree omp_tmp;
12731 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
12732 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
12733 :
12734 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12735 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12736 : fold_convert (pvoid_type_node,
12737 : lse.expr), size_in_bytes,
12738 : build_zero_cst (ptr_type_node),
12739 : build_zero_cst (ptr_type_node));
12740 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
12741 : omp_cond, omp_tmp, tmp);
12742 : }
12743 1490 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12744 1490 : gfc_add_modify (block, lse.expr, tmp);
12745 1490 : if (omp_cond)
12746 1 : gfc_add_expr_to_block (block,
12747 : build3_loc (input_location, COND_EXPR,
12748 : void_type_node, omp_cond,
12749 : gfc_omp_call_add_alloc (lse.expr),
12750 : build_empty_stmt (input_location)));
12751 1490 : tmp = build1_v (LABEL_EXPR, jump_label2);
12752 1490 : gfc_add_expr_to_block (block, tmp);
12753 :
12754 : /* Update the lhs character length. */
12755 1490 : size = string_length;
12756 1490 : gfc_add_modify (block, lse.string_length,
12757 1490 : fold_convert (TREE_TYPE (lse.string_length), size));
12758 : }
12759 : }
12760 :
12761 : /* Check for assignments of the type
12762 :
12763 : a = a + 4
12764 :
12765 : to make sure we do not check for reallocation unneccessarily. */
12766 :
12767 :
12768 : /* Strip parentheses from an expression to get the underlying variable.
12769 : This is needed for self-assignment detection since (a) creates a
12770 : parentheses operator node. */
12771 :
12772 : static gfc_expr *
12773 7629 : strip_parentheses (gfc_expr *expr)
12774 : {
12775 0 : while (expr->expr_type == EXPR_OP
12776 311836 : && expr->value.op.op == INTRINSIC_PARENTHESES)
12777 536 : expr = expr->value.op.op1;
12778 310665 : return expr;
12779 : }
12780 :
12781 :
12782 : static bool
12783 7188 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
12784 : {
12785 7629 : gfc_actual_arglist *a;
12786 7629 : gfc_expr *e1, *e2;
12787 :
12788 : /* Strip parentheses to handle cases like a = (a). */
12789 15285 : expr1 = strip_parentheses (expr1);
12790 7629 : expr2 = strip_parentheses (expr2);
12791 :
12792 7629 : switch (expr2->expr_type)
12793 : {
12794 2026 : case EXPR_VARIABLE:
12795 2026 : return gfc_dep_compare_expr (expr1, expr2) == 0;
12796 :
12797 2809 : case EXPR_FUNCTION:
12798 2809 : if (expr2->value.function.esym
12799 275 : && expr2->value.function.esym->attr.elemental)
12800 : {
12801 57 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12802 : {
12803 56 : e1 = a->expr;
12804 56 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12805 : return false;
12806 : }
12807 : return true;
12808 : }
12809 2765 : else if (expr2->value.function.isym
12810 2520 : && expr2->value.function.isym->elemental)
12811 : {
12812 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12813 : {
12814 322 : e1 = a->expr;
12815 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12816 : return false;
12817 : }
12818 : return true;
12819 : }
12820 :
12821 : break;
12822 :
12823 635 : case EXPR_OP:
12824 635 : switch (expr2->value.op.op)
12825 : {
12826 19 : case INTRINSIC_NOT:
12827 19 : case INTRINSIC_UPLUS:
12828 19 : case INTRINSIC_UMINUS:
12829 19 : case INTRINSIC_PARENTHESES:
12830 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
12831 :
12832 591 : case INTRINSIC_PLUS:
12833 591 : case INTRINSIC_MINUS:
12834 591 : case INTRINSIC_TIMES:
12835 591 : case INTRINSIC_DIVIDE:
12836 591 : case INTRINSIC_POWER:
12837 591 : case INTRINSIC_AND:
12838 591 : case INTRINSIC_OR:
12839 591 : case INTRINSIC_EQV:
12840 591 : case INTRINSIC_NEQV:
12841 591 : case INTRINSIC_EQ:
12842 591 : case INTRINSIC_NE:
12843 591 : case INTRINSIC_GT:
12844 591 : case INTRINSIC_GE:
12845 591 : case INTRINSIC_LT:
12846 591 : case INTRINSIC_LE:
12847 591 : case INTRINSIC_EQ_OS:
12848 591 : case INTRINSIC_NE_OS:
12849 591 : case INTRINSIC_GT_OS:
12850 591 : case INTRINSIC_GE_OS:
12851 591 : case INTRINSIC_LT_OS:
12852 591 : case INTRINSIC_LE_OS:
12853 :
12854 591 : e1 = expr2->value.op.op1;
12855 591 : e2 = expr2->value.op.op2;
12856 :
12857 591 : if (e1->rank == 0 && e2->rank > 0)
12858 : return is_runtime_conformable (expr1, e2);
12859 539 : else if (e1->rank > 0 && e2->rank == 0)
12860 : return is_runtime_conformable (expr1, e1);
12861 169 : else if (e1->rank > 0 && e2->rank > 0)
12862 169 : return is_runtime_conformable (expr1, e1)
12863 169 : && is_runtime_conformable (expr1, e2);
12864 : break;
12865 :
12866 : default:
12867 : break;
12868 :
12869 : }
12870 :
12871 : break;
12872 :
12873 : default:
12874 : break;
12875 : }
12876 : return false;
12877 : }
12878 :
12879 :
12880 : static tree
12881 3280 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
12882 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
12883 : bool class_realloc)
12884 : {
12885 3280 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
12886 3280 : vec<tree, va_gc> *args = NULL;
12887 3280 : bool final_expr;
12888 :
12889 3280 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
12890 3280 : if (final_expr)
12891 : {
12892 485 : if (rse->loop)
12893 226 : gfc_prepend_expr_to_block (&rse->loop->pre,
12894 : gfc_finish_block (&lse->finalblock));
12895 : else
12896 259 : gfc_add_block_to_block (block, &lse->finalblock);
12897 : }
12898 :
12899 : /* Store the old vptr so that dynamic types can be compared for
12900 : reallocation to occur or not. */
12901 3280 : if (class_realloc)
12902 : {
12903 301 : tmp = lse->expr;
12904 301 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
12905 18 : tmp = gfc_get_class_from_expr (tmp);
12906 : }
12907 :
12908 3280 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
12909 : &from_len, &rhs_vptr);
12910 3280 : if (rhs_vptr == NULL_TREE)
12911 61 : rhs_vptr = vptr;
12912 :
12913 : /* Generate (re)allocation of the lhs. */
12914 3280 : if (class_realloc)
12915 : {
12916 301 : stmtblock_t alloc, re_alloc;
12917 301 : tree class_han, re, size;
12918 :
12919 301 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
12920 283 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
12921 : else
12922 18 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
12923 :
12924 301 : size = gfc_vptr_size_get (rhs_vptr);
12925 :
12926 : /* Take into account _len of unlimited polymorphic entities.
12927 : TODO: handle class(*) allocatable function results on rhs. */
12928 301 : if (UNLIMITED_POLY (rhs))
12929 : {
12930 18 : tree len;
12931 18 : if (rhs->expr_type == EXPR_VARIABLE)
12932 12 : len = trans_get_upoly_len (block, rhs);
12933 : else
12934 6 : len = gfc_class_len_get (tmp);
12935 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12936 : fold_convert (size_type_node, len),
12937 : size_one_node);
12938 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
12939 18 : size, fold_convert (TREE_TYPE (size), len));
12940 18 : }
12941 283 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
12942 27 : size = fold_build2_loc (input_location, MULT_EXPR,
12943 : gfc_charlen_type_node, size,
12944 : rse->string_length);
12945 :
12946 :
12947 301 : tmp = lse->expr;
12948 301 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
12949 301 : ? gfc_class_data_get (tmp) : tmp;
12950 :
12951 301 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
12952 18 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
12953 :
12954 : /* Allocate block. */
12955 301 : gfc_init_block (&alloc);
12956 301 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
12957 :
12958 : /* Reallocate if dynamic types are different. */
12959 301 : gfc_init_block (&re_alloc);
12960 301 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
12961 : {
12962 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
12963 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
12964 : }
12965 : else
12966 : {
12967 274 : tmp = fold_convert (pvoid_type_node, class_han);
12968 274 : re = build_call_expr_loc (input_location,
12969 : builtin_decl_explicit (BUILT_IN_REALLOC),
12970 : 2, tmp, size);
12971 274 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
12972 : tmp, re);
12973 274 : tmp = fold_build2_loc (input_location, NE_EXPR,
12974 : logical_type_node, rhs_vptr, old_vptr);
12975 274 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
12976 : tmp, re, build_empty_stmt (input_location));
12977 274 : gfc_add_expr_to_block (&re_alloc, re);
12978 : }
12979 301 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
12980 283 : gfc_finish_block (&re_alloc) :
12981 18 : build_empty_stmt (input_location);
12982 :
12983 : /* Allocate if _data is NULL, reallocate otherwise. */
12984 301 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12985 : logical_type_node, class_han,
12986 : build_int_cst (prvoid_type_node, 0));
12987 301 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
12988 : gfc_unlikely (tmp,
12989 : PRED_FORTRAN_FAIL_ALLOC),
12990 : gfc_finish_block (&alloc),
12991 : realloc_expr);
12992 301 : gfc_add_expr_to_block (&lse->pre, tmp);
12993 : }
12994 :
12995 3280 : fcn = gfc_vptr_copy_get (vptr);
12996 :
12997 3280 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
12998 3280 : ? gfc_class_data_get (rse->expr) : rse->expr;
12999 3280 : if (use_vptr_copy)
13000 : {
13001 5534 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13002 524 : || INDIRECT_REF_P (tmp)
13003 403 : || (rhs->ts.type == BT_DERIVED
13004 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13005 0 : && !rhs->ts.u.derived->attr.pointer
13006 0 : && !rhs->ts.u.derived->attr.allocatable)
13007 3429 : || (UNLIMITED_POLY (rhs)
13008 134 : && !CLASS_DATA (rhs)->attr.pointer
13009 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13010 2623 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13011 : else
13012 403 : vec_safe_push (args, tmp);
13013 3026 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13014 3026 : ? gfc_class_data_get (lse->expr) : lse->expr;
13015 5272 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13016 780 : || INDIRECT_REF_P (tmp)
13017 283 : || (lhs->ts.type == BT_DERIVED
13018 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13019 0 : && !lhs->ts.u.derived->attr.pointer
13020 0 : && !lhs->ts.u.derived->attr.allocatable)
13021 3309 : || (UNLIMITED_POLY (lhs)
13022 119 : && !CLASS_DATA (lhs)->attr.pointer
13023 119 : && !CLASS_DATA (lhs)->attr.allocatable))
13024 2743 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13025 : else
13026 283 : vec_safe_push (args, tmp);
13027 :
13028 3026 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13029 :
13030 3026 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13031 : {
13032 406 : tree extcopy;
13033 406 : vec_safe_push (args, from_len);
13034 406 : vec_safe_push (args, to_len);
13035 406 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13036 :
13037 406 : tmp = fold_build2_loc (input_location, GT_EXPR,
13038 : logical_type_node, from_len,
13039 406 : build_zero_cst (TREE_TYPE (from_len)));
13040 406 : return fold_build3_loc (input_location, COND_EXPR,
13041 : void_type_node, tmp,
13042 406 : extcopy, stdcopy);
13043 : }
13044 : else
13045 2620 : return stdcopy;
13046 : }
13047 : else
13048 : {
13049 254 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13050 254 : ? gfc_class_data_get (lse->expr) : lse->expr;
13051 254 : stmtblock_t tblock;
13052 254 : gfc_init_block (&tblock);
13053 254 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13054 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13055 254 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13056 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13057 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13058 254 : gfc_add_modify_loc (input_location, &tblock, rhst,
13059 254 : fold_convert (TREE_TYPE (rhst), tmp));
13060 254 : return gfc_finish_block (&tblock);
13061 : }
13062 : }
13063 :
13064 : bool
13065 305109 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13066 : {
13067 305109 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13068 : return false;
13069 :
13070 31280 : return lhs->symtree->n.sym->assoc
13071 31280 : && lhs->symtree->n.sym->assoc->target == rhs;
13072 : }
13073 :
13074 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13075 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13076 : init_flag indicates initialization expressions and dealloc that no
13077 : deallocate prior assignment is needed (if in doubt, set true).
13078 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13079 : routine instead of a pointer assignment. Alias resolution is only done,
13080 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13081 : where it is known, that newly allocated memory on the lhs can never be
13082 : an alias of the rhs. */
13083 :
13084 : static tree
13085 305109 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13086 : bool dealloc, bool use_vptr_copy, bool may_alias)
13087 : {
13088 305109 : gfc_se lse;
13089 305109 : gfc_se rse;
13090 305109 : gfc_ss *lss;
13091 305109 : gfc_ss *lss_section;
13092 305109 : gfc_ss *rss;
13093 305109 : gfc_loopinfo loop;
13094 305109 : tree tmp;
13095 305109 : stmtblock_t block;
13096 305109 : stmtblock_t body;
13097 305109 : bool final_expr;
13098 305109 : bool l_is_temp;
13099 305109 : bool scalar_to_array;
13100 305109 : tree string_length;
13101 305109 : int n;
13102 305109 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13103 305109 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
13104 305109 : bool is_poly_assign;
13105 305109 : bool realloc_flag;
13106 305109 : bool assoc_assign = false;
13107 :
13108 : /* Assignment of the form lhs = rhs. */
13109 305109 : gfc_start_block (&block);
13110 :
13111 305109 : gfc_init_se (&lse, NULL);
13112 305109 : gfc_init_se (&rse, NULL);
13113 :
13114 305109 : gfc_fix_class_refs (expr1);
13115 :
13116 610218 : realloc_flag = flag_realloc_lhs
13117 299116 : && gfc_is_reallocatable_lhs (expr1)
13118 7999 : && expr2->rank
13119 311655 : && !is_runtime_conformable (expr1, expr2);
13120 :
13121 : /* Walk the lhs. */
13122 305109 : lss = gfc_walk_expr (expr1);
13123 305109 : if (realloc_flag)
13124 : {
13125 6193 : lss->no_bounds_check = 1;
13126 6193 : lss->is_alloc_lhs = 1;
13127 : }
13128 : else
13129 298916 : lss->no_bounds_check = expr1->no_bounds_check;
13130 :
13131 305109 : rss = NULL;
13132 :
13133 305109 : if (expr2->expr_type != EXPR_VARIABLE
13134 305109 : && expr2->expr_type != EXPR_CONSTANT
13135 305109 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13136 : {
13137 844 : expr2->must_finalize = 1;
13138 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13139 : function, the result is finalized after execution of the innermost
13140 : executable construct containing the reference. */
13141 844 : if (expr2->expr_type == EXPR_FUNCTION
13142 844 : && (gfc_expr_attr (expr2).pointer
13143 292 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13144 145 : expr2->must_finalize = 0;
13145 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13146 : structure constructor or array constructor, the entity created by
13147 : the constructor is finalized after execution of the innermost
13148 : executable construct containing the reference.
13149 : These finalizations were later deleted by the Combined Techical
13150 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13151 699 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13152 699 : && (expr2->expr_type == EXPR_STRUCTURE
13153 656 : || expr2->expr_type == EXPR_ARRAY))
13154 351 : expr2->must_finalize = 0;
13155 : }
13156 :
13157 :
13158 : /* Checking whether a class assignment is desired is quite complicated and
13159 : needed at two locations, so do it once only before the information is
13160 : needed. */
13161 305109 : lhs_attr = gfc_expr_attr (expr1);
13162 :
13163 305109 : is_poly_assign
13164 305109 : = (use_vptr_copy
13165 288601 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13166 22316 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13167 20285 : || gfc_is_class_scalar_expr (expr1)
13168 18987 : || gfc_is_class_array_ref (expr2, NULL)
13169 18987 : || gfc_is_class_scalar_expr (expr2))
13170 308456 : && lhs_attr.flavor != FL_PROCEDURE;
13171 :
13172 305109 : assoc_assign = is_assoc_assign (expr1, expr2);
13173 :
13174 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13175 : mode. Avoid false-positive uninitialized diagnostics with initializing
13176 : the codimension flag unconditionally. */
13177 305109 : lhs_caf_attr.codimension = false;
13178 305109 : rhs_caf_attr.codimension = false;
13179 305109 : if (flag_coarray == GFC_FCOARRAY_LIB)
13180 : {
13181 6534 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13182 6534 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13183 : }
13184 :
13185 305109 : tree reallocation = NULL_TREE;
13186 305109 : if (lss != gfc_ss_terminator)
13187 : {
13188 : /* The assignment needs scalarization. */
13189 : lss_section = lss;
13190 :
13191 : /* Find a non-scalar SS from the lhs. */
13192 : while (lss_section != gfc_ss_terminator
13193 39128 : && lss_section->info->type != GFC_SS_SECTION)
13194 0 : lss_section = lss_section->next;
13195 :
13196 39128 : gcc_assert (lss_section != gfc_ss_terminator);
13197 :
13198 : /* Initialize the scalarizer. */
13199 39128 : gfc_init_loopinfo (&loop);
13200 :
13201 : /* Walk the rhs. */
13202 39128 : rss = gfc_walk_expr (expr2);
13203 39128 : if (rss == gfc_ss_terminator)
13204 : {
13205 : /* The rhs is scalar. Add a ss for the expression. */
13206 14736 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13207 14736 : lss->is_alloc_lhs = 0;
13208 : }
13209 :
13210 : /* When doing a class assign, then the handle to the rhs needs to be a
13211 : pointer to allow for polymorphism. */
13212 39128 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13213 485 : rss->info->type = GFC_SS_REFERENCE;
13214 :
13215 39128 : rss->no_bounds_check = expr2->no_bounds_check;
13216 : /* Associate the SS with the loop. */
13217 39128 : gfc_add_ss_to_loop (&loop, lss);
13218 39128 : gfc_add_ss_to_loop (&loop, rss);
13219 :
13220 : /* Calculate the bounds of the scalarization. */
13221 39128 : gfc_conv_ss_startstride (&loop);
13222 : /* Enable loop reversal. */
13223 665176 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13224 586920 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13225 : /* Resolve any data dependencies in the statement. */
13226 39128 : if (may_alias)
13227 36876 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13228 : /* Setup the scalarizing loops. */
13229 39128 : gfc_conv_loop_setup (&loop, &expr2->where);
13230 :
13231 : /* Setup the gfc_se structures. */
13232 39128 : gfc_copy_loopinfo_to_se (&lse, &loop);
13233 39128 : gfc_copy_loopinfo_to_se (&rse, &loop);
13234 :
13235 39128 : rse.ss = rss;
13236 39128 : gfc_mark_ss_chain_used (rss, 1);
13237 39128 : if (loop.temp_ss == NULL)
13238 : {
13239 38070 : lse.ss = lss;
13240 38070 : gfc_mark_ss_chain_used (lss, 1);
13241 : }
13242 : else
13243 : {
13244 1058 : lse.ss = loop.temp_ss;
13245 1058 : gfc_mark_ss_chain_used (lss, 3);
13246 1058 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13247 : }
13248 :
13249 : /* Allow the scalarizer to workshare array assignments. */
13250 39128 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13251 : == OMPWS_WORKSHARE_FLAG
13252 85 : && loop.temp_ss == NULL)
13253 : {
13254 73 : maybe_workshare = true;
13255 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13256 : }
13257 :
13258 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13259 39128 : if (realloc_flag)
13260 : {
13261 6193 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13262 6193 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13263 6193 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13264 : expr2);
13265 : }
13266 :
13267 : /* Start the scalarized loop body. */
13268 39128 : gfc_start_scalarized_body (&loop, &body);
13269 : }
13270 : else
13271 265981 : gfc_init_block (&body);
13272 :
13273 305109 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13274 :
13275 : /* Translate the expression. */
13276 610218 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13277 305109 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13278 305109 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13279 305109 : gfc_conv_expr (&rse, expr2);
13280 :
13281 : /* Deal with the case of a scalar class function assigned to a derived type.
13282 : */
13283 305109 : if (gfc_is_alloc_class_scalar_function (expr2)
13284 305109 : && expr1->ts.type == BT_DERIVED)
13285 : {
13286 60 : rse.expr = gfc_class_data_get (rse.expr);
13287 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13288 : }
13289 :
13290 : /* Stabilize a string length for temporaries. */
13291 305109 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13292 24354 : && !(VAR_P (rse.string_length)
13293 : || TREE_CODE (rse.string_length) == PARM_DECL
13294 : || INDIRECT_REF_P (rse.string_length)))
13295 23490 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13296 281619 : else if (expr2->ts.type == BT_CHARACTER)
13297 : {
13298 4348 : if (expr1->ts.deferred
13299 6741 : && gfc_expr_attr (expr1).allocatable
13300 6861 : && gfc_check_dependency (expr1, expr2, true))
13301 120 : rse.string_length =
13302 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13303 4348 : string_length = rse.string_length;
13304 : }
13305 : else
13306 : string_length = NULL_TREE;
13307 :
13308 305109 : if (l_is_temp)
13309 : {
13310 1058 : gfc_conv_tmp_array_ref (&lse);
13311 1058 : if (expr2->ts.type == BT_CHARACTER)
13312 123 : lse.string_length = string_length;
13313 : }
13314 : else
13315 : {
13316 304051 : gfc_conv_expr (&lse, expr1);
13317 : /* For some expression (e.g. complex numbers) fold_convert uses a
13318 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13319 : not updated when assigned to. */
13320 304051 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13321 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13322 :
13323 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13324 310204 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13325 : {
13326 36 : tree cond;
13327 36 : const char* msg;
13328 :
13329 36 : tmp = INDIRECT_REF_P (lse.expr)
13330 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13331 36 : STRIP_NOPS (tmp);
13332 :
13333 : /* We should only get array references here. */
13334 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13335 : || TREE_CODE (tmp) == ARRAY_REF);
13336 :
13337 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13338 : or the array itself(ARRAY_REF). */
13339 36 : tmp = TREE_OPERAND (tmp, 0);
13340 :
13341 : /* Provide the address of the array. */
13342 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13343 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13344 :
13345 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13346 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13347 36 : msg = _("Assignment of scalar to unallocated array");
13348 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13349 : &expr1->where, msg);
13350 : }
13351 :
13352 : /* Deallocate the lhs parameterized components if required. */
13353 304051 : if (dealloc
13354 286014 : && !expr1->symtree->n.sym->attr.associate_var
13355 284128 : && expr2->expr_type != EXPR_ARRAY
13356 278314 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
13357 : {
13358 258 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
13359 :
13360 258 : tmp = lse.expr;
13361 258 : if (pdt_dep)
13362 : {
13363 : /* Create a temporary for deallocation after assignment. */
13364 126 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
13365 126 : gfc_add_modify (&lse.pre, tmp, lse.expr);
13366 : }
13367 :
13368 258 : if (expr1->ts.type == BT_DERIVED)
13369 258 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
13370 : expr1->rank);
13371 0 : else if (expr1->ts.type == BT_CLASS)
13372 : {
13373 0 : tmp = gfc_class_data_get (tmp);
13374 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
13375 : tmp, expr1->rank);
13376 : }
13377 :
13378 258 : if (tmp && pdt_dep)
13379 68 : gfc_add_expr_to_block (&rse.post, tmp);
13380 190 : else if (tmp)
13381 42 : gfc_add_expr_to_block (&lse.pre, tmp);
13382 : }
13383 : }
13384 :
13385 : /* Assignments of scalar derived types with allocatable components
13386 : to arrays must be done with a deep copy and the rhs temporary
13387 : must have its components deallocated afterwards. */
13388 610218 : scalar_to_array = (expr2->ts.type == BT_DERIVED
13389 18811 : && expr2->ts.u.derived->attr.alloc_comp
13390 6379 : && !gfc_expr_is_variable (expr2)
13391 308643 : && expr1->rank && !expr2->rank);
13392 610218 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
13393 19088 : && expr1->rank
13394 3609 : && expr1->ts.u.derived->attr.alloc_comp
13395 306416 : && gfc_is_alloc_class_scalar_function (expr2));
13396 305109 : if (scalar_to_array && dealloc)
13397 : {
13398 53 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
13399 53 : gfc_prepend_expr_to_block (&loop.post, tmp);
13400 : }
13401 :
13402 : /* When assigning a character function result to a deferred-length variable,
13403 : the function call must happen before the (re)allocation of the lhs -
13404 : otherwise the character length of the result is not known.
13405 : NOTE 1: This relies on having the exact dependence of the length type
13406 : parameter available to the caller; gfortran saves it in the .mod files.
13407 : NOTE 2: Vector array references generate an index temporary that must
13408 : not go outside the loop. Otherwise, variables should not generate
13409 : a pre block.
13410 : NOTE 3: The concatenation operation generates a temporary pointer,
13411 : whose allocation must go to the innermost loop.
13412 : NOTE 4: Elemental functions may generate a temporary, too. */
13413 305109 : if (flag_realloc_lhs
13414 299116 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
13415 2956 : && !(lss != gfc_ss_terminator
13416 928 : && rss != gfc_ss_terminator
13417 928 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
13418 741 : || (expr2->expr_type == EXPR_FUNCTION
13419 160 : && expr2->value.function.esym != NULL
13420 26 : && expr2->value.function.esym->attr.elemental)
13421 728 : || (expr2->expr_type == EXPR_FUNCTION
13422 147 : && expr2->value.function.isym != NULL
13423 134 : && expr2->value.function.isym->elemental)
13424 672 : || (expr2->expr_type == EXPR_OP
13425 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
13426 2675 : gfc_add_block_to_block (&block, &rse.pre);
13427 :
13428 : /* Nullify the allocatable components corresponding to those of the lhs
13429 : derived type, so that the finalization of the function result does not
13430 : affect the lhs of the assignment. Prepend is used to ensure that the
13431 : nullification occurs before the call to the finalizer. In the case of
13432 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
13433 : as part of the deep copy. */
13434 304318 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
13435 323406 : && (gfc_is_class_array_function (expr2)
13436 18273 : || gfc_is_alloc_class_scalar_function (expr2)))
13437 : {
13438 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
13439 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
13440 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
13441 0 : gfc_add_block_to_block (&loop.post, &rse.post);
13442 : }
13443 :
13444 305109 : tmp = NULL_TREE;
13445 :
13446 305109 : if (is_poly_assign)
13447 : {
13448 3280 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
13449 3280 : use_vptr_copy || (lhs_attr.allocatable
13450 301 : && !lhs_attr.dimension),
13451 3024 : !realloc_flag && flag_realloc_lhs
13452 3835 : && !lhs_attr.pointer);
13453 3280 : if (expr2->expr_type == EXPR_FUNCTION
13454 230 : && expr2->ts.type == BT_DERIVED
13455 30 : && expr2->ts.u.derived->attr.alloc_comp)
13456 : {
13457 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
13458 : rse.expr, expr2->rank);
13459 18 : if (lss == gfc_ss_terminator)
13460 18 : gfc_add_expr_to_block (&rse.post, tmp2);
13461 : else
13462 0 : gfc_add_expr_to_block (&loop.post, tmp2);
13463 : }
13464 :
13465 3280 : expr1->must_finalize = 0;
13466 : }
13467 301829 : else if (!is_poly_assign && expr2->must_finalize
13468 373 : && expr1->ts.type == BT_CLASS
13469 126 : && expr2->ts.type == BT_CLASS)
13470 : {
13471 : /* This case comes about when the scalarizer provides array element
13472 : references. Use the vptr copy function, since this does a deep
13473 : copy of allocatable components, without which the finalizer call
13474 : will deallocate the components. */
13475 120 : tmp = gfc_get_vptr_from_expr (rse.expr);
13476 120 : if (tmp != NULL_TREE)
13477 : {
13478 120 : tree fcn = gfc_vptr_copy_get (tmp);
13479 120 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
13480 120 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
13481 120 : tmp = build_call_expr_loc (input_location,
13482 : fcn, 2,
13483 : gfc_build_addr_expr (NULL, rse.expr),
13484 : gfc_build_addr_expr (NULL, lse.expr));
13485 : }
13486 : }
13487 :
13488 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
13489 : after evaluation of the rhs and before reallocation.
13490 : Skip finalization for self-assignment to avoid use-after-free.
13491 : Strip parentheses from both sides to handle cases like a = (a). */
13492 305109 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
13493 305109 : if (final_expr
13494 588 : && gfc_dep_compare_expr (strip_parentheses (expr1),
13495 : strip_parentheses (expr2)) != 0
13496 305673 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
13497 175 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
13498 : {
13499 564 : if (lss == gfc_ss_terminator)
13500 : {
13501 165 : gfc_add_block_to_block (&block, &rse.pre);
13502 165 : gfc_add_block_to_block (&block, &lse.finalblock);
13503 : }
13504 : else
13505 : {
13506 399 : gfc_add_block_to_block (&body, &rse.pre);
13507 399 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
13508 : &lse.finalblock);
13509 : }
13510 : }
13511 : else
13512 304545 : gfc_add_block_to_block (&body, &rse.pre);
13513 :
13514 305109 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
13515 2994 : && assoc_assign)
13516 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
13517 :
13518 : /* If nothing else works, do it the old fashioned way! */
13519 305109 : if (tmp == NULL_TREE)
13520 : {
13521 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
13522 301709 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
13523 301709 : tmp
13524 301709 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13525 301709 : gfc_expr_is_variable (expr2_stripped)
13526 272163 : || scalar_to_array
13527 573165 : || expr2->expr_type == EXPR_ARRAY,
13528 301709 : !(l_is_temp || init_flag) && dealloc,
13529 301709 : expr1->symtree->n.sym->attr.codimension,
13530 : assoc_assign);
13531 : }
13532 :
13533 : /* Add the lse pre block to the body */
13534 305109 : gfc_add_block_to_block (&body, &lse.pre);
13535 305109 : gfc_add_expr_to_block (&body, tmp);
13536 :
13537 : /* Add the post blocks to the body. Scalar finalization must appear before
13538 : the post block in case any dellocations are done. */
13539 305109 : if (rse.finalblock.head
13540 305109 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
13541 14 : && gfc_expr_attr (expr2).elemental)))
13542 : {
13543 136 : gfc_add_block_to_block (&body, &rse.finalblock);
13544 136 : gfc_add_block_to_block (&body, &rse.post);
13545 : }
13546 : else
13547 304973 : gfc_add_block_to_block (&body, &rse.post);
13548 :
13549 305109 : gfc_add_block_to_block (&body, &lse.post);
13550 :
13551 305109 : if (lss == gfc_ss_terminator)
13552 : {
13553 : /* F2003: Add the code for reallocation on assignment. */
13554 263278 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
13555 269561 : && !is_poly_assign)
13556 3562 : alloc_scalar_allocatable_for_assignment (&block, string_length,
13557 : expr1, expr2);
13558 :
13559 : /* Use the scalar assignment as is. */
13560 265981 : gfc_add_block_to_block (&block, &body);
13561 : }
13562 : else
13563 : {
13564 39128 : gcc_assert (lse.ss == gfc_ss_terminator
13565 : && rse.ss == gfc_ss_terminator);
13566 :
13567 39128 : if (l_is_temp)
13568 : {
13569 1058 : gfc_trans_scalarized_loop_boundary (&loop, &body);
13570 :
13571 : /* We need to copy the temporary to the actual lhs. */
13572 1058 : gfc_init_se (&lse, NULL);
13573 1058 : gfc_init_se (&rse, NULL);
13574 1058 : gfc_copy_loopinfo_to_se (&lse, &loop);
13575 1058 : gfc_copy_loopinfo_to_se (&rse, &loop);
13576 :
13577 1058 : rse.ss = loop.temp_ss;
13578 1058 : lse.ss = lss;
13579 :
13580 1058 : gfc_conv_tmp_array_ref (&rse);
13581 1058 : gfc_conv_expr (&lse, expr1);
13582 :
13583 1058 : gcc_assert (lse.ss == gfc_ss_terminator
13584 : && rse.ss == gfc_ss_terminator);
13585 :
13586 1058 : if (expr2->ts.type == BT_CHARACTER)
13587 123 : rse.string_length = string_length;
13588 :
13589 1058 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13590 : false, dealloc);
13591 1058 : gfc_add_expr_to_block (&body, tmp);
13592 : }
13593 :
13594 39128 : if (reallocation != NULL_TREE)
13595 6193 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
13596 :
13597 39128 : if (maybe_workshare)
13598 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
13599 :
13600 : /* Generate the copying loops. */
13601 39128 : gfc_trans_scalarizing_loops (&loop, &body);
13602 :
13603 : /* Wrap the whole thing up. */
13604 39128 : gfc_add_block_to_block (&block, &loop.pre);
13605 39128 : gfc_add_block_to_block (&block, &loop.post);
13606 :
13607 39128 : gfc_cleanup_loop (&loop);
13608 : }
13609 :
13610 : /* Since parameterized components cannot have default initializers,
13611 : the default PDT constructor leaves them unallocated. Do the
13612 : allocation now. */
13613 305109 : if (init_flag && IS_PDT (expr1)
13614 317 : && !expr1->symtree->n.sym->attr.allocatable
13615 317 : && !expr1->symtree->n.sym->attr.dummy)
13616 : {
13617 69 : gfc_symbol *sym = expr1->symtree->n.sym;
13618 69 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
13619 : sym->backend_decl,
13620 69 : sym->as ? sym->as->rank : 0,
13621 69 : sym->param_list);
13622 69 : gfc_add_expr_to_block (&block, tmp);
13623 : }
13624 :
13625 305109 : return gfc_finish_block (&block);
13626 : }
13627 :
13628 :
13629 : /* Check whether EXPR is a copyable array. */
13630 :
13631 : static bool
13632 966729 : copyable_array_p (gfc_expr * expr)
13633 : {
13634 966729 : if (expr->expr_type != EXPR_VARIABLE)
13635 : return false;
13636 :
13637 : /* First check it's an array. */
13638 943422 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
13639 : return false;
13640 :
13641 144476 : if (!gfc_full_array_ref_p (expr->ref, NULL))
13642 : return false;
13643 :
13644 : /* Next check that it's of a simple enough type. */
13645 114462 : switch (expr->ts.type)
13646 : {
13647 : case BT_INTEGER:
13648 : case BT_REAL:
13649 : case BT_COMPLEX:
13650 : case BT_LOGICAL:
13651 : return true;
13652 :
13653 : case BT_CHARACTER:
13654 : return false;
13655 :
13656 6245 : case_bt_struct:
13657 6245 : return (!expr->ts.u.derived->attr.alloc_comp
13658 6245 : && !expr->ts.u.derived->attr.pdt_type);
13659 :
13660 : default:
13661 : break;
13662 : }
13663 :
13664 : return false;
13665 : }
13666 :
13667 : /* Translate an assignment. */
13668 :
13669 : tree
13670 322793 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13671 : bool dealloc, bool use_vptr_copy, bool may_alias)
13672 : {
13673 322793 : tree tmp;
13674 :
13675 : /* Special case a single function returning an array. */
13676 322793 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
13677 : {
13678 14403 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
13679 14403 : if (tmp)
13680 : return tmp;
13681 : }
13682 :
13683 : /* Special case assigning an array to zero. */
13684 315957 : if (copyable_array_p (expr1)
13685 315957 : && is_zero_initializer_p (expr2))
13686 : {
13687 3929 : tmp = gfc_trans_zero_assign (expr1);
13688 3929 : if (tmp)
13689 : return tmp;
13690 : }
13691 :
13692 : /* Special case copying one array to another. */
13693 312307 : if (copyable_array_p (expr1)
13694 27644 : && copyable_array_p (expr2)
13695 2687 : && gfc_compare_types (&expr1->ts, &expr2->ts)
13696 314994 : && !gfc_check_dependency (expr1, expr2, 0))
13697 : {
13698 2591 : tmp = gfc_trans_array_copy (expr1, expr2);
13699 2591 : if (tmp)
13700 : return tmp;
13701 : }
13702 :
13703 : /* Special case initializing an array from a constant array constructor. */
13704 310821 : if (copyable_array_p (expr1)
13705 26158 : && expr2->expr_type == EXPR_ARRAY
13706 318780 : && gfc_compare_types (&expr1->ts, &expr2->ts))
13707 : {
13708 7959 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
13709 7959 : if (tmp)
13710 : return tmp;
13711 : }
13712 :
13713 305109 : if (UNLIMITED_POLY (expr1) && expr1->rank)
13714 305109 : use_vptr_copy = true;
13715 :
13716 : /* Fallback to the scalarizer to generate explicit loops. */
13717 305109 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
13718 305109 : use_vptr_copy, may_alias);
13719 : }
13720 :
13721 : tree
13722 12727 : gfc_trans_init_assign (gfc_code * code)
13723 : {
13724 12727 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
13725 : }
13726 :
13727 : tree
13728 301829 : gfc_trans_assign (gfc_code * code)
13729 : {
13730 301829 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
13731 : }
13732 :
13733 : /* Generate a simple loop for internal use of the form
13734 : for (var = begin; var <cond> end; var += step)
13735 : body; */
13736 : void
13737 12147 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
13738 : enum tree_code cond, tree step, tree body)
13739 : {
13740 12147 : tree tmp;
13741 :
13742 : /* var = begin. */
13743 12147 : gfc_add_modify (block, var, begin);
13744 :
13745 : /* Loop: for (var = begin; var <cond> end; var += step). */
13746 12147 : tree label_loop = gfc_build_label_decl (NULL_TREE);
13747 12147 : tree label_cond = gfc_build_label_decl (NULL_TREE);
13748 12147 : TREE_USED (label_loop) = 1;
13749 12147 : TREE_USED (label_cond) = 1;
13750 :
13751 12147 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
13752 12147 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
13753 :
13754 : /* Loop body. */
13755 12147 : gfc_add_expr_to_block (block, body);
13756 :
13757 : /* End of loop body. */
13758 12147 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
13759 12147 : gfc_add_modify (block, var, tmp);
13760 12147 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
13761 12147 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
13762 12147 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
13763 : build_empty_stmt (input_location));
13764 12147 : gfc_add_expr_to_block (block, tmp);
13765 12147 : }
|
