Line data Source code
1 : /* Expression translation
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Paul Brook <paul@nowt.org>
4 : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 :
6 : This file is part of GCC.
7 :
8 : GCC is free software; you can redistribute it and/or modify it under
9 : the terms of the GNU General Public License as published by the Free
10 : Software Foundation; either version 3, or (at your option) any later
11 : version.
12 :
13 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : for more details.
17 :
18 : You should have received a copy of the GNU General Public License
19 : along with GCC; see the file COPYING3. If not see
20 : <http://www.gnu.org/licenses/>. */
21 :
22 : /* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
23 :
24 : #define INCLUDE_MEMORY
25 : #include "config.h"
26 : #include "system.h"
27 : #include "coretypes.h"
28 : #include "options.h"
29 : #include "tree.h"
30 : #include "gfortran.h"
31 : #include "trans.h"
32 : #include "stringpool.h"
33 : #include "diagnostic-core.h" /* For fatal_error. */
34 : #include "fold-const.h"
35 : #include "langhooks.h"
36 : #include "arith.h"
37 : #include "constructor.h"
38 : #include "trans-const.h"
39 : #include "trans-types.h"
40 : #include "trans-array.h"
41 : #include "trans-descriptor.h"
42 : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 : #include "trans-stmt.h"
44 : #include "dependency.h"
45 : #include "gimplify.h"
46 : #include "tm.h" /* For CHAR_TYPE_SIZE. */
47 :
48 :
49 : /* Calculate the number of characters in a string. */
50 :
51 : static tree
52 36202 : gfc_get_character_len (tree type)
53 : {
54 36202 : tree len;
55 :
56 36202 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
57 : && TYPE_STRING_FLAG (type));
58 :
59 36202 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
60 36202 : len = (len) ? (len) : (integer_zero_node);
61 36202 : return fold_convert (gfc_charlen_type_node, len);
62 : }
63 :
64 :
65 :
66 : /* Calculate the number of bytes in a string. */
67 :
68 : tree
69 36202 : gfc_get_character_len_in_bytes (tree type)
70 : {
71 36202 : tree tmp, len;
72 :
73 36202 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
74 : && TYPE_STRING_FLAG (type));
75 :
76 36202 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
77 72404 : tmp = (tmp && !integer_zerop (tmp))
78 72404 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
79 36202 : len = gfc_get_character_len (type);
80 36202 : if (tmp && len && !integer_zerop (len))
81 35430 : len = fold_build2_loc (input_location, MULT_EXPR,
82 : gfc_charlen_type_node, len, tmp);
83 36202 : return len;
84 : }
85 :
86 :
87 : /* Convert a scalar to an array descriptor. To be used for assumed-rank
88 : arrays. */
89 :
90 : static tree
91 6342 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
92 : {
93 6342 : enum gfc_array_kind akind;
94 6342 : tree *lbound = NULL, *ubound = NULL;
95 6342 : int codim = 0;
96 :
97 6342 : if (attr.pointer)
98 : akind = GFC_ARRAY_POINTER_CONT;
99 5990 : else if (attr.allocatable)
100 : akind = GFC_ARRAY_ALLOCATABLE;
101 : else
102 5221 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
103 :
104 6342 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
105 5377 : scalar = TREE_TYPE (scalar);
106 6342 : if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
107 : {
108 4800 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
109 4800 : codim = lang_specific->corank;
110 4800 : lbound = lang_specific->lbound;
111 4800 : ubound = lang_specific->ubound;
112 : }
113 6342 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
114 : ubound, 1, akind,
115 6342 : !(attr.pointer || attr.target));
116 : }
117 :
118 : tree
119 5664 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
120 : {
121 5664 : tree desc, type, etype;
122 :
123 5664 : type = get_scalar_to_descriptor_type (scalar, attr);
124 5664 : etype = TREE_TYPE (scalar);
125 5664 : desc = gfc_create_var (type, "desc");
126 5664 : DECL_ARTIFICIAL (desc) = 1;
127 :
128 5664 : if (CONSTANT_CLASS_P (scalar))
129 : {
130 54 : tree tmp;
131 54 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
132 54 : gfc_add_modify (&se->pre, tmp, scalar);
133 54 : scalar = tmp;
134 : }
135 5664 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
136 965 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
137 4699 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
138 158 : etype = TREE_TYPE (etype);
139 5664 : gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
140 : gfc_get_dtype_rank_type (0, etype));
141 5664 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
142 5664 : gfc_conv_descriptor_span_set (&se->pre, desc,
143 : gfc_conv_descriptor_elem_len (desc));
144 :
145 : /* Copy pointer address back - but only if it could have changed and
146 : if the actual argument is a pointer and not, e.g., NULL(). */
147 5664 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
148 846 : gfc_add_modify (&se->post, scalar,
149 423 : fold_convert (TREE_TYPE (scalar),
150 : gfc_conv_descriptor_data_get (desc)));
151 5664 : return desc;
152 : }
153 :
154 :
155 : /* Get the coarray token from the ultimate array or component ref.
156 : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
157 :
158 : tree
159 512 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
160 : {
161 512 : gfc_symbol *sym = expr->symtree->n.sym;
162 1024 : bool is_coarray = sym->ts.type == BT_CLASS
163 512 : ? CLASS_DATA (sym)->attr.codimension
164 467 : : sym->attr.codimension;
165 512 : gfc_expr *caf_expr = gfc_copy_expr (expr);
166 512 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
167 :
168 1622 : while (ref)
169 : {
170 1110 : if (ref->type == REF_COMPONENT
171 417 : && (ref->u.c.component->attr.allocatable
172 104 : || ref->u.c.component->attr.pointer)
173 415 : && (is_coarray || ref->u.c.component->attr.codimension))
174 1110 : last_caf_ref = ref;
175 1110 : ref = ref->next;
176 : }
177 :
178 512 : if (last_caf_ref == NULL)
179 : {
180 180 : gfc_free_expr (caf_expr);
181 180 : return NULL_TREE;
182 : }
183 :
184 143 : tree comp = last_caf_ref->u.c.component->caf_token
185 332 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
186 : : NULL_TREE,
187 : caf;
188 332 : gfc_se se;
189 332 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
190 332 : if (comp == NULL_TREE && comp_ref)
191 : {
192 46 : gfc_free_expr (caf_expr);
193 46 : return NULL_TREE;
194 : }
195 286 : gfc_init_se (&se, outerse);
196 286 : gfc_free_ref_list (last_caf_ref->next);
197 286 : last_caf_ref->next = NULL;
198 286 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
199 572 : caf_expr->corank = last_caf_ref->u.c.component->as
200 286 : ? last_caf_ref->u.c.component->as->corank
201 : : expr->corank;
202 286 : se.want_pointer = comp_ref;
203 286 : gfc_conv_expr (&se, caf_expr);
204 286 : gfc_add_block_to_block (&outerse->pre, &se.pre);
205 :
206 286 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
207 143 : se.expr = TREE_OPERAND (se.expr, 0);
208 286 : gfc_free_expr (caf_expr);
209 :
210 286 : if (comp_ref)
211 143 : caf = fold_build3_loc (input_location, COMPONENT_REF,
212 143 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
213 : else
214 143 : caf = gfc_conv_descriptor_token (se.expr);
215 286 : return gfc_build_addr_expr (NULL_TREE, caf);
216 : }
217 :
218 :
219 : /* This is the seed for an eventual trans-class.c
220 :
221 : The following parameters should not be used directly since they might
222 : in future implementations. Use the corresponding APIs. */
223 : #define CLASS_DATA_FIELD 0
224 : #define CLASS_VPTR_FIELD 1
225 : #define CLASS_LEN_FIELD 2
226 : #define VTABLE_HASH_FIELD 0
227 : #define VTABLE_SIZE_FIELD 1
228 : #define VTABLE_EXTENDS_FIELD 2
229 : #define VTABLE_DEF_INIT_FIELD 3
230 : #define VTABLE_COPY_FIELD 4
231 : #define VTABLE_FINAL_FIELD 5
232 : #define VTABLE_DEALLOCATE_FIELD 6
233 :
234 :
235 : tree
236 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
237 : {
238 40 : tree tmp;
239 40 : tree field;
240 40 : vec<constructor_elt, va_gc> *init = NULL;
241 :
242 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
243 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
244 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
245 :
246 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
247 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
248 :
249 40 : return build_constructor (TREE_TYPE (decl), init);
250 : }
251 :
252 :
253 : tree
254 32510 : gfc_class_data_get (tree decl)
255 : {
256 32510 : tree data;
257 32510 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
258 5441 : decl = build_fold_indirect_ref_loc (input_location, decl);
259 32510 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
260 : CLASS_DATA_FIELD);
261 32510 : return fold_build3_loc (input_location, COMPONENT_REF,
262 32510 : TREE_TYPE (data), decl, data,
263 32510 : NULL_TREE);
264 : }
265 :
266 :
267 : tree
268 46061 : gfc_class_vptr_get (tree decl)
269 : {
270 46061 : tree vptr;
271 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
272 : then available through the saved descriptor. */
273 28442 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
274 47867 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
275 1303 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
276 46061 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
277 2369 : decl = build_fold_indirect_ref_loc (input_location, decl);
278 46061 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
279 : CLASS_VPTR_FIELD);
280 46061 : return fold_build3_loc (input_location, COMPONENT_REF,
281 46061 : TREE_TYPE (vptr), decl, vptr,
282 46061 : NULL_TREE);
283 : }
284 :
285 :
286 : tree
287 6805 : gfc_class_len_get (tree decl)
288 : {
289 6805 : tree len;
290 : /* For class arrays decl may be a temporary descriptor handle, the len is
291 : then available through the saved descriptor. */
292 4859 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
293 7060 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
294 91 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
295 6805 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
296 668 : decl = build_fold_indirect_ref_loc (input_location, decl);
297 6805 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
298 : CLASS_LEN_FIELD);
299 6805 : return fold_build3_loc (input_location, COMPONENT_REF,
300 6805 : TREE_TYPE (len), decl, len,
301 6805 : NULL_TREE);
302 : }
303 :
304 :
305 : /* Try to get the _len component of a class. When the class is not unlimited
306 : poly, i.e. no _len field exists, then return a zero node. */
307 :
308 : static tree
309 8374 : gfc_class_len_or_zero_get (tree decl)
310 : {
311 8374 : tree len;
312 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
313 : then available through the saved descriptor. */
314 4138 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
315 8440 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
316 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
317 8374 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
318 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
319 8374 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
320 : CLASS_LEN_FIELD);
321 10698 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
322 2324 : TREE_TYPE (len), decl, len,
323 : NULL_TREE)
324 6050 : : build_zero_cst (gfc_charlen_type_node);
325 : }
326 :
327 :
328 : tree
329 8204 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
330 : {
331 8204 : tree tmp;
332 8204 : tree tmp2;
333 8204 : tree type;
334 :
335 8204 : tmp = gfc_class_len_or_zero_get (class_expr);
336 :
337 : /* Include the len value in the element size if present. */
338 8204 : if (!integer_zerop (tmp))
339 : {
340 2154 : type = TREE_TYPE (size);
341 2154 : if (block)
342 : {
343 996 : size = gfc_evaluate_now (size, block);
344 996 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
345 : }
346 : else
347 1158 : tmp = fold_convert (type , tmp);
348 2154 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
349 : type, size, tmp);
350 2154 : tmp = fold_build2_loc (input_location, GT_EXPR,
351 : logical_type_node, tmp,
352 : build_zero_cst (type));
353 2154 : size = fold_build3_loc (input_location, COND_EXPR,
354 : type, tmp, tmp2, size);
355 : }
356 : else
357 : return size;
358 :
359 2154 : if (block)
360 996 : size = gfc_evaluate_now (size, block);
361 :
362 : return size;
363 : }
364 :
365 :
366 : /* Get the specified FIELD from the VPTR. */
367 :
368 : static tree
369 21406 : vptr_field_get (tree vptr, int fieldno)
370 : {
371 21406 : tree field;
372 21406 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
373 21406 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
374 : fieldno);
375 21406 : field = fold_build3_loc (input_location, COMPONENT_REF,
376 21406 : TREE_TYPE (field), vptr, field,
377 : NULL_TREE);
378 21406 : gcc_assert (field);
379 21406 : return field;
380 : }
381 :
382 :
383 : /* Get the field from the class' vptr. */
384 :
385 : static tree
386 9984 : class_vtab_field_get (tree decl, int fieldno)
387 : {
388 9984 : tree vptr;
389 9984 : vptr = gfc_class_vptr_get (decl);
390 9984 : return vptr_field_get (vptr, fieldno);
391 : }
392 :
393 :
394 : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
395 : unison. */
396 : #define VTAB_GET_FIELD_GEN(name, field) tree \
397 : gfc_class_vtab_## name ##_get (tree cl) \
398 : { \
399 : return class_vtab_field_get (cl, field); \
400 : } \
401 : \
402 : tree \
403 : gfc_vptr_## name ##_get (tree vptr) \
404 : { \
405 : return vptr_field_get (vptr, field); \
406 : }
407 :
408 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
409 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
410 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
411 4377 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
412 1836 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
413 1023 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
414 : #undef VTAB_GET_FIELD_GEN
415 :
416 : /* The size field is returned as an array index type. Therefore treat
417 : it and only it specially. */
418 :
419 : tree
420 7970 : gfc_class_vtab_size_get (tree cl)
421 : {
422 7970 : tree size;
423 7970 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
424 : /* Always return size as an array index type. */
425 7970 : size = fold_convert (gfc_array_index_type, size);
426 7970 : gcc_assert (size);
427 7970 : return size;
428 : }
429 :
430 : tree
431 6017 : gfc_vptr_size_get (tree vptr)
432 : {
433 6017 : tree size;
434 6017 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
435 : /* Always return size as an array index type. */
436 6017 : size = fold_convert (gfc_array_index_type, size);
437 6017 : gcc_assert (size);
438 6017 : return size;
439 : }
440 :
441 :
442 : #undef CLASS_DATA_FIELD
443 : #undef CLASS_VPTR_FIELD
444 : #undef CLASS_LEN_FIELD
445 : #undef VTABLE_HASH_FIELD
446 : #undef VTABLE_SIZE_FIELD
447 : #undef VTABLE_EXTENDS_FIELD
448 : #undef VTABLE_DEF_INIT_FIELD
449 : #undef VTABLE_COPY_FIELD
450 : #undef VTABLE_FINAL_FIELD
451 :
452 :
453 : /* IF ts is null (default), search for the last _class ref in the chain
454 : of references of the expression and cut the chain there. Although
455 : this routine is similar to class.cc:gfc_add_component_ref (), there
456 : is a significant difference: gfc_add_component_ref () concentrates
457 : on an array ref that is the last ref in the chain and is oblivious
458 : to the kind of refs following.
459 : ELSE IF ts is non-null the cut is at the class entity or component
460 : that is followed by an array reference, which is not an element.
461 : These calls come from trans-array.cc:build_class_array_ref, which
462 : handles scalarized class array references.*/
463 :
464 : gfc_expr *
465 9493 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
466 : gfc_typespec **ts)
467 : {
468 9493 : gfc_expr *base_expr;
469 9493 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
470 :
471 : /* Find the last class reference. */
472 9493 : class_ref = NULL;
473 9493 : array_ref = NULL;
474 :
475 9493 : if (ts)
476 : {
477 435 : if (e->symtree
478 410 : && e->symtree->n.sym->ts.type == BT_CLASS)
479 410 : *ts = &e->symtree->n.sym->ts;
480 : else
481 25 : *ts = NULL;
482 : }
483 :
484 23893 : for (ref = e->ref; ref; ref = ref->next)
485 : {
486 14820 : if (ts)
487 : {
488 1038 : if (ref->type == REF_COMPONENT
489 490 : && ref->u.c.component->ts.type == BT_CLASS
490 0 : && ref->next && ref->next->type == REF_COMPONENT
491 0 : && !strcmp (ref->next->u.c.component->name, "_data")
492 0 : && ref->next->next
493 0 : && ref->next->next->type == REF_ARRAY
494 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
495 : {
496 0 : *ts = &ref->u.c.component->ts;
497 0 : class_ref = ref;
498 0 : break;
499 : }
500 :
501 1038 : if (ref->next == NULL)
502 : break;
503 : }
504 : else
505 : {
506 13782 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
507 13782 : array_ref = ref;
508 :
509 13782 : if (ref->type == REF_COMPONENT
510 8289 : && ref->u.c.component->ts.type == BT_CLASS)
511 : {
512 : /* Component to the right of a part reference with nonzero
513 : rank must not have the ALLOCATABLE attribute. If attempts
514 : are made to reference such a component reference, an error
515 : results followed by an ICE. */
516 1618 : if (array_ref
517 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
518 : return NULL;
519 : class_ref = ref;
520 : }
521 : }
522 : }
523 :
524 9483 : if (ts && *ts == NULL)
525 : return NULL;
526 :
527 : /* Remove and store all subsequent references after the
528 : CLASS reference. */
529 9458 : if (class_ref)
530 : {
531 1416 : tail = class_ref->next;
532 1416 : class_ref->next = NULL;
533 : }
534 8042 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
535 : {
536 8042 : tail = e->ref;
537 8042 : e->ref = NULL;
538 : }
539 :
540 9458 : if (is_mold)
541 61 : base_expr = gfc_expr_to_initialize (e);
542 : else
543 9397 : base_expr = gfc_copy_expr (e);
544 :
545 : /* Restore the original tail expression. */
546 9458 : if (class_ref)
547 : {
548 1416 : gfc_free_ref_list (class_ref->next);
549 1416 : class_ref->next = tail;
550 : }
551 8042 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
552 : {
553 8042 : gfc_free_ref_list (e->ref);
554 8042 : e->ref = tail;
555 : }
556 : return base_expr;
557 : }
558 :
559 : /* Reset the vptr to the declared type, e.g. after deallocation.
560 : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
561 : one with e or class_type. At least one of the two has to be set. The
562 : generated assignment code is added at the end of BLOCK. */
563 :
564 : void
565 11290 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
566 : gfc_symbol *class_type)
567 : {
568 11290 : tree vptr = NULL_TREE;
569 :
570 11290 : if (class_container != NULL_TREE)
571 6764 : vptr = gfc_get_vptr_from_expr (class_container);
572 :
573 6764 : if (vptr == NULL_TREE)
574 : {
575 4533 : gfc_se se;
576 4533 : gcc_assert (e);
577 :
578 : /* Evaluate the expression and obtain the vptr from it. */
579 4533 : gfc_init_se (&se, NULL);
580 4533 : if (e->rank)
581 2261 : gfc_conv_expr_descriptor (&se, e);
582 : else
583 2272 : gfc_conv_expr (&se, e);
584 4533 : gfc_add_block_to_block (block, &se.pre);
585 :
586 4533 : vptr = gfc_get_vptr_from_expr (se.expr);
587 : }
588 :
589 : /* If a vptr is not found, we can do nothing more. */
590 4533 : if (vptr == NULL_TREE)
591 : return;
592 :
593 11280 : if (UNLIMITED_POLY (e)
594 10244 : || UNLIMITED_POLY (class_type)
595 : /* When the class_type's source is not a symbol (e.g. a component's ts),
596 : then look at the _data-components type. */
597 1529 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
598 1529 : && class_type->components && class_type->components->ts.u.derived
599 1523 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
600 1204 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
601 : else
602 : {
603 10076 : gfc_symbol *vtab, *type = nullptr;
604 10076 : tree vtable;
605 :
606 10076 : if (e)
607 8715 : type = e->ts.u.derived;
608 1361 : else if (class_type)
609 : {
610 1361 : if (class_type->ts.type == BT_CLASS)
611 0 : type = CLASS_DATA (class_type)->ts.u.derived;
612 : else
613 : type = class_type;
614 : }
615 8715 : gcc_assert (type);
616 : /* Return the vptr to the address of the declared type. */
617 10076 : vtab = gfc_find_derived_vtab (type);
618 10076 : vtable = vtab->backend_decl;
619 10076 : if (vtable == NULL_TREE)
620 100 : vtable = gfc_get_symbol_decl (vtab);
621 10076 : vtable = gfc_build_addr_expr (NULL, vtable);
622 10076 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
623 10076 : gfc_add_modify (block, vptr, vtable);
624 : }
625 : }
626 :
627 : /* Set the vptr of a class in to from the type given in from. If from is NULL,
628 : then reset the vptr to the default or to. */
629 :
630 : void
631 228 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
632 : {
633 228 : tree tmp, vptr_ref;
634 228 : gfc_symbol *type;
635 :
636 228 : vptr_ref = gfc_get_vptr_from_expr (to);
637 264 : if (POINTER_TYPE_P (TREE_TYPE (from))
638 228 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
639 : {
640 44 : gfc_add_modify (block, vptr_ref,
641 22 : fold_convert (TREE_TYPE (vptr_ref),
642 : gfc_get_vptr_from_expr (from)));
643 250 : return;
644 : }
645 206 : tmp = gfc_get_vptr_from_expr (from);
646 206 : if (tmp)
647 : {
648 170 : gfc_add_modify (block, vptr_ref,
649 170 : fold_convert (TREE_TYPE (vptr_ref), tmp));
650 170 : return;
651 : }
652 36 : if (VAR_P (from)
653 36 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
654 : {
655 36 : gfc_add_modify (block, vptr_ref,
656 36 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
657 36 : return;
658 : }
659 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
660 0 : && GFC_CLASS_TYPE_P (
661 : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
662 : {
663 0 : gfc_add_modify (block, vptr_ref,
664 0 : fold_convert (TREE_TYPE (vptr_ref),
665 : gfc_get_vptr_from_expr (TREE_OPERAND (
666 : TREE_OPERAND (from, 0), 0))));
667 0 : return;
668 : }
669 :
670 : /* If nothing of the above matches, set the vtype according to the type. */
671 0 : tmp = TREE_TYPE (from);
672 0 : if (POINTER_TYPE_P (tmp))
673 0 : tmp = TREE_TYPE (tmp);
674 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
675 : &type);
676 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
677 0 : gcc_assert (tmp);
678 0 : gfc_add_modify (block, vptr_ref,
679 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
680 : }
681 :
682 : /* Reset the len for unlimited polymorphic objects. */
683 :
684 : void
685 639 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
686 : {
687 639 : gfc_expr *e;
688 639 : gfc_se se_len;
689 639 : e = gfc_find_and_cut_at_last_class_ref (expr);
690 639 : if (e == NULL)
691 0 : return;
692 639 : gfc_add_len_component (e);
693 639 : gfc_init_se (&se_len, NULL);
694 639 : gfc_conv_expr (&se_len, e);
695 639 : gfc_add_modify (block, se_len.expr,
696 639 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
697 639 : gfc_free_expr (e);
698 : }
699 :
700 :
701 : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
702 : reference is found. Note that it is up to the caller to avoid using this
703 : for expressions other than variables. */
704 :
705 : tree
706 1451 : gfc_get_class_from_gfc_expr (gfc_expr *e)
707 : {
708 1451 : gfc_expr *class_expr;
709 1451 : gfc_se cse;
710 1451 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
711 1451 : if (class_expr == NULL)
712 : return NULL_TREE;
713 1451 : gfc_init_se (&cse, NULL);
714 1451 : gfc_conv_expr (&cse, class_expr);
715 1451 : gfc_free_expr (class_expr);
716 1451 : return cse.expr;
717 : }
718 :
719 :
720 : /* Obtain the last class reference in an expression.
721 : Return NULL_TREE if no class reference is found. */
722 :
723 : tree
724 108473 : gfc_get_class_from_expr (tree expr)
725 : {
726 108473 : tree tmp;
727 108473 : tree type;
728 108473 : bool array_descr_found = false;
729 108473 : bool comp_after_descr_found = false;
730 :
731 279519 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
732 : {
733 279519 : if (CONSTANT_CLASS_P (tmp))
734 : return NULL_TREE;
735 :
736 279482 : type = TREE_TYPE (tmp);
737 324061 : while (type)
738 : {
739 316183 : if (GFC_CLASS_TYPE_P (type))
740 : return tmp;
741 296121 : if (GFC_DESCRIPTOR_TYPE_P (type))
742 35404 : array_descr_found = true;
743 296121 : if (type != TYPE_CANONICAL (type))
744 44579 : type = TYPE_CANONICAL (type);
745 : else
746 : type = NULL_TREE;
747 : }
748 259420 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
749 : break;
750 :
751 : /* Avoid walking up the reference chain too far. For class arrays, the
752 : array descriptor is a direct component (through a pointer) of the class
753 : container. So there is exactly one COMPONENT_REF between a class
754 : container and its child array descriptor. After seeing an array
755 : descriptor, we can give up on the second COMPONENT_REF we see, if no
756 : class container was found until that point. */
757 171046 : if (array_descr_found)
758 : {
759 7467 : if (comp_after_descr_found)
760 : {
761 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
762 : return NULL_TREE;
763 : }
764 7455 : else if (TREE_CODE (tmp) == COMPONENT_REF)
765 7467 : comp_after_descr_found = true;
766 : }
767 : }
768 :
769 88374 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
770 59282 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
771 :
772 88374 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
773 : return tmp;
774 :
775 : return NULL_TREE;
776 : }
777 :
778 :
779 : /* Obtain the vptr of the last class reference in an expression.
780 : Return NULL_TREE if no class reference is found. */
781 :
782 : tree
783 11945 : gfc_get_vptr_from_expr (tree expr)
784 : {
785 11945 : tree tmp;
786 :
787 11945 : tmp = gfc_get_class_from_expr (expr);
788 :
789 11945 : if (tmp != NULL_TREE)
790 11880 : return gfc_class_vptr_get (tmp);
791 :
792 : return NULL_TREE;
793 : }
794 :
795 : static void
796 2287 : copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
797 : {
798 2287 : tree src_type = TREE_TYPE (src);
799 2287 : if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
800 : {
801 135 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
802 270 : for (int c = 0; c < lang_specific->corank; ++c)
803 : {
804 135 : int dim = lang_specific->rank + c;
805 135 : tree codim = gfc_rank_cst[dim];
806 :
807 135 : if (lang_specific->lbound[dim])
808 54 : gfc_conv_descriptor_lbound_set (block, dest, codim,
809 : lang_specific->lbound[dim]);
810 : else
811 81 : gfc_conv_descriptor_lbound_set (
812 : block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
813 135 : if (dim + 1 < lang_specific->corank)
814 : {
815 0 : if (lang_specific->ubound[dim])
816 0 : gfc_conv_descriptor_ubound_set (block, dest, codim,
817 : lang_specific->ubound[dim]);
818 : else
819 0 : gfc_conv_descriptor_ubound_set (
820 : block, dest, codim,
821 : gfc_conv_descriptor_ubound_get (src, codim));
822 : }
823 : }
824 : }
825 2287 : }
826 :
827 : void
828 1965 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
829 : bool lhs_type)
830 : {
831 1965 : tree lhs_dim, rhs_dim, type;
832 :
833 1965 : gfc_conv_descriptor_data_set (block, lhs_desc,
834 : gfc_conv_descriptor_data_get (rhs_desc));
835 1965 : gfc_conv_descriptor_offset_set (block, lhs_desc,
836 : gfc_conv_descriptor_offset_get (rhs_desc));
837 :
838 1965 : gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
839 : gfc_conv_descriptor_dtype (rhs_desc));
840 :
841 : /* Assign the dimension as range-ref. */
842 1965 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
843 1965 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
844 :
845 1965 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
846 1965 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
847 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
848 1965 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
849 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
850 1965 : gfc_add_modify (block, lhs_dim, rhs_dim);
851 :
852 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
853 1965 : copy_coarray_desc_part (block, lhs_desc, rhs_desc);
854 1965 : }
855 :
856 : /* Takes a derived type expression and returns the address of a temporary
857 : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
858 : used for the temporary class object.
859 : optional_alloc_ptr is false when the dummy is neither allocatable
860 : nor a pointer; that's only relevant for the optional handling.
861 : The optional argument 'derived_array' is used to preserve the parmse
862 : expression for deallocation of allocatable components. Assumed rank
863 : formal arguments made this necessary. */
864 : void
865 5253 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
866 : tree opt_vptr_src, bool optional,
867 : bool optional_alloc_ptr, const char *proc_name,
868 : tree *derived_array)
869 : {
870 5253 : tree cond_optional = NULL_TREE;
871 5253 : gfc_ss *ss;
872 5253 : tree ctree;
873 5253 : tree var;
874 5253 : tree tmp;
875 5253 : tree packed = NULL_TREE;
876 :
877 : /* The derived type needs to be converted to a temporary CLASS object. */
878 5253 : tmp = gfc_typenode_for_spec (&fsym->ts);
879 5253 : var = gfc_create_var (tmp, "class");
880 :
881 : /* Set the vptr. */
882 5253 : if (opt_vptr_src)
883 128 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
884 : else
885 5125 : gfc_reset_vptr (&parmse->pre, e, var);
886 :
887 : /* Now set the data field. */
888 5253 : ctree = gfc_class_data_get (var);
889 :
890 5253 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
891 : {
892 4 : tree token;
893 4 : tmp = gfc_get_tree_for_caf_expr (e);
894 4 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
895 2 : tmp = build_fold_indirect_ref (tmp);
896 4 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
897 4 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), token);
898 : }
899 :
900 5253 : if (optional)
901 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
902 :
903 : /* Set the _len as early as possible. */
904 5253 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
905 5253 : && fsym->ts.u.derived->components->ts.u.derived->attr
906 5253 : .unlimited_polymorphic)
907 : {
908 : /* Take care about initializing the _len component correctly. */
909 386 : tree len_tree = gfc_class_len_get (var);
910 386 : if (UNLIMITED_POLY (e))
911 : {
912 12 : gfc_expr *len;
913 12 : gfc_se se;
914 :
915 12 : len = gfc_find_and_cut_at_last_class_ref (e);
916 12 : gfc_add_len_component (len);
917 12 : gfc_init_se (&se, NULL);
918 12 : gfc_conv_expr (&se, len);
919 12 : if (optional)
920 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
921 : cond_optional, se.expr,
922 0 : fold_convert (TREE_TYPE (se.expr),
923 : integer_zero_node));
924 : else
925 12 : tmp = se.expr;
926 12 : gfc_free_expr (len);
927 12 : }
928 : else
929 374 : tmp = integer_zero_node;
930 386 : gfc_add_modify (&parmse->pre, len_tree,
931 386 : fold_convert (TREE_TYPE (len_tree), tmp));
932 : }
933 :
934 5253 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
935 : {
936 : /* If there is a ready made pointer to a derived type, use it
937 : rather than evaluating the expression again. */
938 535 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
939 535 : gfc_add_modify (&parmse->pre, ctree, tmp);
940 : }
941 4718 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
942 : {
943 : /* For an array reference in an elemental procedure call we need
944 : to retain the ss to provide the scalarized array reference. */
945 445 : gfc_conv_expr_reference (parmse, e);
946 445 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
947 445 : if (optional)
948 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
949 : cond_optional, tmp,
950 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
951 445 : gfc_add_modify (&parmse->pre, ctree, tmp);
952 : }
953 : else
954 : {
955 4273 : ss = gfc_walk_expr (e);
956 4273 : if (ss == gfc_ss_terminator)
957 : {
958 3019 : parmse->ss = NULL;
959 3019 : gfc_conv_expr_reference (parmse, e);
960 :
961 : /* Scalar to an assumed-rank array. */
962 3019 : if (fsym->ts.u.derived->components->as)
963 : {
964 322 : tree type;
965 322 : type = get_scalar_to_descriptor_type (parmse->expr,
966 : gfc_expr_attr (e));
967 322 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
968 : gfc_get_dtype (type));
969 322 : copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
970 322 : if (optional)
971 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
972 96 : TREE_TYPE (parmse->expr),
973 : cond_optional, parmse->expr,
974 96 : fold_convert (TREE_TYPE (parmse->expr),
975 : null_pointer_node));
976 322 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
977 : }
978 : else
979 : {
980 2697 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
981 2697 : if (optional)
982 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
983 : cond_optional, tmp,
984 132 : fold_convert (TREE_TYPE (tmp),
985 : null_pointer_node));
986 2697 : gfc_add_modify (&parmse->pre, ctree, tmp);
987 : }
988 : }
989 : else
990 : {
991 1254 : stmtblock_t block;
992 1254 : gfc_init_block (&block);
993 1254 : gfc_ref *ref;
994 1254 : int dim;
995 1254 : tree lbshift = NULL_TREE;
996 :
997 : /* Array refs with sections indicate, that a for a formal argument
998 : expecting contiguous repacking needs to be done. */
999 2357 : for (ref = e->ref; ref; ref = ref->next)
1000 1253 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1001 : break;
1002 1254 : if (IS_CLASS_ARRAY (fsym)
1003 1146 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
1004 888 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
1005 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
1006 144 : fsym->attr.contiguous = 1;
1007 :
1008 : /* Detect any array references with vector subscripts. */
1009 2501 : for (ref = e->ref; ref; ref = ref->next)
1010 1253 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
1011 1211 : && ref->u.ar.type != AR_FULL)
1012 : {
1013 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
1014 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
1015 : break;
1016 150 : if (dim < ref->u.ar.dimen)
1017 : break;
1018 : }
1019 : /* Array references with vector subscripts and non-variable
1020 : expressions need be converted to a one-based descriptor. */
1021 1254 : if (ref || e->expr_type != EXPR_VARIABLE)
1022 49 : lbshift = gfc_index_one_node;
1023 :
1024 1254 : parmse->expr = var;
1025 1254 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
1026 : &lbshift, &packed);
1027 :
1028 1254 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
1029 : {
1030 1158 : *derived_array
1031 1158 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
1032 1158 : if (e->rank == -1)
1033 : {
1034 : /* Assumed-rank actual: parmse->expr physically holds only
1035 : dtype.rank dims; a full struct assign reads past the end.
1036 : Copy field-by-field with a runtime-sized dim[] memcpy.
1037 : PR fortran/60576. */
1038 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
1039 :
1040 78 : gfc_conv_descriptor_data_set
1041 78 : (&block, *derived_array,
1042 : gfc_conv_descriptor_data_get (parmse->expr));
1043 78 : gfc_conv_descriptor_offset_set
1044 78 : (&block, *derived_array,
1045 : gfc_conv_descriptor_offset_get (parmse->expr));
1046 78 : gfc_add_modify (&block,
1047 : gfc_conv_descriptor_dtype (*derived_array),
1048 : gfc_conv_descriptor_dtype (parmse->expr));
1049 78 : rank = fold_convert (size_type_node,
1050 : gfc_conv_descriptor_rank (parmse->expr));
1051 78 : dim_field = gfc_get_descriptor_dimension (parmse->expr);
1052 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
1053 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
1054 : size_type_node, rank, dim_size);
1055 78 : dst_ptr = gfc_build_addr_expr
1056 78 : (pvoid_type_node, gfc_get_descriptor_dimension (*derived_array));
1057 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
1058 78 : gfc_add_expr_to_block (&block,
1059 : build_call_expr_loc (input_location,
1060 : builtin_decl_explicit (BUILT_IN_MEMCPY),
1061 : 3, dst_ptr, src_ptr, copy_size));
1062 : }
1063 : else
1064 1080 : gfc_add_modify (&block, *derived_array, parmse->expr);
1065 : }
1066 :
1067 1254 : if (optional)
1068 : {
1069 348 : tmp = gfc_finish_block (&block);
1070 :
1071 348 : gfc_init_block (&block);
1072 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
1073 348 : if (derived_array && *derived_array != NULL_TREE)
1074 348 : gfc_conv_descriptor_data_set (&block, *derived_array,
1075 : null_pointer_node);
1076 :
1077 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
1078 : gfc_finish_block (&block));
1079 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
1080 : }
1081 : else
1082 906 : gfc_add_block_to_block (&parmse->pre, &block);
1083 : }
1084 : }
1085 :
1086 : /* Pass the address of the class object. */
1087 5253 : if (packed)
1088 96 : parmse->expr = packed;
1089 : else
1090 5157 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1091 :
1092 5253 : if (optional && optional_alloc_ptr)
1093 84 : parmse->expr
1094 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1095 : cond_optional, parmse->expr,
1096 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1097 5253 : }
1098 :
1099 : /* Create a new class container, which is required as scalar coarrays
1100 : have an array descriptor while normal scalars haven't. Optionally,
1101 : NULL pointer checks are added if the argument is OPTIONAL. */
1102 :
1103 : static void
1104 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1105 : gfc_typespec class_ts, bool optional)
1106 : {
1107 48 : tree var, ctree, tmp;
1108 48 : stmtblock_t block;
1109 48 : gfc_ref *ref;
1110 48 : gfc_ref *class_ref;
1111 :
1112 48 : gfc_init_block (&block);
1113 :
1114 48 : class_ref = NULL;
1115 144 : for (ref = e->ref; ref; ref = ref->next)
1116 : {
1117 96 : if (ref->type == REF_COMPONENT
1118 48 : && ref->u.c.component->ts.type == BT_CLASS)
1119 96 : class_ref = ref;
1120 : }
1121 :
1122 48 : if (class_ref == NULL
1123 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1124 48 : tmp = e->symtree->n.sym->backend_decl;
1125 : else
1126 : {
1127 : /* Remove everything after the last class reference, convert the
1128 : expression and then recover its tailend once more. */
1129 0 : gfc_se tmpse;
1130 0 : ref = class_ref->next;
1131 0 : class_ref->next = NULL;
1132 0 : gfc_init_se (&tmpse, NULL);
1133 0 : gfc_conv_expr (&tmpse, e);
1134 0 : class_ref->next = ref;
1135 0 : tmp = tmpse.expr;
1136 : }
1137 :
1138 48 : var = gfc_typenode_for_spec (&class_ts);
1139 48 : var = gfc_create_var (var, "class");
1140 :
1141 48 : ctree = gfc_class_vptr_get (var);
1142 96 : gfc_add_modify (&block, ctree,
1143 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1144 :
1145 48 : ctree = gfc_class_data_get (var);
1146 48 : tmp = gfc_conv_descriptor_data_get (
1147 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1148 : ? tmp
1149 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1150 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1151 :
1152 : /* Pass the address of the class object. */
1153 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1154 :
1155 48 : if (optional)
1156 : {
1157 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1158 48 : tree tmp2;
1159 :
1160 48 : tmp = gfc_finish_block (&block);
1161 :
1162 48 : gfc_init_block (&block);
1163 48 : tmp2 = gfc_class_data_get (var);
1164 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1165 : null_pointer_node));
1166 48 : tmp2 = gfc_finish_block (&block);
1167 :
1168 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1169 : cond, tmp, tmp2);
1170 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1171 : }
1172 : else
1173 0 : gfc_add_block_to_block (&parmse->pre, &block);
1174 48 : }
1175 :
1176 :
1177 : /* Takes an intrinsic type expression and returns the address of a temporary
1178 : class object of the 'declared' type. */
1179 : void
1180 882 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1181 : gfc_typespec class_ts)
1182 : {
1183 882 : gfc_symbol *vtab;
1184 882 : gfc_ss *ss;
1185 882 : tree ctree;
1186 882 : tree var;
1187 882 : tree tmp;
1188 882 : int dim;
1189 882 : bool unlimited_poly;
1190 :
1191 1764 : unlimited_poly = class_ts.type == BT_CLASS
1192 882 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1193 882 : && class_ts.u.derived->components->ts.u.derived
1194 882 : ->attr.unlimited_polymorphic;
1195 :
1196 : /* The intrinsic type needs to be converted to a temporary
1197 : CLASS object. */
1198 882 : tmp = gfc_typenode_for_spec (&class_ts);
1199 882 : var = gfc_create_var (tmp, "class");
1200 :
1201 : /* Force a temporary for component or substring references. */
1202 882 : if (unlimited_poly
1203 882 : && class_ts.u.derived->components->attr.dimension
1204 623 : && !class_ts.u.derived->components->attr.allocatable
1205 623 : && !class_ts.u.derived->components->attr.class_pointer
1206 1505 : && is_subref_array (e))
1207 17 : parmse->force_tmp = 1;
1208 :
1209 : /* Set the vptr. */
1210 882 : ctree = gfc_class_vptr_get (var);
1211 :
1212 882 : vtab = gfc_find_vtab (&e->ts);
1213 882 : gcc_assert (vtab);
1214 882 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1215 882 : gfc_add_modify (&parmse->pre, ctree,
1216 882 : fold_convert (TREE_TYPE (ctree), tmp));
1217 :
1218 : /* Now set the data field. */
1219 882 : ctree = gfc_class_data_get (var);
1220 882 : if (parmse->ss && parmse->ss->info->useflags)
1221 : {
1222 : /* For an array reference in an elemental procedure call we need
1223 : to retain the ss to provide the scalarized array reference. */
1224 36 : gfc_conv_expr_reference (parmse, e);
1225 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1226 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1227 : }
1228 : else
1229 : {
1230 846 : ss = gfc_walk_expr (e);
1231 846 : if (ss == gfc_ss_terminator)
1232 : {
1233 247 : parmse->ss = NULL;
1234 247 : gfc_conv_expr_reference (parmse, e);
1235 247 : if (class_ts.u.derived->components->as
1236 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1237 : {
1238 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1239 : gfc_expr_attr (e));
1240 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1241 24 : TREE_TYPE (ctree), tmp);
1242 : }
1243 : else
1244 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1245 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1246 : }
1247 : else
1248 : {
1249 599 : parmse->ss = ss;
1250 599 : gfc_conv_expr_descriptor (parmse, e);
1251 :
1252 : /* Array references with vector subscripts and non-variable expressions
1253 : need be converted to a one-based descriptor. */
1254 599 : if (e->expr_type != EXPR_VARIABLE)
1255 : {
1256 368 : for (dim = 0; dim < e->rank; ++dim)
1257 193 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1258 : dim, gfc_index_one_node);
1259 : }
1260 :
1261 599 : if (class_ts.u.derived->components->as->rank != e->rank)
1262 : {
1263 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1264 49 : TREE_TYPE (ctree), parmse->expr);
1265 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1266 : }
1267 : else
1268 550 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1269 : }
1270 : }
1271 :
1272 882 : gcc_assert (class_ts.type == BT_CLASS);
1273 882 : if (unlimited_poly)
1274 : {
1275 882 : ctree = gfc_class_len_get (var);
1276 : /* When the actual arg is a char array, then set the _len component of the
1277 : unlimited polymorphic entity to the length of the string. */
1278 882 : if (e->ts.type == BT_CHARACTER)
1279 : {
1280 : /* Start with parmse->string_length because this seems to be set to a
1281 : correct value more often. */
1282 175 : if (parmse->string_length)
1283 : tmp = parmse->string_length;
1284 : /* When the string_length is not yet set, then try the backend_decl of
1285 : the cl. */
1286 0 : else if (e->ts.u.cl->backend_decl)
1287 : tmp = e->ts.u.cl->backend_decl;
1288 : /* If both of the above approaches fail, then try to generate an
1289 : expression from the input, which is only feasible currently, when the
1290 : expression can be evaluated to a constant one. */
1291 : else
1292 : {
1293 : /* Try to simplify the expression. */
1294 0 : gfc_simplify_expr (e, 0);
1295 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1296 : {
1297 : /* Amazingly all data is present to compute the length of a
1298 : constant string, but the expression is not yet there. */
1299 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1300 : gfc_charlen_int_kind,
1301 : &e->where);
1302 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1303 0 : e->value.character.length);
1304 0 : gfc_conv_const_charlen (e->ts.u.cl);
1305 0 : e->ts.u.cl->resolved = 1;
1306 0 : tmp = e->ts.u.cl->backend_decl;
1307 : }
1308 : else
1309 : {
1310 0 : gfc_error ("Cannot compute the length of the char array "
1311 : "at %L.", &e->where);
1312 : }
1313 : }
1314 : }
1315 : else
1316 707 : tmp = integer_zero_node;
1317 :
1318 882 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1319 : }
1320 :
1321 : /* Pass the address of the class object. */
1322 882 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1323 882 : }
1324 :
1325 :
1326 : /* Takes a scalarized class array expression and returns the
1327 : address of a temporary scalar class object of the 'declared'
1328 : type.
1329 : OOP-TODO: This could be improved by adding code that branched on
1330 : the dynamic type being the same as the declared type. In this case
1331 : the original class expression can be passed directly.
1332 : optional_alloc_ptr is false when the dummy is neither allocatable
1333 : nor a pointer; that's relevant for the optional handling.
1334 : Set copyback to true if class container's _data and _vtab pointers
1335 : might get modified. */
1336 :
1337 : void
1338 3654 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1339 : bool elemental, bool copyback, bool optional,
1340 : bool optional_alloc_ptr)
1341 : {
1342 3654 : tree ctree;
1343 3654 : tree var;
1344 3654 : tree tmp;
1345 3654 : tree vptr;
1346 3654 : tree cond = NULL_TREE;
1347 3654 : tree slen = NULL_TREE;
1348 3654 : gfc_ref *ref;
1349 3654 : gfc_ref *class_ref;
1350 3654 : stmtblock_t block;
1351 3654 : bool full_array = false;
1352 :
1353 : /* If this is the data field of a class temporary, the class expression
1354 : can be obtained and returned directly. */
1355 3654 : if (e->expr_type != EXPR_VARIABLE
1356 180 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1357 36 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))
1358 3690 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse->expr, 0))))
1359 : {
1360 36 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1361 36 : if (!VAR_P (parmse->expr))
1362 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1363 36 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1364 174 : return;
1365 : }
1366 :
1367 3618 : gfc_init_block (&block);
1368 :
1369 3618 : class_ref = NULL;
1370 7273 : for (ref = e->ref; ref; ref = ref->next)
1371 : {
1372 6897 : if (ref->type == REF_COMPONENT
1373 3688 : && ref->u.c.component->ts.type == BT_CLASS)
1374 6897 : class_ref = ref;
1375 :
1376 6897 : if (ref->next == NULL)
1377 : break;
1378 : }
1379 :
1380 3618 : if ((ref == NULL || class_ref == ref)
1381 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1382 4088 : && (!class_ts.u.derived->components->as
1383 379 : || class_ts.u.derived->components->as->rank != -1))
1384 : return;
1385 :
1386 : /* Test for FULL_ARRAY. */
1387 3480 : if (e->rank == 0
1388 3480 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1389 494 : || (class_ts.u.derived->components->as
1390 366 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1391 411 : full_array = true;
1392 : else
1393 3069 : gfc_is_class_array_ref (e, &full_array);
1394 :
1395 : /* The derived type needs to be converted to a temporary
1396 : CLASS object. */
1397 3480 : tmp = gfc_typenode_for_spec (&class_ts);
1398 3480 : var = gfc_create_var (tmp, "class");
1399 :
1400 : /* Set the data. */
1401 3480 : ctree = gfc_class_data_get (var);
1402 3480 : if (class_ts.u.derived->components->as
1403 3196 : && e->rank != class_ts.u.derived->components->as->rank)
1404 : {
1405 977 : if (e->rank == 0)
1406 : {
1407 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1408 : gfc_expr_attr (e));
1409 356 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1410 : gfc_get_dtype (type));
1411 :
1412 356 : tmp = gfc_class_data_get (parmse->expr);
1413 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1414 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1415 :
1416 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1417 : }
1418 : else
1419 621 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1420 : }
1421 : else
1422 : {
1423 2503 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1424 1451 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1425 1451 : TREE_TYPE (ctree), parmse->expr);
1426 2503 : gfc_add_modify (&block, ctree, parmse->expr);
1427 : }
1428 :
1429 : /* Return the data component, except in the case of scalarized array
1430 : references, where nullification of the cannot occur and so there
1431 : is no need. */
1432 3480 : if (!elemental && full_array && copyback)
1433 : {
1434 1164 : if (class_ts.u.derived->components->as
1435 1164 : && e->rank != class_ts.u.derived->components->as->rank)
1436 : {
1437 270 : if (e->rank == 0)
1438 : {
1439 102 : tmp = gfc_class_data_get (parmse->expr);
1440 204 : gfc_add_modify (&parmse->post, tmp,
1441 102 : fold_convert (TREE_TYPE (tmp),
1442 : gfc_conv_descriptor_data_get (ctree)));
1443 : }
1444 : else
1445 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1446 : true);
1447 : }
1448 : else
1449 894 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1450 : }
1451 :
1452 : /* Set the vptr. */
1453 3480 : ctree = gfc_class_vptr_get (var);
1454 :
1455 : /* The vptr is the second field of the actual argument.
1456 : First we have to find the corresponding class reference. */
1457 :
1458 3480 : tmp = NULL_TREE;
1459 3480 : if (gfc_is_class_array_function (e)
1460 3480 : && parmse->class_vptr != NULL_TREE)
1461 : tmp = parmse->class_vptr;
1462 3462 : else if (class_ref == NULL
1463 2999 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1464 : {
1465 2999 : tmp = e->symtree->n.sym->backend_decl;
1466 :
1467 2999 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1468 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1469 :
1470 2999 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1471 397 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1472 :
1473 2999 : slen = build_zero_cst (size_type_node);
1474 : }
1475 463 : else if (parmse->class_container != NULL_TREE)
1476 : /* Don't redundantly evaluate the expression if the required information
1477 : is already available. */
1478 : tmp = parmse->class_container;
1479 : else
1480 : {
1481 : /* Remove everything after the last class reference, convert the
1482 : expression and then recover its tailend once more. */
1483 18 : gfc_se tmpse;
1484 18 : ref = class_ref->next;
1485 18 : class_ref->next = NULL;
1486 18 : gfc_init_se (&tmpse, NULL);
1487 18 : gfc_conv_expr (&tmpse, e);
1488 18 : class_ref->next = ref;
1489 18 : tmp = tmpse.expr;
1490 18 : slen = tmpse.string_length;
1491 : }
1492 :
1493 3480 : gcc_assert (tmp != NULL_TREE);
1494 :
1495 : /* Dereference if needs be. */
1496 3480 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1497 345 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1498 :
1499 3480 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1500 3462 : vptr = gfc_class_vptr_get (tmp);
1501 : else
1502 : vptr = tmp;
1503 :
1504 3480 : gfc_add_modify (&block, ctree,
1505 3480 : fold_convert (TREE_TYPE (ctree), vptr));
1506 :
1507 : /* Return the vptr component, except in the case of scalarized array
1508 : references, where the dynamic type cannot change. */
1509 3480 : if (!elemental && full_array && copyback)
1510 1164 : gfc_add_modify (&parmse->post, vptr,
1511 1164 : fold_convert (TREE_TYPE (vptr), ctree));
1512 :
1513 : /* For unlimited polymorphic objects also set the _len component. */
1514 3480 : if (class_ts.type == BT_CLASS
1515 3480 : && class_ts.u.derived->components
1516 3480 : && class_ts.u.derived->components->ts.u
1517 3480 : .derived->attr.unlimited_polymorphic)
1518 : {
1519 1146 : ctree = gfc_class_len_get (var);
1520 1146 : if (UNLIMITED_POLY (e))
1521 943 : tmp = gfc_class_len_get (tmp);
1522 203 : else if (e->ts.type == BT_CHARACTER)
1523 : {
1524 0 : gcc_assert (slen != NULL_TREE);
1525 : tmp = slen;
1526 : }
1527 : else
1528 203 : tmp = build_zero_cst (size_type_node);
1529 1146 : gfc_add_modify (&parmse->pre, ctree,
1530 1146 : fold_convert (TREE_TYPE (ctree), tmp));
1531 :
1532 : /* Return the len component, except in the case of scalarized array
1533 : references, where the dynamic type cannot change. */
1534 1146 : if (!elemental && full_array && copyback
1535 447 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1536 434 : gfc_add_modify (&parmse->post, tmp,
1537 434 : fold_convert (TREE_TYPE (tmp), ctree));
1538 : }
1539 :
1540 3480 : if (optional)
1541 : {
1542 510 : tree tmp2;
1543 :
1544 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1545 : /* parmse->pre may contain some preparatory instructions for the
1546 : temporary array descriptor. Those may only be executed when the
1547 : optional argument is set, therefore add parmse->pre's instructions
1548 : to block, which is later guarded by an if (optional_arg_given). */
1549 510 : gfc_add_block_to_block (&parmse->pre, &block);
1550 510 : block.head = parmse->pre.head;
1551 510 : parmse->pre.head = NULL_TREE;
1552 510 : tmp = gfc_finish_block (&block);
1553 :
1554 510 : if (optional_alloc_ptr)
1555 102 : tmp2 = build_empty_stmt (input_location);
1556 : else
1557 : {
1558 408 : gfc_init_block (&block);
1559 :
1560 408 : tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1561 408 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1562 : null_pointer_node));
1563 408 : tmp2 = gfc_finish_block (&block);
1564 : }
1565 :
1566 510 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1567 : cond, tmp, tmp2);
1568 510 : gfc_add_expr_to_block (&parmse->pre, tmp);
1569 :
1570 510 : if (!elemental && full_array && copyback)
1571 : {
1572 30 : tmp2 = build_empty_stmt (input_location);
1573 30 : tmp = gfc_finish_block (&parmse->post);
1574 30 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1575 : cond, tmp, tmp2);
1576 30 : gfc_add_expr_to_block (&parmse->post, tmp);
1577 : }
1578 : }
1579 : else
1580 2970 : gfc_add_block_to_block (&parmse->pre, &block);
1581 :
1582 : /* Pass the address of the class object. */
1583 3480 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1584 :
1585 3480 : if (optional && optional_alloc_ptr)
1586 204 : parmse->expr = build3_loc (input_location, COND_EXPR,
1587 102 : TREE_TYPE (parmse->expr),
1588 : cond, parmse->expr,
1589 102 : fold_convert (TREE_TYPE (parmse->expr),
1590 : null_pointer_node));
1591 : }
1592 :
1593 :
1594 : /* Given a class array declaration and an index, returns the address
1595 : of the referenced element. */
1596 :
1597 : static tree
1598 744 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1599 : bool unlimited)
1600 : {
1601 744 : tree data, size, tmp, ctmp, offset, ptr;
1602 :
1603 744 : data = data_comp != NULL_TREE ? data_comp :
1604 0 : gfc_class_data_get (class_decl);
1605 744 : size = gfc_class_vtab_size_get (class_decl);
1606 :
1607 744 : if (unlimited)
1608 : {
1609 220 : tmp = fold_convert (gfc_array_index_type,
1610 : gfc_class_len_get (class_decl));
1611 220 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1612 : gfc_array_index_type, size, tmp);
1613 220 : tmp = fold_build2_loc (input_location, GT_EXPR,
1614 : logical_type_node, tmp,
1615 220 : build_zero_cst (TREE_TYPE (tmp)));
1616 220 : size = fold_build3_loc (input_location, COND_EXPR,
1617 : gfc_array_index_type, tmp, ctmp, size);
1618 : }
1619 :
1620 744 : offset = fold_build2_loc (input_location, MULT_EXPR,
1621 : gfc_array_index_type,
1622 : index, size);
1623 :
1624 744 : data = gfc_conv_descriptor_data_get (data);
1625 744 : ptr = fold_convert (pvoid_type_node, data);
1626 744 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1627 744 : return fold_convert (TREE_TYPE (data), ptr);
1628 : }
1629 :
1630 :
1631 : /* Copies one class expression to another, assuming that if either
1632 : 'to' or 'from' are arrays they are packed. Should 'from' be
1633 : NULL_TREE, the initialization expression for 'to' is used, assuming
1634 : that the _vptr is set. */
1635 :
1636 : tree
1637 780 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1638 : {
1639 780 : tree fcn;
1640 780 : tree fcn_type;
1641 780 : tree from_data;
1642 780 : tree from_len;
1643 780 : tree to_data;
1644 780 : tree to_len;
1645 780 : tree to_ref;
1646 780 : tree from_ref;
1647 780 : vec<tree, va_gc> *args;
1648 780 : tree tmp;
1649 780 : tree stdcopy;
1650 780 : tree extcopy;
1651 780 : tree index;
1652 780 : bool is_from_desc = false, is_to_class = false;
1653 :
1654 780 : args = NULL;
1655 : /* To prevent warnings on uninitialized variables. */
1656 780 : from_len = to_len = NULL_TREE;
1657 :
1658 780 : if (from != NULL_TREE)
1659 780 : fcn = gfc_class_vtab_copy_get (from);
1660 : else
1661 0 : fcn = gfc_class_vtab_copy_get (to);
1662 :
1663 780 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1664 :
1665 780 : if (from != NULL_TREE)
1666 : {
1667 780 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1668 780 : if (is_from_desc)
1669 : {
1670 0 : from_data = from;
1671 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1672 : }
1673 : else
1674 : {
1675 : /* Check that from is a class. When the class is part of a coarray,
1676 : then from is a common pointer and is to be used as is. */
1677 1560 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1678 780 : ? build_fold_indirect_ref (from) : from;
1679 1560 : from_data =
1680 780 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1681 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1682 780 : ? gfc_class_data_get (from) : from;
1683 780 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1684 : }
1685 : }
1686 : else
1687 0 : from_data = gfc_class_vtab_def_init_get (to);
1688 :
1689 780 : if (unlimited)
1690 : {
1691 170 : if (from != NULL_TREE && unlimited)
1692 170 : from_len = gfc_class_len_or_zero_get (from);
1693 : else
1694 0 : from_len = build_zero_cst (size_type_node);
1695 : }
1696 :
1697 780 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1698 : {
1699 780 : is_to_class = true;
1700 780 : to_data = gfc_class_data_get (to);
1701 780 : if (unlimited)
1702 170 : to_len = gfc_class_len_get (to);
1703 : }
1704 : else
1705 : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1706 0 : to_data = to;
1707 :
1708 780 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1709 : {
1710 372 : stmtblock_t loopbody;
1711 372 : stmtblock_t body;
1712 372 : stmtblock_t ifbody;
1713 372 : gfc_loopinfo loop;
1714 :
1715 372 : gfc_init_block (&body);
1716 372 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1717 : gfc_array_index_type, nelems,
1718 : gfc_index_one_node);
1719 372 : nelems = gfc_evaluate_now (tmp, &body);
1720 372 : index = gfc_create_var (gfc_array_index_type, "S");
1721 :
1722 372 : if (is_from_desc)
1723 : {
1724 372 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1725 : unlimited);
1726 372 : vec_safe_push (args, from_ref);
1727 : }
1728 : else
1729 0 : vec_safe_push (args, from_data);
1730 :
1731 372 : if (is_to_class)
1732 372 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1733 : else
1734 : {
1735 0 : tmp = gfc_conv_array_data (to);
1736 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1737 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1738 : gfc_build_array_ref (tmp, index, to));
1739 : }
1740 372 : vec_safe_push (args, to_ref);
1741 :
1742 : /* Add bounds check. */
1743 372 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1744 : {
1745 25 : const char *name = "<<unknown>>";
1746 25 : int dim, rank;
1747 :
1748 25 : if (DECL_P (to))
1749 0 : name = IDENTIFIER_POINTER (DECL_NAME (to));
1750 :
1751 25 : rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
1752 55 : for (dim = 1; dim <= rank; dim++)
1753 : {
1754 30 : tree from_len, to_len, cond;
1755 30 : char *msg;
1756 :
1757 30 : from_len = gfc_conv_descriptor_size (from_data, dim);
1758 30 : from_len = fold_convert (long_integer_type_node, from_len);
1759 30 : to_len = gfc_conv_descriptor_size (to_data, dim);
1760 30 : to_len = fold_convert (long_integer_type_node, to_len);
1761 30 : msg = xasprintf ("Array bound mismatch for dimension %d "
1762 : "of array '%s' (%%ld/%%ld)",
1763 : dim, name);
1764 30 : cond = fold_build2_loc (input_location, NE_EXPR,
1765 : logical_type_node, from_len, to_len);
1766 30 : gfc_trans_runtime_check (true, false, cond, &body,
1767 : NULL, msg, to_len, from_len);
1768 30 : free (msg);
1769 : }
1770 : }
1771 :
1772 372 : tmp = build_call_vec (fcn_type, fcn, args);
1773 :
1774 : /* Build the body of the loop. */
1775 372 : gfc_init_block (&loopbody);
1776 372 : gfc_add_expr_to_block (&loopbody, tmp);
1777 :
1778 : /* Build the loop and return. */
1779 372 : gfc_init_loopinfo (&loop);
1780 372 : loop.dimen = 1;
1781 372 : loop.from[0] = gfc_index_zero_node;
1782 372 : loop.loopvar[0] = index;
1783 372 : loop.to[0] = nelems;
1784 372 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1785 372 : gfc_init_block (&ifbody);
1786 372 : gfc_add_block_to_block (&ifbody, &loop.pre);
1787 372 : stdcopy = gfc_finish_block (&ifbody);
1788 : /* In initialization mode from_len is a constant zero. */
1789 372 : if (unlimited && !integer_zerop (from_len))
1790 : {
1791 110 : vec_safe_push (args, from_len);
1792 110 : vec_safe_push (args, to_len);
1793 110 : tmp = build_call_vec (fcn_type, fcn, args);
1794 : /* Build the body of the loop. */
1795 110 : gfc_init_block (&loopbody);
1796 110 : gfc_add_expr_to_block (&loopbody, tmp);
1797 :
1798 : /* Build the loop and return. */
1799 110 : gfc_init_loopinfo (&loop);
1800 110 : loop.dimen = 1;
1801 110 : loop.from[0] = gfc_index_zero_node;
1802 110 : loop.loopvar[0] = index;
1803 110 : loop.to[0] = nelems;
1804 110 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1805 110 : gfc_init_block (&ifbody);
1806 110 : gfc_add_block_to_block (&ifbody, &loop.pre);
1807 110 : extcopy = gfc_finish_block (&ifbody);
1808 :
1809 110 : tmp = fold_build2_loc (input_location, GT_EXPR,
1810 : logical_type_node, from_len,
1811 110 : build_zero_cst (TREE_TYPE (from_len)));
1812 110 : tmp = fold_build3_loc (input_location, COND_EXPR,
1813 : void_type_node, tmp, extcopy, stdcopy);
1814 110 : gfc_add_expr_to_block (&body, tmp);
1815 110 : tmp = gfc_finish_block (&body);
1816 : }
1817 : else
1818 : {
1819 262 : gfc_add_expr_to_block (&body, stdcopy);
1820 262 : tmp = gfc_finish_block (&body);
1821 : }
1822 372 : gfc_cleanup_loop (&loop);
1823 : }
1824 : else
1825 : {
1826 408 : gcc_assert (!is_from_desc);
1827 408 : vec_safe_push (args, from_data);
1828 408 : vec_safe_push (args, to_data);
1829 408 : stdcopy = build_call_vec (fcn_type, fcn, args);
1830 :
1831 : /* In initialization mode from_len is a constant zero. */
1832 408 : if (unlimited && !integer_zerop (from_len))
1833 : {
1834 60 : vec_safe_push (args, from_len);
1835 60 : vec_safe_push (args, to_len);
1836 60 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1837 60 : tmp = fold_build2_loc (input_location, GT_EXPR,
1838 : logical_type_node, from_len,
1839 60 : build_zero_cst (TREE_TYPE (from_len)));
1840 60 : tmp = fold_build3_loc (input_location, COND_EXPR,
1841 : void_type_node, tmp, extcopy, stdcopy);
1842 : }
1843 : else
1844 : tmp = stdcopy;
1845 : }
1846 :
1847 : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1848 780 : if (from == NULL_TREE)
1849 : {
1850 0 : tree cond;
1851 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1852 : logical_type_node,
1853 : from_data, null_pointer_node);
1854 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1855 : void_type_node, cond,
1856 : tmp, build_empty_stmt (input_location));
1857 : }
1858 :
1859 780 : return tmp;
1860 : }
1861 :
1862 :
1863 : static tree
1864 106 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1865 : {
1866 106 : gfc_actual_arglist *actual;
1867 106 : gfc_expr *ppc;
1868 106 : gfc_code *ppc_code;
1869 106 : tree res;
1870 :
1871 106 : actual = gfc_get_actual_arglist ();
1872 106 : actual->expr = gfc_copy_expr (rhs);
1873 106 : actual->next = gfc_get_actual_arglist ();
1874 106 : actual->next->expr = gfc_copy_expr (lhs);
1875 106 : ppc = gfc_copy_expr (obj);
1876 106 : gfc_add_vptr_component (ppc);
1877 106 : gfc_add_component_ref (ppc, "_copy");
1878 106 : ppc_code = gfc_get_code (EXEC_CALL);
1879 106 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1880 : /* Although '_copy' is set to be elemental in class.cc, it is
1881 : not staying that way. Find out why, sometime.... */
1882 106 : ppc_code->resolved_sym->attr.elemental = 1;
1883 106 : ppc_code->ext.actual = actual;
1884 106 : ppc_code->expr1 = ppc;
1885 : /* Since '_copy' is elemental, the scalarizer will take care
1886 : of arrays in gfc_trans_call. */
1887 106 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1888 106 : gfc_free_statements (ppc_code);
1889 :
1890 106 : if (UNLIMITED_POLY(obj))
1891 : {
1892 : /* Check if rhs is non-NULL. */
1893 24 : gfc_se src;
1894 24 : gfc_init_se (&src, NULL);
1895 24 : gfc_conv_expr (&src, rhs);
1896 24 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1897 24 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1898 24 : src.expr, fold_convert (TREE_TYPE (src.expr),
1899 : null_pointer_node));
1900 24 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1901 : build_empty_stmt (input_location));
1902 : }
1903 :
1904 106 : return res;
1905 : }
1906 :
1907 : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1908 : A MEMCPY is needed to copy the full data from the default initializer
1909 : of the dynamic type. */
1910 :
1911 : tree
1912 461 : gfc_trans_class_init_assign (gfc_code *code)
1913 : {
1914 461 : stmtblock_t block;
1915 461 : tree tmp;
1916 461 : bool cmp_flag = true;
1917 461 : gfc_se dst,src,memsz;
1918 461 : gfc_expr *lhs, *rhs, *sz;
1919 461 : gfc_component *cmp;
1920 461 : gfc_symbol *sym;
1921 461 : gfc_ref *ref;
1922 :
1923 461 : gfc_start_block (&block);
1924 :
1925 461 : lhs = gfc_copy_expr (code->expr1);
1926 :
1927 461 : rhs = gfc_copy_expr (code->expr1);
1928 461 : gfc_add_vptr_component (rhs);
1929 :
1930 : /* Make sure that the component backend_decls have been built, which
1931 : will not have happened if the derived types concerned have not
1932 : been referenced. */
1933 461 : gfc_get_derived_type (rhs->ts.u.derived);
1934 461 : gfc_add_def_init_component (rhs);
1935 : /* The _def_init is always scalar. */
1936 461 : rhs->rank = 0;
1937 :
1938 : /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
1939 : default initializer components NULL, use the passed value even though
1940 : F2018(8.5.10) asserts that it should considered to be undefined. This is
1941 : needed for consistency with other brands. */
1942 461 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1943 : : NULL;
1944 461 : if (code->op != EXEC_ALLOCATE
1945 400 : && sym && sym->attr.dummy
1946 400 : && sym->attr.intent == INTENT_OUT)
1947 : {
1948 400 : ref = rhs->ref;
1949 800 : while (ref && ref->next)
1950 : ref = ref->next;
1951 400 : cmp = ref->u.c.component->ts.u.derived->components;
1952 611 : for (; cmp; cmp = cmp->next)
1953 : {
1954 428 : if (cmp->initializer)
1955 : break;
1956 211 : else if (!cmp->next)
1957 146 : cmp_flag = false;
1958 : }
1959 : }
1960 :
1961 461 : if (code->expr1->ts.type == BT_CLASS
1962 438 : && CLASS_DATA (code->expr1)->attr.dimension)
1963 : {
1964 106 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1965 106 : *tmparr = *CLASS_DATA (code->expr1)->as;
1966 : /* Adding the array ref to the class expression results in correct
1967 : indexing to the dynamic type. */
1968 106 : gfc_add_full_array_ref (lhs, tmparr);
1969 106 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1970 106 : }
1971 355 : else if (cmp_flag)
1972 : {
1973 : /* Scalar initialization needs the _data component. */
1974 222 : gfc_add_data_component (lhs);
1975 222 : sz = gfc_copy_expr (code->expr1);
1976 222 : gfc_add_vptr_component (sz);
1977 222 : gfc_add_size_component (sz);
1978 :
1979 222 : gfc_init_se (&dst, NULL);
1980 222 : gfc_init_se (&src, NULL);
1981 222 : gfc_init_se (&memsz, NULL);
1982 222 : gfc_conv_expr (&dst, lhs);
1983 222 : gfc_conv_expr (&src, rhs);
1984 222 : gfc_conv_expr (&memsz, sz);
1985 222 : gfc_add_block_to_block (&block, &src.pre);
1986 222 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1987 :
1988 222 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1989 :
1990 222 : if (UNLIMITED_POLY(code->expr1))
1991 : {
1992 : /* Check if _def_init is non-NULL. */
1993 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1994 : logical_type_node, src.expr,
1995 7 : fold_convert (TREE_TYPE (src.expr),
1996 : null_pointer_node));
1997 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1998 : tmp, build_empty_stmt (input_location));
1999 : }
2000 : }
2001 : else
2002 133 : tmp = build_empty_stmt (input_location);
2003 :
2004 461 : if (code->expr1->symtree->n.sym->attr.dummy
2005 410 : && (code->expr1->symtree->n.sym->attr.optional
2006 404 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
2007 : {
2008 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
2009 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2010 : present, tmp,
2011 : build_empty_stmt (input_location));
2012 : }
2013 :
2014 461 : gfc_add_expr_to_block (&block, tmp);
2015 461 : gfc_free_expr (lhs);
2016 461 : gfc_free_expr (rhs);
2017 :
2018 461 : return gfc_finish_block (&block);
2019 : }
2020 :
2021 :
2022 : /* Class valued elemental function calls or class array elements arriving
2023 : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
2024 : is used to ensure that the rhs dynamic type is assigned to the lhs. */
2025 :
2026 : static bool
2027 788 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
2028 : {
2029 788 : tree fcn;
2030 788 : tree rse_expr;
2031 788 : tree class_data;
2032 788 : tree tmp;
2033 788 : tree zero;
2034 788 : tree cond;
2035 788 : tree final_cond;
2036 788 : stmtblock_t inner_block;
2037 788 : bool is_descriptor;
2038 788 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
2039 788 : bool not_lhs_array_type;
2040 :
2041 : /* Temporaries arising from dependencies in assignment get cast as a
2042 : character type of the dynamic size of the rhs. Use the vptr copy
2043 : for this case. */
2044 788 : tmp = TREE_TYPE (lse->expr);
2045 788 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
2046 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
2047 :
2048 : /* Use ordinary assignment if the rhs is not a call expression or
2049 : the lhs is not a class entity or an array(ie. character) type. */
2050 740 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
2051 1061 : && not_lhs_array_type)
2052 : return false;
2053 :
2054 : /* Ordinary assignment can be used if both sides are class expressions
2055 : since the dynamic type is preserved by copying the vptr. This
2056 : should only occur, where temporaries are involved. */
2057 515 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
2058 515 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
2059 : return false;
2060 :
2061 : /* Fix the class expression and the class data of the rhs. */
2062 454 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
2063 454 : || not_call_expr)
2064 : {
2065 454 : tmp = gfc_get_class_from_expr (rse->expr);
2066 454 : if (tmp == NULL_TREE)
2067 : return false;
2068 146 : rse_expr = gfc_evaluate_now (tmp, block);
2069 : }
2070 : else
2071 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
2072 :
2073 146 : class_data = gfc_class_data_get (rse_expr);
2074 :
2075 : /* Check that the rhs data is not null. */
2076 146 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
2077 146 : if (is_descriptor)
2078 146 : class_data = gfc_conv_descriptor_data_get (class_data);
2079 146 : class_data = gfc_evaluate_now (class_data, block);
2080 :
2081 146 : zero = build_int_cst (TREE_TYPE (class_data), 0);
2082 146 : cond = fold_build2_loc (input_location, NE_EXPR,
2083 : logical_type_node,
2084 : class_data, zero);
2085 :
2086 : /* Copy the rhs to the lhs. */
2087 146 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
2088 146 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2089 146 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
2090 146 : tmp = is_descriptor ? tmp : class_data;
2091 146 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
2092 : gfc_build_addr_expr (NULL, lse->expr));
2093 146 : gfc_add_expr_to_block (block, tmp);
2094 :
2095 : /* Only elemental function results need to be finalised and freed. */
2096 146 : if (not_call_expr)
2097 : return true;
2098 :
2099 : /* Finalize the class data if needed. */
2100 0 : gfc_init_block (&inner_block);
2101 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
2102 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
2103 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
2104 : logical_type_node, fcn, zero);
2105 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2106 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
2107 0 : tmp = build3_v (COND_EXPR, final_cond,
2108 : tmp, build_empty_stmt (input_location));
2109 0 : gfc_add_expr_to_block (&inner_block, tmp);
2110 :
2111 : /* Free the class data. */
2112 0 : tmp = gfc_call_free (class_data);
2113 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2114 : build_empty_stmt (input_location));
2115 0 : gfc_add_expr_to_block (&inner_block, tmp);
2116 :
2117 : /* Finish the inner block and subject it to the condition on the
2118 : class data being non-zero. */
2119 0 : tmp = gfc_finish_block (&inner_block);
2120 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2121 : build_empty_stmt (input_location));
2122 0 : gfc_add_expr_to_block (block, tmp);
2123 :
2124 0 : return true;
2125 : }
2126 :
2127 : /* End of prototype trans-class.c */
2128 :
2129 :
2130 : static void
2131 12864 : realloc_lhs_warning (bt type, bool array, locus *where)
2132 : {
2133 12864 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
2134 25 : gfc_warning (OPT_Wrealloc_lhs,
2135 : "Code for reallocating the allocatable array at %L will "
2136 : "be added", where);
2137 12839 : else if (warn_realloc_lhs_all)
2138 4 : gfc_warning (OPT_Wrealloc_lhs_all,
2139 : "Code for reallocating the allocatable variable at %L "
2140 : "will be added", where);
2141 12864 : }
2142 :
2143 :
2144 : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
2145 : gfc_expr *);
2146 :
2147 : /* Copy the scalarization loop variables. */
2148 :
2149 : static void
2150 1282713 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2151 : {
2152 1282713 : dest->ss = src->ss;
2153 1282713 : dest->loop = src->loop;
2154 1282713 : }
2155 :
2156 :
2157 : /* Initialize a simple expression holder.
2158 :
2159 : Care must be taken when multiple se are created with the same parent.
2160 : The child se must be kept in sync. The easiest way is to delay creation
2161 : of a child se until after the previous se has been translated. */
2162 :
2163 : void
2164 4658308 : gfc_init_se (gfc_se * se, gfc_se * parent)
2165 : {
2166 4658308 : memset (se, 0, sizeof (gfc_se));
2167 4658308 : gfc_init_block (&se->pre);
2168 4658308 : gfc_init_block (&se->finalblock);
2169 4658308 : gfc_init_block (&se->post);
2170 :
2171 4658308 : se->parent = parent;
2172 :
2173 4658308 : if (parent)
2174 1282713 : gfc_copy_se_loopvars (se, parent);
2175 4658308 : }
2176 :
2177 :
2178 : /* Advances to the next SS in the chain. Use this rather than setting
2179 : se->ss = se->ss->next because all the parents needs to be kept in sync.
2180 : See gfc_init_se. */
2181 :
2182 : void
2183 243620 : gfc_advance_se_ss_chain (gfc_se * se)
2184 : {
2185 243620 : gfc_se *p;
2186 :
2187 243620 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2188 :
2189 : p = se;
2190 : /* Walk down the parent chain. */
2191 639734 : while (p != NULL)
2192 : {
2193 : /* Simple consistency check. */
2194 396114 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2195 : || p->parent->ss->nested_ss == p->ss);
2196 :
2197 396114 : p->ss = p->ss->next;
2198 :
2199 396114 : p = p->parent;
2200 : }
2201 243620 : }
2202 :
2203 :
2204 : /* Ensures the result of the expression as either a temporary variable
2205 : or a constant so that it can be used repeatedly. */
2206 :
2207 : void
2208 8136 : gfc_make_safe_expr (gfc_se * se)
2209 : {
2210 8136 : tree var;
2211 :
2212 8136 : if (CONSTANT_CLASS_P (se->expr))
2213 : return;
2214 :
2215 : /* We need a temporary for this result. */
2216 274 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2217 274 : gfc_add_modify (&se->pre, var, se->expr);
2218 274 : se->expr = var;
2219 : }
2220 :
2221 :
2222 : /* Return an expression which determines if a dummy parameter is present.
2223 : Also used for arguments to procedures with multiple entry points. */
2224 :
2225 : tree
2226 11604 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2227 : {
2228 11604 : tree decl, orig_decl, cond;
2229 :
2230 11604 : gcc_assert (sym->attr.dummy);
2231 11604 : orig_decl = decl = gfc_get_symbol_decl (sym);
2232 :
2233 : /* Intrinsic scalars and derived types with VALUE attribute which are passed
2234 : by value use a hidden argument to denote the presence status. */
2235 11604 : if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
2236 : {
2237 1052 : char name[GFC_MAX_SYMBOL_LEN + 2];
2238 1052 : tree tree_name;
2239 :
2240 1052 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2241 1052 : name[0] = '.';
2242 1052 : strcpy (&name[1], sym->name);
2243 1052 : tree_name = get_identifier (name);
2244 :
2245 : /* Walk function argument list to find hidden arg. */
2246 1052 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2247 5320 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2248 5320 : if (DECL_NAME (cond) == tree_name
2249 5320 : && DECL_ARTIFICIAL (cond))
2250 : break;
2251 :
2252 1052 : gcc_assert (cond);
2253 1052 : return cond;
2254 : }
2255 :
2256 : /* Assumed-shape arrays use a local variable for the array data;
2257 : the actual PARAM_DECL is in a saved decl. As the local variable
2258 : is NULL, it can be checked instead, unless use_saved_desc is
2259 : requested. */
2260 :
2261 10552 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2262 : {
2263 822 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2264 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2265 822 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2266 : }
2267 :
2268 10552 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2269 10552 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2270 :
2271 : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2272 : as actual argument to denote absent dummies. For array descriptors,
2273 : we thus also need to check the array descriptor. For BT_CLASS, it
2274 : can also occur for scalars and F2003 due to type->class wrapping and
2275 : class->class wrapping. Note further that BT_CLASS always uses an
2276 : array descriptor for arrays, also for explicit-shape/assumed-size.
2277 : For assumed-rank arrays, no local variable is generated, hence,
2278 : the following also applies with !use_saved_desc. */
2279 :
2280 10552 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2281 7511 : && !sym->attr.allocatable
2282 6299 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2283 2296 : || (sym->ts.type == BT_CLASS
2284 1041 : && !CLASS_DATA (sym)->attr.allocatable
2285 567 : && !CLASS_DATA (sym)->attr.class_pointer))
2286 4210 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2287 6 : || sym->ts.type == BT_CLASS))
2288 : {
2289 4204 : tree tmp;
2290 :
2291 4204 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2292 1495 : || sym->as->type == AS_ASSUMED_RANK
2293 1407 : || sym->attr.codimension))
2294 3336 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2295 : {
2296 1039 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2297 1039 : if (sym->ts.type == BT_CLASS)
2298 171 : tmp = gfc_class_data_get (tmp);
2299 1039 : tmp = gfc_conv_array_data (tmp);
2300 : }
2301 3165 : else if (sym->ts.type == BT_CLASS)
2302 36 : tmp = gfc_class_data_get (decl);
2303 : else
2304 : tmp = NULL_TREE;
2305 :
2306 1075 : if (tmp != NULL_TREE)
2307 : {
2308 1075 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2309 1075 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2310 1075 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2311 : logical_type_node, cond, tmp);
2312 : }
2313 : }
2314 :
2315 : return cond;
2316 : }
2317 :
2318 :
2319 : /* Converts a missing, dummy argument into a null or zero. */
2320 :
2321 : void
2322 844 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2323 : {
2324 844 : tree present;
2325 844 : tree tmp;
2326 :
2327 844 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2328 :
2329 844 : if (kind > 0)
2330 : {
2331 : /* Create a temporary and convert it to the correct type. */
2332 54 : tmp = gfc_get_int_type (kind);
2333 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2334 : se->expr));
2335 :
2336 : /* Test for a NULL value. */
2337 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2338 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2339 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2340 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2341 : }
2342 : else
2343 : {
2344 790 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2345 : present, se->expr,
2346 790 : build_zero_cst (TREE_TYPE (se->expr)));
2347 790 : tmp = gfc_evaluate_now (tmp, &se->pre);
2348 790 : se->expr = tmp;
2349 : }
2350 :
2351 844 : if (ts.type == BT_CHARACTER)
2352 : {
2353 : /* Handle deferred-length dummies that pass the character length by
2354 : reference so that the value can be returned. */
2355 244 : if (ts.deferred && INDIRECT_REF_P (se->string_length))
2356 : {
2357 18 : tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
2358 18 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2359 : present, tmp, null_pointer_node);
2360 18 : tmp = gfc_evaluate_now (tmp, &se->pre);
2361 18 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2362 : }
2363 : else
2364 : {
2365 226 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2366 226 : tmp = fold_build3_loc (input_location, COND_EXPR,
2367 : gfc_charlen_type_node,
2368 : present, se->string_length, tmp);
2369 226 : tmp = gfc_evaluate_now (tmp, &se->pre);
2370 : }
2371 244 : se->string_length = tmp;
2372 : }
2373 844 : return;
2374 : }
2375 :
2376 :
2377 : /* Get the character length of an expression, looking through gfc_refs
2378 : if necessary. */
2379 :
2380 : tree
2381 20183 : gfc_get_expr_charlen (gfc_expr *e)
2382 : {
2383 20183 : gfc_ref *r;
2384 20183 : tree length;
2385 20183 : tree previous = NULL_TREE;
2386 20183 : gfc_se se;
2387 :
2388 20183 : gcc_assert (e->expr_type == EXPR_VARIABLE
2389 : && e->ts.type == BT_CHARACTER);
2390 :
2391 20183 : length = NULL; /* To silence compiler warning. */
2392 :
2393 20183 : if (is_subref_array (e) && e->ts.u.cl->length)
2394 : {
2395 767 : gfc_se tmpse;
2396 767 : gfc_init_se (&tmpse, NULL);
2397 767 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2398 767 : e->ts.u.cl->backend_decl = tmpse.expr;
2399 767 : return tmpse.expr;
2400 : }
2401 :
2402 : /* First candidate: if the variable is of type CHARACTER, the
2403 : expression's length could be the length of the character
2404 : variable. */
2405 19416 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2406 19116 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2407 :
2408 : /* Look through the reference chain for component references. */
2409 38975 : for (r = e->ref; r; r = r->next)
2410 : {
2411 19559 : previous = length;
2412 19559 : switch (r->type)
2413 : {
2414 300 : case REF_COMPONENT:
2415 300 : if (r->u.c.component->ts.type == BT_CHARACTER)
2416 300 : length = r->u.c.component->ts.u.cl->backend_decl;
2417 : break;
2418 :
2419 : case REF_ARRAY:
2420 : /* Do nothing. */
2421 : break;
2422 :
2423 20 : case REF_SUBSTRING:
2424 20 : gfc_init_se (&se, NULL);
2425 20 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2426 20 : length = se.expr;
2427 20 : if (r->u.ss.end)
2428 0 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2429 : else
2430 20 : se.expr = previous;
2431 20 : length = fold_build2_loc (input_location, MINUS_EXPR,
2432 : gfc_charlen_type_node,
2433 : se.expr, length);
2434 20 : length = fold_build2_loc (input_location, PLUS_EXPR,
2435 : gfc_charlen_type_node, length,
2436 : gfc_index_one_node);
2437 20 : break;
2438 :
2439 0 : default:
2440 0 : gcc_unreachable ();
2441 19559 : break;
2442 : }
2443 : }
2444 :
2445 19416 : gcc_assert (length != NULL);
2446 : return length;
2447 : }
2448 :
2449 :
2450 : /* Return for an expression the backend decl of the coarray. */
2451 :
2452 : tree
2453 2052 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2454 : {
2455 2052 : tree caf_decl;
2456 2052 : bool found = false;
2457 2052 : gfc_ref *ref;
2458 :
2459 2052 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2460 :
2461 : /* Not-implemented diagnostic. */
2462 2052 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2463 39 : && UNLIMITED_POLY (expr->symtree->n.sym)
2464 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2465 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2466 : "%L is not supported", &expr->where);
2467 :
2468 4335 : for (ref = expr->ref; ref; ref = ref->next)
2469 2283 : if (ref->type == REF_COMPONENT)
2470 : {
2471 195 : if (ref->u.c.component->ts.type == BT_CLASS
2472 0 : && UNLIMITED_POLY (ref->u.c.component)
2473 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2474 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2475 : "component at %L is not supported", &expr->where);
2476 : }
2477 :
2478 : /* Make sure the backend_decl is present before accessing it. */
2479 2052 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2480 2052 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2481 : : expr->symtree->n.sym->backend_decl;
2482 :
2483 2052 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2484 : {
2485 39 : if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2486 45 : && GFC_DECL_SAVED_DESCRIPTOR (caf_decl))
2487 6 : caf_decl = GFC_DECL_SAVED_DESCRIPTOR (caf_decl);
2488 :
2489 39 : if (expr->ref && expr->ref->type == REF_ARRAY)
2490 : {
2491 28 : caf_decl = gfc_class_data_get (caf_decl);
2492 28 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2493 : return caf_decl;
2494 : }
2495 11 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2496 2 : && GFC_DECL_TOKEN (caf_decl)
2497 13 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2498 : return caf_decl;
2499 :
2500 23 : for (ref = expr->ref; ref; ref = ref->next)
2501 : {
2502 18 : if (ref->type == REF_COMPONENT
2503 9 : && strcmp (ref->u.c.component->name, "_data") != 0)
2504 : {
2505 0 : caf_decl = gfc_class_data_get (caf_decl);
2506 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2507 : return caf_decl;
2508 : break;
2509 : }
2510 18 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2511 : break;
2512 : }
2513 : }
2514 2022 : if (expr->symtree->n.sym->attr.codimension)
2515 : return caf_decl;
2516 :
2517 : /* The following code assumes that the coarray is a component reachable via
2518 : only scalar components/variables; the Fortran standard guarantees this. */
2519 :
2520 46 : for (ref = expr->ref; ref; ref = ref->next)
2521 46 : if (ref->type == REF_COMPONENT)
2522 : {
2523 46 : gfc_component *comp = ref->u.c.component;
2524 :
2525 46 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2526 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2527 46 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2528 46 : TREE_TYPE (comp->backend_decl), caf_decl,
2529 : comp->backend_decl, NULL_TREE);
2530 46 : if (comp->ts.type == BT_CLASS)
2531 : {
2532 0 : caf_decl = gfc_class_data_get (caf_decl);
2533 0 : if (CLASS_DATA (comp)->attr.codimension)
2534 : {
2535 : found = true;
2536 : break;
2537 : }
2538 : }
2539 46 : if (comp->attr.codimension)
2540 : {
2541 : found = true;
2542 : break;
2543 : }
2544 : }
2545 46 : gcc_assert (found && caf_decl);
2546 : return caf_decl;
2547 : }
2548 :
2549 :
2550 : /* Obtain the Coarray token - and optionally also the offset. */
2551 :
2552 : void
2553 1923 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2554 : tree se_expr, gfc_expr *expr)
2555 : {
2556 1923 : tree tmp;
2557 :
2558 1923 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2559 :
2560 : /* Coarray token. */
2561 1923 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2562 548 : *token = gfc_conv_descriptor_token (caf_decl);
2563 1373 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2564 1574 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2565 6 : *token = GFC_DECL_TOKEN (caf_decl);
2566 : else
2567 : {
2568 1369 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2569 : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2570 1369 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2571 : }
2572 :
2573 1923 : if (offset == NULL)
2574 : return;
2575 :
2576 : /* Offset between the coarray base address and the address wanted. */
2577 179 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2578 179 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2579 0 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2580 0 : *offset = build_int_cst (gfc_array_index_type, 0);
2581 179 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2582 179 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2583 0 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2584 179 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2585 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2586 : else
2587 179 : *offset = build_int_cst (gfc_array_index_type, 0);
2588 :
2589 179 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2590 179 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2591 : {
2592 0 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2593 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2594 : }
2595 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2596 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2597 : else
2598 : {
2599 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2600 : tmp = se_expr;
2601 : }
2602 :
2603 179 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2604 : *offset, fold_convert (gfc_array_index_type, tmp));
2605 :
2606 179 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2607 0 : && expr->symtree->n.sym->attr.codimension
2608 0 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2609 : {
2610 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2611 0 : gfc_ref *ref = base_expr->ref;
2612 0 : gfc_se base_se;
2613 :
2614 : // Iterate through the refs until the last one.
2615 0 : while (ref->next)
2616 : ref = ref->next;
2617 :
2618 0 : if (ref->type == REF_ARRAY
2619 0 : && ref->u.ar.type != AR_FULL)
2620 : {
2621 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2622 0 : int i;
2623 0 : for (i = 0; i < ranksum; ++i)
2624 : {
2625 0 : ref->u.ar.start[i] = NULL;
2626 0 : ref->u.ar.end[i] = NULL;
2627 : }
2628 0 : ref->u.ar.type = AR_FULL;
2629 : }
2630 0 : gfc_init_se (&base_se, NULL);
2631 0 : if (gfc_caf_attr (base_expr).dimension)
2632 : {
2633 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2634 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2635 : }
2636 : else
2637 : {
2638 0 : gfc_conv_expr (&base_se, base_expr);
2639 0 : tmp = base_se.expr;
2640 : }
2641 :
2642 0 : gfc_free_expr (base_expr);
2643 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2644 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2645 0 : }
2646 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2647 0 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2648 179 : else if (INDIRECT_REF_P (caf_decl))
2649 0 : tmp = TREE_OPERAND (caf_decl, 0);
2650 : else
2651 : {
2652 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2653 : tmp = caf_decl;
2654 : }
2655 :
2656 179 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2657 : fold_convert (gfc_array_index_type, *offset),
2658 : fold_convert (gfc_array_index_type, tmp));
2659 : }
2660 :
2661 :
2662 : /* Convert the coindex of a coarray into an image index; the result is
2663 : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2664 : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2665 :
2666 : tree
2667 1634 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2668 : {
2669 1634 : gfc_ref *ref;
2670 1634 : tree lbound, ubound, extent, tmp, img_idx;
2671 1634 : gfc_se se;
2672 1634 : int i;
2673 :
2674 1665 : for (ref = e->ref; ref; ref = ref->next)
2675 1665 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2676 : break;
2677 1634 : gcc_assert (ref != NULL);
2678 :
2679 1634 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2680 95 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2681 95 : null_pointer_node);
2682 :
2683 1539 : img_idx = build_zero_cst (gfc_array_index_type);
2684 1539 : extent = build_one_cst (gfc_array_index_type);
2685 1539 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2686 630 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2687 : {
2688 321 : gfc_init_se (&se, NULL);
2689 321 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2690 321 : gfc_add_block_to_block (block, &se.pre);
2691 321 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2692 321 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2693 321 : TREE_TYPE (lbound), se.expr, lbound);
2694 321 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2695 : extent, tmp);
2696 321 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2697 321 : TREE_TYPE (tmp), img_idx, tmp);
2698 321 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2699 : {
2700 12 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2701 12 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2702 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
2703 12 : TREE_TYPE (tmp), extent, tmp);
2704 : }
2705 : }
2706 : else
2707 2476 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2708 : {
2709 1246 : gfc_init_se (&se, NULL);
2710 1246 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2711 1246 : gfc_add_block_to_block (block, &se.pre);
2712 1246 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2713 1246 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2714 1246 : TREE_TYPE (lbound), se.expr, lbound);
2715 1246 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2716 : extent, tmp);
2717 1246 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2718 : img_idx, tmp);
2719 1246 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2720 : {
2721 16 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2722 16 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2723 16 : TREE_TYPE (ubound), ubound, lbound);
2724 16 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2725 16 : tmp, build_one_cst (TREE_TYPE (tmp)));
2726 16 : extent = fold_build2_loc (input_location, MULT_EXPR,
2727 16 : TREE_TYPE (tmp), extent, tmp);
2728 : }
2729 : }
2730 1539 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2731 1539 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2732 1539 : return fold_convert (integer_type_node, img_idx);
2733 : }
2734 :
2735 :
2736 : /* For each character array constructor subexpression without a ts.u.cl->length,
2737 : replace it by its first element (if there aren't any elements, the length
2738 : should already be set to zero). */
2739 :
2740 : static void
2741 110 : flatten_array_ctors_without_strlen (gfc_expr* e)
2742 : {
2743 110 : gfc_actual_arglist* arg;
2744 110 : gfc_constructor* c;
2745 :
2746 110 : if (!e)
2747 : return;
2748 :
2749 110 : switch (e->expr_type)
2750 : {
2751 :
2752 0 : case EXPR_OP:
2753 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2754 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2755 0 : break;
2756 :
2757 0 : case EXPR_COMPCALL:
2758 : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2759 0 : gcc_unreachable ();
2760 :
2761 13 : case EXPR_FUNCTION:
2762 40 : for (arg = e->value.function.actual; arg; arg = arg->next)
2763 27 : flatten_array_ctors_without_strlen (arg->expr);
2764 : break;
2765 :
2766 0 : case EXPR_ARRAY:
2767 :
2768 : /* We've found what we're looking for. */
2769 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2770 : {
2771 0 : gfc_constructor *c;
2772 0 : gfc_expr* new_expr;
2773 :
2774 0 : gcc_assert (e->value.constructor);
2775 :
2776 0 : c = gfc_constructor_first (e->value.constructor);
2777 0 : new_expr = c->expr;
2778 0 : c->expr = NULL;
2779 :
2780 0 : flatten_array_ctors_without_strlen (new_expr);
2781 0 : gfc_replace_expr (e, new_expr);
2782 0 : break;
2783 : }
2784 :
2785 : /* Otherwise, fall through to handle constructor elements. */
2786 0 : gcc_fallthrough ();
2787 0 : case EXPR_STRUCTURE:
2788 0 : for (c = gfc_constructor_first (e->value.constructor);
2789 0 : c; c = gfc_constructor_next (c))
2790 0 : flatten_array_ctors_without_strlen (c->expr);
2791 : break;
2792 :
2793 : default:
2794 : break;
2795 :
2796 : }
2797 : }
2798 :
2799 :
2800 : /* Generate code to initialize a string length variable. Returns the
2801 : value. For array constructors, cl->length might be NULL and in this case,
2802 : the first element of the constructor is needed. expr is the original
2803 : expression so we can access it but can be NULL if this is not needed. */
2804 :
2805 : void
2806 3843 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2807 : {
2808 3843 : gfc_se se;
2809 :
2810 3843 : gfc_init_se (&se, NULL);
2811 :
2812 3843 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2813 1361 : return;
2814 :
2815 : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2816 : "flatten" array constructors by taking their first element; all elements
2817 : should be the same length or a cl->length should be present. */
2818 2575 : if (!cl->length)
2819 : {
2820 176 : gfc_expr* expr_flat;
2821 176 : if (!expr)
2822 : return;
2823 83 : expr_flat = gfc_copy_expr (expr);
2824 83 : flatten_array_ctors_without_strlen (expr_flat);
2825 83 : gfc_resolve_expr (expr_flat);
2826 83 : if (expr_flat->rank)
2827 13 : gfc_conv_expr_descriptor (&se, expr_flat);
2828 : else
2829 70 : gfc_conv_expr (&se, expr_flat);
2830 83 : if (expr_flat->expr_type != EXPR_VARIABLE)
2831 77 : gfc_add_block_to_block (pblock, &se.pre);
2832 83 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2833 83 : gfc_add_block_to_block (pblock, &se.post);
2834 83 : gfc_free_expr (expr_flat);
2835 : }
2836 : else
2837 : {
2838 : /* Convert cl->length. */
2839 2399 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2840 2399 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2841 : gfc_charlen_type_node, se.expr,
2842 2399 : build_zero_cst (TREE_TYPE (se.expr)));
2843 2399 : gfc_add_block_to_block (pblock, &se.pre);
2844 : }
2845 :
2846 2482 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2847 1564 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2848 : else
2849 918 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2850 : }
2851 :
2852 :
2853 : static void
2854 7300 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2855 : const char *name, locus *where)
2856 : {
2857 7300 : tree tmp;
2858 7300 : tree type;
2859 7300 : tree fault;
2860 7300 : gfc_se start;
2861 7300 : gfc_se end;
2862 7300 : char *msg;
2863 7300 : mpz_t length;
2864 :
2865 7300 : type = gfc_get_character_type (kind, ref->u.ss.length);
2866 7300 : type = build_pointer_type (type);
2867 :
2868 7300 : gfc_init_se (&start, se);
2869 7300 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2870 7300 : gfc_add_block_to_block (&se->pre, &start.pre);
2871 :
2872 7300 : if (integer_onep (start.expr))
2873 2768 : gfc_conv_string_parameter (se);
2874 : else
2875 : {
2876 4532 : tmp = start.expr;
2877 4532 : STRIP_NOPS (tmp);
2878 : /* Avoid multiple evaluation of substring start. */
2879 4532 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2880 1697 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2881 :
2882 : /* Change the start of the string. */
2883 4532 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2884 1194 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2885 3458 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2886 5606 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2887 1074 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2888 : tmp = se->expr;
2889 : else
2890 1066 : tmp = build_fold_indirect_ref_loc (input_location,
2891 : se->expr);
2892 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2893 4532 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2894 : {
2895 4404 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2896 4404 : se->expr = gfc_build_addr_expr (type, tmp);
2897 : }
2898 128 : else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2899 : {
2900 8 : tree diff;
2901 8 : diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr,
2902 : build_one_cst (gfc_charlen_type_node));
2903 8 : diff = fold_convert (size_type_node, diff);
2904 8 : se->expr
2905 8 : = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff);
2906 : }
2907 : }
2908 :
2909 : /* Length = end + 1 - start. */
2910 7300 : gfc_init_se (&end, se);
2911 7300 : if (ref->u.ss.end == NULL)
2912 202 : end.expr = se->string_length;
2913 : else
2914 : {
2915 7098 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2916 7098 : gfc_add_block_to_block (&se->pre, &end.pre);
2917 : }
2918 7300 : tmp = end.expr;
2919 7300 : STRIP_NOPS (tmp);
2920 7300 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2921 2301 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2922 :
2923 7300 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2924 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2925 7755 : && !gfc_contains_implied_index_p (ref->u.ss.end))
2926 : {
2927 455 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2928 : logical_type_node, start.expr,
2929 : end.expr);
2930 :
2931 : /* Check lower bound. */
2932 455 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2933 : start.expr,
2934 455 : build_one_cst (TREE_TYPE (start.expr)));
2935 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2936 : logical_type_node, nonempty, fault);
2937 455 : if (name)
2938 454 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2939 : "is less than one", name);
2940 : else
2941 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2942 : "is less than one");
2943 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2944 : fold_convert (long_integer_type_node,
2945 : start.expr));
2946 455 : free (msg);
2947 :
2948 : /* Check upper bound. */
2949 455 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2950 : end.expr, se->string_length);
2951 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2952 : logical_type_node, nonempty, fault);
2953 455 : if (name)
2954 454 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2955 : "exceeds string length (%%ld)", name);
2956 : else
2957 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2958 : "exceeds string length (%%ld)");
2959 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2960 : fold_convert (long_integer_type_node, end.expr),
2961 : fold_convert (long_integer_type_node,
2962 : se->string_length));
2963 455 : free (msg);
2964 : }
2965 :
2966 : /* Try to calculate the length from the start and end expressions. */
2967 7300 : if (ref->u.ss.end
2968 7300 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2969 : {
2970 6081 : HOST_WIDE_INT i_len;
2971 :
2972 6081 : i_len = gfc_mpz_get_hwi (length) + 1;
2973 6081 : if (i_len < 0)
2974 : i_len = 0;
2975 :
2976 6081 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2977 6081 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2978 : }
2979 : else
2980 : {
2981 1219 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2982 : fold_convert (gfc_charlen_type_node, end.expr),
2983 : fold_convert (gfc_charlen_type_node, start.expr));
2984 1219 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2985 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2986 1219 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2987 : tmp, build_int_cst (gfc_charlen_type_node, 0));
2988 : }
2989 :
2990 7300 : se->string_length = tmp;
2991 7300 : }
2992 :
2993 :
2994 : /* Convert a derived type component reference. */
2995 :
2996 : void
2997 177643 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2998 : {
2999 177643 : gfc_component *c;
3000 177643 : tree tmp;
3001 177643 : tree decl;
3002 177643 : tree field;
3003 177643 : tree context;
3004 :
3005 177643 : c = ref->u.c.component;
3006 :
3007 177643 : if (c->backend_decl == NULL_TREE
3008 6 : && ref->u.c.sym != NULL)
3009 6 : gfc_get_derived_type (ref->u.c.sym);
3010 :
3011 177643 : field = c->backend_decl;
3012 177643 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
3013 177643 : decl = se->expr;
3014 177643 : context = DECL_FIELD_CONTEXT (field);
3015 :
3016 : /* Components can correspond to fields of different containing
3017 : types, as components are created without context, whereas
3018 : a concrete use of a component has the type of decl as context.
3019 : So, if the type doesn't match, we search the corresponding
3020 : FIELD_DECL in the parent type. To not waste too much time
3021 : we cache this result in norestrict_decl.
3022 : On the other hand, if the context is a UNION or a MAP (a
3023 : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
3024 :
3025 177643 : if (context != TREE_TYPE (decl)
3026 177643 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
3027 12778 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
3028 : {
3029 12778 : tree f2 = c->norestrict_decl;
3030 21600 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
3031 7855 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
3032 7855 : if (TREE_CODE (f2) == FIELD_DECL
3033 7855 : && DECL_NAME (f2) == DECL_NAME (field))
3034 : break;
3035 12778 : gcc_assert (f2);
3036 12778 : c->norestrict_decl = f2;
3037 12778 : field = f2;
3038 : }
3039 :
3040 177643 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
3041 0 : && strcmp ("_data", c->name) == 0)
3042 : {
3043 : /* Found a ref to the _data component. Store the associated ref to
3044 : the vptr in se->class_vptr. */
3045 0 : se->class_vptr = gfc_class_vptr_get (decl);
3046 : }
3047 : else
3048 177643 : se->class_vptr = NULL_TREE;
3049 :
3050 177643 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
3051 : decl, field, NULL_TREE);
3052 :
3053 177643 : se->expr = tmp;
3054 :
3055 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
3056 : strlen () conditional below. */
3057 177643 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
3058 8802 : && !c->ts.deferred
3059 5644 : && !c->attr.pdt_string)
3060 : {
3061 5470 : tmp = c->ts.u.cl->backend_decl;
3062 : /* Components must always be constant length. */
3063 5470 : gcc_assert (tmp && INTEGER_CST_P (tmp));
3064 5470 : se->string_length = tmp;
3065 : }
3066 :
3067 177643 : if (gfc_deferred_strlen (c, &field))
3068 : {
3069 3332 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
3070 3332 : TREE_TYPE (field),
3071 : decl, field, NULL_TREE);
3072 3332 : se->string_length = tmp;
3073 : }
3074 :
3075 177643 : if (((c->attr.pointer || c->attr.allocatable)
3076 104058 : && (!c->attr.dimension && !c->attr.codimension)
3077 55870 : && c->ts.type != BT_CHARACTER)
3078 123996 : || c->attr.proc_pointer)
3079 59989 : se->expr = build_fold_indirect_ref_loc (input_location,
3080 : se->expr);
3081 177643 : }
3082 :
3083 :
3084 : /* This function deals with component references to components of the
3085 : parent type for derived type extensions. */
3086 : void
3087 64383 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
3088 : {
3089 64383 : gfc_component *c;
3090 64383 : gfc_component *cmp;
3091 64383 : gfc_symbol *dt;
3092 64383 : gfc_ref parent;
3093 :
3094 64383 : dt = ref->u.c.sym;
3095 64383 : c = ref->u.c.component;
3096 :
3097 : /* Return if the component is in this type, i.e. not in the parent type. */
3098 110838 : for (cmp = dt->components; cmp; cmp = cmp->next)
3099 100308 : if (c == cmp)
3100 53853 : return;
3101 :
3102 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3103 10530 : parent.type = REF_COMPONENT;
3104 10530 : parent.next = NULL;
3105 10530 : parent.u.c.sym = dt;
3106 10530 : parent.u.c.component = dt->components;
3107 :
3108 10530 : if (dt->backend_decl == NULL)
3109 0 : gfc_get_derived_type (dt);
3110 :
3111 : /* Build the reference and call self. */
3112 10530 : gfc_conv_component_ref (se, &parent);
3113 10530 : parent.u.c.sym = dt->components->ts.u.derived;
3114 10530 : parent.u.c.component = c;
3115 10530 : conv_parent_component_references (se, &parent);
3116 : }
3117 :
3118 :
3119 : static void
3120 549 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
3121 : {
3122 549 : tree res = se->expr;
3123 :
3124 549 : switch (ref->u.i)
3125 : {
3126 265 : case INQUIRY_RE:
3127 530 : res = fold_build1_loc (input_location, REALPART_EXPR,
3128 265 : TREE_TYPE (TREE_TYPE (res)), res);
3129 265 : break;
3130 :
3131 239 : case INQUIRY_IM:
3132 478 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
3133 239 : TREE_TYPE (TREE_TYPE (res)), res);
3134 239 : break;
3135 :
3136 7 : case INQUIRY_KIND:
3137 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
3138 7 : ts->kind);
3139 7 : se->string_length = NULL_TREE;
3140 7 : break;
3141 :
3142 38 : case INQUIRY_LEN:
3143 38 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
3144 : se->string_length);
3145 38 : se->string_length = NULL_TREE;
3146 38 : break;
3147 :
3148 0 : default:
3149 0 : gcc_unreachable ();
3150 : }
3151 549 : se->expr = res;
3152 549 : }
3153 :
3154 : /* Dereference VAR where needed if it is a pointer, reference, etc.
3155 : according to Fortran semantics. */
3156 :
3157 : tree
3158 1454692 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3159 : bool is_classarray)
3160 : {
3161 1454692 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3162 : return var;
3163 293647 : if (is_CFI_desc (sym, NULL))
3164 11892 : return build_fold_indirect_ref_loc (input_location, var);
3165 :
3166 : /* Characters are entirely different from other types, they are treated
3167 : separately. */
3168 281755 : if (sym->ts.type == BT_CHARACTER)
3169 : {
3170 : /* Dereference character pointer dummy arguments
3171 : or results. */
3172 32886 : if ((sym->attr.pointer || sym->attr.allocatable
3173 18996 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3174 14226 : && (sym->attr.dummy
3175 10910 : || sym->attr.function
3176 10536 : || sym->attr.result))
3177 4375 : var = build_fold_indirect_ref_loc (input_location, var);
3178 : }
3179 248869 : else if (!sym->attr.value)
3180 : {
3181 : /* Dereference temporaries for class array dummy arguments. */
3182 171978 : if (sym->attr.dummy && is_classarray
3183 255764 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3184 : {
3185 5343 : if (!descriptor_only_p)
3186 2722 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3187 :
3188 5343 : var = build_fold_indirect_ref_loc (input_location, var);
3189 : }
3190 :
3191 : /* Dereference non-character scalar dummy arguments. */
3192 248065 : if (sym->attr.dummy && !sym->attr.dimension
3193 104318 : && !(sym->attr.codimension && sym->attr.allocatable)
3194 104252 : && (sym->ts.type != BT_CLASS
3195 19595 : || (!CLASS_DATA (sym)->attr.dimension
3196 11426 : && !(CLASS_DATA (sym)->attr.codimension
3197 283 : && CLASS_DATA (sym)->attr.allocatable))))
3198 95942 : var = build_fold_indirect_ref_loc (input_location, var);
3199 :
3200 : /* Dereference scalar hidden result. */
3201 248065 : if (flag_f2c && sym->ts.type == BT_COMPLEX
3202 286 : && (sym->attr.function || sym->attr.result)
3203 108 : && !sym->attr.dimension && !sym->attr.pointer
3204 60 : && !sym->attr.always_explicit)
3205 36 : var = build_fold_indirect_ref_loc (input_location, var);
3206 :
3207 : /* Dereference non-character, non-class pointer variables.
3208 : These must be dummies, results, or scalars. */
3209 248065 : if (!is_classarray
3210 239920 : && (sym->attr.pointer || sym->attr.allocatable
3211 190591 : || gfc_is_associate_pointer (sym)
3212 185850 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3213 325079 : && (sym->attr.dummy
3214 36225 : || sym->attr.function
3215 35295 : || sym->attr.result
3216 34189 : || (!sym->attr.dimension
3217 34184 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3218 77009 : var = build_fold_indirect_ref_loc (input_location, var);
3219 : /* Now treat the class array pointer variables accordingly. */
3220 171056 : else if (sym->ts.type == BT_CLASS
3221 20041 : && sym->attr.dummy
3222 19595 : && (CLASS_DATA (sym)->attr.dimension
3223 11426 : || CLASS_DATA (sym)->attr.codimension)
3224 8452 : && ((CLASS_DATA (sym)->as
3225 8452 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3226 7401 : || CLASS_DATA (sym)->attr.allocatable
3227 6076 : || CLASS_DATA (sym)->attr.class_pointer))
3228 2967 : var = build_fold_indirect_ref_loc (input_location, var);
3229 : /* And the case where a non-dummy, non-result, non-function,
3230 : non-allocable and non-pointer classarray is present. This case was
3231 : previously covered by the first if, but with introducing the
3232 : condition !is_classarray there, that case has to be covered
3233 : explicitly. */
3234 168089 : else if (sym->ts.type == BT_CLASS
3235 17074 : && !sym->attr.dummy
3236 446 : && !sym->attr.function
3237 446 : && !sym->attr.result
3238 446 : && (CLASS_DATA (sym)->attr.dimension
3239 4 : || CLASS_DATA (sym)->attr.codimension)
3240 446 : && (sym->assoc
3241 0 : || !CLASS_DATA (sym)->attr.allocatable)
3242 446 : && !CLASS_DATA (sym)->attr.class_pointer)
3243 446 : var = build_fold_indirect_ref_loc (input_location, var);
3244 : }
3245 :
3246 : return var;
3247 : }
3248 :
3249 : /* Return the contents of a variable. Also handles reference/pointer
3250 : variables (all Fortran pointer references are implicit). */
3251 :
3252 : static void
3253 1607638 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3254 : {
3255 1607638 : gfc_ss *ss;
3256 1607638 : gfc_ref *ref;
3257 1607638 : gfc_symbol *sym;
3258 1607638 : tree parent_decl = NULL_TREE;
3259 1607638 : int parent_flag;
3260 1607638 : bool return_value;
3261 1607638 : bool alternate_entry;
3262 1607638 : bool entry_master;
3263 1607638 : bool is_classarray;
3264 1607638 : bool first_time = true;
3265 :
3266 1607638 : sym = expr->symtree->n.sym;
3267 1607638 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3268 1607638 : ss = se->ss;
3269 1607638 : if (ss != NULL)
3270 : {
3271 133343 : gfc_ss_info *ss_info = ss->info;
3272 :
3273 : /* Check that something hasn't gone horribly wrong. */
3274 133343 : gcc_assert (ss != gfc_ss_terminator);
3275 133343 : gcc_assert (ss_info->expr == expr);
3276 :
3277 : /* A scalarized term. We already know the descriptor. */
3278 133343 : se->expr = ss_info->data.array.descriptor;
3279 133343 : se->string_length = ss_info->string_length;
3280 133343 : ref = ss_info->data.array.ref;
3281 133343 : if (ref)
3282 132989 : gcc_assert (ref->type == REF_ARRAY
3283 : && ref->u.ar.type != AR_ELEMENT);
3284 : else
3285 354 : gfc_conv_tmp_array_ref (se);
3286 : }
3287 : else
3288 : {
3289 1474295 : tree se_expr = NULL_TREE;
3290 :
3291 1474295 : se->expr = gfc_get_symbol_decl (sym);
3292 :
3293 : /* Deal with references to a parent results or entries by storing
3294 : the current_function_decl and moving to the parent_decl. */
3295 1474295 : return_value = sym->attr.function && sym->result == sym;
3296 19287 : alternate_entry = sym->attr.function && sym->attr.entry
3297 1475434 : && sym->result == sym;
3298 2948590 : entry_master = sym->attr.result
3299 14555 : && sym->ns->proc_name->attr.entry_master
3300 1474676 : && !gfc_return_by_reference (sym->ns->proc_name);
3301 1474295 : if (current_function_decl)
3302 1456122 : parent_decl = DECL_CONTEXT (current_function_decl);
3303 :
3304 1474295 : if ((se->expr == parent_decl && return_value)
3305 1474184 : || (sym->ns && sym->ns->proc_name
3306 1469256 : && parent_decl
3307 1451083 : && sym->ns->proc_name->backend_decl == parent_decl
3308 38284 : && (alternate_entry || entry_master)))
3309 : parent_flag = 1;
3310 : else
3311 1474151 : parent_flag = 0;
3312 :
3313 : /* Special case for assigning the return value of a function.
3314 : Self recursive functions must have an explicit return value. */
3315 1474295 : if (return_value && (se->expr == current_function_decl || parent_flag))
3316 10408 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3317 :
3318 : /* Similarly for alternate entry points. */
3319 1463887 : else if (alternate_entry
3320 1106 : && (sym->ns->proc_name->backend_decl == current_function_decl
3321 0 : || parent_flag))
3322 : {
3323 1106 : gfc_entry_list *el = NULL;
3324 :
3325 1705 : for (el = sym->ns->entries; el; el = el->next)
3326 1705 : if (sym == el->sym)
3327 : {
3328 1106 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3329 1106 : break;
3330 : }
3331 : }
3332 :
3333 1462781 : else if (entry_master
3334 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3335 0 : || parent_flag))
3336 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3337 :
3338 11809 : if (se_expr)
3339 11809 : se->expr = se_expr;
3340 :
3341 : /* Procedure actual arguments. Look out for temporary variables
3342 : with the same attributes as function values. */
3343 1462486 : else if (!sym->attr.temporary
3344 1462418 : && sym->attr.flavor == FL_PROCEDURE
3345 21748 : && se->expr != current_function_decl)
3346 : {
3347 21681 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3348 : {
3349 19969 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3350 19969 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3351 : }
3352 21681 : return;
3353 : }
3354 :
3355 1452614 : if (sym->ts.type == BT_CLASS
3356 72588 : && sym->attr.class_ok
3357 72346 : && sym->ts.u.derived->attr.is_class)
3358 : {
3359 28075 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3360 79844 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3361 5485 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3362 : else
3363 66861 : se->class_container = se->expr;
3364 : }
3365 :
3366 : /* Dereference the expression, where needed. */
3367 1452614 : if (se->class_container && CLASS_DATA (sym)->attr.codimension
3368 2042 : && !CLASS_DATA (sym)->attr.dimension)
3369 877 : se->expr
3370 877 : = gfc_maybe_dereference_var (sym, se->class_container,
3371 877 : se->descriptor_only, is_classarray);
3372 : else
3373 1451737 : se->expr
3374 1451737 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3375 : is_classarray);
3376 :
3377 1452614 : ref = expr->ref;
3378 : }
3379 :
3380 : /* For character variables, also get the length. */
3381 1585957 : if (sym->ts.type == BT_CHARACTER)
3382 : {
3383 : /* If the character length of an entry isn't set, get the length from
3384 : the master function instead. */
3385 166501 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3386 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3387 : else
3388 166501 : se->string_length = sym->ts.u.cl->backend_decl;
3389 166501 : gcc_assert (se->string_length);
3390 :
3391 : /* For coarray strings return the pointer to the data and not the
3392 : descriptor. */
3393 5143 : if (sym->attr.codimension && sym->attr.associate_var
3394 6 : && !se->descriptor_only
3395 166507 : && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
3396 6 : se->expr = gfc_conv_descriptor_data_get (se->expr);
3397 : }
3398 :
3399 : /* F202Y: Runtime warning that an assumed rank object is associated
3400 : with an assumed size object. */
3401 1585957 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3402 90708 : && (gfc_option.allow_std & GFC_STD_F202Y)
3403 1586191 : && expr->rank == -1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3404 : {
3405 60 : tree dim, lower, upper, cond;
3406 60 : char *msg;
3407 :
3408 60 : dim = fold_convert (gfc_array_dim_rank_type,
3409 : gfc_conv_descriptor_rank (se->expr));
3410 60 : dim = fold_build2_loc (input_location, MINUS_EXPR,
3411 : gfc_array_dim_rank_type, dim, gfc_rank_cst[1]);
3412 60 : lower = gfc_conv_descriptor_lbound_get (se->expr, dim);
3413 60 : upper = gfc_conv_descriptor_ubound_get (se->expr, dim);
3414 :
3415 60 : msg = xasprintf ("Assumed rank object %s is associated with an "
3416 : "assumed size object", sym->name);
3417 60 : cond = fold_build2_loc (input_location, LT_EXPR,
3418 : logical_type_node, upper, lower);
3419 60 : gfc_trans_runtime_check (false, true, cond, &se->pre,
3420 : &gfc_current_locus, msg);
3421 60 : free (msg);
3422 : }
3423 :
3424 : /* Some expressions leak through that haven't been fixed up. */
3425 1585957 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3426 418 : gfc_fixup_inferred_type_refs (expr);
3427 :
3428 1585957 : gfc_typespec *ts = &sym->ts;
3429 2022096 : while (ref)
3430 : {
3431 786869 : switch (ref->type)
3432 : {
3433 612363 : case REF_ARRAY:
3434 : /* Return the descriptor if that's what we want and this is an array
3435 : section reference. */
3436 612363 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3437 : return;
3438 : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3439 : /* Return the descriptor for array pointers and allocations. */
3440 271018 : if (se->want_pointer
3441 24082 : && ref->next == NULL && (se->descriptor_only))
3442 : return;
3443 :
3444 261633 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3445 : /* Return a pointer to an element. */
3446 261633 : break;
3447 :
3448 166915 : case REF_COMPONENT:
3449 166915 : ts = &ref->u.c.component->ts;
3450 166915 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3451 5835 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3452 3142 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3453 3142 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3454 2621 : && strcmp ("_data", ref->u.c.component->name) == 0)
3455 : /* Skip the first ref of a _data component, because for class
3456 : arrays that one is already done by introducing a temporary
3457 : array descriptor. */
3458 : break;
3459 :
3460 164294 : if (ref->u.c.sym->attr.extension)
3461 53762 : conv_parent_component_references (se, ref);
3462 :
3463 164294 : gfc_conv_component_ref (se, ref);
3464 :
3465 164294 : if (ref->u.c.component->ts.type == BT_CLASS
3466 12023 : && ref->u.c.component->attr.class_ok
3467 12023 : && ref->u.c.component->ts.u.derived->attr.is_class)
3468 12023 : se->class_container = se->expr;
3469 152271 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3470 149777 : && ref->u.c.sym->attr.is_class))
3471 84140 : se->class_container = NULL_TREE;
3472 :
3473 164294 : if (!ref->next && ref->u.c.sym->attr.codimension
3474 0 : && se->want_pointer && se->descriptor_only)
3475 : return;
3476 :
3477 : break;
3478 :
3479 7042 : case REF_SUBSTRING:
3480 7042 : gfc_conv_substring (se, ref, expr->ts.kind,
3481 7042 : expr->symtree->name, &expr->where);
3482 7042 : break;
3483 :
3484 549 : case REF_INQUIRY:
3485 549 : conv_inquiry (se, ref, expr, ts);
3486 549 : break;
3487 :
3488 0 : default:
3489 0 : gcc_unreachable ();
3490 436139 : break;
3491 : }
3492 436139 : first_time = false;
3493 436139 : ref = ref->next;
3494 : }
3495 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3496 : separately. */
3497 1235227 : if (se->want_pointer)
3498 : {
3499 133402 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3500 8044 : gfc_conv_string_parameter (se);
3501 : else
3502 125358 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3503 : }
3504 : }
3505 :
3506 :
3507 : /* Unary ops are easy... Or they would be if ! was a valid op. */
3508 :
3509 : static void
3510 28853 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3511 : {
3512 28853 : gfc_se operand;
3513 28853 : tree type;
3514 :
3515 28853 : gcc_assert (expr->ts.type != BT_CHARACTER);
3516 : /* Initialize the operand. */
3517 28853 : gfc_init_se (&operand, se);
3518 28853 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3519 28853 : gfc_add_block_to_block (&se->pre, &operand.pre);
3520 :
3521 28853 : type = gfc_typenode_for_spec (&expr->ts);
3522 :
3523 : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3524 : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3525 : All other unary operators have an equivalent GIMPLE unary operator. */
3526 28853 : if (code == TRUTH_NOT_EXPR)
3527 20250 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3528 : build_int_cst (type, 0));
3529 : else
3530 8603 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3531 :
3532 28853 : }
3533 :
3534 : /* Expand power operator to optimal multiplications when a value is raised
3535 : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3536 : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3537 : Programming", 3rd Edition, 1998. */
3538 :
3539 : /* This code is mostly duplicated from expand_powi in the backend.
3540 : We establish the "optimal power tree" lookup table with the defined size.
3541 : The items in the table are the exponents used to calculate the index
3542 : exponents. Any integer n less than the value can get an "addition chain",
3543 : with the first node being one. */
3544 : #define POWI_TABLE_SIZE 256
3545 :
3546 : /* The table is from builtins.cc. */
3547 : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3548 : {
3549 : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3550 : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3551 : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3552 : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3553 : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3554 : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3555 : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3556 : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3557 : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3558 : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3559 : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3560 : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3561 : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3562 : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3563 : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3564 : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3565 : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3566 : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3567 : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3568 : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3569 : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3570 : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3571 : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3572 : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3573 : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3574 : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3575 : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3576 : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3577 : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3578 : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3579 : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3580 : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3581 : };
3582 :
3583 : /* If n is larger than lookup table's max index, we use the "window
3584 : method". */
3585 : #define POWI_WINDOW_SIZE 3
3586 :
3587 : /* Recursive function to expand the power operator. The temporary
3588 : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3589 : static tree
3590 178323 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3591 : {
3592 178323 : tree op0;
3593 178323 : tree op1;
3594 178323 : tree tmp;
3595 178323 : int digit;
3596 :
3597 178323 : if (n < POWI_TABLE_SIZE)
3598 : {
3599 137336 : if (tmpvar[n])
3600 : return tmpvar[n];
3601 :
3602 56612 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3603 56612 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3604 : }
3605 40987 : else if (n & 1)
3606 : {
3607 10015 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3608 10015 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3609 10015 : op1 = gfc_conv_powi (se, digit, tmpvar);
3610 : }
3611 : else
3612 : {
3613 30972 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3614 30972 : op1 = op0;
3615 : }
3616 :
3617 97599 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3618 97599 : tmp = gfc_evaluate_now (tmp, &se->pre);
3619 :
3620 97599 : if (n < POWI_TABLE_SIZE)
3621 56612 : tmpvar[n] = tmp;
3622 :
3623 : return tmp;
3624 : }
3625 :
3626 :
3627 : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3628 : return 1. Else return 0 and a call to runtime library functions
3629 : will have to be built. */
3630 : static int
3631 3305 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3632 : {
3633 3305 : tree cond;
3634 3305 : tree tmp;
3635 3305 : tree type;
3636 3305 : tree vartmp[POWI_TABLE_SIZE];
3637 3305 : HOST_WIDE_INT m;
3638 3305 : unsigned HOST_WIDE_INT n;
3639 3305 : int sgn;
3640 3305 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3641 :
3642 : /* If exponent is too large, we won't expand it anyway, so don't bother
3643 : with large integer values. */
3644 3305 : if (!wi::fits_shwi_p (wrhs))
3645 : return 0;
3646 :
3647 2945 : m = wrhs.to_shwi ();
3648 : /* Use the wide_int's routine to reliably get the absolute value on all
3649 : platforms. Then convert it to a HOST_WIDE_INT like above. */
3650 2945 : n = wi::abs (wrhs).to_shwi ();
3651 :
3652 2945 : type = TREE_TYPE (lhs);
3653 2945 : sgn = tree_int_cst_sgn (rhs);
3654 :
3655 2945 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3656 5890 : || optimize_size) && (m > 2 || m < -1))
3657 : return 0;
3658 :
3659 : /* rhs == 0 */
3660 1639 : if (sgn == 0)
3661 : {
3662 282 : se->expr = gfc_build_const (type, integer_one_node);
3663 282 : return 1;
3664 : }
3665 :
3666 : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3667 1357 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3668 : {
3669 220 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3670 220 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3671 220 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3672 220 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3673 :
3674 : /* If rhs is even,
3675 : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3676 220 : if ((n & 1) == 0)
3677 : {
3678 104 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3679 : logical_type_node, tmp, cond);
3680 104 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3681 : tmp, build_int_cst (type, 1),
3682 : build_int_cst (type, 0));
3683 104 : return 1;
3684 : }
3685 : /* If rhs is odd,
3686 : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3687 116 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3688 : build_int_cst (type, -1),
3689 : build_int_cst (type, 0));
3690 116 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3691 : cond, build_int_cst (type, 1), tmp);
3692 116 : return 1;
3693 : }
3694 :
3695 1137 : memset (vartmp, 0, sizeof (vartmp));
3696 1137 : vartmp[1] = lhs;
3697 1137 : if (sgn == -1)
3698 : {
3699 141 : tmp = gfc_build_const (type, integer_one_node);
3700 141 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3701 : vartmp[1]);
3702 : }
3703 :
3704 1137 : se->expr = gfc_conv_powi (se, n, vartmp);
3705 :
3706 1137 : return 1;
3707 : }
3708 :
3709 : /* Convert lhs**rhs, for constant rhs, when both are unsigned.
3710 : Method:
3711 : if (rhs == 0) ! Checked here.
3712 : return 1;
3713 : if (lhs & 1 == 1) ! odd_cnd
3714 : {
3715 : if (bit_size(rhs) < bit_size(lhs)) ! Checked here.
3716 : return lhs ** rhs;
3717 :
3718 : mask = 1 << (bit_size(a) - 1) / 2;
3719 : return lhs ** (n & rhs);
3720 : }
3721 : if (rhs > bit_size(lhs)) ! Checked here.
3722 : return 0;
3723 :
3724 : return lhs ** rhs;
3725 : */
3726 :
3727 : static int
3728 15120 : gfc_conv_cst_uint_power (gfc_se * se, tree lhs, tree rhs)
3729 : {
3730 15120 : tree type = TREE_TYPE (lhs);
3731 15120 : tree tmp, is_odd, odd_branch, even_branch;
3732 15120 : unsigned HOST_WIDE_INT lhs_prec, rhs_prec;
3733 15120 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3734 15120 : unsigned HOST_WIDE_INT n, n_odd;
3735 15120 : tree vartmp_odd[POWI_TABLE_SIZE], vartmp_even[POWI_TABLE_SIZE];
3736 :
3737 : /* Anything ** 0 is one. */
3738 15120 : if (integer_zerop (rhs))
3739 : {
3740 1800 : se->expr = build_int_cst (type, 1);
3741 1800 : return 1;
3742 : }
3743 :
3744 13320 : if (!wi::fits_uhwi_p (wrhs))
3745 : return 0;
3746 :
3747 12960 : n = wrhs.to_uhwi ();
3748 :
3749 : /* tmp = a & 1; . */
3750 12960 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3751 : lhs, build_int_cst (type, 1));
3752 12960 : is_odd = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3753 : tmp, build_int_cst (type, 1));
3754 :
3755 12960 : lhs_prec = TYPE_PRECISION (type);
3756 12960 : rhs_prec = TYPE_PRECISION (TREE_TYPE (rhs));
3757 :
3758 12960 : if (rhs_prec >= lhs_prec && lhs_prec <= HOST_BITS_PER_WIDE_INT)
3759 : {
3760 7044 : unsigned HOST_WIDE_INT mask = (HOST_WIDE_INT_1U << (lhs_prec - 1)) - 1;
3761 7044 : n_odd = n & mask;
3762 : }
3763 : else
3764 : n_odd = n;
3765 :
3766 12960 : memset (vartmp_odd, 0, sizeof (vartmp_odd));
3767 12960 : vartmp_odd[0] = build_int_cst (type, 1);
3768 12960 : vartmp_odd[1] = lhs;
3769 12960 : odd_branch = gfc_conv_powi (se, n_odd, vartmp_odd);
3770 12960 : even_branch = NULL_TREE;
3771 :
3772 12960 : if (n > lhs_prec)
3773 4260 : even_branch = build_int_cst (type, 0);
3774 : else
3775 : {
3776 8700 : if (n_odd != n)
3777 : {
3778 0 : memset (vartmp_even, 0, sizeof (vartmp_even));
3779 0 : vartmp_even[0] = build_int_cst (type, 1);
3780 0 : vartmp_even[1] = lhs;
3781 0 : even_branch = gfc_conv_powi (se, n, vartmp_even);
3782 : }
3783 : }
3784 4260 : if (even_branch != NULL_TREE)
3785 4260 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, is_odd,
3786 : odd_branch, even_branch);
3787 : else
3788 8700 : se->expr = odd_branch;
3789 :
3790 : return 1;
3791 : }
3792 :
3793 : /* Power op (**). Constant integer exponent and powers of 2 have special
3794 : handling. */
3795 :
3796 : static void
3797 49177 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3798 : {
3799 49177 : tree gfc_int4_type_node;
3800 49177 : int kind;
3801 49177 : int ikind;
3802 49177 : int res_ikind_1, res_ikind_2;
3803 49177 : gfc_se lse;
3804 49177 : gfc_se rse;
3805 49177 : tree fndecl = NULL;
3806 :
3807 49177 : gfc_init_se (&lse, se);
3808 49177 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3809 49177 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3810 49177 : gfc_add_block_to_block (&se->pre, &lse.pre);
3811 :
3812 49177 : gfc_init_se (&rse, se);
3813 49177 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3814 49177 : gfc_add_block_to_block (&se->pre, &rse.pre);
3815 :
3816 49177 : if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
3817 : {
3818 17563 : if (expr->value.op.op2->ts.type == BT_INTEGER)
3819 : {
3820 2292 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3821 20477 : return;
3822 : }
3823 15271 : else if (expr->value.op.op2->ts.type == BT_UNSIGNED)
3824 : {
3825 15120 : if (gfc_conv_cst_uint_power (se, lse.expr, rse.expr))
3826 : return;
3827 : }
3828 : }
3829 :
3830 32778 : if ((expr->value.op.op2->ts.type == BT_INTEGER
3831 31468 : || expr->value.op.op2->ts.type == BT_UNSIGNED)
3832 31910 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3833 1013 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3834 : return;
3835 :
3836 32778 : if (INTEGER_CST_P (lse.expr)
3837 15371 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE
3838 48149 : && expr->value.op.op2->ts.type == BT_INTEGER)
3839 : {
3840 251 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3841 251 : HOST_WIDE_INT v;
3842 251 : unsigned HOST_WIDE_INT w;
3843 251 : int kind, ikind, bit_size;
3844 :
3845 251 : v = wlhs.to_shwi ();
3846 251 : w = absu_hwi (v);
3847 :
3848 251 : kind = expr->value.op.op1->ts.kind;
3849 251 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3850 251 : bit_size = gfc_integer_kinds[ikind].bit_size;
3851 :
3852 251 : if (v == 1)
3853 : {
3854 : /* 1**something is always 1. */
3855 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3856 239 : return;
3857 : }
3858 216 : else if (v == -1)
3859 : {
3860 : /* (-1)**n is 1 - ((n & 1) << 1) */
3861 34 : tree type;
3862 34 : tree tmp;
3863 :
3864 34 : type = TREE_TYPE (lse.expr);
3865 34 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3866 : rse.expr, build_int_cst (type, 1));
3867 34 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3868 : tmp, build_int_cst (type, 1));
3869 34 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3870 : build_int_cst (type, 1), tmp);
3871 34 : se->expr = tmp;
3872 34 : return;
3873 : }
3874 182 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3875 : {
3876 : /* Here v is +/- 2**e. The further simplification uses
3877 : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3878 : 1<<(4*n), etc., but we have to make sure to return zero
3879 : if the number of bits is too large. */
3880 170 : tree lshift;
3881 170 : tree type;
3882 170 : tree shift;
3883 170 : tree ge;
3884 170 : tree cond;
3885 170 : tree num_bits;
3886 170 : tree cond2;
3887 170 : tree tmp1;
3888 :
3889 170 : type = TREE_TYPE (lse.expr);
3890 :
3891 170 : if (w == 2)
3892 110 : shift = rse.expr;
3893 60 : else if (w == 4)
3894 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3895 12 : TREE_TYPE (rse.expr),
3896 : rse.expr, rse.expr);
3897 : else
3898 : {
3899 : /* use popcount for fast log2(w) */
3900 48 : int e = wi::popcount (w-1);
3901 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3902 48 : TREE_TYPE (rse.expr),
3903 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3904 : rse.expr);
3905 : }
3906 :
3907 170 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3908 : build_int_cst (type, 1), shift);
3909 170 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3910 : rse.expr, build_int_cst (type, 0));
3911 170 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3912 : build_int_cst (type, 0));
3913 170 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3914 170 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3915 : rse.expr, num_bits);
3916 170 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3917 : build_int_cst (type, 0), cond);
3918 170 : if (v > 0)
3919 : {
3920 128 : se->expr = tmp1;
3921 : }
3922 : else
3923 : {
3924 : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3925 42 : tree tmp2;
3926 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3927 : rse.expr, build_int_cst (type, 1));
3928 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3929 : tmp2, build_int_cst (type, 1));
3930 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3931 : build_int_cst (type, 1), tmp2);
3932 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3933 : tmp1, tmp2);
3934 : }
3935 170 : return;
3936 : }
3937 : }
3938 : /* Handle unsigned separate from signed above, things would be too
3939 : complicated otherwise. */
3940 :
3941 32539 : if (INTEGER_CST_P (lse.expr) && expr->value.op.op1->ts.type == BT_UNSIGNED)
3942 : {
3943 15120 : gfc_expr * op1 = expr->value.op.op1;
3944 15120 : tree type;
3945 :
3946 15120 : type = TREE_TYPE (lse.expr);
3947 :
3948 15120 : if (mpz_cmp_ui (op1->value.integer, 1) == 0)
3949 : {
3950 : /* 1**something is always 1. */
3951 1260 : se->expr = build_int_cst (type, 1);
3952 1260 : return;
3953 : }
3954 :
3955 : /* Simplify 2u**x to a shift, with the value set to zero if it falls
3956 : outside the range. */
3957 26460 : if (mpz_popcount (op1->value.integer) == 1)
3958 : {
3959 2520 : tree prec_m1, lim, shift, lshift, cond, tmp;
3960 2520 : tree rtype = TREE_TYPE (rse.expr);
3961 2520 : int e = mpz_scan1 (op1->value.integer, 0);
3962 :
3963 2520 : shift = fold_build2_loc (input_location, MULT_EXPR,
3964 2520 : rtype, build_int_cst (rtype, e),
3965 : rse.expr);
3966 2520 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3967 : build_int_cst (type, 1), shift);
3968 5040 : prec_m1 = fold_build2_loc (input_location, MINUS_EXPR, rtype,
3969 2520 : build_int_cst (rtype, TYPE_PRECISION (type)),
3970 : build_int_cst (rtype, 1));
3971 2520 : lim = fold_build2_loc (input_location, TRUNC_DIV_EXPR, rtype,
3972 2520 : prec_m1, build_int_cst (rtype, e));
3973 2520 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3974 : rse.expr, lim);
3975 2520 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond,
3976 : build_int_cst (type, 0), lshift);
3977 2520 : se->expr = tmp;
3978 2520 : return;
3979 : }
3980 : }
3981 :
3982 28759 : gfc_int4_type_node = gfc_get_int_type (4);
3983 :
3984 : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3985 : library routine. But in the end, we have to convert the result back
3986 : if this case applies -- with res_ikind_K, we keep track whether operand K
3987 : falls into this case. */
3988 28759 : res_ikind_1 = -1;
3989 28759 : res_ikind_2 = -1;
3990 :
3991 28759 : kind = expr->value.op.op1->ts.kind;
3992 28759 : switch (expr->value.op.op2->ts.type)
3993 : {
3994 1071 : case BT_INTEGER:
3995 1071 : ikind = expr->value.op.op2->ts.kind;
3996 1071 : switch (ikind)
3997 : {
3998 168 : case 1:
3999 168 : case 2:
4000 168 : rse.expr = convert (gfc_int4_type_node, rse.expr);
4001 168 : res_ikind_2 = ikind;
4002 : /* Fall through. */
4003 :
4004 : case 4:
4005 : ikind = 0;
4006 : break;
4007 :
4008 : case 8:
4009 : ikind = 1;
4010 : break;
4011 :
4012 6 : case 16:
4013 6 : ikind = 2;
4014 6 : break;
4015 :
4016 0 : default:
4017 0 : gcc_unreachable ();
4018 : }
4019 1071 : switch (kind)
4020 : {
4021 0 : case 1:
4022 0 : case 2:
4023 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
4024 : {
4025 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
4026 0 : res_ikind_1 = kind;
4027 : }
4028 : else
4029 0 : gcc_unreachable ();
4030 : /* Fall through. */
4031 :
4032 : case 4:
4033 : kind = 0;
4034 : break;
4035 :
4036 : case 8:
4037 : kind = 1;
4038 : break;
4039 :
4040 6 : case 10:
4041 6 : kind = 2;
4042 6 : break;
4043 :
4044 18 : case 16:
4045 18 : kind = 3;
4046 18 : break;
4047 :
4048 0 : default:
4049 0 : gcc_unreachable ();
4050 : }
4051 :
4052 1071 : switch (expr->value.op.op1->ts.type)
4053 : {
4054 129 : case BT_INTEGER:
4055 129 : if (kind == 3) /* Case 16 was not handled properly above. */
4056 : kind = 2;
4057 129 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
4058 129 : break;
4059 :
4060 710 : case BT_REAL:
4061 : /* Use builtins for real ** int4. */
4062 :
4063 710 : if (real_minus_onep (lse.expr))
4064 : {
4065 : /* (-1.0)**n is (real) (1 - ((n & 1) << 1)), see the integer case
4066 : above. */
4067 :
4068 59 : tree lhs_type, rhs_type;
4069 59 : tree tmp;
4070 59 : lhs_type = TREE_TYPE (lse.expr);
4071 59 : rhs_type = TREE_TYPE (rse.expr);
4072 59 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, rhs_type,
4073 : rse.expr, build_int_cst (rhs_type, 1));
4074 59 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, rhs_type,
4075 : tmp, build_int_cst (rhs_type, 1));
4076 59 : tmp = fold_build2_loc (input_location, MINUS_EXPR, rhs_type,
4077 : build_int_cst (rhs_type, 1), tmp);
4078 59 : se->expr = fold_convert (lhs_type, tmp);
4079 59 : return;
4080 : }
4081 :
4082 651 : if (ikind == 0)
4083 : {
4084 555 : switch (kind)
4085 : {
4086 391 : case 0:
4087 391 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
4088 391 : break;
4089 :
4090 146 : case 1:
4091 146 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
4092 146 : break;
4093 :
4094 6 : case 2:
4095 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4096 6 : break;
4097 :
4098 12 : case 3:
4099 : /* Use the __builtin_powil() only if real(kind=16) is
4100 : actually the C long double type. */
4101 12 : if (!gfc_real16_is_float128)
4102 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4103 : break;
4104 :
4105 : default:
4106 : gcc_unreachable ();
4107 : }
4108 : }
4109 :
4110 : /* If we don't have a good builtin for this, go for the
4111 : library function. */
4112 543 : if (!fndecl)
4113 108 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
4114 : break;
4115 :
4116 232 : case BT_COMPLEX:
4117 232 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
4118 232 : break;
4119 :
4120 0 : default:
4121 0 : gcc_unreachable ();
4122 : }
4123 : break;
4124 :
4125 139 : case BT_REAL:
4126 139 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
4127 139 : break;
4128 :
4129 729 : case BT_COMPLEX:
4130 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
4131 729 : break;
4132 :
4133 26820 : case BT_UNSIGNED:
4134 26820 : {
4135 : /* Valid kinds for unsigned are 1, 2, 4, 8, 16. Instead of using a
4136 : large switch statement, let's just use __builtin_ctz. */
4137 26820 : int base = __builtin_ctz (expr->value.op.op1->ts.kind);
4138 26820 : int expon = __builtin_ctz (expr->value.op.op2->ts.kind);
4139 26820 : fndecl = gfor_fndecl_unsigned_pow_list[base][expon];
4140 : }
4141 26820 : break;
4142 :
4143 0 : default:
4144 0 : gcc_unreachable ();
4145 28700 : break;
4146 : }
4147 :
4148 28700 : se->expr = build_call_expr_loc (input_location,
4149 : fndecl, 2, lse.expr, rse.expr);
4150 :
4151 : /* Convert the result back if it is of wrong integer kind. */
4152 28700 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
4153 : {
4154 : /* We want the maximum of both operand kinds as result. */
4155 0 : if (res_ikind_1 < res_ikind_2)
4156 0 : res_ikind_1 = res_ikind_2;
4157 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
4158 : }
4159 : }
4160 :
4161 :
4162 : /* Generate code to allocate a string temporary. */
4163 :
4164 : tree
4165 4880 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4166 : {
4167 4880 : tree var;
4168 4880 : tree tmp;
4169 :
4170 4880 : if (gfc_can_put_var_on_stack (len))
4171 : {
4172 : /* Create a temporary variable to hold the result. */
4173 4586 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4174 2293 : TREE_TYPE (len), len,
4175 2293 : build_int_cst (TREE_TYPE (len), 1));
4176 2293 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4177 :
4178 2293 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4179 2293 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4180 : else
4181 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
4182 :
4183 2293 : var = gfc_create_var (tmp, "str");
4184 2293 : var = gfc_build_addr_expr (type, var);
4185 : }
4186 : else
4187 : {
4188 : /* Allocate a temporary to hold the result. */
4189 2587 : var = gfc_create_var (type, "pstr");
4190 2587 : gcc_assert (POINTER_TYPE_P (type));
4191 2587 : tmp = TREE_TYPE (type);
4192 2587 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4193 2587 : tmp = TREE_TYPE (tmp);
4194 2587 : tmp = TYPE_SIZE_UNIT (tmp);
4195 2587 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4196 : fold_convert (size_type_node, len),
4197 : fold_convert (size_type_node, tmp));
4198 2587 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4199 2587 : gfc_add_modify (&se->pre, var, tmp);
4200 :
4201 : /* Free the temporary afterwards. */
4202 2587 : tmp = gfc_call_free (var);
4203 2587 : gfc_add_expr_to_block (&se->post, tmp);
4204 : }
4205 :
4206 4880 : return var;
4207 : }
4208 :
4209 :
4210 : /* Handle a string concatenation operation. A temporary will be allocated to
4211 : hold the result. */
4212 :
4213 : static void
4214 1294 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4215 : {
4216 1294 : gfc_se lse, rse;
4217 1294 : tree len, type, var, tmp, fndecl;
4218 :
4219 1294 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4220 : && expr->value.op.op2->ts.type == BT_CHARACTER);
4221 1294 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4222 :
4223 1294 : gfc_init_se (&lse, se);
4224 1294 : gfc_conv_expr (&lse, expr->value.op.op1);
4225 1294 : gfc_conv_string_parameter (&lse);
4226 1294 : gfc_init_se (&rse, se);
4227 1294 : gfc_conv_expr (&rse, expr->value.op.op2);
4228 1294 : gfc_conv_string_parameter (&rse);
4229 :
4230 1294 : gfc_add_block_to_block (&se->pre, &lse.pre);
4231 1294 : gfc_add_block_to_block (&se->pre, &rse.pre);
4232 :
4233 1294 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4234 1294 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4235 1294 : if (len == NULL_TREE)
4236 : {
4237 1075 : len = fold_build2_loc (input_location, PLUS_EXPR,
4238 : gfc_charlen_type_node,
4239 : fold_convert (gfc_charlen_type_node,
4240 : lse.string_length),
4241 : fold_convert (gfc_charlen_type_node,
4242 : rse.string_length));
4243 : }
4244 :
4245 1294 : type = build_pointer_type (type);
4246 :
4247 1294 : var = gfc_conv_string_tmp (se, type, len);
4248 :
4249 : /* Do the actual concatenation. */
4250 1294 : if (expr->ts.kind == 1)
4251 1203 : fndecl = gfor_fndecl_concat_string;
4252 91 : else if (expr->ts.kind == 4)
4253 91 : fndecl = gfor_fndecl_concat_string_char4;
4254 : else
4255 0 : gcc_unreachable ();
4256 :
4257 1294 : tmp = build_call_expr_loc (input_location,
4258 : fndecl, 6, len, var, lse.string_length, lse.expr,
4259 : rse.string_length, rse.expr);
4260 1294 : gfc_add_expr_to_block (&se->pre, tmp);
4261 :
4262 : /* Add the cleanup for the operands. */
4263 1294 : gfc_add_block_to_block (&se->pre, &rse.post);
4264 1294 : gfc_add_block_to_block (&se->pre, &lse.post);
4265 :
4266 1294 : se->expr = var;
4267 1294 : se->string_length = len;
4268 1294 : }
4269 :
4270 : /* Translates an op expression. Common (binary) cases are handled by this
4271 : function, others are passed on. Recursion is used in either case.
4272 : We use the fact that (op1.ts == op2.ts) (except for the power
4273 : operator **).
4274 : Operators need no special handling for scalarized expressions as long as
4275 : they call gfc_conv_simple_val to get their operands.
4276 : Character strings get special handling. */
4277 :
4278 : static void
4279 506740 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4280 : {
4281 506740 : enum tree_code code;
4282 506740 : gfc_se lse;
4283 506740 : gfc_se rse;
4284 506740 : tree tmp, type;
4285 506740 : int lop;
4286 506740 : int checkstring;
4287 :
4288 506740 : checkstring = 0;
4289 506740 : lop = 0;
4290 506740 : switch (expr->value.op.op)
4291 : {
4292 15088 : case INTRINSIC_PARENTHESES:
4293 15088 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4294 3801 : && flag_protect_parens)
4295 : {
4296 3668 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
4297 3668 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
4298 90750 : return;
4299 : }
4300 :
4301 : /* Fallthrough. */
4302 11426 : case INTRINSIC_UPLUS:
4303 11426 : gfc_conv_expr (se, expr->value.op.op1);
4304 11426 : return;
4305 :
4306 4935 : case INTRINSIC_UMINUS:
4307 4935 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4308 4935 : return;
4309 :
4310 20250 : case INTRINSIC_NOT:
4311 20250 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4312 20250 : return;
4313 :
4314 : case INTRINSIC_PLUS:
4315 : code = PLUS_EXPR;
4316 : break;
4317 :
4318 29309 : case INTRINSIC_MINUS:
4319 29309 : code = MINUS_EXPR;
4320 29309 : break;
4321 :
4322 32934 : case INTRINSIC_TIMES:
4323 32934 : code = MULT_EXPR;
4324 32934 : break;
4325 :
4326 7011 : case INTRINSIC_DIVIDE:
4327 : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
4328 : an integer or unsigned, we must round towards zero, so we use a
4329 : TRUNC_DIV_EXPR. */
4330 7011 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4331 : code = TRUNC_DIV_EXPR;
4332 : else
4333 415990 : code = RDIV_EXPR;
4334 : break;
4335 :
4336 49177 : case INTRINSIC_POWER:
4337 49177 : gfc_conv_power_op (se, expr);
4338 49177 : return;
4339 :
4340 1294 : case INTRINSIC_CONCAT:
4341 1294 : gfc_conv_concat_op (se, expr);
4342 1294 : return;
4343 :
4344 4684 : case INTRINSIC_AND:
4345 4684 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4346 : lop = 1;
4347 : break;
4348 :
4349 55716 : case INTRINSIC_OR:
4350 55716 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
4351 : lop = 1;
4352 : break;
4353 :
4354 : /* EQV and NEQV only work on logicals, but since we represent them
4355 : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4356 12393 : case INTRINSIC_EQ:
4357 12393 : case INTRINSIC_EQ_OS:
4358 12393 : case INTRINSIC_EQV:
4359 12393 : code = EQ_EXPR;
4360 12393 : checkstring = 1;
4361 12393 : lop = 1;
4362 12393 : break;
4363 :
4364 206976 : case INTRINSIC_NE:
4365 206976 : case INTRINSIC_NE_OS:
4366 206976 : case INTRINSIC_NEQV:
4367 206976 : code = NE_EXPR;
4368 206976 : checkstring = 1;
4369 206976 : lop = 1;
4370 206976 : break;
4371 :
4372 12021 : case INTRINSIC_GT:
4373 12021 : case INTRINSIC_GT_OS:
4374 12021 : code = GT_EXPR;
4375 12021 : checkstring = 1;
4376 12021 : lop = 1;
4377 12021 : break;
4378 :
4379 1671 : case INTRINSIC_GE:
4380 1671 : case INTRINSIC_GE_OS:
4381 1671 : code = GE_EXPR;
4382 1671 : checkstring = 1;
4383 1671 : lop = 1;
4384 1671 : break;
4385 :
4386 4355 : case INTRINSIC_LT:
4387 4355 : case INTRINSIC_LT_OS:
4388 4355 : code = LT_EXPR;
4389 4355 : checkstring = 1;
4390 4355 : lop = 1;
4391 4355 : break;
4392 :
4393 2604 : case INTRINSIC_LE:
4394 2604 : case INTRINSIC_LE_OS:
4395 2604 : code = LE_EXPR;
4396 2604 : checkstring = 1;
4397 2604 : lop = 1;
4398 2604 : break;
4399 :
4400 0 : case INTRINSIC_USER:
4401 0 : case INTRINSIC_ASSIGN:
4402 : /* These should be converted into function calls by the frontend. */
4403 0 : gcc_unreachable ();
4404 :
4405 0 : default:
4406 0 : fatal_error (input_location, "Unknown intrinsic op");
4407 415990 : return;
4408 : }
4409 :
4410 : /* The only exception to this is **, which is handled separately anyway. */
4411 415990 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4412 :
4413 415990 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4414 381962 : checkstring = 0;
4415 :
4416 : /* lhs */
4417 415990 : gfc_init_se (&lse, se);
4418 415990 : gfc_conv_expr (&lse, expr->value.op.op1);
4419 415990 : gfc_add_block_to_block (&se->pre, &lse.pre);
4420 :
4421 : /* rhs */
4422 415990 : gfc_init_se (&rse, se);
4423 415990 : gfc_conv_expr (&rse, expr->value.op.op2);
4424 415990 : gfc_add_block_to_block (&se->pre, &rse.pre);
4425 :
4426 415990 : if (checkstring)
4427 : {
4428 34028 : gfc_conv_string_parameter (&lse);
4429 34028 : gfc_conv_string_parameter (&rse);
4430 :
4431 68056 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4432 : rse.string_length, rse.expr,
4433 34028 : expr->value.op.op1->ts.kind,
4434 : code);
4435 34028 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4436 34028 : gfc_add_block_to_block (&lse.post, &rse.post);
4437 : }
4438 :
4439 415990 : type = gfc_typenode_for_spec (&expr->ts);
4440 :
4441 415990 : if (lop)
4442 : {
4443 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4444 300420 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4445 169920 : && expr->value.op.op1->ts.type == BT_INTEGER
4446 73145 : && expr->value.op.op1->symtree
4447 73145 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4448 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4449 :
4450 300420 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4451 72330 : && expr->value.op.op2->ts.type == BT_INTEGER
4452 12981 : && expr->value.op.op2->symtree
4453 12981 : && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
4454 12 : TREE_THIS_VOLATILE (rse.expr) = 1;
4455 :
4456 : /* The result of logical ops is always logical_type_node. */
4457 300420 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4458 : lse.expr, rse.expr);
4459 300420 : se->expr = convert (type, tmp);
4460 : }
4461 : else
4462 115570 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4463 :
4464 : /* Add the post blocks. */
4465 415990 : gfc_add_block_to_block (&se->post, &rse.post);
4466 415990 : gfc_add_block_to_block (&se->post, &lse.post);
4467 : }
4468 :
4469 : static void
4470 159 : gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
4471 : {
4472 159 : gfc_se cond_se, true_se, false_se;
4473 159 : tree condition, true_val, false_val;
4474 159 : tree type;
4475 :
4476 159 : gfc_init_se (&cond_se, se);
4477 159 : gfc_init_se (&true_se, se);
4478 159 : gfc_init_se (&false_se, se);
4479 :
4480 159 : gfc_conv_expr (&cond_se, expr->value.conditional.condition);
4481 159 : gfc_add_block_to_block (&se->pre, &cond_se.pre);
4482 159 : condition = gfc_evaluate_now (cond_se.expr, &se->pre);
4483 :
4484 159 : true_se.want_pointer = se->want_pointer;
4485 159 : gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
4486 159 : true_val = true_se.expr;
4487 159 : false_se.want_pointer = se->want_pointer;
4488 159 : gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
4489 159 : false_val = false_se.expr;
4490 :
4491 159 : if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
4492 24 : gfc_add_expr_to_block (
4493 : &se->pre,
4494 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4495 24 : true_se.pre.head != NULL_TREE
4496 6 : ? gfc_finish_block (&true_se.pre)
4497 18 : : build_empty_stmt (input_location),
4498 24 : false_se.pre.head != NULL_TREE
4499 24 : ? gfc_finish_block (&false_se.pre)
4500 0 : : build_empty_stmt (input_location)));
4501 :
4502 159 : if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
4503 6 : gfc_add_expr_to_block (
4504 : &se->post,
4505 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4506 6 : true_se.post.head != NULL_TREE
4507 0 : ? gfc_finish_block (&true_se.post)
4508 6 : : build_empty_stmt (input_location),
4509 6 : false_se.post.head != NULL_TREE
4510 6 : ? gfc_finish_block (&false_se.post)
4511 0 : : build_empty_stmt (input_location)));
4512 :
4513 159 : type = gfc_typenode_for_spec (&expr->ts);
4514 159 : if (se->want_pointer)
4515 18 : type = build_pointer_type (type);
4516 :
4517 159 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
4518 : true_val, false_val);
4519 159 : if (expr->ts.type == BT_CHARACTER)
4520 66 : se->string_length
4521 66 : = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
4522 : condition, true_se.string_length,
4523 : false_se.string_length);
4524 159 : }
4525 :
4526 : /* If a string's length is one, we convert it to a single character. */
4527 :
4528 : tree
4529 140318 : gfc_string_to_single_character (tree len, tree str, int kind)
4530 : {
4531 :
4532 140318 : if (len == NULL
4533 140318 : || !tree_fits_uhwi_p (len)
4534 257878 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4535 : return NULL_TREE;
4536 :
4537 117508 : if (TREE_INT_CST_LOW (len) == 1)
4538 : {
4539 22552 : str = fold_convert (gfc_get_pchar_type (kind), str);
4540 22552 : return build_fold_indirect_ref_loc (input_location, str);
4541 : }
4542 :
4543 94956 : if (kind == 1
4544 77586 : && TREE_CODE (str) == ADDR_EXPR
4545 66910 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4546 47790 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4547 29394 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4548 29394 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4549 29394 : && TREE_INT_CST_LOW (len) > 1
4550 122543 : && TREE_INT_CST_LOW (len)
4551 : == (unsigned HOST_WIDE_INT)
4552 27587 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4553 : {
4554 27587 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4555 27587 : ret = build_fold_indirect_ref_loc (input_location, ret);
4556 27587 : if (TREE_CODE (ret) == INTEGER_CST)
4557 : {
4558 27587 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4559 27587 : int i, length = TREE_STRING_LENGTH (string_cst);
4560 27587 : const char *ptr = TREE_STRING_POINTER (string_cst);
4561 :
4562 41697 : for (i = 1; i < length; i++)
4563 41017 : if (ptr[i] != ' ')
4564 : return NULL_TREE;
4565 :
4566 : return ret;
4567 : }
4568 : }
4569 :
4570 : return NULL_TREE;
4571 : }
4572 :
4573 :
4574 : static void
4575 172 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4576 : {
4577 172 : gcc_assert (expr);
4578 :
4579 : /* We used to modify the tree here. Now it is done earlier in
4580 : the front-end, so we only check it here to avoid regressions. */
4581 172 : if (sym->backend_decl)
4582 : {
4583 67 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4584 67 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4585 67 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4586 67 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4587 : }
4588 :
4589 : /* If we have a constant character expression, make it into an
4590 : integer of type C char. */
4591 172 : if ((*expr)->expr_type == EXPR_CONSTANT)
4592 : {
4593 166 : gfc_typespec ts;
4594 166 : gfc_clear_ts (&ts);
4595 :
4596 332 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4597 166 : (*expr)->value.character.string[0]);
4598 166 : gfc_replace_expr (*expr, tmp);
4599 : }
4600 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4601 : {
4602 6 : if ((*expr)->ref == NULL)
4603 : {
4604 6 : se->expr = gfc_string_to_single_character
4605 6 : (integer_one_node,
4606 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4607 : gfc_get_symbol_decl
4608 6 : ((*expr)->symtree->n.sym)),
4609 : (*expr)->ts.kind);
4610 : }
4611 : else
4612 : {
4613 0 : gfc_conv_variable (se, *expr);
4614 0 : se->expr = gfc_string_to_single_character
4615 0 : (integer_one_node,
4616 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4617 : se->expr),
4618 0 : (*expr)->ts.kind);
4619 : }
4620 : }
4621 172 : }
4622 :
4623 : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4624 : if STR is a string literal, otherwise return -1. */
4625 :
4626 : static int
4627 32326 : gfc_optimize_len_trim (tree len, tree str, int kind)
4628 : {
4629 32326 : if (kind == 1
4630 27284 : && TREE_CODE (str) == ADDR_EXPR
4631 23946 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4632 15255 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4633 9829 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4634 9829 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4635 9829 : && tree_fits_uhwi_p (len)
4636 9829 : && tree_to_uhwi (len) >= 1
4637 32326 : && tree_to_uhwi (len)
4638 9785 : == (unsigned HOST_WIDE_INT)
4639 9785 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4640 : {
4641 9785 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4642 9785 : folded = build_fold_indirect_ref_loc (input_location, folded);
4643 9785 : if (TREE_CODE (folded) == INTEGER_CST)
4644 : {
4645 9785 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4646 9785 : int length = TREE_STRING_LENGTH (string_cst);
4647 9785 : const char *ptr = TREE_STRING_POINTER (string_cst);
4648 :
4649 14694 : for (; length > 0; length--)
4650 14694 : if (ptr[length - 1] != ' ')
4651 : break;
4652 :
4653 : return length;
4654 : }
4655 : }
4656 : return -1;
4657 : }
4658 :
4659 : /* Helper to build a call to memcmp. */
4660 :
4661 : static tree
4662 13129 : build_memcmp_call (tree s1, tree s2, tree n)
4663 : {
4664 13129 : tree tmp;
4665 :
4666 13129 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4667 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4668 : else
4669 13129 : s1 = fold_convert (pvoid_type_node, s1);
4670 :
4671 13129 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4672 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4673 : else
4674 13129 : s2 = fold_convert (pvoid_type_node, s2);
4675 :
4676 13129 : n = fold_convert (size_type_node, n);
4677 :
4678 13129 : tmp = build_call_expr_loc (input_location,
4679 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4680 : 3, s1, s2, n);
4681 :
4682 13129 : return fold_convert (integer_type_node, tmp);
4683 : }
4684 :
4685 : /* Compare two strings. If they are all single characters, the result is the
4686 : subtraction of them. Otherwise, we build a library call. */
4687 :
4688 : tree
4689 34127 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4690 : enum tree_code code)
4691 : {
4692 34127 : tree sc1;
4693 34127 : tree sc2;
4694 34127 : tree fndecl;
4695 :
4696 34127 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4697 34127 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4698 :
4699 34127 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4700 34127 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4701 :
4702 34127 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4703 : {
4704 : /* Deal with single character specially. */
4705 4839 : sc1 = fold_convert (integer_type_node, sc1);
4706 4839 : sc2 = fold_convert (integer_type_node, sc2);
4707 4839 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4708 4839 : sc1, sc2);
4709 : }
4710 :
4711 29288 : if ((code == EQ_EXPR || code == NE_EXPR)
4712 28726 : && optimize
4713 24062 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4714 : {
4715 : /* If one string is a string literal with LEN_TRIM longer
4716 : than the length of the second string, the strings
4717 : compare unequal. */
4718 16163 : int len = gfc_optimize_len_trim (len1, str1, kind);
4719 16163 : if (len > 0 && compare_tree_int (len2, len) < 0)
4720 0 : return integer_one_node;
4721 16163 : len = gfc_optimize_len_trim (len2, str2, kind);
4722 16163 : if (len > 0 && compare_tree_int (len1, len) < 0)
4723 0 : return integer_one_node;
4724 : }
4725 :
4726 : /* We can compare via memcpy if the strings are known to be equal
4727 : in length and they are
4728 : - kind=1
4729 : - kind=4 and the comparison is for (in)equality. */
4730 :
4731 19702 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4732 19364 : && tree_int_cst_equal (len1, len2)
4733 42477 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4734 : {
4735 13129 : tree tmp;
4736 13129 : tree chartype;
4737 :
4738 13129 : chartype = gfc_get_char_type (kind);
4739 13129 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4740 13129 : fold_convert (TREE_TYPE(len1),
4741 : TYPE_SIZE_UNIT(chartype)),
4742 : len1);
4743 13129 : return build_memcmp_call (str1, str2, tmp);
4744 : }
4745 :
4746 : /* Build a call for the comparison. */
4747 16159 : if (kind == 1)
4748 13316 : fndecl = gfor_fndecl_compare_string;
4749 2843 : else if (kind == 4)
4750 2843 : fndecl = gfor_fndecl_compare_string_char4;
4751 : else
4752 0 : gcc_unreachable ();
4753 :
4754 16159 : return build_call_expr_loc (input_location, fndecl, 4,
4755 16159 : len1, str1, len2, str2);
4756 : }
4757 :
4758 :
4759 : /* Return the backend_decl for a procedure pointer component. */
4760 :
4761 : static tree
4762 1914 : get_proc_ptr_comp (gfc_expr *e)
4763 : {
4764 1914 : gfc_se comp_se;
4765 1914 : gfc_expr *e2;
4766 1914 : expr_t old_type;
4767 :
4768 1914 : gfc_init_se (&comp_se, NULL);
4769 1914 : e2 = gfc_copy_expr (e);
4770 : /* We have to restore the expr type later so that gfc_free_expr frees
4771 : the exact same thing that was allocated.
4772 : TODO: This is ugly. */
4773 1914 : old_type = e2->expr_type;
4774 1914 : e2->expr_type = EXPR_VARIABLE;
4775 1914 : gfc_conv_expr (&comp_se, e2);
4776 1914 : e2->expr_type = old_type;
4777 1914 : gfc_free_expr (e2);
4778 1914 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4779 : }
4780 :
4781 :
4782 : /* Convert a typebound function reference from a class object. */
4783 : static void
4784 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4785 : {
4786 80 : gfc_ref *ref;
4787 80 : tree var;
4788 :
4789 80 : if (!VAR_P (base_object))
4790 : {
4791 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4792 0 : gfc_add_modify (&se->pre, var, base_object);
4793 : }
4794 80 : se->expr = gfc_class_vptr_get (base_object);
4795 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4796 80 : ref = expr->ref;
4797 308 : while (ref && ref->next)
4798 : ref = ref->next;
4799 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4800 80 : if (ref->u.c.sym->attr.extension)
4801 0 : conv_parent_component_references (se, ref);
4802 80 : gfc_conv_component_ref (se, ref);
4803 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4804 80 : }
4805 :
4806 : static tree
4807 127810 : get_builtin_fn (gfc_symbol * sym)
4808 : {
4809 127810 : if (!gfc_option.disable_omp_is_initial_device
4810 127806 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4811 625 : && !strcmp (sym->name, "omp_is_initial_device"))
4812 41 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4813 :
4814 127769 : if (!gfc_option.disable_omp_get_initial_device
4815 127762 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4816 4001 : && !strcmp (sym->name, "omp_get_initial_device"))
4817 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4818 :
4819 127740 : if (!gfc_option.disable_omp_get_num_devices
4820 127733 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4821 3972 : && !strcmp (sym->name, "omp_get_num_devices"))
4822 107 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4823 :
4824 127633 : if (!gfc_option.disable_acc_on_device
4825 127453 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4826 1163 : && !strcmp (sym->name, "acc_on_device_h"))
4827 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4828 :
4829 : return NULL_TREE;
4830 : }
4831 :
4832 : static tree
4833 567 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4834 : {
4835 567 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4836 :
4837 567 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4838 : /* In Fortran omp_is_initial_device returns logical(4)
4839 : but the builtin uses 'int'. */
4840 41 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4841 :
4842 526 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4843 : {
4844 : /* Likewise for the return type; additionally, the argument it a
4845 : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4846 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4847 390 : CALL_EXPR_ARG (fn_call, 0));
4848 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4849 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4850 : }
4851 : return fn_call;
4852 : }
4853 :
4854 : static void
4855 130540 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4856 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4857 : {
4858 130540 : tree tmp;
4859 :
4860 130540 : if (gfc_is_proc_ptr_comp (expr))
4861 1914 : tmp = get_proc_ptr_comp (expr);
4862 128626 : else if (sym->attr.dummy)
4863 : {
4864 816 : tmp = gfc_get_symbol_decl (sym);
4865 816 : if (sym->attr.proc_pointer)
4866 89 : tmp = build_fold_indirect_ref_loc (input_location,
4867 : tmp);
4868 816 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4869 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4870 : }
4871 : else
4872 : {
4873 127810 : if (!sym->backend_decl)
4874 32026 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4875 :
4876 127810 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4877 567 : *is_builtin = true;
4878 : else
4879 : {
4880 127243 : TREE_USED (sym->backend_decl) = 1;
4881 127243 : tmp = sym->backend_decl;
4882 : }
4883 :
4884 127810 : if (sym->attr.cray_pointee)
4885 : {
4886 : /* TODO - make the cray pointee a pointer to a procedure,
4887 : assign the pointer to it and use it for the call. This
4888 : will do for now! */
4889 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4890 19 : gfc_get_symbol_decl (sym->cp_pointer));
4891 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4892 : }
4893 :
4894 127810 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4895 : {
4896 127182 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4897 127182 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4898 : }
4899 : }
4900 130540 : se->expr = tmp;
4901 130540 : }
4902 :
4903 :
4904 : /* Initialize MAPPING. */
4905 :
4906 : void
4907 130657 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4908 : {
4909 130657 : mapping->syms = NULL;
4910 130657 : mapping->charlens = NULL;
4911 130657 : }
4912 :
4913 :
4914 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4915 :
4916 : void
4917 130657 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4918 : {
4919 130657 : gfc_interface_sym_mapping *sym;
4920 130657 : gfc_interface_sym_mapping *nextsym;
4921 130657 : gfc_charlen *cl;
4922 130657 : gfc_charlen *nextcl;
4923 :
4924 171241 : for (sym = mapping->syms; sym; sym = nextsym)
4925 : {
4926 40584 : nextsym = sym->next;
4927 40584 : sym->new_sym->n.sym->formal = NULL;
4928 40584 : gfc_free_symbol (sym->new_sym->n.sym);
4929 40584 : gfc_free_expr (sym->expr);
4930 40584 : free (sym->new_sym);
4931 40584 : free (sym);
4932 : }
4933 135297 : for (cl = mapping->charlens; cl; cl = nextcl)
4934 : {
4935 4640 : nextcl = cl->next;
4936 4640 : gfc_free_expr (cl->length);
4937 4640 : free (cl);
4938 : }
4939 130657 : }
4940 :
4941 :
4942 : /* Return a copy of gfc_charlen CL. Add the returned structure to
4943 : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4944 :
4945 : static gfc_charlen *
4946 4640 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4947 : gfc_charlen * cl)
4948 : {
4949 4640 : gfc_charlen *new_charlen;
4950 :
4951 4640 : new_charlen = gfc_get_charlen ();
4952 4640 : new_charlen->next = mapping->charlens;
4953 4640 : new_charlen->length = gfc_copy_expr (cl->length);
4954 :
4955 4640 : mapping->charlens = new_charlen;
4956 4640 : return new_charlen;
4957 : }
4958 :
4959 :
4960 : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4961 : array variable that can be used as the actual argument for dummy
4962 : argument SYM, except in the case of assumed rank dummies of
4963 : non-intrinsic functions where the descriptor must be passed. Add any
4964 : initialization code to BLOCK. PACKED is as for gfc_get_nodesc_array_type
4965 : and DATA points to the first element in the passed array. */
4966 :
4967 : static tree
4968 8394 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4969 : gfc_packed packed, tree data, tree len,
4970 : bool assumed_rank_formal)
4971 : {
4972 8394 : tree type;
4973 8394 : tree var;
4974 :
4975 8394 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4976 58 : type = gfc_get_character_type_len (sym->ts.kind, len);
4977 : else
4978 8336 : type = gfc_typenode_for_spec (&sym->ts);
4979 :
4980 8394 : if (assumed_rank_formal)
4981 13 : type = TREE_TYPE (data);
4982 : else
4983 8381 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4984 8357 : !sym->attr.target && !sym->attr.pointer
4985 16738 : && !sym->attr.proc_pointer);
4986 :
4987 8394 : var = gfc_create_var (type, "ifm");
4988 8394 : gfc_add_modify (block, var, fold_convert (type, data));
4989 :
4990 8394 : return var;
4991 : }
4992 :
4993 :
4994 : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4995 : and offset of descriptorless array type TYPE given that it has the same
4996 : size as DESC. Add any set-up code to BLOCK. */
4997 :
4998 : static void
4999 8124 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
5000 : {
5001 8124 : int n;
5002 8124 : tree dim;
5003 8124 : tree offset;
5004 8124 : tree tmp;
5005 :
5006 8124 : offset = gfc_index_zero_node;
5007 9238 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
5008 : {
5009 1114 : dim = gfc_rank_cst[n];
5010 1114 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
5011 1114 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
5012 : {
5013 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
5014 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
5015 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
5016 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
5017 : }
5018 1113 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
5019 : {
5020 1087 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5021 : gfc_array_index_type,
5022 : gfc_conv_descriptor_ubound_get (desc, dim),
5023 : gfc_conv_descriptor_lbound_get (desc, dim));
5024 3261 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5025 : gfc_array_index_type,
5026 1087 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
5027 1087 : tmp = gfc_evaluate_now (tmp, block);
5028 1087 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
5029 : }
5030 4456 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5031 1114 : GFC_TYPE_ARRAY_LBOUND (type, n),
5032 1114 : GFC_TYPE_ARRAY_STRIDE (type, n));
5033 1114 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5034 : gfc_array_index_type, offset, tmp);
5035 : }
5036 8124 : offset = gfc_evaluate_now (offset, block);
5037 8124 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
5038 8124 : }
5039 :
5040 :
5041 : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
5042 : in SE. The caller may still use se->expr and se->string_length after
5043 : calling this function. */
5044 :
5045 : void
5046 40584 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
5047 : gfc_symbol * sym, gfc_se * se,
5048 : gfc_expr *expr)
5049 : {
5050 40584 : gfc_interface_sym_mapping *sm;
5051 40584 : tree desc;
5052 40584 : tree tmp;
5053 40584 : tree value;
5054 40584 : gfc_symbol *new_sym;
5055 40584 : gfc_symtree *root;
5056 40584 : gfc_symtree *new_symtree;
5057 :
5058 : /* Create a new symbol to represent the actual argument. */
5059 40584 : new_sym = gfc_new_symbol (sym->name, NULL);
5060 40584 : new_sym->ts = sym->ts;
5061 40584 : new_sym->as = gfc_copy_array_spec (sym->as);
5062 40584 : new_sym->attr.referenced = 1;
5063 40584 : new_sym->attr.dimension = sym->attr.dimension;
5064 40584 : new_sym->attr.contiguous = sym->attr.contiguous;
5065 40584 : new_sym->attr.codimension = sym->attr.codimension;
5066 40584 : new_sym->attr.pointer = sym->attr.pointer;
5067 40584 : new_sym->attr.allocatable = sym->attr.allocatable;
5068 40584 : new_sym->attr.flavor = sym->attr.flavor;
5069 40584 : new_sym->attr.function = sym->attr.function;
5070 40584 : new_sym->attr.dummy = 0;
5071 :
5072 : /* Ensure that the interface is available and that
5073 : descriptors are passed for array actual arguments. */
5074 40584 : if (sym->attr.flavor == FL_PROCEDURE)
5075 : {
5076 36 : new_sym->formal = expr->symtree->n.sym->formal;
5077 36 : new_sym->attr.always_explicit
5078 36 : = expr->symtree->n.sym->attr.always_explicit;
5079 : }
5080 :
5081 : /* Create a fake symtree for it. */
5082 40584 : root = NULL;
5083 40584 : new_symtree = gfc_new_symtree (&root, sym->name);
5084 40584 : new_symtree->n.sym = new_sym;
5085 40584 : gcc_assert (new_symtree == root);
5086 :
5087 : /* Create a dummy->actual mapping. */
5088 40584 : sm = XCNEW (gfc_interface_sym_mapping);
5089 40584 : sm->next = mapping->syms;
5090 40584 : sm->old = sym;
5091 40584 : sm->new_sym = new_symtree;
5092 40584 : sm->expr = gfc_copy_expr (expr);
5093 40584 : mapping->syms = sm;
5094 :
5095 : /* Stabilize the argument's value. */
5096 40584 : if (!sym->attr.function && se)
5097 40486 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5098 :
5099 40584 : if (sym->ts.type == BT_CHARACTER)
5100 : {
5101 : /* Create a copy of the dummy argument's length. */
5102 2856 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
5103 2856 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
5104 :
5105 : /* If the length is specified as "*", record the length that
5106 : the caller is passing. We should use the callee's length
5107 : in all other cases. */
5108 2856 : if (!new_sym->ts.u.cl->length && se)
5109 : {
5110 2628 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5111 2628 : new_sym->ts.u.cl->backend_decl = se->string_length;
5112 : }
5113 : }
5114 :
5115 40570 : if (!se)
5116 62 : return;
5117 :
5118 : /* Use the passed value as-is if the argument is a function. */
5119 40522 : if (sym->attr.flavor == FL_PROCEDURE)
5120 36 : value = se->expr;
5121 :
5122 : /* If the argument is a pass-by-value scalar, use the value as is. */
5123 40486 : else if (!sym->attr.dimension && sym->attr.value)
5124 78 : value = se->expr;
5125 :
5126 : /* If the argument is either a string or a pointer to a string,
5127 : convert it to a boundless character type. */
5128 40408 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5129 : {
5130 1287 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5131 1287 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5132 1287 : tmp = build_pointer_type (tmp);
5133 1287 : if (sym->attr.pointer)
5134 126 : value = build_fold_indirect_ref_loc (input_location,
5135 : se->expr);
5136 : else
5137 1161 : value = se->expr;
5138 1287 : value = fold_convert (tmp, value);
5139 : }
5140 :
5141 : /* If the argument is a scalar, a pointer to an array or an allocatable,
5142 : dereference it. */
5143 39121 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5144 29230 : value = build_fold_indirect_ref_loc (input_location,
5145 : se->expr);
5146 :
5147 : /* For character(*), use the actual argument's descriptor. */
5148 9891 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5149 1497 : value = build_fold_indirect_ref_loc (input_location,
5150 : se->expr);
5151 :
5152 : /* If the argument is an array descriptor, use it to determine
5153 : information about the actual argument's shape. */
5154 8394 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5155 8394 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5156 : {
5157 8124 : bool assumed_rank_formal = false;
5158 :
5159 : /* Get the actual argument's descriptor. */
5160 8124 : desc = build_fold_indirect_ref_loc (input_location,
5161 : se->expr);
5162 :
5163 : /* Create the replacement variable. */
5164 8124 : if (sym->as && sym->as->type == AS_ASSUMED_RANK
5165 7334 : && !(sym->ns && sym->ns->proc_name
5166 7334 : && sym->ns->proc_name->attr.proc == PROC_INTRINSIC))
5167 : {
5168 : assumed_rank_formal = true;
5169 : tmp = desc;
5170 : }
5171 : else
5172 8111 : tmp = gfc_conv_descriptor_data_get (desc);
5173 :
5174 8124 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5175 : PACKED_NO, tmp,
5176 : se->string_length,
5177 : assumed_rank_formal);
5178 :
5179 : /* Use DESC to work out the upper bounds, strides and offset. */
5180 8124 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5181 : }
5182 : else
5183 : /* Otherwise we have a packed array. */
5184 270 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5185 : PACKED_FULL, se->expr,
5186 : se->string_length,
5187 : false);
5188 :
5189 40522 : new_sym->backend_decl = value;
5190 : }
5191 :
5192 :
5193 : /* Called once all dummy argument mappings have been added to MAPPING,
5194 : but before the mapping is used to evaluate expressions. Pre-evaluate
5195 : the length of each argument, adding any initialization code to PRE and
5196 : any finalization code to POST. */
5197 :
5198 : static void
5199 130620 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5200 : stmtblock_t * pre, stmtblock_t * post)
5201 : {
5202 130620 : gfc_interface_sym_mapping *sym;
5203 130620 : gfc_expr *expr;
5204 130620 : gfc_se se;
5205 :
5206 171142 : for (sym = mapping->syms; sym; sym = sym->next)
5207 40522 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5208 2842 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5209 : {
5210 214 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5211 214 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5212 214 : gfc_init_se (&se, NULL);
5213 214 : gfc_conv_expr (&se, expr);
5214 214 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5215 214 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5216 214 : gfc_add_block_to_block (pre, &se.pre);
5217 214 : gfc_add_block_to_block (post, &se.post);
5218 :
5219 214 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5220 : }
5221 130620 : }
5222 :
5223 :
5224 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5225 : constructor C. */
5226 :
5227 : static void
5228 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5229 : gfc_constructor_base base)
5230 : {
5231 47 : gfc_constructor *c;
5232 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5233 : {
5234 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5235 381 : if (c->iterator)
5236 : {
5237 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5238 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5239 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5240 : }
5241 : }
5242 47 : }
5243 :
5244 :
5245 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5246 : reference REF. */
5247 :
5248 : static void
5249 12585 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5250 : gfc_ref * ref)
5251 : {
5252 12585 : int n;
5253 :
5254 14070 : for (; ref; ref = ref->next)
5255 1485 : switch (ref->type)
5256 : {
5257 : case REF_ARRAY:
5258 2915 : for (n = 0; n < ref->u.ar.dimen; n++)
5259 : {
5260 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5261 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5262 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5263 : }
5264 : break;
5265 :
5266 : case REF_COMPONENT:
5267 : case REF_INQUIRY:
5268 : break;
5269 :
5270 43 : case REF_SUBSTRING:
5271 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5272 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5273 43 : break;
5274 : }
5275 12585 : }
5276 :
5277 :
5278 : /* Convert intrinsic function calls into result expressions. */
5279 :
5280 : static bool
5281 2214 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5282 : {
5283 2214 : gfc_symbol *sym;
5284 2214 : gfc_expr *new_expr;
5285 2214 : gfc_expr *arg1;
5286 2214 : gfc_expr *arg2;
5287 2214 : int d, dup;
5288 :
5289 2214 : arg1 = expr->value.function.actual->expr;
5290 2214 : if (expr->value.function.actual->next)
5291 2093 : arg2 = expr->value.function.actual->next->expr;
5292 : else
5293 : arg2 = NULL;
5294 :
5295 2214 : sym = arg1->symtree->n.sym;
5296 :
5297 2214 : if (sym->attr.dummy)
5298 : return false;
5299 :
5300 2190 : new_expr = NULL;
5301 :
5302 2190 : switch (expr->value.function.isym->id)
5303 : {
5304 929 : case GFC_ISYM_LEN:
5305 : /* TODO figure out why this condition is necessary. */
5306 929 : if (sym->attr.function
5307 43 : && (arg1->ts.u.cl->length == NULL
5308 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5309 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5310 : return false;
5311 :
5312 886 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5313 886 : break;
5314 :
5315 228 : case GFC_ISYM_LEN_TRIM:
5316 228 : new_expr = gfc_copy_expr (arg1);
5317 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5318 :
5319 228 : if (!new_expr)
5320 : return false;
5321 :
5322 228 : gfc_replace_expr (arg1, new_expr);
5323 228 : return true;
5324 :
5325 606 : case GFC_ISYM_SIZE:
5326 606 : if (!sym->as || sym->as->rank == 0)
5327 : return false;
5328 :
5329 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5330 : {
5331 360 : dup = mpz_get_si (arg2->value.integer);
5332 360 : d = dup - 1;
5333 : }
5334 : else
5335 : {
5336 530 : dup = sym->as->rank;
5337 530 : d = 0;
5338 : }
5339 :
5340 542 : for (; d < dup; d++)
5341 : {
5342 530 : gfc_expr *tmp;
5343 :
5344 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5345 : {
5346 518 : gfc_free_expr (new_expr);
5347 518 : return false;
5348 : }
5349 :
5350 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5351 : gfc_get_int_expr (gfc_default_integer_kind,
5352 : NULL, 1));
5353 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5354 12 : if (new_expr)
5355 0 : new_expr = gfc_multiply (new_expr, tmp);
5356 : else
5357 : new_expr = tmp;
5358 : }
5359 : break;
5360 :
5361 44 : case GFC_ISYM_LBOUND:
5362 44 : case GFC_ISYM_UBOUND:
5363 : /* TODO These implementations of lbound and ubound do not limit if
5364 : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5365 :
5366 44 : if (!sym->as || sym->as->rank == 0)
5367 : return false;
5368 :
5369 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5370 38 : d = mpz_get_si (arg2->value.integer) - 1;
5371 : else
5372 : return false;
5373 :
5374 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5375 : {
5376 23 : if (sym->as->lower[d])
5377 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5378 : }
5379 : else
5380 : {
5381 15 : if (sym->as->upper[d])
5382 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5383 : }
5384 : break;
5385 :
5386 : default:
5387 : break;
5388 : }
5389 :
5390 1319 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5391 1319 : if (!new_expr)
5392 : return false;
5393 :
5394 113 : gfc_replace_expr (expr, new_expr);
5395 113 : return true;
5396 : }
5397 :
5398 :
5399 : static void
5400 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5401 : gfc_interface_mapping * mapping)
5402 : {
5403 24 : gfc_formal_arglist *f;
5404 24 : gfc_actual_arglist *actual;
5405 :
5406 24 : actual = expr->value.function.actual;
5407 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5408 :
5409 72 : for (; f && actual; f = f->next, actual = actual->next)
5410 : {
5411 24 : if (!actual->expr)
5412 0 : continue;
5413 :
5414 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5415 : }
5416 :
5417 24 : if (map_expr->symtree->n.sym->attr.dimension)
5418 : {
5419 6 : int d;
5420 6 : gfc_array_spec *as;
5421 :
5422 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5423 :
5424 18 : for (d = 0; d < as->rank; d++)
5425 : {
5426 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5427 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5428 : }
5429 :
5430 6 : expr->value.function.esym->as = as;
5431 : }
5432 :
5433 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5434 : {
5435 0 : expr->value.function.esym->ts.u.cl->length
5436 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5437 :
5438 0 : gfc_apply_interface_mapping_to_expr (mapping,
5439 0 : expr->value.function.esym->ts.u.cl->length);
5440 : }
5441 24 : }
5442 :
5443 :
5444 : /* EXPR is a copy of an expression that appeared in the interface
5445 : associated with MAPPING. Walk it recursively looking for references to
5446 : dummy arguments that MAPPING maps to actual arguments. Replace each such
5447 : reference with a reference to the associated actual argument. */
5448 :
5449 : static void
5450 21118 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5451 : gfc_expr * expr)
5452 : {
5453 22683 : gfc_interface_sym_mapping *sym;
5454 22683 : gfc_actual_arglist *actual;
5455 :
5456 22683 : if (!expr)
5457 : return;
5458 :
5459 : /* Copying an expression does not copy its length, so do that here. */
5460 12585 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5461 : {
5462 1784 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5463 1784 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5464 : }
5465 :
5466 : /* Apply the mapping to any references. */
5467 12585 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5468 :
5469 : /* ...and to the expression's symbol, if it has one. */
5470 : /* TODO Find out why the condition on expr->symtree had to be moved into
5471 : the loop rather than being outside it, as originally. */
5472 29942 : for (sym = mapping->syms; sym; sym = sym->next)
5473 17357 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5474 : {
5475 3370 : if (sym->new_sym->n.sym->backend_decl)
5476 3326 : expr->symtree = sym->new_sym;
5477 44 : else if (sym->expr)
5478 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5479 : }
5480 :
5481 : /* ...and to subexpressions in expr->value. */
5482 12585 : switch (expr->expr_type)
5483 : {
5484 : case EXPR_VARIABLE:
5485 : case EXPR_CONSTANT:
5486 : case EXPR_NULL:
5487 : case EXPR_SUBSTRING:
5488 : break;
5489 :
5490 1565 : case EXPR_OP:
5491 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5492 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5493 1565 : break;
5494 :
5495 0 : case EXPR_CONDITIONAL:
5496 0 : gfc_apply_interface_mapping_to_expr (mapping,
5497 0 : expr->value.conditional.true_expr);
5498 0 : gfc_apply_interface_mapping_to_expr (mapping,
5499 0 : expr->value.conditional.false_expr);
5500 0 : break;
5501 :
5502 2957 : case EXPR_FUNCTION:
5503 9502 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5504 6545 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5505 :
5506 2957 : if (expr->value.function.esym == NULL
5507 2644 : && expr->value.function.isym != NULL
5508 2632 : && expr->value.function.actual
5509 2631 : && expr->value.function.actual->expr
5510 2631 : && expr->value.function.actual->expr->symtree
5511 5171 : && gfc_map_intrinsic_function (expr, mapping))
5512 : break;
5513 :
5514 6154 : for (sym = mapping->syms; sym; sym = sym->next)
5515 3538 : if (sym->old == expr->value.function.esym)
5516 : {
5517 24 : expr->value.function.esym = sym->new_sym->n.sym;
5518 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5519 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5520 : }
5521 : break;
5522 :
5523 47 : case EXPR_ARRAY:
5524 47 : case EXPR_STRUCTURE:
5525 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5526 47 : break;
5527 :
5528 0 : case EXPR_COMPCALL:
5529 0 : case EXPR_PPC:
5530 0 : case EXPR_UNKNOWN:
5531 0 : gcc_unreachable ();
5532 : break;
5533 : }
5534 :
5535 : return;
5536 : }
5537 :
5538 :
5539 : /* Evaluate interface expression EXPR using MAPPING. Store the result
5540 : in SE. */
5541 :
5542 : void
5543 4016 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5544 : gfc_se * se, gfc_expr * expr)
5545 : {
5546 4016 : expr = gfc_copy_expr (expr);
5547 4016 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5548 4016 : gfc_conv_expr (se, expr);
5549 4016 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5550 4016 : gfc_free_expr (expr);
5551 4016 : }
5552 :
5553 :
5554 : /* Returns a reference to a temporary array into which a component of
5555 : an actual argument derived type array is copied and then returned
5556 : after the function call. */
5557 : void
5558 2631 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5559 : sym_intent intent, bool formal_ptr,
5560 : const gfc_symbol *fsym, const char *proc_name,
5561 : gfc_symbol *sym, bool check_contiguous)
5562 : {
5563 2631 : gfc_se lse;
5564 2631 : gfc_se rse;
5565 2631 : gfc_ss *lss;
5566 2631 : gfc_ss *rss;
5567 2631 : gfc_loopinfo loop;
5568 2631 : gfc_loopinfo loop2;
5569 2631 : gfc_array_info *info;
5570 2631 : tree offset;
5571 2631 : tree tmp_index;
5572 2631 : tree tmp;
5573 2631 : tree base_type;
5574 2631 : tree size;
5575 2631 : stmtblock_t body;
5576 2631 : int n;
5577 2631 : int dimen;
5578 2631 : gfc_se work_se;
5579 2631 : gfc_se *parmse;
5580 2631 : bool pass_optional;
5581 2631 : bool readonly;
5582 :
5583 2631 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5584 :
5585 2620 : if (pass_optional || check_contiguous)
5586 : {
5587 1348 : gfc_init_se (&work_se, NULL);
5588 1348 : parmse = &work_se;
5589 : }
5590 : else
5591 : parmse = se;
5592 :
5593 2631 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5594 : {
5595 : /* We will create a temporary array, so let us warn. */
5596 868 : char * msg;
5597 :
5598 868 : if (fsym && proc_name)
5599 868 : msg = xasprintf ("An array temporary was created for argument "
5600 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5601 : else
5602 0 : msg = xasprintf ("An array temporary was created");
5603 :
5604 868 : tmp = build_int_cst (logical_type_node, 1);
5605 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5606 : &expr->where, msg);
5607 868 : free (msg);
5608 : }
5609 :
5610 2631 : gfc_init_se (&lse, NULL);
5611 2631 : gfc_init_se (&rse, NULL);
5612 :
5613 : /* Walk the argument expression. */
5614 2631 : rss = gfc_walk_expr (expr);
5615 :
5616 2631 : gcc_assert (rss != gfc_ss_terminator);
5617 :
5618 : /* Initialize the scalarizer. */
5619 2631 : gfc_init_loopinfo (&loop);
5620 2631 : gfc_add_ss_to_loop (&loop, rss);
5621 :
5622 : /* Calculate the bounds of the scalarization. */
5623 2631 : gfc_conv_ss_startstride (&loop);
5624 :
5625 : /* Build an ss for the temporary. */
5626 2631 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5627 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5628 :
5629 2631 : base_type = gfc_typenode_for_spec (&expr->ts);
5630 2631 : if (GFC_ARRAY_TYPE_P (base_type)
5631 2631 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5632 0 : base_type = gfc_get_element_type (base_type);
5633 :
5634 2631 : if (expr->ts.type == BT_CLASS)
5635 121 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5636 :
5637 3795 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5638 1164 : ? expr->ts.u.cl->backend_decl
5639 : : NULL),
5640 : loop.dimen);
5641 :
5642 2631 : parmse->string_length = loop.temp_ss->info->string_length;
5643 :
5644 : /* Associate the SS with the loop. */
5645 2631 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5646 :
5647 : /* Setup the scalarizing loops. */
5648 2631 : gfc_conv_loop_setup (&loop, &expr->where);
5649 :
5650 : /* Pass the temporary descriptor back to the caller. */
5651 2631 : info = &loop.temp_ss->info->data.array;
5652 2631 : parmse->expr = info->descriptor;
5653 :
5654 : /* Setup the gfc_se structures. */
5655 2631 : gfc_copy_loopinfo_to_se (&lse, &loop);
5656 2631 : gfc_copy_loopinfo_to_se (&rse, &loop);
5657 :
5658 2631 : rse.ss = rss;
5659 2631 : lse.ss = loop.temp_ss;
5660 2631 : gfc_mark_ss_chain_used (rss, 1);
5661 2631 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5662 :
5663 : /* Start the scalarized loop body. */
5664 2631 : gfc_start_scalarized_body (&loop, &body);
5665 :
5666 : /* Translate the expression. */
5667 2631 : gfc_conv_expr (&rse, expr);
5668 :
5669 2631 : gfc_conv_tmp_array_ref (&lse);
5670 :
5671 2631 : if (intent != INTENT_OUT)
5672 : {
5673 2593 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5674 2593 : gfc_add_expr_to_block (&body, tmp);
5675 2593 : gcc_assert (rse.ss == gfc_ss_terminator);
5676 2593 : gfc_trans_scalarizing_loops (&loop, &body);
5677 : }
5678 : else
5679 : {
5680 : /* Make sure that the temporary declaration survives by merging
5681 : all the loop declarations into the current context. */
5682 85 : for (n = 0; n < loop.dimen; n++)
5683 : {
5684 47 : gfc_merge_block_scope (&body);
5685 47 : body = loop.code[loop.order[n]];
5686 : }
5687 38 : gfc_merge_block_scope (&body);
5688 : }
5689 :
5690 : /* Add the post block after the second loop, so that any
5691 : freeing of allocated memory is done at the right time. */
5692 2631 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5693 :
5694 : /**********Copy the temporary back again.*********/
5695 :
5696 2631 : gfc_init_se (&lse, NULL);
5697 2631 : gfc_init_se (&rse, NULL);
5698 :
5699 : /* Walk the argument expression. */
5700 2631 : lss = gfc_walk_expr (expr);
5701 2631 : rse.ss = loop.temp_ss;
5702 2631 : lse.ss = lss;
5703 :
5704 : /* Initialize the scalarizer. */
5705 2631 : gfc_init_loopinfo (&loop2);
5706 2631 : gfc_add_ss_to_loop (&loop2, lss);
5707 :
5708 2631 : dimen = rse.ss->dimen;
5709 :
5710 : /* Skip the write-out loop for this case. */
5711 2631 : if (gfc_is_class_array_function (expr))
5712 13 : goto class_array_fcn;
5713 :
5714 : /* Calculate the bounds of the scalarization. */
5715 2618 : gfc_conv_ss_startstride (&loop2);
5716 :
5717 : /* Setup the scalarizing loops. */
5718 2618 : gfc_conv_loop_setup (&loop2, &expr->where);
5719 :
5720 2618 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5721 2618 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5722 :
5723 2618 : gfc_mark_ss_chain_used (lss, 1);
5724 2618 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5725 :
5726 : /* Declare the variable to hold the temporary offset and start the
5727 : scalarized loop body. */
5728 2618 : offset = gfc_create_var (gfc_array_index_type, NULL);
5729 2618 : gfc_start_scalarized_body (&loop2, &body);
5730 :
5731 : /* Build the offsets for the temporary from the loop variables. The
5732 : temporary array has lbounds of zero and strides of one in all
5733 : dimensions, so this is very simple. The offset is only computed
5734 : outside the innermost loop, so the overall transfer could be
5735 : optimized further. */
5736 2618 : info = &rse.ss->info->data.array;
5737 :
5738 2618 : tmp_index = gfc_index_zero_node;
5739 3989 : for (n = dimen - 1; n > 0; n--)
5740 : {
5741 1371 : tree tmp_str;
5742 1371 : tmp = rse.loop->loopvar[n];
5743 1371 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5744 : tmp, rse.loop->from[n]);
5745 1371 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5746 : tmp, tmp_index);
5747 :
5748 2742 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5749 : gfc_array_index_type,
5750 1371 : rse.loop->to[n-1], rse.loop->from[n-1]);
5751 1371 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5752 : gfc_array_index_type,
5753 : tmp_str, gfc_index_one_node);
5754 :
5755 1371 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5756 : gfc_array_index_type, tmp, tmp_str);
5757 : }
5758 :
5759 5236 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5760 : gfc_array_index_type,
5761 2618 : tmp_index, rse.loop->from[0]);
5762 2618 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5763 :
5764 5236 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5765 : gfc_array_index_type,
5766 2618 : rse.loop->loopvar[0], offset);
5767 :
5768 : /* Now use the offset for the reference. */
5769 2618 : tmp = build_fold_indirect_ref_loc (input_location,
5770 : info->data);
5771 2618 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5772 :
5773 2618 : if (expr->ts.type == BT_CHARACTER)
5774 1164 : rse.string_length = expr->ts.u.cl->backend_decl;
5775 :
5776 2618 : gfc_conv_expr (&lse, expr);
5777 :
5778 2618 : gcc_assert (lse.ss == gfc_ss_terminator);
5779 :
5780 : /* Do not do deallocations when we are looking at a g77-style argument. */
5781 :
5782 2618 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, !g77);
5783 2618 : gfc_add_expr_to_block (&body, tmp);
5784 :
5785 : /* Generate the copying loops. */
5786 2618 : gfc_trans_scalarizing_loops (&loop2, &body);
5787 :
5788 : /* Wrap the whole thing up by adding the second loop to the post-block
5789 : and following it by the post-block of the first loop. In this way,
5790 : if the temporary needs freeing, it is done after use!
5791 : If input expr is read-only, e.g. a PARAMETER array, copying back
5792 : modified values is undefined behavior. */
5793 5236 : readonly = (expr->expr_type == EXPR_VARIABLE
5794 2552 : && expr->symtree
5795 5170 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5796 :
5797 2618 : if ((intent != INTENT_IN) && !readonly)
5798 : {
5799 1155 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5800 1155 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5801 : }
5802 :
5803 1463 : class_array_fcn:
5804 :
5805 2631 : gfc_add_block_to_block (&parmse->post, &loop.post);
5806 :
5807 2631 : gfc_cleanup_loop (&loop);
5808 2631 : gfc_cleanup_loop (&loop2);
5809 :
5810 : /* Pass the string length to the argument expression. */
5811 2631 : if (expr->ts.type == BT_CHARACTER)
5812 1164 : parmse->string_length = expr->ts.u.cl->backend_decl;
5813 :
5814 : /* Determine the offset for pointer formal arguments and set the
5815 : lbounds to one. */
5816 2631 : if (formal_ptr)
5817 : {
5818 18 : size = gfc_index_one_node;
5819 18 : offset = gfc_index_zero_node;
5820 36 : for (n = 0; n < dimen; n++)
5821 : {
5822 18 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5823 : gfc_rank_cst[n]);
5824 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5825 : gfc_array_index_type, tmp,
5826 : gfc_index_one_node);
5827 18 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5828 : parmse->expr,
5829 : gfc_rank_cst[n],
5830 : tmp);
5831 18 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5832 : parmse->expr,
5833 : gfc_rank_cst[n],
5834 : gfc_index_one_node);
5835 18 : size = gfc_evaluate_now (size, &parmse->pre);
5836 18 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5837 : gfc_array_index_type,
5838 : offset, size);
5839 18 : offset = gfc_evaluate_now (offset, &parmse->pre);
5840 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5841 : gfc_array_index_type,
5842 18 : rse.loop->to[n], rse.loop->from[n]);
5843 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5844 : gfc_array_index_type,
5845 : tmp, gfc_index_one_node);
5846 18 : size = fold_build2_loc (input_location, MULT_EXPR,
5847 : gfc_array_index_type, size, tmp);
5848 : }
5849 :
5850 18 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5851 : offset);
5852 : }
5853 :
5854 : /* We want either the address for the data or the address of the descriptor,
5855 : depending on the mode of passing array arguments. */
5856 2631 : if (g77)
5857 426 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5858 : else
5859 2205 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5860 :
5861 : /* Basically make this into
5862 :
5863 : if (present)
5864 : {
5865 : if (contiguous)
5866 : {
5867 : pointer = a;
5868 : }
5869 : else
5870 : {
5871 : parmse->pre();
5872 : pointer = parmse->expr;
5873 : }
5874 : }
5875 : else
5876 : pointer = NULL;
5877 :
5878 : foo (pointer);
5879 : if (present && !contiguous)
5880 : se->post();
5881 :
5882 : */
5883 :
5884 2631 : if (pass_optional || check_contiguous)
5885 : {
5886 1348 : tree type;
5887 1348 : stmtblock_t else_block;
5888 1348 : tree pre_stmts, post_stmts;
5889 1348 : tree pointer;
5890 1348 : tree else_stmt;
5891 1348 : tree present_var = NULL_TREE;
5892 1348 : tree cont_var = NULL_TREE;
5893 1348 : tree post_cond;
5894 :
5895 1348 : type = TREE_TYPE (parmse->expr);
5896 1348 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5897 1027 : type = TREE_TYPE (type);
5898 1348 : pointer = gfc_create_var (type, "arg_ptr");
5899 :
5900 1348 : if (check_contiguous)
5901 : {
5902 1348 : gfc_se cont_se, array_se;
5903 1348 : stmtblock_t if_block, else_block;
5904 1348 : tree if_stmt, else_stmt;
5905 1348 : mpz_t size;
5906 1348 : bool size_set;
5907 :
5908 1348 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5909 :
5910 : /* If the size is known to be one at compile-time, set
5911 : cont_var to true unconditionally. This may look
5912 : inelegant, but we're only doing this during
5913 : optimization, so the statements will be optimized away,
5914 : and this saves complexity here. */
5915 :
5916 1348 : size_set = gfc_array_size (expr, &size);
5917 1348 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5918 : {
5919 6 : gfc_add_modify (&se->pre, cont_var,
5920 : build_one_cst (boolean_type_node));
5921 : }
5922 : else
5923 : {
5924 : /* cont_var = is_contiguous (expr); . */
5925 1342 : gfc_init_se (&cont_se, parmse);
5926 1342 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5927 1342 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5928 1342 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5929 1342 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5930 : }
5931 :
5932 1348 : if (size_set)
5933 1149 : mpz_clear (size);
5934 :
5935 : /* arrayse->expr = descriptor of a. */
5936 1348 : gfc_init_se (&array_se, se);
5937 1348 : gfc_conv_expr_descriptor (&array_se, expr);
5938 1348 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5939 1348 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5940 :
5941 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5942 1348 : gfc_init_block (&if_block);
5943 1348 : if (GFC_DESCRIPTOR_TYPE_P (type))
5944 1027 : gfc_add_modify (&if_block, pointer, array_se.expr);
5945 : else
5946 : {
5947 321 : tmp = gfc_conv_array_data (array_se.expr);
5948 321 : tmp = fold_convert (type, tmp);
5949 321 : gfc_add_modify (&if_block, pointer, tmp);
5950 : }
5951 1348 : if_stmt = gfc_finish_block (&if_block);
5952 :
5953 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5954 1348 : gfc_init_block (&else_block);
5955 1348 : gfc_add_block_to_block (&else_block, &parmse->pre);
5956 1669 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5957 1348 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5958 : : parmse->expr);
5959 1348 : gfc_add_modify (&else_block, pointer, tmp);
5960 1348 : else_stmt = gfc_finish_block (&else_block);
5961 :
5962 : /* And put the above into an if statement. */
5963 1348 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5964 : gfc_likely (cont_var,
5965 : PRED_FORTRAN_CONTIGUOUS),
5966 : if_stmt, else_stmt);
5967 : }
5968 : else
5969 : {
5970 : /* pointer = pramse->expr; . */
5971 0 : gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5972 0 : pre_stmts = gfc_finish_block (&parmse->pre);
5973 : }
5974 :
5975 1348 : if (pass_optional)
5976 : {
5977 11 : present_var = gfc_create_var (boolean_type_node, "present");
5978 :
5979 : /* present_var = present(sym); . */
5980 11 : tmp = gfc_conv_expr_present (sym);
5981 11 : tmp = fold_convert (boolean_type_node, tmp);
5982 11 : gfc_add_modify (&se->pre, present_var, tmp);
5983 :
5984 : /* else_stmt = { pointer = NULL; } . */
5985 11 : gfc_init_block (&else_block);
5986 11 : if (GFC_DESCRIPTOR_TYPE_P (type))
5987 0 : gfc_conv_descriptor_data_set (&else_block, pointer,
5988 : null_pointer_node);
5989 : else
5990 11 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5991 11 : else_stmt = gfc_finish_block (&else_block);
5992 :
5993 11 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5994 : gfc_likely (present_var,
5995 : PRED_FORTRAN_ABSENT_DUMMY),
5996 : pre_stmts, else_stmt);
5997 11 : gfc_add_expr_to_block (&se->pre, tmp);
5998 : }
5999 : else
6000 1337 : gfc_add_expr_to_block (&se->pre, pre_stmts);
6001 :
6002 1348 : post_stmts = gfc_finish_block (&parmse->post);
6003 :
6004 : /* Put together the post stuff, plus the optional
6005 : deallocation. */
6006 1348 : if (check_contiguous)
6007 : {
6008 : /* !cont_var. */
6009 1348 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6010 : cont_var,
6011 : build_zero_cst (boolean_type_node));
6012 1348 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
6013 :
6014 1348 : if (pass_optional)
6015 : {
6016 11 : tree present_likely = gfc_likely (present_var,
6017 : PRED_FORTRAN_ABSENT_DUMMY);
6018 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6019 : boolean_type_node, present_likely,
6020 : tmp);
6021 : }
6022 : else
6023 : post_cond = tmp;
6024 : }
6025 : else
6026 : {
6027 0 : gcc_assert (pass_optional);
6028 : post_cond = present_var;
6029 : }
6030 :
6031 1348 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
6032 : post_stmts, build_empty_stmt (input_location));
6033 1348 : gfc_add_expr_to_block (&se->post, tmp);
6034 1348 : if (GFC_DESCRIPTOR_TYPE_P (type))
6035 : {
6036 1027 : type = TREE_TYPE (parmse->expr);
6037 1027 : if (POINTER_TYPE_P (type))
6038 : {
6039 1027 : pointer = gfc_build_addr_expr (type, pointer);
6040 1027 : if (pass_optional)
6041 : {
6042 0 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
6043 0 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
6044 : tmp, pointer,
6045 : fold_convert (type,
6046 : null_pointer_node));
6047 : }
6048 : }
6049 : else
6050 0 : gcc_assert (!pass_optional);
6051 : }
6052 1348 : se->expr = pointer;
6053 : }
6054 :
6055 2631 : return;
6056 : }
6057 :
6058 :
6059 : /* Generate the code for argument list functions. */
6060 :
6061 : static void
6062 5826 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
6063 : {
6064 : /* Pass by value for g77 %VAL(arg), pass the address
6065 : indirectly for %LOC, else by reference. Thus %REF
6066 : is a "do-nothing" and %LOC is the same as an F95
6067 : pointer. */
6068 5826 : if (strcmp (name, "%VAL") == 0)
6069 5814 : gfc_conv_expr (se, expr);
6070 12 : else if (strcmp (name, "%LOC") == 0)
6071 : {
6072 6 : gfc_conv_expr_reference (se, expr);
6073 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
6074 : }
6075 6 : else if (strcmp (name, "%REF") == 0)
6076 6 : gfc_conv_expr_reference (se, expr);
6077 : else
6078 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
6079 5826 : }
6080 :
6081 :
6082 : /* This function tells whether the middle-end representation of the expression
6083 : E given as input may point to data otherwise accessible through a variable
6084 : (sub-)reference.
6085 : It is assumed that the only expressions that may alias are variables,
6086 : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
6087 : may alias.
6088 : This function is used to decide whether freeing an expression's allocatable
6089 : components is safe or should be avoided.
6090 :
6091 : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
6092 : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
6093 : is necessary because for array constructors, aliasing depends on how
6094 : the array is used:
6095 : - If E is an array constructor used as argument to an elemental procedure,
6096 : the array, which is generated through shallow copy by the scalarizer,
6097 : is used directly and can alias the expressions it was copied from.
6098 : - If E is an array constructor used as argument to a non-elemental
6099 : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
6100 : the array as in the previous case, but then that array is used
6101 : to initialize a new descriptor through deep copy. There is no alias
6102 : possible in that case.
6103 : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
6104 : above. */
6105 :
6106 : static bool
6107 7654 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6108 : {
6109 7654 : gfc_constructor *c;
6110 :
6111 7654 : if (e->expr_type == EXPR_VARIABLE)
6112 : return true;
6113 562 : else if (e->expr_type == EXPR_FUNCTION)
6114 : {
6115 161 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
6116 :
6117 161 : if (proc_ifc->result != NULL
6118 161 : && ((proc_ifc->result->ts.type == BT_CLASS
6119 25 : && proc_ifc->result->ts.u.derived->attr.is_class
6120 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
6121 161 : || proc_ifc->result->attr.pointer))
6122 : return true;
6123 : else
6124 : return false;
6125 : }
6126 401 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6127 : return false;
6128 :
6129 79 : for (c = gfc_constructor_first (e->value.constructor);
6130 233 : c; c = gfc_constructor_next (c))
6131 189 : if (c->expr
6132 189 : && expr_may_alias_variables (c->expr, array_may_alias))
6133 : return true;
6134 :
6135 : return false;
6136 : }
6137 :
6138 :
6139 : /* A helper function to set the dtype for unallocated or unassociated
6140 : entities. */
6141 :
6142 : static void
6143 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6144 : {
6145 891 : tree tmp;
6146 891 : tree desc;
6147 891 : tree cond;
6148 891 : tree type;
6149 891 : stmtblock_t block;
6150 :
6151 : /* TODO Figure out how to handle optional dummies. */
6152 891 : if (e && e->expr_type == EXPR_VARIABLE
6153 807 : && e->symtree->n.sym->attr.optional)
6154 108 : return;
6155 :
6156 819 : desc = parmse->expr;
6157 819 : if (desc == NULL_TREE)
6158 : return;
6159 :
6160 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6161 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6162 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6163 192 : desc = gfc_class_data_get (desc);
6164 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6165 : return;
6166 :
6167 783 : gfc_init_block (&block);
6168 783 : tmp = gfc_conv_descriptor_data_get (desc);
6169 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6170 : logical_type_node, tmp,
6171 783 : build_int_cst (TREE_TYPE (tmp), 0));
6172 783 : tmp = gfc_conv_descriptor_dtype (desc);
6173 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6174 1566 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6175 783 : TREE_TYPE (tmp), tmp,
6176 : gfc_get_dtype_rank_type (e->rank, type));
6177 783 : gfc_add_expr_to_block (&block, tmp);
6178 783 : cond = build3_v (COND_EXPR, cond,
6179 : gfc_finish_block (&block),
6180 : build_empty_stmt (input_location));
6181 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6182 : }
6183 :
6184 :
6185 :
6186 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6187 : ISO_Fortran_binding array descriptors. */
6188 :
6189 : static void
6190 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6191 : {
6192 6537 : stmtblock_t block, block2;
6193 6537 : tree cfi, gfc, tmp, tmp2;
6194 6537 : tree present = NULL;
6195 6537 : tree gfc_strlen = NULL;
6196 6537 : tree rank;
6197 6537 : gfc_se se;
6198 :
6199 6537 : if (fsym->attr.optional
6200 1094 : && e->expr_type == EXPR_VARIABLE
6201 1094 : && e->symtree->n.sym->attr.optional)
6202 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6203 :
6204 6537 : gfc_init_block (&block);
6205 :
6206 : /* Convert original argument to a tree. */
6207 6537 : gfc_init_se (&se, NULL);
6208 6537 : if (e->rank == 0)
6209 : {
6210 687 : se.want_pointer = 1;
6211 687 : gfc_conv_expr (&se, e);
6212 687 : gfc = se.expr;
6213 : }
6214 : else
6215 : {
6216 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6217 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6218 : length assumed-length/assumed-size CHARACTER array. This only
6219 : applies if the actual argument is a "variable"; if it's some
6220 : non-lvalue expression, we are going to evaluate it to a
6221 : temporary below anyway. */
6222 5850 : se.force_no_tmp = 1;
6223 5850 : if ((fsym->attr.contiguous
6224 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6225 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6226 937 : || fsym->as->type == AS_EXPLICIT)))
6227 2023 : && !gfc_is_simply_contiguous (e, false, true)
6228 6883 : && gfc_expr_is_variable (e))
6229 : {
6230 1027 : bool optional = fsym->attr.optional;
6231 1027 : fsym->attr.optional = 0;
6232 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6233 1027 : fsym->attr.pointer, fsym,
6234 1027 : fsym->ns->proc_name->name, NULL,
6235 : /* check_contiguous= */ true);
6236 1027 : fsym->attr.optional = optional;
6237 : }
6238 : else
6239 4823 : gfc_conv_expr_descriptor (&se, e);
6240 5850 : gfc = se.expr;
6241 : /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
6242 : elem_len = sizeof(dt) and base_addr = dt(lb) instead.
6243 : gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
6244 : While sm is fine as it uses span*stride and not elem_len. */
6245 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6246 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6247 4823 : else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
6248 12 : gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
6249 : }
6250 6537 : if (e->ts.type == BT_CHARACTER)
6251 : {
6252 3409 : if (se.string_length)
6253 : gfc_strlen = se.string_length;
6254 883 : else if (e->ts.u.cl->backend_decl)
6255 : gfc_strlen = e->ts.u.cl->backend_decl;
6256 : else
6257 0 : gcc_unreachable ();
6258 : }
6259 6537 : gfc_add_block_to_block (&block, &se.pre);
6260 :
6261 : /* Create array descriptor and set version, rank, attribute, type. */
6262 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6263 : ? GFC_MAX_DIMENSIONS : e->rank,
6264 : false), "cfi");
6265 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6266 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6267 : {
6268 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6269 2338 : tmp = build_pointer_type (tmp);
6270 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6271 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6272 : }
6273 : else
6274 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6275 :
6276 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6277 6537 : gfc_add_modify (&block, tmp,
6278 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6279 6537 : if (e->rank < 0)
6280 305 : rank = gfc_conv_descriptor_rank (gfc);
6281 : else
6282 6232 : rank = gfc_rank_cst[e->rank];
6283 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6284 6537 : gfc_add_modify (&block, tmp,
6285 6537 : fold_convert (TREE_TYPE (tmp), rank));
6286 6537 : int itype = CFI_type_other;
6287 6537 : if (e->ts.f90_type == BT_VOID)
6288 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6289 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6290 : else
6291 : {
6292 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6293 1 : e->ts = fsym->ts;
6294 6441 : switch (e->ts.type)
6295 : {
6296 2296 : case BT_INTEGER:
6297 2296 : case BT_LOGICAL:
6298 2296 : case BT_REAL:
6299 2296 : case BT_COMPLEX:
6300 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6301 2296 : break;
6302 3410 : case BT_CHARACTER:
6303 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6304 3410 : break;
6305 : case BT_DERIVED:
6306 6537 : itype = CFI_type_struct;
6307 : break;
6308 0 : case BT_VOID:
6309 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6310 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6311 : break;
6312 : case BT_ASSUMED:
6313 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6314 : break;
6315 1 : case BT_CLASS:
6316 1 : if (fsym->ts.type == BT_ASSUMED)
6317 : {
6318 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6319 : // type specifier is assumed-type and is an unlimited polymorphic
6320 : // entity." The actual argument _data component is passed.
6321 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6322 : break;
6323 : }
6324 : else
6325 0 : gcc_unreachable ();
6326 :
6327 0 : case BT_UNSIGNED:
6328 0 : gfc_internal_error ("Unsigned not yet implemented");
6329 :
6330 0 : case BT_PROCEDURE:
6331 0 : case BT_HOLLERITH:
6332 0 : case BT_UNION:
6333 0 : case BT_BOZ:
6334 0 : case BT_UNKNOWN:
6335 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6336 0 : gcc_unreachable ();
6337 : }
6338 : }
6339 :
6340 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6341 6537 : gfc_add_modify (&block, tmp,
6342 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6343 :
6344 6537 : int attr = CFI_attribute_other;
6345 6537 : if (fsym->attr.pointer)
6346 : attr = CFI_attribute_pointer;
6347 5774 : else if (fsym->attr.allocatable)
6348 433 : attr = CFI_attribute_allocatable;
6349 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6350 6537 : gfc_add_modify (&block, tmp,
6351 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6352 :
6353 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6354 : That is very sensible for undefined pointers, but the C code might assume
6355 : that the pointer retains the value, in particular, if it was NULL. */
6356 6537 : if (e->rank == 0)
6357 : {
6358 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6359 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6360 : }
6361 : else
6362 : {
6363 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6364 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6365 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6366 : }
6367 :
6368 : /* Set elem_len if known - must be before the next if block.
6369 : Note that allocatable implies 'len=:'. */
6370 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6371 : {
6372 : /* Length is known at compile time; use 'block' for it. */
6373 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6374 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6375 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6376 : }
6377 :
6378 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6379 91 : goto done;
6380 :
6381 : /* When allocatable + intent out, free the cfi descriptor. */
6382 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6383 : {
6384 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6385 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6386 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6387 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6388 90 : gfc_add_modify (&block, tmp,
6389 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6390 90 : goto done;
6391 : }
6392 :
6393 : /* If not unallocated/unassociated. */
6394 6356 : gfc_init_block (&block2);
6395 :
6396 : /* Set elem_len, which may be only known at run time. */
6397 6356 : if (e->ts.type == BT_CHARACTER
6398 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6399 : {
6400 3408 : gcc_assert (gfc_strlen);
6401 3409 : tmp = gfc_strlen;
6402 3409 : if (e->ts.kind != 1)
6403 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6404 : gfc_charlen_type_node, tmp,
6405 : build_int_cst (gfc_charlen_type_node,
6406 1117 : e->ts.kind));
6407 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6408 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6409 : }
6410 2947 : else if (e->ts.type == BT_ASSUMED)
6411 : {
6412 54 : tmp = gfc_conv_descriptor_elem_len (gfc);
6413 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6414 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6415 : }
6416 :
6417 6356 : if (e->ts.type == BT_ASSUMED)
6418 : {
6419 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6420 : an CFI descriptor. Use the type in the descriptor as it provide
6421 : mode information. (Quality of implementation feature.) */
6422 54 : tree cond;
6423 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6424 54 : tree type = fold_convert (TREE_TYPE (ctype),
6425 : gfc_conv_descriptor_type (gfc));
6426 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6427 : gfc_conv_descriptor_elem_len (gfc));
6428 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6429 54 : kind, build_int_cst (TREE_TYPE (type),
6430 : CFI_type_kind_shift));
6431 :
6432 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6433 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6434 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6435 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6436 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6437 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6438 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6439 : ctype,
6440 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6441 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6442 : tmp, tmp2);
6443 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6444 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6445 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6446 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6447 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6448 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6449 : tmp, tmp2);
6450 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6451 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6452 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6453 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6454 54 : tmp = build_int_cst (TREE_TYPE (type),
6455 : CFI_type_from_type_kind (CFI_type_Character, 1));
6456 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6457 : ctype, tmp);
6458 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6459 : tmp, tmp2);
6460 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6461 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6462 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6463 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6464 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6465 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6466 54 : build_int_cst (TREE_TYPE (type),
6467 : CFI_type_Complex));
6468 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6469 : ctype, tmp);
6470 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6471 : tmp, tmp2);
6472 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6473 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6474 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6475 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6476 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6477 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6478 : cond, tmp);
6479 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6480 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6481 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6482 : cond, tmp);
6483 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6484 : type, kind);
6485 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6486 : ctype, tmp);
6487 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6488 : tmp, tmp2);
6489 54 : gfc_add_expr_to_block (&block2, tmp2);
6490 : }
6491 :
6492 6356 : if (e->rank != 0)
6493 : {
6494 : /* Loop: for (i = 0; i < rank; ++i). */
6495 5735 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6496 : /* Loop body. */
6497 5735 : stmtblock_t loop_body;
6498 5735 : gfc_init_block (&loop_body);
6499 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6500 : ? gfc->dim[i].lbound : 0 */
6501 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6502 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6503 : else
6504 5087 : tmp = gfc_index_zero_node;
6505 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6506 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6507 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6508 : gfc_conv_descriptor_ubound_get (gfc, idx),
6509 : gfc_conv_descriptor_lbound_get (gfc, idx));
6510 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6511 : tmp, gfc_index_one_node);
6512 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6513 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6514 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6515 : gfc_conv_descriptor_stride_get (gfc, idx),
6516 : gfc_conv_descriptor_span_get (gfc));
6517 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6518 :
6519 : /* Generate loop. */
6520 5735 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6521 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6522 :
6523 5735 : if (e->expr_type == EXPR_VARIABLE
6524 5573 : && e->ref
6525 5573 : && e->ref->u.ar.type == AR_FULL
6526 2732 : && e->symtree->n.sym->attr.dummy
6527 988 : && e->symtree->n.sym->as
6528 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6529 : {
6530 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6531 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6532 : }
6533 : }
6534 :
6535 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6536 : {
6537 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6538 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6539 : tmp, null_pointer_node);
6540 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6541 : build_empty_stmt (input_location));
6542 1015 : gfc_add_expr_to_block (&block, tmp);
6543 : }
6544 : else
6545 5341 : gfc_add_block_to_block (&block, &block2);
6546 :
6547 :
6548 6537 : done:
6549 6537 : if (present)
6550 : {
6551 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6552 103 : TREE_TYPE (parmse->expr),
6553 : present, parmse->expr, null_pointer_node);
6554 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6555 : build_empty_stmt (input_location));
6556 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6557 : }
6558 : else
6559 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6560 :
6561 6537 : gfc_init_block (&block);
6562 :
6563 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6564 1196 : || fsym->attr.intent == INTENT_IN)
6565 5550 : goto post_call;
6566 :
6567 987 : gfc_init_block (&block2);
6568 987 : if (e->rank == 0)
6569 : {
6570 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6571 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6572 : }
6573 : else
6574 : {
6575 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6576 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6577 :
6578 559 : if (fsym->attr.allocatable)
6579 : {
6580 : /* gfc->span = cfi->elem_len. */
6581 252 : tmp = fold_convert (gfc_array_index_type,
6582 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6583 : }
6584 : else
6585 : {
6586 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6587 : ? cfi->dim[0].sm : cfi->elem_len). */
6588 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6589 307 : tmp2 = fold_convert (gfc_array_index_type,
6590 : gfc_get_cfi_desc_elem_len (cfi));
6591 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6592 : gfc_array_index_type, tmp, tmp2);
6593 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6594 : tmp, gfc_index_zero_node);
6595 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6596 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6597 : }
6598 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6599 :
6600 : /* Calculate offset + set lbound, ubound and stride. */
6601 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6602 : /* Loop: for (i = 0; i < rank; ++i). */
6603 559 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6604 : /* Loop body. */
6605 559 : stmtblock_t loop_body;
6606 559 : gfc_init_block (&loop_body);
6607 : /* gfc->dim[i].lbound = ... */
6608 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6609 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6610 :
6611 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6612 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6613 : gfc_conv_descriptor_lbound_get (gfc, idx),
6614 : gfc_index_one_node);
6615 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6616 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6617 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6618 :
6619 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6620 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6621 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6622 : gfc_array_index_type, tmp,
6623 : fold_convert (gfc_array_index_type,
6624 : gfc_get_cfi_desc_elem_len (cfi)));
6625 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6626 :
6627 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6628 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6629 : gfc_conv_descriptor_stride_get (gfc, idx),
6630 : gfc_conv_descriptor_lbound_get (gfc, idx));
6631 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6632 : gfc_conv_descriptor_offset_get (gfc), tmp);
6633 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6634 : /* Generate loop. */
6635 559 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6636 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6637 : }
6638 :
6639 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6640 : {
6641 60 : tmp = fold_convert (gfc_charlen_type_node,
6642 : gfc_get_cfi_desc_elem_len (cfi));
6643 60 : if (e->ts.kind != 1)
6644 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6645 : gfc_charlen_type_node, tmp,
6646 : build_int_cst (gfc_charlen_type_node,
6647 24 : e->ts.kind));
6648 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6649 : }
6650 :
6651 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6652 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6653 : tmp, null_pointer_node);
6654 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6655 : build_empty_stmt (input_location));
6656 987 : gfc_add_expr_to_block (&block, tmp);
6657 :
6658 6537 : post_call:
6659 6537 : gfc_add_block_to_block (&block, &se.post);
6660 6537 : if (present && block.head)
6661 : {
6662 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6663 : build_empty_stmt (input_location));
6664 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6665 : }
6666 6531 : else if (block.head)
6667 1564 : gfc_add_block_to_block (&parmse->post, &block);
6668 6537 : }
6669 :
6670 :
6671 : /* Create "conditional temporary" to handle scalar dummy variables with the
6672 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6673 : as fallback. Does not handle CLASS. */
6674 :
6675 : static void
6676 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6677 : {
6678 234 : tree temp;
6679 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6680 234 : gcc_assert (e->rank == 0);
6681 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6682 234 : TREE_STATIC (temp) = 1;
6683 234 : TREE_CONSTANT (temp) = 1;
6684 234 : TREE_READONLY (temp) = 1;
6685 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6686 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6687 234 : TREE_TYPE (parmse->expr),
6688 : cond, parmse->expr, temp);
6689 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6690 234 : }
6691 :
6692 :
6693 : /* Returns true if the type specified in TS is a character type whose length
6694 : is constant. Otherwise returns false. */
6695 :
6696 : static bool
6697 22115 : gfc_const_length_character_type_p (gfc_typespec *ts)
6698 : {
6699 22115 : return (ts->type == BT_CHARACTER
6700 467 : && ts->u.cl
6701 467 : && ts->u.cl->length
6702 467 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6703 22582 : && ts->u.cl->length->ts.type == BT_INTEGER);
6704 : }
6705 :
6706 :
6707 : /* Helper function for the handling of (currently) scalar dummy variables
6708 : with the VALUE attribute. Argument parmse should already be set up. */
6709 : static void
6710 22548 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6711 : vec<tree, va_gc> *& optionalargs)
6712 : {
6713 22548 : tree tmp;
6714 :
6715 22548 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6716 :
6717 22548 : if (IS_PDT (e))
6718 : {
6719 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6720 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6721 6 : gfc_add_expr_to_block (&parmse->pre,
6722 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6723 : parmse->expr, tmp,
6724 : e->rank, 0));
6725 6 : parmse->expr = tmp;
6726 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6727 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6728 6 : return;
6729 : }
6730 :
6731 : /* Absent actual argument for optional scalar dummy. */
6732 22542 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6733 : {
6734 : /* For scalar arguments with VALUE attribute which are passed by
6735 : value, pass "0" and a hidden argument for the optional status. */
6736 427 : if (fsym->ts.type == BT_CHARACTER)
6737 : {
6738 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6739 : zero. */
6740 90 : parmse->expr = null_pointer_node;
6741 90 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6742 : }
6743 337 : else if (gfc_bt_struct (fsym->ts.type)
6744 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6745 : {
6746 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6747 : are pointers and passed as such below. */
6748 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6749 24 : TREE_CONSTANT (temp) = 1;
6750 24 : TREE_READONLY (temp) = 1;
6751 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6752 24 : parmse->expr = temp;
6753 24 : }
6754 : else
6755 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6756 : integer_zero_node);
6757 427 : vec_safe_push (optionalargs, boolean_false_node);
6758 :
6759 427 : return;
6760 : }
6761 :
6762 : /* Truncate a too long constant character actual argument. */
6763 22115 : if (gfc_const_length_character_type_p (&fsym->ts)
6764 467 : && e->expr_type == EXPR_CONSTANT
6765 22198 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6766 : e->value.character.length) < 0)
6767 : {
6768 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6769 :
6770 : /* Truncate actual string argument. */
6771 17 : gfc_conv_expr (parmse, e);
6772 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6773 17 : e->value.character.string);
6774 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6775 :
6776 17 : if (flen == 1)
6777 : {
6778 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6779 14 : gfc_conv_string_parameter (parmse);
6780 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6781 : e->ts.kind);
6782 : }
6783 :
6784 : /* Indicate value,optional scalar dummy argument as present. */
6785 17 : if (fsym->attr.optional)
6786 1 : vec_safe_push (optionalargs, boolean_true_node);
6787 17 : return;
6788 : }
6789 :
6790 : /* gfortran argument passing conventions:
6791 : actual arguments to CHARACTER(len=1),VALUE
6792 : dummy arguments are actually passed by value.
6793 : Strings are truncated to length 1. */
6794 22098 : if (gfc_length_one_character_type_p (&fsym->ts))
6795 : {
6796 378 : if (e->expr_type == EXPR_CONSTANT
6797 54 : && e->value.character.length > 1)
6798 : {
6799 0 : e->value.character.length = 1;
6800 0 : gfc_conv_expr (parmse, e);
6801 : }
6802 :
6803 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6804 378 : gfc_conv_string_parameter (parmse);
6805 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6806 : e->ts.kind);
6807 : /* Truncate resulting string to length 1. */
6808 378 : parmse->string_length = slen1;
6809 : }
6810 :
6811 22098 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6812 : {
6813 : /* F2018:15.5.2.12 Argument presence and
6814 : restrictions on arguments not present. */
6815 823 : if (e->expr_type == EXPR_VARIABLE
6816 650 : && e->rank == 0
6817 1419 : && (gfc_expr_attr (e).allocatable
6818 482 : || gfc_expr_attr (e).pointer))
6819 : {
6820 198 : gfc_se argse;
6821 198 : tree cond;
6822 198 : gfc_init_se (&argse, NULL);
6823 198 : argse.want_pointer = 1;
6824 198 : gfc_conv_expr (&argse, e);
6825 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6826 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6827 : argse.expr, cond);
6828 198 : if (e->symtree->n.sym->attr.dummy)
6829 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6830 : logical_type_node,
6831 : gfc_conv_expr_present (e->symtree->n.sym),
6832 : cond);
6833 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
6834 : /* Create "conditional temporary". */
6835 198 : conv_cond_temp (parmse, e, cond);
6836 : }
6837 625 : else if (e->expr_type != EXPR_VARIABLE
6838 452 : || !e->symtree->n.sym->attr.optional
6839 260 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6840 365 : vec_safe_push (optionalargs, boolean_true_node);
6841 : else
6842 : {
6843 260 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6844 260 : if (gfc_bt_struct (fsym->ts.type)
6845 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6846 36 : conv_cond_temp (parmse, e, tmp);
6847 224 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6848 84 : parmse->expr
6849 168 : = fold_build3_loc (input_location, COND_EXPR,
6850 84 : TREE_TYPE (parmse->expr),
6851 : tmp, parmse->expr,
6852 84 : fold_convert (TREE_TYPE (parmse->expr),
6853 : integer_zero_node));
6854 :
6855 520 : vec_safe_push (optionalargs,
6856 260 : fold_convert (boolean_type_node, tmp));
6857 : }
6858 : }
6859 : }
6860 :
6861 :
6862 : /* Helper function for the handling of NULL() actual arguments associated with
6863 : non-optional dummy variables. Argument parmse should already be set up. */
6864 : static void
6865 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
6866 : {
6867 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
6868 :
6869 : /* Obtain the character length for a NULL() actual with a character
6870 : MOLD argument. Otherwise substitute a suitable dummy length.
6871 : Here we handle only non-optional dummies of non-bind(c) procedures. */
6872 426 : if (fsym->ts.type == BT_CHARACTER)
6873 : {
6874 216 : if (e->ts.type == BT_CHARACTER
6875 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
6876 : {
6877 : /* MOLD is present. Substitute a temporary character NULL pointer.
6878 : For an assumed-rank dummy we need a descriptor that passes the
6879 : correct rank. */
6880 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
6881 : {
6882 54 : tree rank;
6883 54 : tree tmp = parmse->expr;
6884 54 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6885 54 : rank = gfc_conv_descriptor_rank (tmp);
6886 54 : gfc_add_modify (&parmse->pre, rank,
6887 54 : build_int_cst (TREE_TYPE (rank), e->rank));
6888 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6889 54 : }
6890 : else
6891 : {
6892 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
6893 108 : gfc_add_modify (&parmse->pre, tmp,
6894 108 : build_zero_cst (TREE_TYPE (tmp)));
6895 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6896 : }
6897 :
6898 : /* Ensure that a usable length is available. */
6899 162 : if (parmse->string_length == NULL_TREE)
6900 : {
6901 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
6902 :
6903 162 : if (ts->u.cl->length != NULL
6904 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6905 108 : gfc_conv_const_charlen (ts->u.cl);
6906 :
6907 162 : if (ts->u.cl->backend_decl)
6908 162 : parmse->string_length = ts->u.cl->backend_decl;
6909 : }
6910 : }
6911 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
6912 : {
6913 : /* MOLD is not present. Pass length of associated dummy character
6914 : argument if constant, or zero. */
6915 54 : if (fsym->ts.u.cl->length != NULL
6916 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6917 : {
6918 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
6919 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
6920 : }
6921 : else
6922 : {
6923 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
6924 : "slen");
6925 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
6926 : build_zero_cst (gfc_charlen_type_node));
6927 : }
6928 : }
6929 : }
6930 210 : else if (fsym->ts.type == BT_DERIVED)
6931 : {
6932 210 : if (e->ts.type != BT_UNKNOWN)
6933 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
6934 : For an assumed-rank dummy we provide a descriptor that passes
6935 : the correct rank. */
6936 : {
6937 138 : tree rank;
6938 138 : tree tmp = parmse->expr;
6939 :
6940 138 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, gfc_expr_attr (e));
6941 138 : rank = gfc_conv_descriptor_rank (tmp);
6942 138 : gfc_add_modify (&parmse->pre, rank,
6943 138 : build_int_cst (TREE_TYPE (rank), e->rank));
6944 138 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6945 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6946 : }
6947 : else
6948 : /* MOLD is not present. Use attributes from dummy argument, which is
6949 : not allowed to be assumed-rank. */
6950 : {
6951 72 : int dummy_rank;
6952 72 : tree tmp = parmse->expr;
6953 :
6954 72 : if ((fsym->attr.allocatable || fsym->attr.pointer)
6955 72 : && fsym->attr.intent == INTENT_UNKNOWN)
6956 36 : fsym->attr.intent = INTENT_IN;
6957 72 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6958 72 : dummy_rank = fsym->as ? fsym->as->rank : 0;
6959 24 : if (dummy_rank > 0)
6960 : {
6961 24 : tree rank = gfc_conv_descriptor_rank (tmp);
6962 24 : gfc_add_modify (&parmse->pre, rank,
6963 24 : build_int_cst (TREE_TYPE (rank), dummy_rank));
6964 : }
6965 72 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6966 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6967 : }
6968 : }
6969 426 : }
6970 :
6971 :
6972 : /* Generate code for a procedure call. Note can return se->post != NULL.
6973 : If se->direct_byref is set then se->expr contains the return parameter.
6974 : Return nonzero, if the call has alternate specifiers.
6975 : 'expr' is only needed for procedure pointer components. */
6976 :
6977 : int
6978 136398 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6979 : gfc_actual_arglist * args, gfc_expr * expr,
6980 : vec<tree, va_gc> *append_args)
6981 : {
6982 136398 : gfc_interface_mapping mapping;
6983 136398 : vec<tree, va_gc> *arglist;
6984 136398 : vec<tree, va_gc> *retargs;
6985 136398 : tree tmp;
6986 136398 : tree fntype;
6987 136398 : gfc_se parmse;
6988 136398 : gfc_array_info *info;
6989 136398 : int byref;
6990 136398 : int parm_kind;
6991 136398 : tree type;
6992 136398 : tree var;
6993 136398 : tree len;
6994 136398 : tree base_object;
6995 136398 : vec<tree, va_gc> *stringargs;
6996 136398 : vec<tree, va_gc> *optionalargs;
6997 136398 : tree result = NULL;
6998 136398 : gfc_formal_arglist *formal;
6999 136398 : gfc_actual_arglist *arg;
7000 136398 : int has_alternate_specifier = 0;
7001 136398 : bool need_interface_mapping;
7002 136398 : bool is_builtin;
7003 136398 : bool callee_alloc;
7004 136398 : bool ulim_copy;
7005 136398 : gfc_typespec ts;
7006 136398 : gfc_charlen cl;
7007 136398 : gfc_expr *e;
7008 136398 : gfc_symbol *fsym;
7009 136398 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
7010 136398 : gfc_component *comp = NULL;
7011 136398 : int arglen;
7012 136398 : unsigned int argc;
7013 136398 : tree arg1_cntnr = NULL_TREE;
7014 136398 : arglist = NULL;
7015 136398 : retargs = NULL;
7016 136398 : stringargs = NULL;
7017 136398 : optionalargs = NULL;
7018 136398 : var = NULL_TREE;
7019 136398 : len = NULL_TREE;
7020 136398 : gfc_clear_ts (&ts);
7021 136398 : gfc_intrinsic_sym *isym = expr && expr->rank ?
7022 : expr->value.function.isym : NULL;
7023 :
7024 136398 : comp = gfc_get_proc_ptr_comp (expr);
7025 :
7026 272796 : bool elemental_proc = (comp
7027 2043 : && comp->ts.interface
7028 1989 : && comp->ts.interface->attr.elemental)
7029 1844 : || (comp && comp->attr.elemental)
7030 138242 : || sym->attr.elemental;
7031 :
7032 136398 : if (se->ss != NULL)
7033 : {
7034 25053 : if (!elemental_proc)
7035 : {
7036 21494 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
7037 21494 : if (se->ss->info->useflags)
7038 : {
7039 5778 : gcc_assert ((!comp && gfc_return_by_reference (sym)
7040 : && sym->result->attr.dimension)
7041 : || (comp && comp->attr.dimension)
7042 : || gfc_is_class_array_function (expr));
7043 5778 : gcc_assert (se->loop != NULL);
7044 : /* Access the previously obtained result. */
7045 5778 : gfc_conv_tmp_array_ref (se);
7046 5778 : return 0;
7047 : }
7048 : }
7049 19275 : info = &se->ss->info->data.array;
7050 : }
7051 : else
7052 : info = NULL;
7053 :
7054 130620 : stmtblock_t post, clobbers, dealloc_blk;
7055 130620 : gfc_init_block (&post);
7056 130620 : gfc_init_block (&clobbers);
7057 130620 : gfc_init_block (&dealloc_blk);
7058 130620 : gfc_init_interface_mapping (&mapping);
7059 130620 : if (!comp)
7060 : {
7061 128626 : formal = gfc_sym_get_dummy_args (sym);
7062 128626 : need_interface_mapping = sym->attr.dimension ||
7063 113162 : (sym->ts.type == BT_CHARACTER
7064 3180 : && sym->ts.u.cl->length
7065 2434 : && sym->ts.u.cl->length->expr_type
7066 : != EXPR_CONSTANT);
7067 : }
7068 : else
7069 : {
7070 1994 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
7071 1994 : need_interface_mapping = comp->attr.dimension ||
7072 1925 : (comp->ts.type == BT_CHARACTER
7073 229 : && comp->ts.u.cl->length
7074 220 : && comp->ts.u.cl->length->expr_type
7075 : != EXPR_CONSTANT);
7076 : }
7077 :
7078 130620 : base_object = NULL_TREE;
7079 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7080 : is the third and fourth argument to such a function call a value
7081 : denoting the number of elements to copy (i.e., most of the time the
7082 : length of a deferred length string). */
7083 261240 : ulim_copy = (formal == NULL)
7084 31956 : && UNLIMITED_POLY (sym)
7085 130700 : && comp && (strcmp ("_copy", comp->name) == 0);
7086 :
7087 : /* Scan for allocatable actual arguments passed to allocatable dummy
7088 : arguments with INTENT(OUT). As the corresponding actual arguments are
7089 : deallocated before execution of the procedure, we evaluate actual
7090 : argument expressions to avoid problems with possible dependencies. */
7091 130620 : bool force_eval_args = false;
7092 130620 : gfc_formal_arglist *tmp_formal;
7093 401376 : for (arg = args, tmp_formal = formal; arg != NULL;
7094 237430 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7095 : {
7096 271257 : e = arg->expr;
7097 271257 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7098 257841 : if (e && fsym
7099 225942 : && e->expr_type == EXPR_VARIABLE
7100 99252 : && fsym->attr.intent == INTENT_OUT
7101 6337 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7102 6337 : ? CLASS_DATA (fsym)->attr.allocatable
7103 4809 : : fsym->attr.allocatable)
7104 501 : && e->symtree
7105 501 : && e->symtree->n.sym
7106 529098 : && gfc_variable_attr (e, NULL).allocatable)
7107 : {
7108 : force_eval_args = true;
7109 : break;
7110 : }
7111 : }
7112 :
7113 : /* Evaluate the arguments. */
7114 402279 : for (arg = args, argc = 0; arg != NULL;
7115 271659 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7116 : {
7117 271659 : bool finalized = false;
7118 271659 : tree derived_array = NULL_TREE;
7119 271659 : symbol_attribute *attr;
7120 :
7121 271659 : e = arg->expr;
7122 271659 : fsym = formal ? formal->sym : NULL;
7123 509992 : parm_kind = MISSING;
7124 :
7125 238333 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7126 : : fsym->attr)
7127 : : nullptr;
7128 : /* If the procedure requires an explicit interface, the actual
7129 : argument is passed according to the corresponding formal
7130 : argument. If the corresponding formal argument is a POINTER,
7131 : ALLOCATABLE or assumed shape, we do not use g77's calling
7132 : convention, and pass the address of the array descriptor
7133 : instead. Otherwise we use g77's calling convention, in other words
7134 : pass the array data pointer without descriptor. */
7135 238280 : bool nodesc_arg = fsym != NULL
7136 238280 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7137 229182 : && fsym->as
7138 40894 : && fsym->as->type != AS_ASSUMED_SHAPE
7139 24762 : && fsym->as->type != AS_ASSUMED_RANK;
7140 271659 : if (comp)
7141 2749 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7142 : else
7143 268910 : nodesc_arg
7144 : = nodesc_arg
7145 268910 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7146 :
7147 : /* Class array expressions are sometimes coming completely unadorned
7148 : with either arrayspec or _data component. Correct that here.
7149 : OOP-TODO: Move this to the frontend. */
7150 271659 : if (e && e->expr_type == EXPR_VARIABLE
7151 113357 : && !e->ref
7152 51596 : && e->ts.type == BT_CLASS
7153 2609 : && (CLASS_DATA (e)->attr.codimension
7154 2609 : || CLASS_DATA (e)->attr.dimension))
7155 : {
7156 0 : gfc_typespec temp_ts = e->ts;
7157 0 : gfc_add_class_array_ref (e);
7158 0 : e->ts = temp_ts;
7159 : }
7160 :
7161 271659 : if (e == NULL
7162 258237 : || (e->expr_type == EXPR_NULL
7163 745 : && fsym
7164 745 : && fsym->attr.value
7165 72 : && fsym->attr.optional
7166 72 : && !fsym->attr.dimension
7167 72 : && fsym->ts.type != BT_CLASS))
7168 : {
7169 13494 : if (se->ignore_optional)
7170 : {
7171 : /* Some intrinsics have already been resolved to the correct
7172 : parameters. */
7173 632 : continue;
7174 : }
7175 13296 : else if (arg->label)
7176 : {
7177 224 : has_alternate_specifier = 1;
7178 224 : continue;
7179 : }
7180 : else
7181 : {
7182 13072 : gfc_init_se (&parmse, NULL);
7183 :
7184 : /* For scalar arguments with VALUE attribute which are passed by
7185 : value, pass "0" and a hidden argument gives the optional
7186 : status. */
7187 13072 : if (fsym && fsym->attr.optional && fsym->attr.value
7188 427 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7189 : {
7190 427 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7191 : }
7192 : else
7193 : {
7194 : /* Pass a NULL pointer for an absent arg. */
7195 12645 : parmse.expr = null_pointer_node;
7196 :
7197 : /* Is it an absent character dummy? */
7198 12645 : bool absent_char = false;
7199 12645 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7200 :
7201 : /* Fall back to inferred type only if no formal. */
7202 12645 : if (fsym)
7203 11587 : absent_char = (fsym->ts.type == BT_CHARACTER);
7204 1058 : else if (dummy_arg)
7205 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7206 : == BT_CHARACTER);
7207 12645 : if (absent_char)
7208 1115 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7209 : 0);
7210 : }
7211 : }
7212 : }
7213 258165 : else if (e->expr_type == EXPR_NULL
7214 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7215 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7216 293 : && fsym->ts.type == BT_DERIVED)
7217 : {
7218 210 : gfc_init_se (&parmse, NULL);
7219 210 : gfc_conv_expr_reference (&parmse, e);
7220 210 : conv_null_actual (&parmse, e, fsym);
7221 : }
7222 257955 : else if (arg->expr->expr_type == EXPR_NULL
7223 463 : && fsym && !fsym->attr.pointer
7224 163 : && (fsym->ts.type != BT_CLASS
7225 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7226 : {
7227 : /* Pass a NULL pointer to denote an absent arg. */
7228 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7229 : && (fsym->ts.type != BT_CLASS
7230 : || !CLASS_DATA (fsym)->attr.allocatable));
7231 163 : gfc_init_se (&parmse, NULL);
7232 163 : parmse.expr = null_pointer_node;
7233 163 : if (fsym->ts.type == BT_CHARACTER)
7234 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7235 : }
7236 257792 : else if (fsym && fsym->ts.type == BT_CLASS
7237 11273 : && e->ts.type == BT_DERIVED)
7238 : {
7239 : /* The derived type needs to be converted to a temporary
7240 : CLASS object. */
7241 4718 : gfc_init_se (&parmse, se);
7242 4718 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7243 4718 : fsym->attr.optional
7244 1008 : && e->expr_type == EXPR_VARIABLE
7245 5726 : && e->symtree->n.sym->attr.optional,
7246 4718 : CLASS_DATA (fsym)->attr.class_pointer
7247 4718 : || CLASS_DATA (fsym)->attr.allocatable,
7248 : sym->name, &derived_array);
7249 : }
7250 221175 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7251 906 : && e->ts.type != BT_PROCEDURE
7252 882 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7253 12 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7254 : {
7255 : /* The intrinsic type needs to be converted to a temporary
7256 : CLASS object for the unlimited polymorphic formal. */
7257 882 : gfc_find_vtab (&e->ts);
7258 882 : gfc_init_se (&parmse, se);
7259 882 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7260 :
7261 : }
7262 252192 : else if (se->ss && se->ss->info->useflags)
7263 : {
7264 5837 : gfc_ss *ss;
7265 :
7266 5837 : ss = se->ss;
7267 :
7268 : /* An elemental function inside a scalarized loop. */
7269 5837 : gfc_init_se (&parmse, se);
7270 5837 : parm_kind = ELEMENTAL;
7271 :
7272 : /* When no fsym is present, ulim_copy is set and this is a third or
7273 : fourth argument, use call-by-value instead of by reference to
7274 : hand the length properties to the copy routine (i.e., most of the
7275 : time this will be a call to a __copy_character_* routine where the
7276 : third and fourth arguments are the lengths of a deferred length
7277 : char array). */
7278 5837 : if ((fsym && fsym->attr.value)
7279 5603 : || (ulim_copy && (argc == 2 || argc == 3)))
7280 234 : gfc_conv_expr (&parmse, e);
7281 5603 : else if (e->expr_type == EXPR_ARRAY)
7282 : {
7283 306 : gfc_conv_expr (&parmse, e);
7284 306 : if (e->ts.type != BT_CHARACTER)
7285 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7286 : }
7287 : else
7288 5297 : gfc_conv_expr_reference (&parmse, e);
7289 :
7290 5837 : if (e->ts.type == BT_CHARACTER && !e->rank
7291 174 : && e->expr_type == EXPR_FUNCTION)
7292 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7293 : parmse.expr);
7294 :
7295 5787 : if (fsym && fsym->ts.type == BT_DERIVED
7296 7459 : && gfc_is_class_container_ref (e))
7297 : {
7298 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7299 :
7300 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7301 24 : && e->symtree->n.sym->attr.optional)
7302 : {
7303 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7304 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7305 0 : TREE_TYPE (parmse.expr),
7306 : cond, parmse.expr,
7307 0 : fold_convert (TREE_TYPE (parmse.expr),
7308 : null_pointer_node));
7309 : }
7310 : }
7311 :
7312 : /* Scalar dummy arguments of intrinsic type or derived type with
7313 : VALUE attribute. */
7314 5837 : if (fsym
7315 5787 : && fsym->attr.value
7316 234 : && fsym->ts.type != BT_CLASS)
7317 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7318 :
7319 : /* If we are passing an absent array as optional dummy to an
7320 : elemental procedure, make sure that we pass NULL when the data
7321 : pointer is NULL. We need this extra conditional because of
7322 : scalarization which passes arrays elements to the procedure,
7323 : ignoring the fact that the array can be absent/unallocated/... */
7324 5603 : else if (ss->info->can_be_null_ref
7325 415 : && ss->info->type != GFC_SS_REFERENCE)
7326 : {
7327 193 : tree descriptor_data;
7328 :
7329 193 : descriptor_data = ss->info->data.array.data;
7330 193 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7331 : descriptor_data,
7332 193 : fold_convert (TREE_TYPE (descriptor_data),
7333 : null_pointer_node));
7334 193 : parmse.expr
7335 386 : = fold_build3_loc (input_location, COND_EXPR,
7336 193 : TREE_TYPE (parmse.expr),
7337 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7338 193 : fold_convert (TREE_TYPE (parmse.expr),
7339 : null_pointer_node),
7340 : parmse.expr);
7341 : }
7342 :
7343 : /* The scalarizer does not repackage the reference to a class
7344 : array - instead it returns a pointer to the data element. */
7345 5837 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7346 186 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7347 186 : fsym->attr.intent != INTENT_IN
7348 186 : && (CLASS_DATA (fsym)->attr.class_pointer
7349 24 : || CLASS_DATA (fsym)->attr.allocatable),
7350 186 : fsym->attr.optional
7351 0 : && e->expr_type == EXPR_VARIABLE
7352 186 : && e->symtree->n.sym->attr.optional,
7353 186 : CLASS_DATA (fsym)->attr.class_pointer
7354 186 : || CLASS_DATA (fsym)->attr.allocatable);
7355 : }
7356 : else
7357 : {
7358 246355 : bool scalar;
7359 246355 : gfc_ss *argss;
7360 :
7361 246355 : gfc_init_se (&parmse, NULL);
7362 :
7363 : /* Check whether the expression is a scalar or not; we cannot use
7364 : e->rank as it can be nonzero for functions arguments. */
7365 246355 : argss = gfc_walk_expr (e);
7366 246355 : scalar = argss == gfc_ss_terminator;
7367 246355 : if (!scalar)
7368 60681 : gfc_free_ss_chain (argss);
7369 :
7370 : /* Special handling for passing scalar polymorphic coarrays;
7371 : otherwise one passes "class->_data.data" instead of "&class". */
7372 246355 : if (e->rank == 0 && e->ts.type == BT_CLASS
7373 3563 : && fsym && fsym->ts.type == BT_CLASS
7374 3141 : && CLASS_DATA (fsym)->attr.codimension
7375 55 : && !CLASS_DATA (fsym)->attr.dimension)
7376 : {
7377 55 : gfc_add_class_array_ref (e);
7378 55 : parmse.want_coarray = 1;
7379 55 : scalar = false;
7380 : }
7381 :
7382 : /* A scalar or transformational function. */
7383 246355 : if (scalar)
7384 : {
7385 185619 : if (e->expr_type == EXPR_VARIABLE
7386 54940 : && e->symtree->n.sym->attr.cray_pointee
7387 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7388 : {
7389 : /* The Cray pointer needs to be converted to a pointer to
7390 : a type given by the expression. */
7391 6 : gfc_conv_expr (&parmse, e);
7392 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7393 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7394 6 : parmse.expr = convert (type, tmp);
7395 : }
7396 :
7397 185613 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7398 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7399 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7400 :
7401 184926 : else if (fsym && fsym->attr.value)
7402 : {
7403 22059 : if (fsym->ts.type == BT_CHARACTER
7404 543 : && fsym->ts.is_c_interop
7405 181 : && fsym->ns->proc_name != NULL
7406 181 : && fsym->ns->proc_name->attr.is_bind_c)
7407 : {
7408 172 : parmse.expr = NULL;
7409 172 : conv_scalar_char_value (fsym, &parmse, &e);
7410 172 : if (parmse.expr == NULL)
7411 166 : gfc_conv_expr (&parmse, e);
7412 : }
7413 : else
7414 : {
7415 21887 : gfc_conv_expr (&parmse, e);
7416 21887 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7417 : }
7418 : }
7419 :
7420 162867 : else if (arg->name && arg->name[0] == '%')
7421 : /* Argument list functions %VAL, %LOC and %REF are signalled
7422 : through arg->name. */
7423 5826 : conv_arglist_function (&parmse, arg->expr, arg->name);
7424 157041 : else if ((e->expr_type == EXPR_FUNCTION)
7425 8305 : && ((e->value.function.esym
7426 2154 : && e->value.function.esym->result->attr.pointer)
7427 8210 : || (!e->value.function.esym
7428 6151 : && e->symtree->n.sym->attr.pointer))
7429 95 : && fsym && fsym->attr.target)
7430 : /* Make sure the function only gets called once. */
7431 8 : gfc_conv_expr_reference (&parmse, e);
7432 157033 : else if (e->expr_type == EXPR_FUNCTION
7433 8297 : && e->symtree->n.sym->result
7434 7262 : && e->symtree->n.sym->result != e->symtree->n.sym
7435 138 : && e->symtree->n.sym->result->attr.proc_pointer)
7436 : {
7437 : /* Functions returning procedure pointers. */
7438 18 : gfc_conv_expr (&parmse, e);
7439 18 : if (fsym && fsym->attr.proc_pointer)
7440 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7441 : }
7442 :
7443 : else
7444 : {
7445 157015 : bool defer_to_dealloc_blk = false;
7446 157015 : if (e->ts.type == BT_CLASS && fsym
7447 3496 : && fsym->ts.type == BT_CLASS
7448 3074 : && (!CLASS_DATA (fsym)->as
7449 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7450 2718 : && CLASS_DATA (e)->attr.codimension)
7451 : {
7452 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7453 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7454 48 : gfc_add_class_array_ref (e);
7455 48 : parmse.want_coarray = 1;
7456 48 : gfc_conv_expr_reference (&parmse, e);
7457 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7458 48 : fsym->attr.optional
7459 48 : && e->expr_type == EXPR_VARIABLE);
7460 : }
7461 156967 : else if (e->ts.type == BT_CLASS && fsym
7462 3448 : && fsym->ts.type == BT_CLASS
7463 3026 : && !CLASS_DATA (fsym)->as
7464 2670 : && !CLASS_DATA (e)->as
7465 2560 : && strcmp (fsym->ts.u.derived->name,
7466 : e->ts.u.derived->name))
7467 : {
7468 1619 : type = gfc_typenode_for_spec (&fsym->ts);
7469 1619 : var = gfc_create_var (type, fsym->name);
7470 1619 : gfc_conv_expr (&parmse, e);
7471 1619 : if (fsym->attr.optional
7472 153 : && e->expr_type == EXPR_VARIABLE
7473 153 : && e->symtree->n.sym->attr.optional)
7474 : {
7475 66 : stmtblock_t block;
7476 66 : tree cond;
7477 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7478 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7479 : logical_type_node, tmp,
7480 66 : fold_convert (TREE_TYPE (tmp),
7481 : null_pointer_node));
7482 66 : gfc_start_block (&block);
7483 66 : gfc_add_modify (&block, var,
7484 : fold_build1_loc (input_location,
7485 : VIEW_CONVERT_EXPR,
7486 : type, parmse.expr));
7487 66 : gfc_add_expr_to_block (&parmse.pre,
7488 : fold_build3_loc (input_location,
7489 : COND_EXPR, void_type_node,
7490 : cond, gfc_finish_block (&block),
7491 : build_empty_stmt (input_location)));
7492 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7493 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7494 66 : TREE_TYPE (parmse.expr),
7495 : cond, parmse.expr,
7496 66 : fold_convert (TREE_TYPE (parmse.expr),
7497 : null_pointer_node));
7498 66 : }
7499 : else
7500 : {
7501 : /* Since the internal representation of unlimited
7502 : polymorphic expressions includes an extra field
7503 : that other class objects do not, a cast to the
7504 : formal type does not work. */
7505 1553 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7506 : {
7507 91 : tree efield;
7508 :
7509 : /* Evaluate arguments just once, when they have
7510 : side effects. */
7511 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7512 : {
7513 25 : tree cldata, zero;
7514 :
7515 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7516 : &parmse.pre);
7517 :
7518 : /* Prevent memory leak, when old component
7519 : was allocated already. */
7520 25 : cldata = gfc_class_data_get (parmse.expr);
7521 25 : zero = build_int_cst (TREE_TYPE (cldata),
7522 : 0);
7523 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7524 : logical_type_node,
7525 : cldata, zero);
7526 25 : tmp = build3_v (COND_EXPR, tmp,
7527 : gfc_call_free (cldata),
7528 : build_empty_stmt (
7529 : input_location));
7530 25 : gfc_add_expr_to_block (&parmse.finalblock,
7531 : tmp);
7532 25 : gfc_add_modify (&parmse.finalblock,
7533 : cldata, zero);
7534 : }
7535 :
7536 : /* Set the _data field. */
7537 91 : tmp = gfc_class_data_get (var);
7538 91 : efield = fold_convert (TREE_TYPE (tmp),
7539 : gfc_class_data_get (parmse.expr));
7540 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7541 :
7542 : /* Set the _vptr field. */
7543 91 : tmp = gfc_class_vptr_get (var);
7544 91 : efield = fold_convert (TREE_TYPE (tmp),
7545 : gfc_class_vptr_get (parmse.expr));
7546 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7547 :
7548 : /* Set the _len field. */
7549 91 : tmp = gfc_class_len_get (var);
7550 91 : gfc_add_modify (&parmse.pre, tmp,
7551 91 : build_int_cst (TREE_TYPE (tmp), 0));
7552 91 : }
7553 : else
7554 : {
7555 1462 : tmp = fold_build1_loc (input_location,
7556 : VIEW_CONVERT_EXPR,
7557 : type, parmse.expr);
7558 1462 : gfc_add_modify (&parmse.pre, var, tmp);
7559 1553 : ;
7560 : }
7561 1553 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7562 : }
7563 : }
7564 : else
7565 : {
7566 155348 : gfc_conv_expr_reference (&parmse, e);
7567 :
7568 155348 : gfc_symbol *dsym = fsym;
7569 155348 : gfc_dummy_arg *dummy;
7570 :
7571 : /* Use associated dummy as fallback for formal
7572 : argument if there is no explicit interface. */
7573 155348 : if (dsym == NULL
7574 27416 : && (dummy = arg->associated_dummy)
7575 24889 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7576 178830 : && dummy->u.non_intrinsic->sym)
7577 : dsym = dummy->u.non_intrinsic->sym;
7578 :
7579 155348 : if (dsym
7580 151414 : && dsym->attr.intent == INTENT_OUT
7581 3266 : && !dsym->attr.allocatable
7582 3124 : && !dsym->attr.pointer
7583 3106 : && e->expr_type == EXPR_VARIABLE
7584 3105 : && e->ref == NULL
7585 2996 : && e->symtree
7586 2996 : && e->symtree->n.sym
7587 2996 : && !e->symtree->n.sym->attr.dimension
7588 2996 : && e->ts.type != BT_CHARACTER
7589 2894 : && e->ts.type != BT_CLASS
7590 2664 : && (e->ts.type != BT_DERIVED
7591 492 : || (dsym->ts.type == BT_DERIVED
7592 492 : && e->ts.u.derived == dsym->ts.u.derived
7593 : /* Types with allocatable components are
7594 : excluded from clobbering because we need
7595 : the unclobbered pointers to free the
7596 : allocatable components in the callee.
7597 : Same goes for finalizable types or types
7598 : with finalizable components, we need to
7599 : pass the unclobbered values to the
7600 : finalization routines.
7601 : For parameterized types, it's less clear
7602 : but they may not have a constant size
7603 : so better exclude them in any case. */
7604 453 : && !e->ts.u.derived->attr.alloc_comp
7605 327 : && !e->ts.u.derived->attr.pdt_type
7606 327 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7607 2457 : && e->ts.type != BT_PROCEDURE
7608 157769 : && !sym->attr.elemental)
7609 : {
7610 1088 : tree var;
7611 1088 : var = build_fold_indirect_ref_loc (input_location,
7612 : parmse.expr);
7613 1088 : tree clobber = build_clobber (TREE_TYPE (var));
7614 1088 : gfc_add_modify (&clobbers, var, clobber);
7615 : }
7616 : }
7617 : /* Catch base objects that are not variables. */
7618 157015 : if (e->ts.type == BT_CLASS
7619 3496 : && e->expr_type != EXPR_VARIABLE
7620 306 : && expr && e == expr->base_expr)
7621 80 : base_object = build_fold_indirect_ref_loc (input_location,
7622 : parmse.expr);
7623 :
7624 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7625 : allocated on entry, it must be deallocated. */
7626 129599 : if (fsym && fsym->attr.intent == INTENT_OUT
7627 3195 : && (fsym->attr.allocatable
7628 3053 : || (fsym->ts.type == BT_CLASS
7629 259 : && CLASS_DATA (fsym)->attr.allocatable))
7630 157306 : && !is_CFI_desc (fsym, NULL))
7631 : {
7632 291 : stmtblock_t block;
7633 291 : tree ptr;
7634 :
7635 291 : defer_to_dealloc_blk = true;
7636 :
7637 291 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7638 : &parmse.pre);
7639 :
7640 291 : if (parmse.class_container != NULL_TREE)
7641 156 : parmse.class_container
7642 156 : = gfc_evaluate_data_ref_now (parmse.class_container,
7643 : &parmse.pre);
7644 :
7645 291 : gfc_init_block (&block);
7646 291 : ptr = parmse.expr;
7647 291 : if (e->ts.type == BT_CLASS)
7648 156 : ptr = gfc_class_data_get (ptr);
7649 :
7650 291 : tree cls = parmse.class_container;
7651 291 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7652 : NULL_TREE, true,
7653 : e, e->ts, cls);
7654 291 : gfc_add_expr_to_block (&block, tmp);
7655 291 : gfc_add_modify (&block, ptr,
7656 291 : fold_convert (TREE_TYPE (ptr),
7657 : null_pointer_node));
7658 :
7659 291 : if (fsym->ts.type == BT_CLASS)
7660 149 : gfc_reset_vptr (&block, nullptr,
7661 : build_fold_indirect_ref (parmse.expr),
7662 149 : fsym->ts.u.derived);
7663 :
7664 291 : if (fsym->attr.optional
7665 42 : && e->expr_type == EXPR_VARIABLE
7666 42 : && e->symtree->n.sym->attr.optional)
7667 : {
7668 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7669 : void_type_node,
7670 18 : gfc_conv_expr_present (e->symtree->n.sym),
7671 : gfc_finish_block (&block),
7672 : build_empty_stmt (input_location));
7673 : }
7674 : else
7675 273 : tmp = gfc_finish_block (&block);
7676 :
7677 291 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7678 : }
7679 :
7680 : /* A class array element needs converting back to be a
7681 : class object, if the formal argument is a class object. */
7682 157015 : if (fsym && fsym->ts.type == BT_CLASS
7683 3098 : && e->ts.type == BT_CLASS
7684 3074 : && ((CLASS_DATA (fsym)->as
7685 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7686 2718 : || CLASS_DATA (e)->attr.dimension))
7687 : {
7688 466 : gfc_se class_se = parmse;
7689 466 : gfc_init_block (&class_se.pre);
7690 466 : gfc_init_block (&class_se.post);
7691 :
7692 466 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7693 466 : fsym->attr.intent != INTENT_IN
7694 466 : && (CLASS_DATA (fsym)->attr.class_pointer
7695 267 : || CLASS_DATA (fsym)->attr.allocatable),
7696 466 : fsym->attr.optional
7697 198 : && e->expr_type == EXPR_VARIABLE
7698 664 : && e->symtree->n.sym->attr.optional,
7699 466 : CLASS_DATA (fsym)->attr.class_pointer
7700 466 : || CLASS_DATA (fsym)->attr.allocatable);
7701 :
7702 466 : parmse.expr = class_se.expr;
7703 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7704 466 : ? &dealloc_blk
7705 : : &parmse.pre;
7706 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7707 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7708 : }
7709 :
7710 129599 : if (fsym && (fsym->ts.type == BT_DERIVED
7711 117665 : || fsym->ts.type == BT_ASSUMED)
7712 12573 : && e->ts.type == BT_CLASS
7713 410 : && !CLASS_DATA (e)->attr.dimension
7714 374 : && !CLASS_DATA (e)->attr.codimension)
7715 : {
7716 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7717 : /* The result is a class temporary, whose _data component
7718 : must be freed to avoid a memory leak. */
7719 374 : if (e->expr_type == EXPR_FUNCTION
7720 23 : && CLASS_DATA (e)->attr.allocatable)
7721 : {
7722 19 : tree zero;
7723 :
7724 : /* Finalize the expression. */
7725 19 : gfc_finalize_tree_expr (&parmse, NULL,
7726 19 : gfc_expr_attr (e), e->rank);
7727 19 : gfc_add_block_to_block (&parmse.post,
7728 : &parmse.finalblock);
7729 :
7730 : /* Then free the class _data. */
7731 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7732 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7733 : logical_type_node,
7734 : parmse.expr, zero);
7735 19 : tmp = build3_v (COND_EXPR, tmp,
7736 : gfc_call_free (parmse.expr),
7737 : build_empty_stmt (input_location));
7738 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7739 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7740 : }
7741 : }
7742 :
7743 : /* Wrap scalar variable in a descriptor. We need to convert
7744 : the address of a pointer back to the pointer itself before,
7745 : we can assign it to the data field. */
7746 :
7747 129599 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7748 1338 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7749 : {
7750 1266 : tmp = parmse.expr;
7751 1266 : if (TREE_CODE (tmp) == ADDR_EXPR)
7752 748 : tmp = TREE_OPERAND (tmp, 0);
7753 1266 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7754 : fsym->attr);
7755 1266 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
7756 : parmse.expr);
7757 : }
7758 128333 : else if (fsym && e->expr_type != EXPR_NULL
7759 128035 : && ((fsym->attr.pointer
7760 1740 : && fsym->attr.flavor != FL_PROCEDURE)
7761 126301 : || (fsym->attr.proc_pointer
7762 199 : && !(e->expr_type == EXPR_VARIABLE
7763 199 : && e->symtree->n.sym->attr.dummy))
7764 126114 : || (fsym->attr.proc_pointer
7765 12 : && e->expr_type == EXPR_VARIABLE
7766 12 : && gfc_is_proc_ptr_comp (e))
7767 126108 : || (fsym->attr.allocatable
7768 1040 : && fsym->attr.flavor != FL_PROCEDURE)))
7769 : {
7770 : /* Scalar pointer dummy args require an extra level of
7771 : indirection. The null pointer already contains
7772 : this level of indirection. */
7773 2961 : parm_kind = SCALAR_POINTER;
7774 2961 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7775 : }
7776 : }
7777 : }
7778 60736 : else if (e->ts.type == BT_CLASS
7779 2723 : && fsym && fsym->ts.type == BT_CLASS
7780 2377 : && (CLASS_DATA (fsym)->attr.dimension
7781 55 : || CLASS_DATA (fsym)->attr.codimension))
7782 : {
7783 : /* Pass a class array. */
7784 2377 : gfc_conv_expr_descriptor (&parmse, e);
7785 2377 : bool defer_to_dealloc_blk = false;
7786 :
7787 2377 : if (fsym->attr.optional
7788 798 : && e->expr_type == EXPR_VARIABLE
7789 798 : && e->symtree->n.sym->attr.optional)
7790 : {
7791 438 : stmtblock_t block;
7792 :
7793 438 : gfc_init_block (&block);
7794 438 : gfc_add_block_to_block (&block, &parmse.pre);
7795 :
7796 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
7797 : void_type_node,
7798 438 : gfc_conv_expr_present (e->symtree->n.sym),
7799 : gfc_finish_block (&block),
7800 : build_empty_stmt (input_location));
7801 :
7802 438 : gfc_add_expr_to_block (&parmse.pre, t);
7803 : }
7804 :
7805 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7806 : allocated on entry, it must be deallocated. */
7807 2377 : if (fsym->attr.intent == INTENT_OUT
7808 141 : && CLASS_DATA (fsym)->attr.allocatable)
7809 : {
7810 110 : stmtblock_t block;
7811 110 : tree ptr;
7812 :
7813 : /* In case the data reference to deallocate is dependent on
7814 : its own content, save the resulting pointer to a variable
7815 : and only use that variable from now on, before the
7816 : expression becomes invalid. */
7817 110 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7818 : &parmse.pre);
7819 :
7820 110 : if (parmse.class_container != NULL_TREE)
7821 110 : parmse.class_container
7822 110 : = gfc_evaluate_data_ref_now (parmse.class_container,
7823 : &parmse.pre);
7824 :
7825 110 : gfc_init_block (&block);
7826 110 : ptr = parmse.expr;
7827 110 : ptr = gfc_class_data_get (ptr);
7828 :
7829 110 : tree cls = parmse.class_container;
7830 110 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
7831 : NULL_TREE, NULL_TREE,
7832 : NULL_TREE, true, e,
7833 : GFC_CAF_COARRAY_NOCOARRAY,
7834 : cls);
7835 110 : gfc_add_expr_to_block (&block, tmp);
7836 110 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7837 : void_type_node, ptr,
7838 : null_pointer_node);
7839 110 : gfc_add_expr_to_block (&block, tmp);
7840 110 : gfc_reset_vptr (&block, e, parmse.class_container);
7841 :
7842 110 : if (fsym->attr.optional
7843 30 : && e->expr_type == EXPR_VARIABLE
7844 30 : && (!e->ref
7845 30 : || (e->ref->type == REF_ARRAY
7846 0 : && e->ref->u.ar.type != AR_FULL))
7847 0 : && e->symtree->n.sym->attr.optional)
7848 : {
7849 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7850 : void_type_node,
7851 0 : gfc_conv_expr_present (e->symtree->n.sym),
7852 : gfc_finish_block (&block),
7853 : build_empty_stmt (input_location));
7854 : }
7855 : else
7856 110 : tmp = gfc_finish_block (&block);
7857 :
7858 110 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7859 110 : defer_to_dealloc_blk = true;
7860 : }
7861 :
7862 2377 : gfc_se class_se = parmse;
7863 2377 : gfc_init_block (&class_se.pre);
7864 2377 : gfc_init_block (&class_se.post);
7865 :
7866 2377 : if (e->expr_type != EXPR_VARIABLE)
7867 : {
7868 : int n;
7869 : /* Set the bounds and offset correctly. */
7870 60 : for (n = 0; n < e->rank; n++)
7871 30 : gfc_conv_shift_descriptor_lbound (&class_se.pre,
7872 : class_se.expr,
7873 : n, gfc_index_one_node);
7874 : }
7875 :
7876 : /* The conversion does not repackage the reference to a class
7877 : array - _data descriptor. */
7878 2377 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7879 2377 : fsym->attr.intent != INTENT_IN
7880 2377 : && (CLASS_DATA (fsym)->attr.class_pointer
7881 1229 : || CLASS_DATA (fsym)->attr.allocatable),
7882 2377 : fsym->attr.optional
7883 798 : && e->expr_type == EXPR_VARIABLE
7884 3175 : && e->symtree->n.sym->attr.optional,
7885 2377 : CLASS_DATA (fsym)->attr.class_pointer
7886 2377 : || CLASS_DATA (fsym)->attr.allocatable);
7887 :
7888 2377 : parmse.expr = class_se.expr;
7889 2267 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7890 2377 : ? &dealloc_blk
7891 : : &parmse.pre;
7892 2377 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7893 2377 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7894 :
7895 2377 : if (e->expr_type == EXPR_OP
7896 12 : && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
7897 2389 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
7898 : {
7899 12 : tree cond;
7900 12 : tree dealloc_expr = gfc_finish_block (&parmse.post);
7901 12 : tmp = TREE_OPERAND (parmse.expr, 0);
7902 12 : gfc_init_block (&parmse.post);
7903 12 : cond = gfc_class_data_get (tmp);
7904 12 : tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
7905 : tmp, e->rank, true);
7906 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7907 12 : cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
7908 12 : cond = gfc_conv_descriptor_data_get (cond);
7909 12 : cond = fold_build2_loc (input_location, NE_EXPR,
7910 : logical_type_node, cond,
7911 12 : build_int_cst (TREE_TYPE (cond), 0));
7912 12 : tmp = build3_v (COND_EXPR, cond, dealloc_expr,
7913 : build_empty_stmt (input_location));
7914 :
7915 : /* This specific case should not be processed further and so
7916 : bundle everything up and proceed to the next argument. */
7917 12 : if (fsym && need_interface_mapping && e)
7918 12 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
7919 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7920 12 : gfc_add_block_to_block (&se->pre, &parmse.pre);
7921 12 : gfc_add_block_to_block (&post, &parmse.post);
7922 12 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
7923 12 : vec_safe_push (arglist, parmse.expr);
7924 12 : continue;
7925 12 : }
7926 2365 : }
7927 : else
7928 : {
7929 : /* If the argument is a function call that may not create
7930 : a temporary for the result, we have to check that we
7931 : can do it, i.e. that there is no alias between this
7932 : argument and another one. */
7933 58359 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7934 : {
7935 412 : gfc_expr *iarg;
7936 412 : sym_intent intent;
7937 :
7938 412 : if (fsym != NULL)
7939 403 : intent = fsym->attr.intent;
7940 : else
7941 : intent = INTENT_UNKNOWN;
7942 :
7943 412 : if (gfc_check_fncall_dependency (e, intent, sym, args,
7944 : NOT_ELEMENTAL))
7945 21 : parmse.force_tmp = 1;
7946 :
7947 412 : iarg = e->value.function.actual->expr;
7948 :
7949 : /* Temporary needed if aliasing due to host association. */
7950 412 : if (sym->attr.contained
7951 168 : && !sym->attr.pure
7952 168 : && !sym->attr.implicit_pure
7953 84 : && !sym->attr.use_assoc
7954 84 : && iarg->expr_type == EXPR_VARIABLE
7955 84 : && sym->ns == iarg->symtree->n.sym->ns)
7956 36 : parmse.force_tmp = 1;
7957 :
7958 : /* Ditto within module. */
7959 412 : if (sym->attr.use_assoc
7960 6 : && !sym->attr.pure
7961 6 : && !sym->attr.implicit_pure
7962 0 : && iarg->expr_type == EXPR_VARIABLE
7963 0 : && sym->module == iarg->symtree->n.sym->module)
7964 0 : parmse.force_tmp = 1;
7965 : }
7966 :
7967 : /* Special case for assumed-rank arrays: when passing an
7968 : argument to a nonallocatable/nonpointer dummy, the bounds have
7969 : to be reset as otherwise a last-dim ubound of -1 is
7970 : indistinguishable from an assumed-size array in the callee. */
7971 58359 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
7972 35318 : && fsym->as->type == AS_ASSUMED_RANK
7973 11966 : && e->rank != -1
7974 11652 : && e->expr_type == EXPR_VARIABLE
7975 11187 : && ((fsym->ts.type == BT_CLASS
7976 0 : && !CLASS_DATA (fsym)->attr.class_pointer
7977 0 : && !CLASS_DATA (fsym)->attr.allocatable)
7978 11187 : || (fsym->ts.type != BT_CLASS
7979 11187 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
7980 : {
7981 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7982 10644 : gfc_ref *ref;
7983 10902 : for (ref = e->ref; ref->next; ref = ref->next)
7984 : {
7985 330 : if (ref->next->type == REF_INQUIRY)
7986 : break;
7987 282 : if (ref->type == REF_ARRAY
7988 24 : && ref->u.ar.type != AR_ELEMENT)
7989 : break;
7990 10644 : };
7991 10644 : if (ref->u.ar.type == AR_FULL
7992 9894 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
7993 9774 : ref->u.ar.type = AR_SECTION;
7994 : }
7995 :
7996 58359 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7997 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7998 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7999 :
8000 52509 : else if (e->expr_type == EXPR_VARIABLE
8001 40931 : && is_subref_array (e)
8002 53489 : && !(fsym && fsym->attr.pointer))
8003 : /* The actual argument is a component reference to an
8004 : array of derived types. In this case, the argument
8005 : is converted to a temporary, which is passed and then
8006 : written back after the procedure call. */
8007 727 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8008 685 : fsym ? fsym->attr.intent : INTENT_INOUT,
8009 727 : fsym && fsym->attr.pointer);
8010 :
8011 51782 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
8012 345 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
8013 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
8014 : /* An assumed size class actual argument being passed to
8015 : a 'no descriptor' formal argument just requires the
8016 : data pointer to be passed. For class dummy arguments
8017 : this is stored in the symbol backend decl.. */
8018 6 : parmse.expr = e->symtree->n.sym->backend_decl;
8019 :
8020 51776 : else if (gfc_is_class_array_ref (e, NULL)
8021 51776 : && fsym && fsym->ts.type == BT_DERIVED)
8022 : /* The actual argument is a component reference to an
8023 : array of derived types. In this case, the argument
8024 : is converted to a temporary, which is passed and then
8025 : written back after the procedure call.
8026 : OOP-TODO: Insert code so that if the dynamic type is
8027 : the same as the declared type, copy-in/copy-out does
8028 : not occur. */
8029 108 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8030 108 : fsym->attr.intent,
8031 108 : fsym->attr.pointer);
8032 :
8033 51668 : else if (gfc_is_class_array_function (e)
8034 51668 : && fsym && fsym->ts.type == BT_DERIVED)
8035 : /* See previous comment. For function actual argument,
8036 : the write out is not needed so the intent is set as
8037 : intent in. */
8038 : {
8039 13 : e->must_finalize = 1;
8040 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8041 13 : INTENT_IN, fsym->attr.pointer);
8042 : }
8043 48076 : else if (fsym && fsym->attr.contiguous
8044 90 : && (fsym->attr.target
8045 1762 : ? gfc_is_not_contiguous (e)
8046 1672 : : !gfc_is_simply_contiguous (e, false, true))
8047 357 : && gfc_expr_is_variable (e)
8048 53762 : && e->rank != -1)
8049 : {
8050 333 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8051 333 : fsym->attr.intent,
8052 333 : fsym->attr.pointer);
8053 : }
8054 : else
8055 : /* This is where we introduce a temporary to store the
8056 : result of a non-lvalue array expression. */
8057 51322 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
8058 : sym->name, NULL);
8059 :
8060 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8061 : allocated on entry, it must be deallocated.
8062 : CFI descriptors are handled elsewhere. */
8063 54738 : if (fsym && fsym->attr.allocatable
8064 1784 : && fsym->attr.intent == INTENT_OUT
8065 58105 : && !is_CFI_desc (fsym, NULL))
8066 : {
8067 158 : if (fsym->ts.type == BT_DERIVED
8068 45 : && fsym->ts.u.derived->attr.alloc_comp)
8069 : {
8070 : // deallocate the components first
8071 9 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
8072 : parmse.expr, e->rank);
8073 : /* But check whether dummy argument is optional. */
8074 9 : if (tmp != NULL_TREE
8075 9 : && fsym->attr.optional
8076 6 : && e->expr_type == EXPR_VARIABLE
8077 6 : && e->symtree->n.sym->attr.optional)
8078 : {
8079 6 : tree present;
8080 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
8081 6 : tmp = build3_v (COND_EXPR, present, tmp,
8082 : build_empty_stmt (input_location));
8083 : }
8084 9 : if (tmp != NULL_TREE)
8085 9 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8086 : }
8087 :
8088 158 : tmp = parmse.expr;
8089 : /* With bind(C), the actual argument is replaced by a bind-C
8090 : descriptor; in this case, the data component arrives here,
8091 : which shall not be dereferenced, but still freed and
8092 : nullified. */
8093 158 : if (TREE_TYPE(tmp) != pvoid_type_node)
8094 158 : tmp = build_fold_indirect_ref_loc (input_location,
8095 : parmse.expr);
8096 158 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8097 : NULL_TREE, NULL_TREE, true,
8098 : e,
8099 : GFC_CAF_COARRAY_NOCOARRAY);
8100 158 : if (fsym->attr.optional
8101 48 : && e->expr_type == EXPR_VARIABLE
8102 48 : && e->symtree->n.sym->attr.optional)
8103 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
8104 : void_type_node,
8105 24 : gfc_conv_expr_present (e->symtree->n.sym),
8106 : tmp, build_empty_stmt (input_location));
8107 158 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8108 : }
8109 : }
8110 : }
8111 : /* Special case for an assumed-rank dummy argument. */
8112 271225 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
8113 57040 : && (fsym->ts.type == BT_CLASS
8114 57040 : ? (CLASS_DATA (fsym)->as
8115 4594 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
8116 52446 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8117 : {
8118 12803 : if (fsym->ts.type == BT_CLASS
8119 12803 : ? (CLASS_DATA (fsym)->attr.class_pointer
8120 1067 : || CLASS_DATA (fsym)->attr.allocatable)
8121 11736 : : (fsym->attr.pointer || fsym->attr.allocatable))
8122 : {
8123 : /* Unallocated allocatable arrays and unassociated pointer
8124 : arrays need their dtype setting if they are argument
8125 : associated with assumed rank dummies to set the rank. */
8126 891 : set_dtype_for_unallocated (&parmse, e);
8127 : }
8128 11912 : else if (e->expr_type == EXPR_VARIABLE
8129 11409 : && e->symtree->n.sym->attr.dummy
8130 722 : && (e->ts.type == BT_CLASS
8131 915 : ? (e->ref && e->ref->next
8132 193 : && e->ref->next->type == REF_ARRAY
8133 193 : && e->ref->next->u.ar.type == AR_FULL
8134 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8135 529 : : (e->ref && e->ref->type == REF_ARRAY
8136 529 : && e->ref->u.ar.type == AR_FULL
8137 757 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8138 : {
8139 : /* Assumed-size actual to assumed-rank dummy requires
8140 : dim[rank-1].ubound = -1. */
8141 180 : tree minus_one;
8142 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8143 180 : if (fsym->ts.type == BT_CLASS)
8144 60 : tmp = gfc_class_data_get (tmp);
8145 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8146 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8147 180 : gfc_rank_cst[e->rank - 1],
8148 : minus_one);
8149 : }
8150 : }
8151 :
8152 : /* The case with fsym->attr.optional is that of a user subroutine
8153 : with an interface indicating an optional argument. When we call
8154 : an intrinsic subroutine, however, fsym is NULL, but we might still
8155 : have an optional argument, so we proceed to the substitution
8156 : just in case. Arguments passed to bind(c) procedures via CFI
8157 : descriptors are handled elsewhere. */
8158 258225 : if (e && (fsym == NULL || fsym->attr.optional)
8159 331649 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8160 : {
8161 : /* If an optional argument is itself an optional dummy argument,
8162 : check its presence and substitute a null if absent. This is
8163 : only needed when passing an array to an elemental procedure
8164 : as then array elements are accessed - or no NULL pointer is
8165 : allowed and a "1" or "0" should be passed if not present.
8166 : When passing a non-array-descriptor full array to a
8167 : non-array-descriptor dummy, no check is needed. For
8168 : array-descriptor actual to array-descriptor dummy, see
8169 : PR 41911 for why a check has to be inserted.
8170 : fsym == NULL is checked as intrinsics required the descriptor
8171 : but do not always set fsym.
8172 : Also, it is necessary to pass a NULL pointer to library routines
8173 : which usually ignore optional arguments, so they can handle
8174 : these themselves. */
8175 59330 : if (e->expr_type == EXPR_VARIABLE
8176 26432 : && e->symtree->n.sym->attr.optional
8177 2421 : && (((e->rank != 0 && elemental_proc)
8178 2246 : || e->representation.length || e->ts.type == BT_CHARACTER
8179 2020 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8180 1910 : || (e->rank != 0
8181 1070 : && (fsym == NULL
8182 1034 : || (fsym->as
8183 272 : && (fsym->as->type == AS_ASSUMED_SHAPE
8184 235 : || fsym->as->type == AS_ASSUMED_RANK
8185 117 : || fsym->as->type == AS_DEFERRED)))))
8186 1685 : || se->ignore_optional))
8187 764 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8188 764 : e->representation.length);
8189 : }
8190 :
8191 : /* Make the class container for the first argument available with class
8192 : valued transformational functions. */
8193 271225 : if (argc == 0 && e && e->ts.type == BT_CLASS
8194 4991 : && isym && isym->transformational
8195 84 : && se->ss && se->ss->info)
8196 : {
8197 84 : arg1_cntnr = parmse.expr;
8198 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8199 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8200 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8201 84 : se->ss->info->class_container = arg1_cntnr;
8202 : }
8203 :
8204 : /* Obtain the character length of an assumed character length procedure
8205 : from the typespec of the actual argument. */
8206 271225 : if (e
8207 258225 : && parmse.string_length == NULL_TREE
8208 222627 : && e->ts.type == BT_PROCEDURE
8209 1935 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8210 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8211 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8212 : {
8213 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8214 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8215 : }
8216 :
8217 271225 : if (fsym && e)
8218 : {
8219 : /* Obtain the character length for a NULL() actual with a character
8220 : MOLD argument. Otherwise substitute a suitable dummy length.
8221 : Here we handle non-optional dummies of non-bind(c) procedures. */
8222 226326 : if (e->expr_type == EXPR_NULL
8223 745 : && fsym->ts.type == BT_CHARACTER
8224 296 : && !fsym->attr.optional
8225 226544 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8226 216 : conv_null_actual (&parmse, e, fsym);
8227 : }
8228 :
8229 : /* If any actual argument of the procedure is allocatable and passed
8230 : to an allocatable dummy with INTENT(OUT), we conservatively
8231 : evaluate actual argument expressions before deallocations are
8232 : performed and the procedure is executed. May create temporaries.
8233 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8234 258225 : if (e && fsym && force_eval_args
8235 1104 : && fsym->attr.intent != INTENT_OUT
8236 271634 : && !gfc_is_constant_expr (e))
8237 268 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8238 :
8239 271225 : if (fsym && need_interface_mapping && e)
8240 40510 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8241 :
8242 271225 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8243 271225 : gfc_add_block_to_block (&post, &parmse.post);
8244 271225 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8245 :
8246 : /* Allocated allocatable components of derived types must be
8247 : deallocated for non-variable scalars, array arguments to elemental
8248 : procedures, and array arguments with descriptor to non-elemental
8249 : procedures. As bounds information for descriptorless arrays is no
8250 : longer available here, they are dealt with in trans-array.cc
8251 : (gfc_conv_array_parameter). */
8252 258225 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8253 28473 : && e->ts.u.derived->attr.alloc_comp
8254 7603 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8255 278690 : && !expr_may_alias_variables (e, elemental_proc))
8256 : {
8257 372 : int parm_rank;
8258 : /* It is known the e returns a structure type with at least one
8259 : allocatable component. When e is a function, ensure that the
8260 : function is called once only by using a temporary variable. */
8261 372 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8262 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8263 : parmse.expr, &se->pre);
8264 :
8265 372 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8266 152 : tmp = parmse.expr;
8267 : else
8268 220 : tmp = build_fold_indirect_ref_loc (input_location,
8269 : parmse.expr);
8270 :
8271 372 : parm_rank = e->rank;
8272 372 : switch (parm_kind)
8273 : {
8274 : case (ELEMENTAL):
8275 : case (SCALAR):
8276 372 : parm_rank = 0;
8277 : break;
8278 :
8279 0 : case (SCALAR_POINTER):
8280 0 : tmp = build_fold_indirect_ref_loc (input_location,
8281 : tmp);
8282 0 : break;
8283 : }
8284 :
8285 372 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8286 : {
8287 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8288 : Therefore, class actuals can be handled correctly but derived
8289 : types passed to class formals need the _data component. */
8290 82 : tmp = gfc_class_data_get (tmp);
8291 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8292 : {
8293 56 : if (UNLIMITED_POLY (fsym))
8294 : {
8295 12 : tree type = gfc_typenode_for_spec (&e->ts);
8296 12 : type = build_pointer_type (type);
8297 12 : tmp = fold_convert (type, tmp);
8298 : }
8299 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8300 : }
8301 : }
8302 :
8303 372 : if (e->expr_type == EXPR_OP
8304 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8305 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8306 : {
8307 24 : tree local_tmp;
8308 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8309 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8310 : parm_rank, 0);
8311 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8312 : }
8313 :
8314 : /* Items of array expressions passed to a polymorphic formal arguments
8315 : create their own clean up, so prevent double free. */
8316 372 : if (!finalized && !e->must_finalize
8317 371 : && !(e->expr_type == EXPR_ARRAY && fsym
8318 86 : && fsym->ts.type == BT_CLASS))
8319 : {
8320 351 : bool scalar_res_outside_loop;
8321 1041 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8322 151 : && parm_rank == 0
8323 490 : && parmse.loop;
8324 :
8325 : /* Scalars passed to an assumed rank argument are converted to
8326 : a descriptor. Obtain the data field before deallocating any
8327 : allocatable components. */
8328 298 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8329 612 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8330 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8331 :
8332 351 : if (scalar_res_outside_loop)
8333 : {
8334 : /* Go through the ss chain to find the argument and use
8335 : the stored value. */
8336 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8337 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8338 60 : if (tmp_ss->info
8339 48 : && tmp_ss->info->expr == e
8340 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8341 : {
8342 18 : tmp = tmp_ss->info->data.scalar.value;
8343 18 : break;
8344 : }
8345 : }
8346 :
8347 351 : STRIP_NOPS (tmp);
8348 :
8349 351 : if (derived_array != NULL_TREE)
8350 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8351 : derived_array,
8352 : parm_rank);
8353 351 : else if ((e->ts.type == BT_CLASS
8354 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8355 351 : || e->ts.type == BT_DERIVED)
8356 351 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8357 : parm_rank, 0, true);
8358 0 : else if (e->ts.type == BT_CLASS)
8359 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8360 : tmp, parm_rank);
8361 :
8362 351 : if (scalar_res_outside_loop)
8363 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8364 : else
8365 321 : gfc_prepend_expr_to_block (&post, tmp);
8366 : }
8367 : }
8368 :
8369 : /* Add argument checking of passing an unallocated/NULL actual to
8370 : a nonallocatable/nonpointer dummy. */
8371 :
8372 271225 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8373 : {
8374 6546 : symbol_attribute attr;
8375 6546 : char *msg;
8376 6546 : tree cond;
8377 6546 : tree tmp;
8378 6546 : symbol_attribute fsym_attr;
8379 :
8380 6546 : if (fsym)
8381 : {
8382 6385 : if (fsym->ts.type == BT_CLASS)
8383 : {
8384 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8385 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8386 : }
8387 : else
8388 6064 : fsym_attr = fsym->attr;
8389 : }
8390 :
8391 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8392 4094 : attr = gfc_expr_attr (e);
8393 : else
8394 6081 : goto end_pointer_check;
8395 :
8396 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8397 : allocatable to an optional dummy, cf. 12.5.2.12. */
8398 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8399 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8400 1032 : goto end_pointer_check;
8401 :
8402 3062 : if (attr.optional)
8403 : {
8404 : /* If the actual argument is an optional pointer/allocatable and
8405 : the formal argument takes an nonpointer optional value,
8406 : it is invalid to pass a non-present argument on, even
8407 : though there is no technical reason for this in gfortran.
8408 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8409 60 : tree present, null_ptr, type;
8410 :
8411 60 : if (attr.allocatable
8412 0 : && (fsym == NULL || !fsym_attr.allocatable))
8413 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8414 : "allocated or not present",
8415 0 : e->symtree->n.sym->name);
8416 60 : else if (attr.pointer
8417 12 : && (fsym == NULL || !fsym_attr.pointer))
8418 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8419 : "associated or not present",
8420 12 : e->symtree->n.sym->name);
8421 48 : else if (attr.proc_pointer && !e->value.function.actual
8422 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8423 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8424 : "associated or not present",
8425 0 : e->symtree->n.sym->name);
8426 : else
8427 48 : goto end_pointer_check;
8428 :
8429 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8430 12 : type = TREE_TYPE (present);
8431 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8432 : logical_type_node, present,
8433 : fold_convert (type,
8434 : null_pointer_node));
8435 12 : type = TREE_TYPE (parmse.expr);
8436 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8437 : logical_type_node, parmse.expr,
8438 : fold_convert (type,
8439 : null_pointer_node));
8440 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8441 : logical_type_node, present, null_ptr);
8442 : }
8443 : else
8444 : {
8445 3002 : if (attr.allocatable
8446 256 : && (fsym == NULL || !fsym_attr.allocatable))
8447 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8448 190 : "allocated", e->symtree->n.sym->name);
8449 2812 : else if (attr.pointer
8450 272 : && (fsym == NULL || !fsym_attr.pointer))
8451 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8452 184 : "associated", e->symtree->n.sym->name);
8453 2628 : else if (attr.proc_pointer && !e->value.function.actual
8454 80 : && (fsym == NULL
8455 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8456 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8457 79 : "associated", e->symtree->n.sym->name);
8458 : else
8459 2549 : goto end_pointer_check;
8460 :
8461 453 : tmp = parmse.expr;
8462 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8463 : {
8464 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8465 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8466 76 : tmp = gfc_class_data_get (tmp);
8467 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8468 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8469 : }
8470 :
8471 : /* If the argument is passed by value, we need to strip the
8472 : INDIRECT_REF. */
8473 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8474 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8475 :
8476 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8477 : logical_type_node, tmp,
8478 453 : fold_convert (TREE_TYPE (tmp),
8479 : null_pointer_node));
8480 : }
8481 :
8482 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8483 : msg);
8484 465 : free (msg);
8485 : }
8486 264679 : end_pointer_check:
8487 :
8488 : /* Deferred length dummies pass the character length by reference
8489 : so that the value can be returned. */
8490 271225 : if (parmse.string_length && fsym && fsym->ts.deferred)
8491 : {
8492 795 : if (INDIRECT_REF_P (parmse.string_length))
8493 : {
8494 : /* In chains of functions/procedure calls the string_length already
8495 : is a pointer to the variable holding the length. Therefore
8496 : remove the deref on call. */
8497 90 : tmp = parmse.string_length;
8498 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8499 : }
8500 : else
8501 : {
8502 705 : tmp = parmse.string_length;
8503 705 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8504 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8505 705 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8506 : }
8507 :
8508 795 : if (e && e->expr_type == EXPR_VARIABLE
8509 638 : && fsym->attr.allocatable
8510 368 : && e->ts.u.cl->backend_decl
8511 368 : && VAR_P (e->ts.u.cl->backend_decl))
8512 : {
8513 284 : if (INDIRECT_REF_P (tmp))
8514 0 : tmp = TREE_OPERAND (tmp, 0);
8515 284 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8516 : fold_convert (gfc_charlen_type_node, tmp));
8517 : }
8518 : }
8519 :
8520 : /* Character strings are passed as two parameters, a length and a
8521 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8522 : An unlimited polymorphic formal argument likewise does not
8523 : need the length. */
8524 271225 : if (parmse.string_length != NULL_TREE
8525 36996 : && !sym->attr.is_bind_c
8526 36300 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8527 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8528 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8529 30415 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8530 30306 : && !(fsym && UNLIMITED_POLY (fsym)))
8531 36010 : vec_safe_push (stringargs, parmse.string_length);
8532 :
8533 : /* When calling __copy for character expressions to unlimited
8534 : polymorphic entities, the dst argument needs a string length. */
8535 51900 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8536 5326 : && startswith (sym->name, "__vtab_CHARACTER")
8537 0 : && arg->next && arg->next->expr
8538 0 : && (arg->next->expr->ts.type == BT_DERIVED
8539 0 : || arg->next->expr->ts.type == BT_CLASS)
8540 271225 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8541 0 : vec_safe_push (stringargs, parmse.string_length);
8542 :
8543 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8544 : pass the token and the offset as additional arguments. */
8545 271225 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8546 122 : && attr->codimension && !attr->allocatable)
8547 : {
8548 : /* Token and offset. */
8549 5 : vec_safe_push (stringargs, null_pointer_node);
8550 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8551 5 : gcc_assert (fsym->attr.optional);
8552 : }
8553 238263 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8554 145 : && !attr->allocatable)
8555 : {
8556 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8557 123 : tree offset, tmp2;
8558 :
8559 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8560 123 : caf_type = TREE_TYPE (caf_decl);
8561 123 : if (POINTER_TYPE_P (caf_type)
8562 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8563 3 : caf_desc = TREE_TYPE (caf_type);
8564 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8565 : caf_desc = caf_type;
8566 :
8567 51 : if (caf_desc
8568 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8569 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8570 : {
8571 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8572 54 : ? build_fold_indirect_ref (caf_decl)
8573 : : caf_decl;
8574 51 : tmp = gfc_conv_descriptor_token (tmp);
8575 : }
8576 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8577 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8578 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8579 : else
8580 : {
8581 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8582 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8583 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8584 : }
8585 :
8586 123 : vec_safe_push (stringargs, tmp);
8587 :
8588 123 : if (caf_desc
8589 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8590 51 : offset = build_int_cst (gfc_array_index_type, 0);
8591 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8592 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8593 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8594 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8595 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8596 : else
8597 60 : offset = build_int_cst (gfc_array_index_type, 0);
8598 :
8599 123 : if (caf_desc)
8600 : {
8601 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8602 54 : ? build_fold_indirect_ref (caf_decl)
8603 : : caf_decl;
8604 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8605 : }
8606 : else
8607 : {
8608 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8609 72 : tmp = caf_decl;
8610 : }
8611 :
8612 108 : tmp2 = fsym->ts.type == BT_CLASS
8613 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8614 123 : if ((fsym->ts.type != BT_CLASS
8615 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8616 59 : || fsym->as->type == AS_ASSUMED_RANK))
8617 74 : || (fsym->ts.type == BT_CLASS
8618 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8619 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8620 : {
8621 54 : if (fsym->ts.type == BT_CLASS)
8622 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8623 : else
8624 : {
8625 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8626 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8627 : }
8628 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8629 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8630 : }
8631 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8632 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8633 : else
8634 : {
8635 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8636 : }
8637 :
8638 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8639 : gfc_array_index_type,
8640 : fold_convert (gfc_array_index_type, tmp2),
8641 : fold_convert (gfc_array_index_type, tmp));
8642 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8643 : gfc_array_index_type, offset, tmp);
8644 :
8645 123 : vec_safe_push (stringargs, offset);
8646 : }
8647 :
8648 271225 : vec_safe_push (arglist, parmse.expr);
8649 : }
8650 :
8651 130620 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8652 130620 : gfc_add_block_to_block (&se->pre, &clobbers);
8653 130620 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8654 :
8655 130620 : if (comp)
8656 1994 : ts = comp->ts;
8657 128626 : else if (sym->ts.type == BT_CLASS)
8658 851 : ts = CLASS_DATA (sym)->ts;
8659 : else
8660 127775 : ts = sym->ts;
8661 :
8662 130620 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8663 210 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8664 130410 : else if (ts.type == BT_CHARACTER)
8665 : {
8666 5022 : if (ts.u.cl->length == NULL)
8667 : {
8668 : /* Assumed character length results are not allowed by C418 of the 2003
8669 : standard and are trapped in resolve.cc; except in the case of SPREAD
8670 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8671 : we take the character length of the first argument for the result.
8672 : For dummies, we have to look through the formal argument list for
8673 : this function and use the character length found there.
8674 : Likewise, we handle the case of deferred-length character dummy
8675 : arguments to intrinsics that determine the characteristics of
8676 : the result, which cannot be deferred-length. */
8677 2309 : if (expr->value.function.isym)
8678 1703 : ts.deferred = false;
8679 2309 : if (ts.deferred)
8680 599 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8681 1710 : else if (!sym->attr.dummy)
8682 1703 : cl.backend_decl = (*stringargs)[0];
8683 : else
8684 : {
8685 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8686 26 : for (; formal; formal = formal->next)
8687 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8688 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8689 : }
8690 2309 : len = cl.backend_decl;
8691 : }
8692 : else
8693 : {
8694 2713 : tree tmp;
8695 :
8696 : /* Calculate the length of the returned string. */
8697 2713 : gfc_init_se (&parmse, NULL);
8698 2713 : if (need_interface_mapping)
8699 1867 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8700 : else
8701 846 : gfc_conv_expr (&parmse, ts.u.cl->length);
8702 2713 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8703 2713 : gfc_add_block_to_block (&se->post, &parmse.post);
8704 2713 : tmp = parmse.expr;
8705 : /* TODO: It would be better to have the charlens as
8706 : gfc_charlen_type_node already when the interface is
8707 : created instead of converting it here (see PR 84615). */
8708 2713 : tmp = fold_build2_loc (input_location, MAX_EXPR,
8709 : gfc_charlen_type_node,
8710 : fold_convert (gfc_charlen_type_node, tmp),
8711 : build_zero_cst (gfc_charlen_type_node));
8712 2713 : cl.backend_decl = tmp;
8713 : }
8714 :
8715 : /* Set up a charlen structure for it. */
8716 5022 : cl.next = NULL;
8717 5022 : cl.length = NULL;
8718 5022 : ts.u.cl = &cl;
8719 :
8720 5022 : len = cl.backend_decl;
8721 : }
8722 :
8723 1994 : byref = (comp && (comp->attr.dimension
8724 1925 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
8725 130620 : || (!comp && gfc_return_by_reference (sym));
8726 :
8727 18793 : if (byref)
8728 : {
8729 18793 : if (se->direct_byref)
8730 : {
8731 : /* Sometimes, too much indirection can be applied; e.g. for
8732 : function_result = array_valued_recursive_function. */
8733 6999 : if (TREE_TYPE (TREE_TYPE (se->expr))
8734 6999 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
8735 7017 : && GFC_DESCRIPTOR_TYPE_P
8736 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
8737 18 : se->expr = build_fold_indirect_ref_loc (input_location,
8738 : se->expr);
8739 :
8740 : /* If the lhs of an assignment x = f(..) is allocatable and
8741 : f2003 is allowed, we must do the automatic reallocation.
8742 : TODO - deal with intrinsics, without using a temporary. */
8743 6999 : if (flag_realloc_lhs
8744 6924 : && se->ss && se->ss->loop_chain
8745 203 : && se->ss->loop_chain->is_alloc_lhs
8746 203 : && !expr->value.function.isym
8747 203 : && sym->result->as != NULL)
8748 : {
8749 : /* Evaluate the bounds of the result, if known. */
8750 203 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
8751 : sym->result->as);
8752 :
8753 : /* Perform the automatic reallocation. */
8754 203 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
8755 : expr, NULL);
8756 203 : gfc_add_expr_to_block (&se->pre, tmp);
8757 :
8758 : /* Pass the temporary as the first argument. */
8759 203 : result = info->descriptor;
8760 : }
8761 : else
8762 6796 : result = build_fold_indirect_ref_loc (input_location,
8763 : se->expr);
8764 6999 : vec_safe_push (retargs, se->expr);
8765 : }
8766 11794 : else if (comp && comp->attr.dimension)
8767 : {
8768 66 : gcc_assert (se->loop && info);
8769 :
8770 : /* Set the type of the array. vtable charlens are not always reliable.
8771 : Use the interface, if possible. */
8772 66 : if (comp->ts.type == BT_CHARACTER
8773 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
8774 1 : && comp->ts.interface && comp->ts.interface->result)
8775 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
8776 : else
8777 65 : tmp = gfc_typenode_for_spec (&comp->ts);
8778 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
8779 :
8780 : /* Evaluate the bounds of the result, if known. */
8781 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
8782 :
8783 : /* If the lhs of an assignment x = f(..) is allocatable and
8784 : f2003 is allowed, we must not generate the function call
8785 : here but should just send back the results of the mapping.
8786 : This is signalled by the function ss being flagged. */
8787 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8788 : {
8789 0 : gfc_free_interface_mapping (&mapping);
8790 0 : return has_alternate_specifier;
8791 : }
8792 :
8793 : /* Create a temporary to store the result. In case the function
8794 : returns a pointer, the temporary will be a shallow copy and
8795 : mustn't be deallocated. */
8796 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
8797 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8798 : tmp, NULL_TREE, false,
8799 : !comp->attr.pointer, callee_alloc,
8800 66 : &se->ss->info->expr->where);
8801 :
8802 : /* Pass the temporary as the first argument. */
8803 66 : result = info->descriptor;
8804 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8805 66 : vec_safe_push (retargs, tmp);
8806 : }
8807 11499 : else if (!comp && sym->result->attr.dimension)
8808 : {
8809 8468 : gcc_assert (se->loop && info);
8810 :
8811 : /* Set the type of the array. */
8812 8468 : tmp = gfc_typenode_for_spec (&ts);
8813 8468 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
8814 8468 : gcc_assert (se->ss->dimen == se->loop->dimen);
8815 :
8816 : /* Evaluate the bounds of the result, if known. */
8817 8468 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
8818 :
8819 : /* If the lhs of an assignment x = f(..) is allocatable and
8820 : f2003 is allowed, we must not generate the function call
8821 : here but should just send back the results of the mapping.
8822 : This is signalled by the function ss being flagged. */
8823 8468 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8824 : {
8825 0 : gfc_free_interface_mapping (&mapping);
8826 0 : return has_alternate_specifier;
8827 : }
8828 :
8829 : /* Create a temporary to store the result. In case the function
8830 : returns a pointer, the temporary will be a shallow copy and
8831 : mustn't be deallocated. */
8832 8468 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
8833 8468 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8834 : tmp, NULL_TREE, false,
8835 : !sym->attr.pointer, callee_alloc,
8836 8468 : &se->ss->info->expr->where);
8837 :
8838 : /* Pass the temporary as the first argument. */
8839 8468 : result = info->descriptor;
8840 8468 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8841 8468 : vec_safe_push (retargs, tmp);
8842 : }
8843 3260 : else if (ts.type == BT_CHARACTER)
8844 : {
8845 : /* Pass the string length. */
8846 3199 : type = gfc_get_character_type (ts.kind, ts.u.cl);
8847 3199 : type = build_pointer_type (type);
8848 :
8849 : /* Emit a DECL_EXPR for the VLA type. */
8850 3199 : tmp = TREE_TYPE (type);
8851 3199 : if (TYPE_SIZE (tmp)
8852 3199 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
8853 : {
8854 1929 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
8855 1929 : DECL_ARTIFICIAL (tmp) = 1;
8856 1929 : DECL_IGNORED_P (tmp) = 1;
8857 1929 : tmp = fold_build1_loc (input_location, DECL_EXPR,
8858 1929 : TREE_TYPE (tmp), tmp);
8859 1929 : gfc_add_expr_to_block (&se->pre, tmp);
8860 : }
8861 :
8862 : /* Return an address to a char[0:len-1]* temporary for
8863 : character pointers. */
8864 3199 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8865 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8866 : {
8867 642 : var = gfc_create_var (type, "pstr");
8868 :
8869 642 : if ((!comp && sym->attr.allocatable)
8870 21 : || (comp && comp->attr.allocatable))
8871 : {
8872 355 : gfc_add_modify (&se->pre, var,
8873 355 : fold_convert (TREE_TYPE (var),
8874 : null_pointer_node));
8875 355 : tmp = gfc_call_free (var);
8876 355 : gfc_add_expr_to_block (&se->post, tmp);
8877 : }
8878 :
8879 : /* Provide an address expression for the function arguments. */
8880 642 : var = gfc_build_addr_expr (NULL_TREE, var);
8881 : }
8882 : else
8883 2557 : var = gfc_conv_string_tmp (se, type, len);
8884 :
8885 3199 : vec_safe_push (retargs, var);
8886 : }
8887 : else
8888 : {
8889 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
8890 :
8891 61 : type = gfc_get_complex_type (ts.kind);
8892 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
8893 61 : vec_safe_push (retargs, var);
8894 : }
8895 :
8896 : /* Add the string length to the argument list. */
8897 18793 : if (ts.type == BT_CHARACTER && ts.deferred)
8898 : {
8899 599 : tmp = len;
8900 599 : if (!VAR_P (tmp))
8901 0 : tmp = gfc_evaluate_now (len, &se->pre);
8902 599 : TREE_STATIC (tmp) = 1;
8903 599 : gfc_add_modify (&se->pre, tmp,
8904 599 : build_int_cst (TREE_TYPE (tmp), 0));
8905 599 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8906 599 : vec_safe_push (retargs, tmp);
8907 : }
8908 18194 : else if (ts.type == BT_CHARACTER)
8909 4423 : vec_safe_push (retargs, len);
8910 : }
8911 :
8912 130620 : gfc_free_interface_mapping (&mapping);
8913 :
8914 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
8915 243160 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
8916 156037 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
8917 130620 : vec_safe_reserve (retargs, arglen);
8918 :
8919 : /* Add the return arguments. */
8920 130620 : vec_safe_splice (retargs, arglist);
8921 :
8922 : /* Add the hidden present status for optional+value to the arguments. */
8923 130620 : vec_safe_splice (retargs, optionalargs);
8924 :
8925 : /* Add the hidden string length parameters to the arguments. */
8926 130620 : vec_safe_splice (retargs, stringargs);
8927 :
8928 : /* We may want to append extra arguments here. This is used e.g. for
8929 : calls to libgfortran_matmul_??, which need extra information. */
8930 130620 : vec_safe_splice (retargs, append_args);
8931 :
8932 130620 : arglist = retargs;
8933 :
8934 : /* Generate the actual call. */
8935 130620 : is_builtin = false;
8936 130620 : if (base_object == NULL_TREE)
8937 130540 : conv_function_val (se, &is_builtin, sym, expr, args);
8938 : else
8939 80 : conv_base_obj_fcn_val (se, base_object, expr);
8940 :
8941 : /* If there are alternate return labels, function type should be
8942 : integer. Can't modify the type in place though, since it can be shared
8943 : with other functions. For dummy arguments, the typing is done to
8944 : this result, even if it has to be repeated for each call. */
8945 130620 : if (has_alternate_specifier
8946 130620 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
8947 : {
8948 7 : if (!sym->attr.dummy)
8949 : {
8950 0 : TREE_TYPE (sym->backend_decl)
8951 0 : = build_function_type (integer_type_node,
8952 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
8953 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
8954 : }
8955 : else
8956 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
8957 : }
8958 :
8959 130620 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
8960 130620 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
8961 :
8962 130620 : if (is_builtin)
8963 567 : se->expr = update_builtin_function (se->expr, sym);
8964 :
8965 : /* Allocatable scalar function results must be freed and nullified
8966 : after use. This necessitates the creation of a temporary to
8967 : hold the result to prevent duplicate calls. */
8968 130620 : symbol_attribute attr = comp ? comp->attr : sym->attr;
8969 130620 : bool allocatable = attr.allocatable && !attr.dimension;
8970 133960 : gfc_symbol *der = comp ?
8971 1994 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
8972 : :
8973 128626 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
8974 3340 : bool finalizable = der != NULL && der->ns->proc_name
8975 6677 : && gfc_is_finalizable (der, NULL);
8976 :
8977 130620 : if (!byref && finalizable)
8978 188 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8979 :
8980 130620 : if (!byref && sym->ts.type != BT_CHARACTER
8981 111617 : && allocatable && !finalizable)
8982 : {
8983 230 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
8984 230 : gfc_add_modify (&se->pre, tmp, se->expr);
8985 230 : se->expr = tmp;
8986 230 : tmp = gfc_call_free (tmp);
8987 230 : gfc_add_expr_to_block (&post, tmp);
8988 230 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
8989 : }
8990 :
8991 : /* If we have a pointer function, but we don't want a pointer, e.g.
8992 : something like
8993 : x = f()
8994 : where f is pointer valued, we have to dereference the result. */
8995 130620 : if (!se->want_pointer && !byref
8996 111225 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8997 1652 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
8998 456 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8999 :
9000 : /* f2c calling conventions require a scalar default real function to
9001 : return a double precision result. Convert this back to default
9002 : real. We only care about the cases that can happen in Fortran 77.
9003 : */
9004 130620 : if (flag_f2c && sym->ts.type == BT_REAL
9005 98 : && sym->ts.kind == gfc_default_real_kind
9006 74 : && !sym->attr.pointer
9007 55 : && !sym->attr.allocatable
9008 43 : && !sym->attr.always_explicit)
9009 43 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
9010 :
9011 : /* A pure function may still have side-effects - it may modify its
9012 : parameters. */
9013 130620 : TREE_SIDE_EFFECTS (se->expr) = 1;
9014 : #if 0
9015 : if (!sym->attr.pure)
9016 : TREE_SIDE_EFFECTS (se->expr) = 1;
9017 : #endif
9018 :
9019 130620 : if (byref)
9020 : {
9021 : /* Add the function call to the pre chain. There is no expression. */
9022 18793 : gfc_add_expr_to_block (&se->pre, se->expr);
9023 18793 : se->expr = NULL_TREE;
9024 :
9025 18793 : if (!se->direct_byref)
9026 : {
9027 11794 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
9028 : {
9029 8534 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
9030 : {
9031 : /* Check the data pointer hasn't been modified. This would
9032 : happen in a function returning a pointer. */
9033 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9034 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
9035 : logical_type_node,
9036 : tmp, info->data);
9037 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
9038 : gfc_msg_fault);
9039 : }
9040 8534 : se->expr = info->descriptor;
9041 : /* Bundle in the string length. */
9042 8534 : se->string_length = len;
9043 :
9044 8534 : if (finalizable)
9045 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9046 : }
9047 3260 : else if (ts.type == BT_CHARACTER)
9048 : {
9049 : /* Dereference for character pointer results. */
9050 3199 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9051 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9052 642 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9053 : else
9054 2557 : se->expr = var;
9055 :
9056 3199 : se->string_length = len;
9057 : }
9058 : else
9059 : {
9060 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
9061 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9062 : }
9063 : }
9064 : }
9065 :
9066 : /* Associate the rhs class object's meta-data with the result, when the
9067 : result is a temporary. */
9068 112545 : if (args && args->expr && args->expr->ts.type == BT_CLASS
9069 5003 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
9070 130652 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
9071 : {
9072 32 : gfc_se parmse;
9073 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
9074 :
9075 32 : gfc_init_se (&parmse, NULL);
9076 32 : parmse.data_not_needed = 1;
9077 32 : gfc_conv_expr (&parmse, class_expr);
9078 32 : if (!DECL_LANG_SPECIFIC (result))
9079 32 : gfc_allocate_lang_decl (result);
9080 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
9081 32 : gfc_free_expr (class_expr);
9082 : /* -fcheck= can add diagnostic code, which has to be placed before
9083 : the call. */
9084 32 : if (parmse.pre.head != NULL)
9085 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
9086 32 : gcc_assert (parmse.post.head == NULL_TREE);
9087 : }
9088 :
9089 : /* Follow the function call with the argument post block. */
9090 130620 : if (byref)
9091 : {
9092 : /* Transformational functions of derived types with allocatable
9093 : components must have the result allocatable components copied
9094 : BEFORE the argument post block is appended. Copying the result
9095 : first, then freeing the argument, gives the correct order. */
9096 18793 : arg = expr->value.function.actual;
9097 18793 : if (result && arg && expr->rank
9098 14686 : && isym && isym->transformational
9099 13105 : && isym->id != GFC_ISYM_REDUCE
9100 12979 : && arg->expr
9101 12919 : && arg->expr->ts.type == BT_DERIVED
9102 241 : && arg->expr->ts.u.derived->attr.alloc_comp)
9103 : {
9104 48 : tree tmp2;
9105 : /* Copy the allocatable components. We have to use a
9106 : temporary here to prevent source allocatable components
9107 : from being corrupted. */
9108 48 : tmp2 = gfc_evaluate_now (result, &se->pre);
9109 48 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
9110 : result, tmp2, expr->rank, 0);
9111 48 : gfc_add_expr_to_block (&se->pre, tmp);
9112 48 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
9113 : expr->rank);
9114 48 : gfc_add_expr_to_block (&se->pre, tmp);
9115 :
9116 : /* Finally free the temporary's data field. */
9117 48 : tmp = gfc_conv_descriptor_data_get (tmp2);
9118 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9119 : NULL_TREE, NULL_TREE, true,
9120 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9121 48 : gfc_add_expr_to_block (&se->pre, tmp);
9122 : }
9123 :
9124 18793 : gfc_add_block_to_block (&se->pre, &post);
9125 : }
9126 : else
9127 : {
9128 : /* For a function with a class array result, save the result as
9129 : a temporary, set the info fields needed by the scalarizer and
9130 : call the finalization function of the temporary. Note that the
9131 : nullification of allocatable components needed by the result
9132 : is done in gfc_trans_assignment_1. */
9133 34618 : if (expr && (gfc_is_class_array_function (expr)
9134 34296 : || gfc_is_alloc_class_scalar_function (expr))
9135 841 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9136 112656 : && expr->must_finalize)
9137 : {
9138 : /* TODO Eliminate the doubling of temporaries. This
9139 : one is necessary to ensure no memory leakage. */
9140 321 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9141 :
9142 : /* Finalize the result, if necessary. */
9143 642 : attr = expr->value.function.esym
9144 321 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9145 14 : : CLASS_DATA (expr)->attr;
9146 321 : if (!((gfc_is_class_array_function (expr)
9147 108 : || gfc_is_alloc_class_scalar_function (expr))
9148 321 : && attr.pointer))
9149 276 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9150 : }
9151 111827 : gfc_add_block_to_block (&se->post, &post);
9152 : }
9153 :
9154 : return has_alternate_specifier;
9155 : }
9156 :
9157 :
9158 : /* Fill a character string with spaces. */
9159 :
9160 : static tree
9161 30662 : fill_with_spaces (tree start, tree type, tree size)
9162 : {
9163 30662 : stmtblock_t block, loop;
9164 30662 : tree i, el, exit_label, cond, tmp;
9165 :
9166 : /* For a simple char type, we can call memset(). */
9167 30662 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9168 50736 : return build_call_expr_loc (input_location,
9169 : builtin_decl_explicit (BUILT_IN_MEMSET),
9170 : 3, start,
9171 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9172 25368 : lang_hooks.to_target_charset (' ')),
9173 : fold_convert (size_type_node, size));
9174 :
9175 : /* Otherwise, we use a loop:
9176 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9177 : *el = (type) ' ';
9178 : */
9179 :
9180 : /* Initialize variables. */
9181 5294 : gfc_init_block (&block);
9182 5294 : i = gfc_create_var (sizetype, "i");
9183 5294 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9184 5294 : el = gfc_create_var (build_pointer_type (type), "el");
9185 5294 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9186 5294 : exit_label = gfc_build_label_decl (NULL_TREE);
9187 5294 : TREE_USED (exit_label) = 1;
9188 :
9189 :
9190 : /* Loop body. */
9191 5294 : gfc_init_block (&loop);
9192 :
9193 : /* Exit condition. */
9194 5294 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9195 : build_zero_cst (sizetype));
9196 5294 : tmp = build1_v (GOTO_EXPR, exit_label);
9197 5294 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9198 : build_empty_stmt (input_location));
9199 5294 : gfc_add_expr_to_block (&loop, tmp);
9200 :
9201 : /* Assignment. */
9202 5294 : gfc_add_modify (&loop,
9203 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9204 5294 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9205 :
9206 : /* Increment loop variables. */
9207 5294 : gfc_add_modify (&loop, i,
9208 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9209 5294 : TYPE_SIZE_UNIT (type)));
9210 5294 : gfc_add_modify (&loop, el,
9211 : fold_build_pointer_plus_loc (input_location,
9212 5294 : el, TYPE_SIZE_UNIT (type)));
9213 :
9214 : /* Making the loop... actually loop! */
9215 5294 : tmp = gfc_finish_block (&loop);
9216 5294 : tmp = build1_v (LOOP_EXPR, tmp);
9217 5294 : gfc_add_expr_to_block (&block, tmp);
9218 :
9219 : /* The exit label. */
9220 5294 : tmp = build1_v (LABEL_EXPR, exit_label);
9221 5294 : gfc_add_expr_to_block (&block, tmp);
9222 :
9223 :
9224 5294 : return gfc_finish_block (&block);
9225 : }
9226 :
9227 :
9228 : /* Generate code to copy a string. */
9229 :
9230 : void
9231 35825 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9232 : int dkind, tree slength, tree src, int skind)
9233 : {
9234 35825 : tree tmp, dlen, slen;
9235 35825 : tree dsc;
9236 35825 : tree ssc;
9237 35825 : tree cond;
9238 35825 : tree cond2;
9239 35825 : tree tmp2;
9240 35825 : tree tmp3;
9241 35825 : tree tmp4;
9242 35825 : tree chartype;
9243 35825 : stmtblock_t tempblock;
9244 :
9245 35825 : gcc_assert (dkind == skind);
9246 :
9247 35825 : if (slength != NULL_TREE)
9248 : {
9249 35825 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9250 35825 : ssc = gfc_string_to_single_character (slen, src, skind);
9251 : }
9252 : else
9253 : {
9254 0 : slen = build_one_cst (gfc_charlen_type_node);
9255 0 : ssc = src;
9256 : }
9257 :
9258 35825 : if (dlength != NULL_TREE)
9259 : {
9260 35825 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9261 35825 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9262 : }
9263 : else
9264 : {
9265 0 : dlen = build_one_cst (gfc_charlen_type_node);
9266 0 : dsc = dest;
9267 : }
9268 :
9269 : /* Assign directly if the types are compatible. */
9270 35825 : if (dsc != NULL_TREE && ssc != NULL_TREE
9271 35825 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9272 : {
9273 5163 : gfc_add_modify (block, dsc, ssc);
9274 5163 : return;
9275 : }
9276 :
9277 : /* The string copy algorithm below generates code like
9278 :
9279 : if (destlen > 0)
9280 : {
9281 : if (srclen < destlen)
9282 : {
9283 : memmove (dest, src, srclen);
9284 : // Pad with spaces.
9285 : memset (&dest[srclen], ' ', destlen - srclen);
9286 : }
9287 : else
9288 : {
9289 : // Truncate if too long.
9290 : memmove (dest, src, destlen);
9291 : }
9292 : }
9293 : */
9294 :
9295 : /* Do nothing if the destination length is zero. */
9296 30662 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9297 30662 : build_zero_cst (TREE_TYPE (dlen)));
9298 :
9299 : /* For non-default character kinds, we have to multiply the string
9300 : length by the base type size. */
9301 30662 : chartype = gfc_get_char_type (dkind);
9302 30662 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9303 : slen,
9304 30662 : fold_convert (TREE_TYPE (slen),
9305 : TYPE_SIZE_UNIT (chartype)));
9306 30662 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9307 : dlen,
9308 30662 : fold_convert (TREE_TYPE (dlen),
9309 : TYPE_SIZE_UNIT (chartype)));
9310 :
9311 30662 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9312 30614 : dest = fold_convert (pvoid_type_node, dest);
9313 : else
9314 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9315 :
9316 30662 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9317 30658 : src = fold_convert (pvoid_type_node, src);
9318 : else
9319 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9320 :
9321 : /* Truncate string if source is too long. */
9322 30662 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9323 : dlen);
9324 :
9325 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9326 30662 : if (!CONSTANT_CLASS_P (cond2))
9327 : {
9328 9391 : dest = gfc_evaluate_now (dest, block);
9329 9391 : src = gfc_evaluate_now (src, block);
9330 : }
9331 :
9332 : /* Copy and pad with spaces. */
9333 30662 : tmp3 = build_call_expr_loc (input_location,
9334 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9335 : 3, dest, src,
9336 : fold_convert (size_type_node, slen));
9337 :
9338 : /* Wstringop-overflow appears at -O3 even though this warning is not
9339 : explicitly available in fortran nor can it be switched off. If the
9340 : source length is a constant, its negative appears as a very large
9341 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9342 : the result of the MINUS_EXPR suppresses this spurious warning. */
9343 30662 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9344 30662 : TREE_TYPE(dlen), dlen, slen);
9345 30662 : if (slength && TREE_CONSTANT (slength))
9346 27131 : tmp = gfc_evaluate_now (tmp, block);
9347 :
9348 30662 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9349 30662 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9350 :
9351 30662 : gfc_init_block (&tempblock);
9352 30662 : gfc_add_expr_to_block (&tempblock, tmp3);
9353 30662 : gfc_add_expr_to_block (&tempblock, tmp4);
9354 30662 : tmp3 = gfc_finish_block (&tempblock);
9355 :
9356 : /* The truncated memmove if the slen >= dlen. */
9357 30662 : tmp2 = build_call_expr_loc (input_location,
9358 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9359 : 3, dest, src,
9360 : fold_convert (size_type_node, dlen));
9361 :
9362 : /* The whole copy_string function is there. */
9363 30662 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9364 : tmp3, tmp2);
9365 30662 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9366 : build_empty_stmt (input_location));
9367 30662 : gfc_add_expr_to_block (block, tmp);
9368 : }
9369 :
9370 :
9371 : /* Translate a statement function.
9372 : The value of a statement function reference is obtained by evaluating the
9373 : expression using the values of the actual arguments for the values of the
9374 : corresponding dummy arguments. */
9375 :
9376 : static void
9377 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9378 : {
9379 269 : gfc_symbol *sym;
9380 269 : gfc_symbol *fsym;
9381 269 : gfc_formal_arglist *fargs;
9382 269 : gfc_actual_arglist *args;
9383 269 : gfc_se lse;
9384 269 : gfc_se rse;
9385 269 : gfc_saved_var *saved_vars;
9386 269 : tree *temp_vars;
9387 269 : tree type;
9388 269 : tree tmp;
9389 269 : int n;
9390 :
9391 269 : sym = expr->symtree->n.sym;
9392 269 : args = expr->value.function.actual;
9393 269 : gfc_init_se (&lse, NULL);
9394 269 : gfc_init_se (&rse, NULL);
9395 :
9396 269 : n = 0;
9397 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9398 458 : n++;
9399 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9400 269 : temp_vars = XCNEWVEC (tree, n);
9401 :
9402 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9403 458 : fargs = fargs->next, n++)
9404 : {
9405 : /* Each dummy shall be specified, explicitly or implicitly, to be
9406 : scalar. */
9407 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9408 458 : fsym = fargs->sym;
9409 :
9410 458 : if (fsym->ts.type == BT_CHARACTER)
9411 : {
9412 : /* Copy string arguments. */
9413 48 : tree arglen;
9414 :
9415 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9416 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9417 :
9418 : /* Create a temporary to hold the value. */
9419 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9420 1 : fsym->ts.u.cl->backend_decl
9421 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9422 :
9423 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9424 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9425 :
9426 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9427 :
9428 48 : gfc_conv_expr (&rse, args->expr);
9429 48 : gfc_conv_string_parameter (&rse);
9430 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9431 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9432 :
9433 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9434 : rse.string_length, rse.expr, fsym->ts.kind);
9435 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9436 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9437 : }
9438 : else
9439 : {
9440 : /* For everything else, just evaluate the expression. */
9441 :
9442 : /* Create a temporary to hold the value. */
9443 410 : type = gfc_typenode_for_spec (&fsym->ts);
9444 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9445 :
9446 410 : gfc_conv_expr (&lse, args->expr);
9447 :
9448 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9449 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9450 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9451 : }
9452 :
9453 458 : args = args->next;
9454 : }
9455 :
9456 : /* Use the temporary variables in place of the real ones. */
9457 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9458 458 : fargs = fargs->next, n++)
9459 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9460 :
9461 269 : gfc_conv_expr (se, sym->value);
9462 :
9463 269 : if (sym->ts.type == BT_CHARACTER)
9464 : {
9465 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9466 :
9467 : /* Force the expression to the correct length. */
9468 55 : if (!INTEGER_CST_P (se->string_length)
9469 101 : || tree_int_cst_lt (se->string_length,
9470 46 : sym->ts.u.cl->backend_decl))
9471 : {
9472 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9473 31 : tmp = gfc_create_var (type, sym->name);
9474 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9475 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9476 : sym->ts.kind, se->string_length, se->expr,
9477 : sym->ts.kind);
9478 31 : se->expr = tmp;
9479 : }
9480 55 : se->string_length = sym->ts.u.cl->backend_decl;
9481 : }
9482 :
9483 : /* Restore the original variables. */
9484 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9485 458 : fargs = fargs->next, n++)
9486 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9487 269 : free (temp_vars);
9488 269 : free (saved_vars);
9489 269 : }
9490 :
9491 :
9492 : /* Translate a function expression. */
9493 :
9494 : static void
9495 313311 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9496 : {
9497 313311 : gfc_symbol *sym;
9498 :
9499 313311 : if (expr->value.function.isym)
9500 : {
9501 262899 : gfc_conv_intrinsic_function (se, expr);
9502 262899 : return;
9503 : }
9504 :
9505 : /* expr.value.function.esym is the resolved (specific) function symbol for
9506 : most functions. However this isn't set for dummy procedures. */
9507 50412 : sym = expr->value.function.esym;
9508 50412 : if (!sym)
9509 1630 : sym = expr->symtree->n.sym;
9510 :
9511 : /* The IEEE_ARITHMETIC functions are caught here. */
9512 50412 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9513 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9514 : return;
9515 :
9516 : /* We distinguish statement functions from general functions to improve
9517 : runtime performance. */
9518 37955 : if (sym->attr.proc == PROC_ST_FUNCTION)
9519 : {
9520 269 : gfc_conv_statement_function (se, expr);
9521 269 : return;
9522 : }
9523 :
9524 37686 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9525 : NULL);
9526 : }
9527 :
9528 :
9529 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9530 :
9531 : static bool
9532 39857 : is_zero_initializer_p (gfc_expr * expr)
9533 : {
9534 39857 : if (expr->expr_type != EXPR_CONSTANT)
9535 : return false;
9536 :
9537 : /* We ignore constants with prescribed memory representations for now. */
9538 11400 : if (expr->representation.string)
9539 : return false;
9540 :
9541 11382 : switch (expr->ts.type)
9542 : {
9543 5267 : case BT_INTEGER:
9544 5267 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9545 :
9546 4819 : case BT_REAL:
9547 4819 : return mpfr_zero_p (expr->value.real)
9548 4819 : && MPFR_SIGN (expr->value.real) >= 0;
9549 :
9550 919 : case BT_LOGICAL:
9551 919 : return expr->value.logical == 0;
9552 :
9553 243 : case BT_COMPLEX:
9554 243 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9555 155 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9556 155 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9557 386 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9558 :
9559 : default:
9560 : break;
9561 : }
9562 : return false;
9563 : }
9564 :
9565 :
9566 : static void
9567 35923 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9568 : {
9569 35923 : gfc_ss *ss;
9570 :
9571 35923 : ss = se->ss;
9572 35923 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9573 35923 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9574 :
9575 35923 : gfc_conv_tmp_array_ref (se);
9576 35923 : }
9577 :
9578 :
9579 : /* Build a static initializer. EXPR is the expression for the initial value.
9580 : The other parameters describe the variable of the component being
9581 : initialized. EXPR may be null. */
9582 :
9583 : tree
9584 134720 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9585 : bool array, bool pointer, bool procptr)
9586 : {
9587 134720 : gfc_se se;
9588 :
9589 134720 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9590 41928 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9591 171 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9592 59 : return build_constructor (type, NULL);
9593 :
9594 134661 : if (!(expr || pointer || procptr))
9595 : return NULL_TREE;
9596 :
9597 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9598 : (these are the only two iso_c_binding derived types that can be
9599 : used as initialization expressions). If so, we need to modify
9600 : the 'expr' to be that for a (void *). */
9601 126380 : if (expr != NULL && expr->ts.type == BT_DERIVED
9602 37783 : && expr->ts.is_iso_c && expr->ts.u.derived)
9603 : {
9604 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9605 4 : return build_constructor (type, NULL);
9606 182 : else if (POINTER_TYPE_P (type))
9607 182 : return build_int_cst (type, 0);
9608 : else
9609 0 : gcc_unreachable ();
9610 : }
9611 :
9612 126194 : if (array && !procptr)
9613 : {
9614 8767 : tree ctor;
9615 : /* Arrays need special handling. */
9616 8767 : if (pointer)
9617 776 : ctor = gfc_build_null_descriptor (type);
9618 : /* Special case assigning an array to zero. */
9619 7991 : else if (is_zero_initializer_p (expr))
9620 220 : ctor = build_constructor (type, NULL);
9621 : else
9622 7771 : ctor = gfc_conv_array_initializer (type, expr);
9623 8767 : TREE_STATIC (ctor) = 1;
9624 8767 : return ctor;
9625 : }
9626 117427 : else if (pointer || procptr)
9627 : {
9628 54706 : if (ts->type == BT_CLASS && !procptr)
9629 : {
9630 1762 : gfc_init_se (&se, NULL);
9631 1762 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9632 1762 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9633 1762 : TREE_STATIC (se.expr) = 1;
9634 1762 : return se.expr;
9635 : }
9636 52944 : else if (!expr || expr->expr_type == EXPR_NULL)
9637 28149 : return fold_convert (type, null_pointer_node);
9638 : else
9639 : {
9640 24795 : gfc_init_se (&se, NULL);
9641 24795 : se.want_pointer = 1;
9642 24795 : gfc_conv_expr (&se, expr);
9643 24795 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9644 : return se.expr;
9645 : }
9646 : }
9647 : else
9648 : {
9649 62721 : switch (ts->type)
9650 : {
9651 18168 : case_bt_struct:
9652 18168 : case BT_CLASS:
9653 18168 : gfc_init_se (&se, NULL);
9654 18168 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9655 779 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9656 : else
9657 17389 : gfc_conv_structure (&se, expr, 1);
9658 18168 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9659 18168 : TREE_STATIC (se.expr) = 1;
9660 18168 : return se.expr;
9661 :
9662 2705 : case BT_CHARACTER:
9663 2705 : if (expr->expr_type == EXPR_CONSTANT)
9664 : {
9665 2704 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9666 2704 : TREE_STATIC (ctor) = 1;
9667 2704 : return ctor;
9668 : }
9669 :
9670 : /* Fallthrough. */
9671 41849 : default:
9672 41849 : gfc_init_se (&se, NULL);
9673 41849 : gfc_conv_constant (&se, expr);
9674 41849 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9675 : return se.expr;
9676 : }
9677 : }
9678 : }
9679 :
9680 : static tree
9681 956 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9682 : {
9683 956 : gfc_se rse;
9684 956 : gfc_se lse;
9685 956 : gfc_ss *rss;
9686 956 : gfc_ss *lss;
9687 956 : gfc_array_info *lss_array;
9688 956 : stmtblock_t body;
9689 956 : stmtblock_t block;
9690 956 : gfc_loopinfo loop;
9691 956 : int n;
9692 956 : tree tmp;
9693 :
9694 956 : gfc_start_block (&block);
9695 :
9696 : /* Initialize the scalarizer. */
9697 956 : gfc_init_loopinfo (&loop);
9698 :
9699 956 : gfc_init_se (&lse, NULL);
9700 956 : gfc_init_se (&rse, NULL);
9701 :
9702 : /* Walk the rhs. */
9703 956 : rss = gfc_walk_expr (expr);
9704 956 : if (rss == gfc_ss_terminator)
9705 : /* The rhs is scalar. Add a ss for the expression. */
9706 208 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
9707 :
9708 : /* Create a SS for the destination. */
9709 956 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
9710 : GFC_SS_COMPONENT);
9711 956 : lss_array = &lss->info->data.array;
9712 956 : lss_array->shape = gfc_get_shape (cm->as->rank);
9713 956 : lss_array->descriptor = dest;
9714 956 : lss_array->data = gfc_conv_array_data (dest);
9715 956 : lss_array->offset = gfc_conv_array_offset (dest);
9716 1969 : for (n = 0; n < cm->as->rank; n++)
9717 : {
9718 1013 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
9719 1013 : lss_array->stride[n] = gfc_index_one_node;
9720 :
9721 1013 : mpz_init (lss_array->shape[n]);
9722 1013 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
9723 1013 : cm->as->lower[n]->value.integer);
9724 1013 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
9725 : }
9726 :
9727 : /* Associate the SS with the loop. */
9728 956 : gfc_add_ss_to_loop (&loop, lss);
9729 956 : gfc_add_ss_to_loop (&loop, rss);
9730 :
9731 : /* Calculate the bounds of the scalarization. */
9732 956 : gfc_conv_ss_startstride (&loop);
9733 :
9734 : /* Setup the scalarizing loops. */
9735 956 : gfc_conv_loop_setup (&loop, &expr->where);
9736 :
9737 : /* Setup the gfc_se structures. */
9738 956 : gfc_copy_loopinfo_to_se (&lse, &loop);
9739 956 : gfc_copy_loopinfo_to_se (&rse, &loop);
9740 :
9741 956 : rse.ss = rss;
9742 956 : gfc_mark_ss_chain_used (rss, 1);
9743 956 : lse.ss = lss;
9744 956 : gfc_mark_ss_chain_used (lss, 1);
9745 :
9746 : /* Start the scalarized loop body. */
9747 956 : gfc_start_scalarized_body (&loop, &body);
9748 :
9749 956 : gfc_conv_tmp_array_ref (&lse);
9750 956 : if (cm->ts.type == BT_CHARACTER)
9751 176 : lse.string_length = cm->ts.u.cl->backend_decl;
9752 :
9753 956 : gfc_conv_expr (&rse, expr);
9754 :
9755 956 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
9756 956 : gfc_add_expr_to_block (&body, tmp);
9757 :
9758 956 : gcc_assert (rse.ss == gfc_ss_terminator);
9759 :
9760 : /* Generate the copying loops. */
9761 956 : gfc_trans_scalarizing_loops (&loop, &body);
9762 :
9763 : /* Wrap the whole thing up. */
9764 956 : gfc_add_block_to_block (&block, &loop.pre);
9765 956 : gfc_add_block_to_block (&block, &loop.post);
9766 :
9767 956 : gcc_assert (lss_array->shape != NULL);
9768 956 : gfc_free_shape (&lss_array->shape, cm->as->rank);
9769 956 : gfc_cleanup_loop (&loop);
9770 :
9771 956 : return gfc_finish_block (&block);
9772 : }
9773 :
9774 :
9775 : static stmtblock_t *final_block;
9776 : static tree
9777 1312 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
9778 : gfc_expr * expr)
9779 : {
9780 1312 : gfc_se se;
9781 1312 : stmtblock_t block;
9782 1312 : tree offset;
9783 1312 : int n;
9784 1312 : tree tmp;
9785 1312 : tree tmp2;
9786 1312 : gfc_array_spec *as;
9787 1312 : gfc_expr *arg = NULL;
9788 :
9789 1312 : gfc_start_block (&block);
9790 1312 : gfc_init_se (&se, NULL);
9791 :
9792 : /* Get the descriptor for the expressions. */
9793 1312 : se.want_pointer = 0;
9794 1312 : gfc_conv_expr_descriptor (&se, expr);
9795 1312 : gfc_add_block_to_block (&block, &se.pre);
9796 1312 : gfc_add_modify (&block, dest, se.expr);
9797 1312 : if (cm->ts.type == BT_CHARACTER
9798 1312 : && gfc_deferred_strlen (cm, &tmp))
9799 : {
9800 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
9801 30 : TREE_TYPE (tmp),
9802 30 : TREE_OPERAND (dest, 0),
9803 : tmp, NULL_TREE);
9804 30 : gfc_add_modify (&block, tmp,
9805 30 : fold_convert (TREE_TYPE (tmp),
9806 : se.string_length));
9807 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
9808 : "slen");
9809 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
9810 : }
9811 :
9812 : /* Deal with arrays of derived types with allocatable components. */
9813 1312 : if (gfc_bt_struct (cm->ts.type)
9814 199 : && cm->ts.u.derived->attr.alloc_comp)
9815 : // TODO: Fix caf_mode
9816 113 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
9817 : se.expr, dest,
9818 113 : cm->as->rank, 0);
9819 1199 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
9820 36 : && CLASS_DATA(cm)->attr.allocatable)
9821 : {
9822 36 : if (cm->ts.u.derived->attr.alloc_comp)
9823 : // TODO: Fix caf_mode
9824 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
9825 : se.expr, dest,
9826 : expr->rank, 0);
9827 : else
9828 : {
9829 36 : tmp = TREE_TYPE (dest);
9830 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9831 : tmp, expr->rank, NULL_TREE);
9832 : }
9833 : }
9834 1163 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9835 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9836 : gfc_typenode_for_spec (&cm->ts),
9837 30 : cm->as->rank, NULL_TREE);
9838 : else
9839 1133 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9840 1133 : TREE_TYPE(cm->backend_decl),
9841 1133 : cm->as->rank, NULL_TREE);
9842 :
9843 :
9844 1312 : gfc_add_expr_to_block (&block, tmp);
9845 1312 : gfc_add_block_to_block (&block, &se.post);
9846 :
9847 1312 : if (final_block && !cm->attr.allocatable
9848 96 : && expr->expr_type == EXPR_ARRAY)
9849 : {
9850 96 : tree data_ptr;
9851 96 : data_ptr = gfc_conv_descriptor_data_get (dest);
9852 96 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
9853 96 : }
9854 1216 : else if (final_block && cm->attr.allocatable)
9855 162 : gfc_add_block_to_block (final_block, &se.finalblock);
9856 :
9857 1312 : if (expr->expr_type != EXPR_VARIABLE)
9858 : {
9859 1191 : if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp)
9860 : {
9861 214 : tmp = gfc_deallocate_alloc_comp_no_caf (cm->ts.u.derived,
9862 107 : se.expr, cm->as->rank, true);
9863 107 : gfc_add_expr_to_block (&block, tmp);
9864 : }
9865 1191 : gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
9866 : }
9867 :
9868 : /* We need to know if the argument of a conversion function is a
9869 : variable, so that the correct lower bound can be used. */
9870 1312 : if (expr->expr_type == EXPR_FUNCTION
9871 68 : && expr->value.function.isym
9872 56 : && expr->value.function.isym->conversion
9873 56 : && expr->value.function.actual->expr
9874 56 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
9875 56 : arg = expr->value.function.actual->expr;
9876 :
9877 : /* Obtain the array spec of full array references. */
9878 56 : if (arg)
9879 56 : as = gfc_get_full_arrayspec_from_expr (arg);
9880 : else
9881 1256 : as = gfc_get_full_arrayspec_from_expr (expr);
9882 :
9883 : /* Shift the lbound and ubound of temporaries to being unity,
9884 : rather than zero, based. Always calculate the offset. */
9885 1312 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
9886 1312 : offset = gfc_conv_descriptor_offset_get (dest);
9887 1312 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
9888 :
9889 2680 : for (n = 0; n < expr->rank; n++)
9890 : {
9891 1368 : tree span;
9892 1368 : tree lbound;
9893 :
9894 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
9895 : TODO It looks as if gfc_conv_expr_descriptor should return
9896 : the correct bounds and that the following should not be
9897 : necessary. This would simplify gfc_conv_intrinsic_bound
9898 : as well. */
9899 1368 : if (as && as->lower[n])
9900 : {
9901 92 : gfc_se lbse;
9902 92 : gfc_init_se (&lbse, NULL);
9903 92 : gfc_conv_expr (&lbse, as->lower[n]);
9904 92 : gfc_add_block_to_block (&block, &lbse.pre);
9905 92 : lbound = gfc_evaluate_now (lbse.expr, &block);
9906 92 : }
9907 1276 : else if (as && arg)
9908 : {
9909 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
9910 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
9911 : gfc_rank_cst[n]);
9912 : }
9913 1242 : else if (as)
9914 64 : lbound = gfc_conv_descriptor_lbound_get (dest,
9915 : gfc_rank_cst[n]);
9916 : else
9917 1178 : lbound = gfc_index_one_node;
9918 :
9919 1368 : lbound = fold_convert (gfc_array_index_type, lbound);
9920 :
9921 : /* Shift the bounds and set the offset accordingly. */
9922 1368 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
9923 1368 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9924 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
9925 1368 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9926 : span, lbound);
9927 1368 : gfc_conv_descriptor_ubound_set (&block, dest,
9928 : gfc_rank_cst[n], tmp);
9929 1368 : gfc_conv_descriptor_lbound_set (&block, dest,
9930 : gfc_rank_cst[n], lbound);
9931 :
9932 1368 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9933 : gfc_conv_descriptor_lbound_get (dest,
9934 : gfc_rank_cst[n]),
9935 : gfc_conv_descriptor_stride_get (dest,
9936 : gfc_rank_cst[n]));
9937 1368 : gfc_add_modify (&block, tmp2, tmp);
9938 1368 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9939 : offset, tmp2);
9940 1368 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
9941 : }
9942 :
9943 1312 : if (arg)
9944 : {
9945 : /* If a conversion expression has a null data pointer
9946 : argument, nullify the allocatable component. */
9947 56 : tree non_null_expr;
9948 56 : tree null_expr;
9949 :
9950 56 : if (arg->symtree->n.sym->attr.allocatable
9951 24 : || arg->symtree->n.sym->attr.pointer)
9952 : {
9953 32 : non_null_expr = gfc_finish_block (&block);
9954 32 : gfc_start_block (&block);
9955 32 : gfc_conv_descriptor_data_set (&block, dest,
9956 : null_pointer_node);
9957 32 : null_expr = gfc_finish_block (&block);
9958 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
9959 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
9960 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9961 32 : return build3_v (COND_EXPR, tmp,
9962 : null_expr, non_null_expr);
9963 : }
9964 : }
9965 :
9966 1280 : return gfc_finish_block (&block);
9967 : }
9968 :
9969 :
9970 : /* Allocate or reallocate scalar component, as necessary. */
9971 :
9972 : static void
9973 416 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
9974 : gfc_component *cm, gfc_expr *expr2,
9975 : tree slen)
9976 : {
9977 416 : tree tmp;
9978 416 : tree ptr;
9979 416 : tree size;
9980 416 : tree size_in_bytes;
9981 416 : tree lhs_cl_size = NULL_TREE;
9982 416 : gfc_se se;
9983 :
9984 416 : if (!comp)
9985 0 : return;
9986 :
9987 416 : if (!expr2 || expr2->rank)
9988 : return;
9989 :
9990 416 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9991 :
9992 416 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9993 : {
9994 145 : gcc_assert (expr2->ts.type == BT_CHARACTER);
9995 145 : size = expr2->ts.u.cl->backend_decl;
9996 145 : if (!size || !VAR_P (size))
9997 145 : size = gfc_create_var (TREE_TYPE (slen), "slen");
9998 145 : gfc_add_modify (block, size, slen);
9999 :
10000 145 : gfc_deferred_strlen (cm, &tmp);
10001 145 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
10002 : gfc_charlen_type_node,
10003 145 : TREE_OPERAND (comp, 0),
10004 : tmp, NULL_TREE);
10005 :
10006 145 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
10007 145 : tmp = TYPE_SIZE_UNIT (tmp);
10008 290 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10009 145 : TREE_TYPE (tmp), tmp,
10010 145 : fold_convert (TREE_TYPE (tmp), size));
10011 : }
10012 271 : else if (cm->ts.type == BT_CLASS)
10013 : {
10014 103 : if (expr2->ts.type != BT_CLASS)
10015 : {
10016 103 : if (expr2->ts.type == BT_CHARACTER)
10017 : {
10018 24 : gfc_init_se (&se, NULL);
10019 24 : gfc_conv_expr (&se, expr2);
10020 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
10021 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10022 : gfc_charlen_type_node,
10023 : se.string_length, size);
10024 24 : size = fold_convert (size_type_node, size);
10025 : }
10026 : else
10027 : {
10028 79 : if (expr2->ts.type == BT_DERIVED)
10029 48 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
10030 : else
10031 31 : tmp = gfc_typenode_for_spec (&expr2->ts);
10032 79 : size = TYPE_SIZE_UNIT (tmp);
10033 : }
10034 : }
10035 : else
10036 : {
10037 0 : gfc_expr *e2vtab;
10038 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
10039 0 : gfc_add_vptr_component (e2vtab);
10040 0 : gfc_add_size_component (e2vtab);
10041 0 : gfc_init_se (&se, NULL);
10042 0 : gfc_conv_expr (&se, e2vtab);
10043 0 : gfc_add_block_to_block (block, &se.pre);
10044 0 : size = fold_convert (size_type_node, se.expr);
10045 0 : gfc_free_expr (e2vtab);
10046 : }
10047 : size_in_bytes = size;
10048 : }
10049 : else
10050 : {
10051 : /* Otherwise use the length in bytes of the rhs. */
10052 168 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
10053 168 : size_in_bytes = size;
10054 : }
10055 :
10056 416 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10057 : size_in_bytes, size_one_node);
10058 :
10059 416 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
10060 : {
10061 0 : tmp = build_call_expr_loc (input_location,
10062 : builtin_decl_explicit (BUILT_IN_CALLOC),
10063 : 2, build_one_cst (size_type_node),
10064 : size_in_bytes);
10065 0 : tmp = fold_convert (TREE_TYPE (comp), tmp);
10066 0 : gfc_add_modify (block, comp, tmp);
10067 : }
10068 : else
10069 : {
10070 416 : tmp = build_call_expr_loc (input_location,
10071 : builtin_decl_explicit (BUILT_IN_MALLOC),
10072 : 1, size_in_bytes);
10073 416 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
10074 103 : ptr = gfc_class_data_get (comp);
10075 : else
10076 : ptr = comp;
10077 416 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
10078 416 : gfc_add_modify (block, ptr, tmp);
10079 : }
10080 :
10081 416 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10082 : /* Update the lhs character length. */
10083 145 : gfc_add_modify (block, lhs_cl_size,
10084 145 : fold_convert (TREE_TYPE (lhs_cl_size), size));
10085 : }
10086 :
10087 :
10088 : /* Assign a single component of a derived type constructor. */
10089 :
10090 : static tree
10091 29419 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
10092 : gfc_expr * expr, bool init)
10093 : {
10094 29419 : gfc_se se;
10095 29419 : gfc_se lse;
10096 29419 : stmtblock_t block;
10097 29419 : tree tmp;
10098 29419 : tree vtab;
10099 :
10100 29419 : gfc_start_block (&block);
10101 :
10102 29419 : if (cm->attr.pointer || cm->attr.proc_pointer)
10103 : {
10104 : /* Only care about pointers here, not about allocatables. */
10105 2668 : gfc_init_se (&se, NULL);
10106 : /* Pointer component. */
10107 2668 : if ((cm->attr.dimension || cm->attr.codimension)
10108 682 : && !cm->attr.proc_pointer)
10109 : {
10110 : /* Array pointer. */
10111 666 : if (expr->expr_type == EXPR_NULL)
10112 660 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10113 : else
10114 : {
10115 6 : se.direct_byref = 1;
10116 6 : se.expr = dest;
10117 6 : gfc_conv_expr_descriptor (&se, expr);
10118 6 : gfc_add_block_to_block (&block, &se.pre);
10119 6 : gfc_add_block_to_block (&block, &se.post);
10120 : }
10121 : }
10122 : else
10123 : {
10124 : /* Scalar pointers. */
10125 2002 : se.want_pointer = 1;
10126 2002 : gfc_conv_expr (&se, expr);
10127 2002 : gfc_add_block_to_block (&block, &se.pre);
10128 :
10129 2002 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10130 12 : && expr->symtree->n.sym->attr.dummy)
10131 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10132 :
10133 2002 : gfc_add_modify (&block, dest,
10134 2002 : fold_convert (TREE_TYPE (dest), se.expr));
10135 2002 : gfc_add_block_to_block (&block, &se.post);
10136 : }
10137 : }
10138 26751 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10139 : {
10140 : /* NULL initialization for CLASS components. */
10141 940 : tmp = gfc_trans_structure_assign (dest,
10142 : gfc_class_initializer (&cm->ts, expr),
10143 : false);
10144 940 : gfc_add_expr_to_block (&block, tmp);
10145 : }
10146 25811 : else if ((cm->attr.dimension || cm->attr.codimension)
10147 : && !cm->attr.proc_pointer)
10148 : {
10149 4984 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10150 : {
10151 2752 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10152 2752 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10153 2 : gfc_add_modify (&block, gfc_conv_descriptor_token (dest),
10154 : null_pointer_node);
10155 : }
10156 2232 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10157 : {
10158 1276 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10159 1276 : gfc_add_expr_to_block (&block, tmp);
10160 : }
10161 : else
10162 : {
10163 956 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10164 956 : gfc_add_expr_to_block (&block, tmp);
10165 : }
10166 : }
10167 20827 : else if (cm->ts.type == BT_CLASS
10168 145 : && CLASS_DATA (cm)->attr.dimension
10169 36 : && CLASS_DATA (cm)->attr.allocatable
10170 36 : && expr->ts.type == BT_DERIVED)
10171 : {
10172 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10173 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10174 36 : tmp = gfc_class_vptr_get (dest);
10175 36 : gfc_add_modify (&block, tmp,
10176 36 : fold_convert (TREE_TYPE (tmp), vtab));
10177 36 : tmp = gfc_class_data_get (dest);
10178 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10179 36 : gfc_add_expr_to_block (&block, tmp);
10180 : }
10181 20791 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10182 1772 : && (init
10183 1645 : || (cm->ts.type == BT_CHARACTER
10184 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10185 : {
10186 : /* NULL initialization for allocatable components.
10187 : Deferred-length character is dealt with later. */
10188 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10189 : null_pointer_node));
10190 : }
10191 20640 : else if (init && (cm->attr.allocatable
10192 13461 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10193 109 : && expr->ts.type != BT_CLASS)))
10194 : {
10195 416 : tree size;
10196 :
10197 416 : gfc_init_se (&se, NULL);
10198 416 : gfc_conv_expr (&se, expr);
10199 :
10200 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10201 : if (!cm->attr.dimension) part above. */
10202 416 : gfc_add_block_to_block (&block, &se.pre);
10203 : /* Take care about non-array allocatable components here. The alloc_*
10204 : routine below is motivated by the alloc_scalar_allocatable_for_
10205 : assignment() routine, but with the realloc portions removed and
10206 : different input. */
10207 416 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10208 : se.string_length);
10209 :
10210 416 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10211 0 : && expr->symtree->n.sym->attr.dummy)
10212 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10213 :
10214 416 : if (cm->ts.type == BT_CLASS)
10215 : {
10216 103 : tmp = gfc_class_data_get (dest);
10217 103 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10218 103 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10219 103 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10220 103 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10221 103 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10222 : }
10223 : else
10224 313 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10225 :
10226 : /* For deferred strings insert a memcpy. */
10227 416 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10228 : {
10229 145 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10230 145 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10231 : ? se.string_length
10232 0 : : expr->ts.u.cl->backend_decl);
10233 145 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10234 145 : gfc_add_expr_to_block (&block, tmp);
10235 : }
10236 271 : else if (cm->ts.type == BT_CLASS)
10237 : {
10238 : /* Fix the expression for memcpy. */
10239 103 : if (expr->expr_type != EXPR_VARIABLE)
10240 73 : se.expr = gfc_evaluate_now (se.expr, &block);
10241 :
10242 103 : if (expr->ts.type == BT_CHARACTER)
10243 : {
10244 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10245 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10246 : gfc_charlen_type_node,
10247 : se.string_length, size);
10248 24 : size = fold_convert (size_type_node, size);
10249 : }
10250 : else
10251 79 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10252 :
10253 : /* Now copy the expression to the constructor component _data. */
10254 103 : gfc_add_expr_to_block (&block,
10255 : gfc_build_memcpy_call (tmp, se.expr, size));
10256 :
10257 : /* Fill the unlimited polymorphic _len field. */
10258 103 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10259 : {
10260 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10261 24 : gfc_add_modify (&block, tmp,
10262 24 : fold_convert (TREE_TYPE (tmp),
10263 : se.string_length));
10264 : }
10265 : }
10266 : else
10267 168 : gfc_add_modify (&block, tmp,
10268 168 : fold_convert (TREE_TYPE (tmp), se.expr));
10269 416 : gfc_add_block_to_block (&block, &se.post);
10270 416 : }
10271 20224 : else if (expr->ts.type == BT_UNION)
10272 : {
10273 13 : tree tmp;
10274 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10275 : /* We mark that the entire union should be initialized with a contrived
10276 : EXPR_NULL expression at the beginning. */
10277 13 : if (c != NULL && c->n.component == NULL
10278 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10279 : {
10280 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10281 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10282 6 : gfc_add_expr_to_block (&block, tmp);
10283 6 : c = gfc_constructor_next (c);
10284 : }
10285 : /* The following constructor expression, if any, represents a specific
10286 : map initializer, as given by the user. */
10287 13 : if (c != NULL && c->expr != NULL)
10288 : {
10289 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10290 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10291 6 : gfc_add_expr_to_block (&block, tmp);
10292 : }
10293 : }
10294 20211 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10295 : {
10296 3123 : if (expr->expr_type != EXPR_STRUCTURE)
10297 : {
10298 452 : tree dealloc = NULL_TREE;
10299 452 : gfc_init_se (&se, NULL);
10300 452 : gfc_conv_expr (&se, expr);
10301 452 : gfc_add_block_to_block (&block, &se.pre);
10302 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10303 : expression in a temporary variable and deallocate the allocatable
10304 : components. Then we can the copy the expression to the result. */
10305 452 : if (cm->ts.u.derived->attr.alloc_comp
10306 330 : && expr->expr_type != EXPR_VARIABLE)
10307 : {
10308 300 : se.expr = gfc_evaluate_now (se.expr, &block);
10309 300 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10310 : expr->rank);
10311 : }
10312 452 : gfc_add_modify (&block, dest,
10313 452 : fold_convert (TREE_TYPE (dest), se.expr));
10314 452 : if (cm->ts.u.derived->attr.alloc_comp
10315 330 : && expr->expr_type != EXPR_NULL)
10316 : {
10317 : // TODO: Fix caf_mode
10318 48 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10319 : dest, expr->rank, 0);
10320 48 : gfc_add_expr_to_block (&block, tmp);
10321 48 : if (dealloc != NULL_TREE)
10322 18 : gfc_add_expr_to_block (&block, dealloc);
10323 : }
10324 452 : gfc_add_block_to_block (&block, &se.post);
10325 : }
10326 : else
10327 : {
10328 : /* Nested constructors. */
10329 2671 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10330 2671 : gfc_add_expr_to_block (&block, tmp);
10331 : }
10332 : }
10333 17088 : else if (gfc_deferred_strlen (cm, &tmp))
10334 : {
10335 125 : tree strlen;
10336 125 : strlen = tmp;
10337 125 : gcc_assert (strlen);
10338 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10339 125 : TREE_TYPE (strlen),
10340 125 : TREE_OPERAND (dest, 0),
10341 : strlen, NULL_TREE);
10342 :
10343 125 : if (expr->expr_type == EXPR_NULL)
10344 : {
10345 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10346 107 : gfc_add_modify (&block, dest, tmp);
10347 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10348 107 : gfc_add_modify (&block, strlen, tmp);
10349 : }
10350 : else
10351 : {
10352 18 : tree size;
10353 18 : gfc_init_se (&se, NULL);
10354 18 : gfc_conv_expr (&se, expr);
10355 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10356 18 : size = fold_convert (size_type_node, size);
10357 18 : tmp = build_call_expr_loc (input_location,
10358 : builtin_decl_explicit (BUILT_IN_MALLOC),
10359 : 1, size);
10360 18 : gfc_add_modify (&block, dest,
10361 18 : fold_convert (TREE_TYPE (dest), tmp));
10362 18 : gfc_add_modify (&block, strlen,
10363 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10364 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10365 18 : gfc_add_expr_to_block (&block, tmp);
10366 : }
10367 : }
10368 16963 : else if (!cm->attr.artificial)
10369 : {
10370 : /* Scalar component (excluding deferred parameters). */
10371 16842 : gfc_init_se (&se, NULL);
10372 16842 : gfc_init_se (&lse, NULL);
10373 :
10374 16842 : gfc_conv_expr (&se, expr);
10375 16842 : if (cm->ts.type == BT_CHARACTER)
10376 1057 : lse.string_length = cm->ts.u.cl->backend_decl;
10377 16842 : lse.expr = dest;
10378 16842 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10379 16842 : gfc_add_expr_to_block (&block, tmp);
10380 : }
10381 29419 : return gfc_finish_block (&block);
10382 : }
10383 :
10384 : /* Assign a derived type constructor to a variable. */
10385 :
10386 : tree
10387 20558 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10388 : {
10389 20558 : gfc_constructor *c;
10390 20558 : gfc_component *cm;
10391 20558 : stmtblock_t block;
10392 20558 : tree field;
10393 20558 : tree tmp;
10394 20558 : gfc_se se;
10395 :
10396 20558 : gfc_start_block (&block);
10397 :
10398 20558 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10399 179 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10400 13 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10401 : {
10402 179 : gfc_se lse;
10403 :
10404 179 : gfc_init_se (&se, NULL);
10405 179 : gfc_init_se (&lse, NULL);
10406 179 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10407 179 : lse.expr = dest;
10408 179 : gfc_add_modify (&block, lse.expr,
10409 179 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10410 :
10411 179 : return gfc_finish_block (&block);
10412 : }
10413 :
10414 : /* Make sure that the derived type has been completely built. */
10415 20379 : if (!expr->ts.u.derived->backend_decl
10416 20379 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10417 : {
10418 224 : tmp = gfc_typenode_for_spec (&expr->ts);
10419 224 : gcc_assert (tmp);
10420 : }
10421 :
10422 20379 : cm = expr->ts.u.derived->components;
10423 :
10424 :
10425 20379 : if (coarray)
10426 225 : gfc_init_se (&se, NULL);
10427 :
10428 20379 : for (c = gfc_constructor_first (expr->value.constructor);
10429 52948 : c; c = gfc_constructor_next (c), cm = cm->next)
10430 : {
10431 : /* Skip absent members in default initializers. */
10432 32569 : if (!c->expr && !cm->attr.allocatable)
10433 3150 : continue;
10434 :
10435 : /* Register the component with the caf-lib before it is initialized.
10436 : Register only allocatable components, that are not coarray'ed
10437 : components (%comp[*]). Only register when the constructor is the
10438 : null-expression. */
10439 29419 : if (coarray && !cm->attr.codimension
10440 515 : && (cm->attr.allocatable || cm->attr.pointer)
10441 179 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10442 : {
10443 177 : tree token, desc, size;
10444 354 : bool is_array = cm->ts.type == BT_CLASS
10445 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10446 :
10447 177 : field = cm->backend_decl;
10448 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
10449 177 : TREE_TYPE (field), dest, field, NULL_TREE);
10450 177 : if (cm->ts.type == BT_CLASS)
10451 0 : field = gfc_class_data_get (field);
10452 :
10453 177 : token
10454 : = is_array
10455 177 : ? gfc_conv_descriptor_token (field)
10456 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10457 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10458 52 : gfc_comp_caf_token (cm), NULL_TREE);
10459 :
10460 177 : if (is_array)
10461 : {
10462 : /* The _caf_register routine looks at the rank of the array
10463 : descriptor to decide whether the data registered is an array
10464 : or not. */
10465 125 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10466 125 : : cm->as->rank;
10467 : /* When the rank is not known just set a positive rank, which
10468 : suffices to recognize the data as array. */
10469 125 : if (rank < 0)
10470 0 : rank = 1;
10471 125 : size = build_zero_cst (size_type_node);
10472 125 : desc = field;
10473 125 : gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
10474 : gfc_rank_cst[rank]);
10475 : }
10476 : else
10477 : {
10478 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10479 52 : cm->ts.type == BT_CLASS
10480 52 : ? CLASS_DATA (cm)->attr
10481 : : cm->attr);
10482 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10483 : }
10484 177 : gfc_add_block_to_block (&block, &se.pre);
10485 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10486 : 7, size, build_int_cst (
10487 : integer_type_node,
10488 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10489 : gfc_build_addr_expr (pvoid_type_node,
10490 : token),
10491 : gfc_build_addr_expr (NULL_TREE, desc),
10492 : null_pointer_node, null_pointer_node,
10493 : integer_zero_node);
10494 177 : gfc_add_expr_to_block (&block, tmp);
10495 : }
10496 29419 : field = cm->backend_decl;
10497 29419 : gcc_assert(field);
10498 29419 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10499 : dest, field, NULL_TREE);
10500 29419 : if (!c->expr)
10501 : {
10502 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10503 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10504 0 : gfc_free_expr (e);
10505 : }
10506 : else
10507 29419 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10508 29419 : gfc_add_expr_to_block (&block, tmp);
10509 : }
10510 20379 : return gfc_finish_block (&block);
10511 : }
10512 :
10513 : static void
10514 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10515 : gfc_component *un, gfc_expr *init)
10516 : {
10517 21 : gfc_constructor *ctor;
10518 :
10519 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
10520 : return;
10521 :
10522 21 : ctor = gfc_constructor_first (init->value.constructor);
10523 :
10524 21 : if (ctor == NULL || ctor->expr == NULL)
10525 : return;
10526 :
10527 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
10528 :
10529 : /* If we have an 'initialize all' constructor, do it first. */
10530 21 : if (ctor->expr->expr_type == EXPR_NULL)
10531 : {
10532 9 : tree union_type = TREE_TYPE (un->backend_decl);
10533 9 : tree val = build_constructor (union_type, NULL);
10534 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10535 9 : ctor = gfc_constructor_next (ctor);
10536 : }
10537 :
10538 : /* Add the map initializer on top. */
10539 21 : if (ctor != NULL && ctor->expr != NULL)
10540 : {
10541 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
10542 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
10543 12 : TREE_TYPE (un->backend_decl),
10544 12 : un->attr.dimension, un->attr.pointer,
10545 12 : un->attr.proc_pointer);
10546 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10547 : }
10548 : }
10549 :
10550 : /* Build an expression for a constructor. If init is nonzero then
10551 : this is part of a static variable initializer. */
10552 :
10553 : void
10554 38316 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
10555 : {
10556 38316 : gfc_constructor *c;
10557 38316 : gfc_component *cm;
10558 38316 : tree val;
10559 38316 : tree type;
10560 38316 : tree tmp;
10561 38316 : vec<constructor_elt, va_gc> *v = NULL;
10562 :
10563 38316 : gcc_assert (se->ss == NULL);
10564 38316 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10565 38316 : type = gfc_typenode_for_spec (&expr->ts);
10566 :
10567 38316 : if (!init)
10568 : {
10569 16138 : if (IS_PDT (expr) && expr->must_finalize)
10570 276 : final_block = &se->finalblock;
10571 :
10572 : /* Create a temporary variable and fill it in. */
10573 16138 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
10574 : /* The symtree in expr is NULL, if the code to generate is for
10575 : initializing the static members only. */
10576 32276 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
10577 16138 : se->want_coarray);
10578 16138 : gfc_add_expr_to_block (&se->pre, tmp);
10579 16138 : final_block = NULL;
10580 16138 : return;
10581 : }
10582 :
10583 22178 : cm = expr->ts.u.derived->components;
10584 :
10585 22178 : for (c = gfc_constructor_first (expr->value.constructor);
10586 113294 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
10587 : {
10588 : /* Skip absent members in default initializers and allocatable
10589 : components. Although the latter have a default initializer
10590 : of EXPR_NULL,... by default, the static nullify is not needed
10591 : since this is done every time we come into scope. */
10592 99789 : if (!c->expr
10593 88698 : || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)
10594 173649 : || (IS_PDT (cm) && has_parameterized_comps (cm->ts.u.derived)))
10595 8673 : continue;
10596 :
10597 82443 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
10598 47923 : && strcmp (cm->name, "_extends") == 0
10599 1308 : && cm->initializer->symtree)
10600 : {
10601 1308 : tree vtab;
10602 1308 : gfc_symbol *vtabs;
10603 1308 : vtabs = cm->initializer->symtree->n.sym;
10604 1308 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
10605 1308 : vtab = unshare_expr_without_location (vtab);
10606 1308 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
10607 1308 : }
10608 81135 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
10609 : {
10610 8746 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
10611 8746 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10612 : fold_convert (TREE_TYPE (cm->backend_decl),
10613 : val));
10614 8746 : }
10615 72389 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
10616 413 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10617 : fold_convert (TREE_TYPE (cm->backend_decl),
10618 413 : integer_zero_node));
10619 71976 : else if (cm->ts.type == BT_UNION)
10620 21 : gfc_conv_union_initializer (v, cm, c->expr);
10621 : else
10622 : {
10623 71955 : val = gfc_conv_initializer (c->expr, &cm->ts,
10624 71955 : TREE_TYPE (cm->backend_decl),
10625 71955 : cm->attr.dimension, cm->attr.pointer,
10626 71955 : cm->attr.proc_pointer);
10627 71955 : val = unshare_expr_without_location (val);
10628 :
10629 : /* Append it to the constructor list. */
10630 163071 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
10631 : }
10632 : }
10633 :
10634 22178 : se->expr = build_constructor (type, v);
10635 22178 : if (init)
10636 22178 : TREE_CONSTANT (se->expr) = 1;
10637 : }
10638 :
10639 :
10640 : /* Translate a substring expression. */
10641 :
10642 : static void
10643 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
10644 : {
10645 258 : gfc_ref *ref;
10646 :
10647 258 : ref = expr->ref;
10648 :
10649 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
10650 :
10651 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
10652 258 : expr->value.character.length,
10653 258 : expr->value.character.string);
10654 :
10655 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
10656 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
10657 :
10658 258 : if (ref)
10659 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
10660 258 : }
10661 :
10662 :
10663 : /* Entry point for expression translation. Evaluates a scalar quantity.
10664 : EXPR is the expression to be translated, and SE is the state structure if
10665 : called from within the scalarized. */
10666 :
10667 : void
10668 3658083 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
10669 : {
10670 3658083 : gfc_ss *ss;
10671 :
10672 3658083 : ss = se->ss;
10673 3658083 : if (ss && ss->info->expr == expr
10674 239218 : && (ss->info->type == GFC_SS_SCALAR
10675 : || ss->info->type == GFC_SS_REFERENCE))
10676 : {
10677 40643 : gfc_ss_info *ss_info;
10678 :
10679 40643 : ss_info = ss->info;
10680 : /* Substitute a scalar expression evaluated outside the scalarization
10681 : loop. */
10682 40643 : se->expr = ss_info->data.scalar.value;
10683 40643 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
10684 844 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
10685 :
10686 40643 : se->string_length = ss_info->string_length;
10687 40643 : gfc_advance_se_ss_chain (se);
10688 40643 : return;
10689 : }
10690 :
10691 : /* We need to convert the expressions for the iso_c_binding derived types.
10692 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
10693 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
10694 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
10695 : updated to be an integer with a kind equal to the size of a (void *). */
10696 3617440 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
10697 14823 : && expr->ts.u.derived->attr.is_bind_c)
10698 : {
10699 13974 : if (expr->expr_type == EXPR_VARIABLE
10700 9526 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
10701 9526 : || expr->symtree->n.sym->intmod_sym_id
10702 : == ISOCBINDING_NULL_FUNPTR))
10703 : {
10704 : /* Set expr_type to EXPR_NULL, which will result in
10705 : null_pointer_node being used below. */
10706 0 : expr->expr_type = EXPR_NULL;
10707 : }
10708 : else
10709 : {
10710 : /* Update the type/kind of the expression to be what the new
10711 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
10712 13974 : expr->ts.type = BT_INTEGER;
10713 13974 : expr->ts.f90_type = BT_VOID;
10714 13974 : expr->ts.kind = gfc_index_integer_kind;
10715 : }
10716 : }
10717 :
10718 3617440 : gfc_fix_class_refs (expr);
10719 :
10720 3617440 : switch (expr->expr_type)
10721 : {
10722 506740 : case EXPR_OP:
10723 506740 : gfc_conv_expr_op (se, expr);
10724 506740 : break;
10725 :
10726 159 : case EXPR_CONDITIONAL:
10727 159 : gfc_conv_conditional_expr (se, expr);
10728 159 : break;
10729 :
10730 306395 : case EXPR_FUNCTION:
10731 306395 : gfc_conv_function_expr (se, expr);
10732 306395 : break;
10733 :
10734 1139978 : case EXPR_CONSTANT:
10735 1139978 : gfc_conv_constant (se, expr);
10736 1139978 : break;
10737 :
10738 1607638 : case EXPR_VARIABLE:
10739 1607638 : gfc_conv_variable (se, expr);
10740 1607638 : break;
10741 :
10742 4211 : case EXPR_NULL:
10743 4211 : se->expr = null_pointer_node;
10744 4211 : break;
10745 :
10746 258 : case EXPR_SUBSTRING:
10747 258 : gfc_conv_substring_expr (se, expr);
10748 258 : break;
10749 :
10750 16138 : case EXPR_STRUCTURE:
10751 16138 : gfc_conv_structure (se, expr, 0);
10752 : /* F2008 4.5.6.3 para 5: If an executable construct references a
10753 : structure constructor or array constructor, the entity created by
10754 : the constructor is finalized after execution of the innermost
10755 : executable construct containing the reference. This, in fact,
10756 : was later deleted by the Combined Technical Corrigenda 1 TO 4 for
10757 : fortran 2008 (f08/0011). */
10758 16138 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
10759 16138 : && !(gfc_option.allow_std & GFC_STD_GNU)
10760 139 : && expr->must_finalize
10761 16150 : && gfc_may_be_finalized (expr->ts))
10762 : {
10763 12 : locus loc;
10764 12 : gfc_locus_from_location (&loc, input_location);
10765 12 : gfc_warning (0, "The structure constructor at %L has been"
10766 : " finalized. This feature was removed by f08/0011."
10767 : " Use -std=f2018 or -std=gnu to eliminate the"
10768 : " finalization.", &loc);
10769 12 : symbol_attribute attr;
10770 12 : attr.allocatable = attr.pointer = 0;
10771 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
10772 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
10773 : }
10774 : break;
10775 :
10776 35923 : case EXPR_ARRAY:
10777 35923 : gfc_conv_array_constructor_expr (se, expr);
10778 35923 : gfc_add_block_to_block (&se->post, &se->finalblock);
10779 35923 : break;
10780 :
10781 0 : default:
10782 0 : gcc_unreachable ();
10783 3658083 : break;
10784 : }
10785 : }
10786 :
10787 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
10788 : of an assignment. */
10789 : void
10790 374441 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
10791 : {
10792 374441 : gfc_conv_expr (se, expr);
10793 : /* All numeric lvalues should have empty post chains. If not we need to
10794 : figure out a way of rewriting an lvalue so that it has no post chain. */
10795 374441 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
10796 374441 : }
10797 :
10798 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
10799 : numeric expressions. Used for scalar values where inserting cleanup code
10800 : is inconvenient. */
10801 : void
10802 1036819 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
10803 : {
10804 1036819 : tree val;
10805 :
10806 1036819 : gcc_assert (expr->ts.type != BT_CHARACTER);
10807 1036819 : gfc_conv_expr (se, expr);
10808 1036819 : if (se->post.head)
10809 : {
10810 2551 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
10811 2551 : gfc_add_modify (&se->pre, val, se->expr);
10812 2551 : se->expr = val;
10813 2551 : gfc_add_block_to_block (&se->pre, &se->post);
10814 : }
10815 1036819 : }
10816 :
10817 : /* Helper to translate an expression and convert it to a particular type. */
10818 : void
10819 293323 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
10820 : {
10821 293323 : gfc_conv_expr_val (se, expr);
10822 293323 : se->expr = convert (type, se->expr);
10823 293323 : }
10824 :
10825 :
10826 : /* Converts an expression so that it can be passed by reference. Scalar
10827 : values only. */
10828 :
10829 : void
10830 228358 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
10831 : {
10832 228358 : gfc_ss *ss;
10833 228358 : tree var;
10834 :
10835 228358 : ss = se->ss;
10836 228358 : if (ss && ss->info->expr == expr
10837 8023 : && ss->info->type == GFC_SS_REFERENCE)
10838 : {
10839 : /* Returns a reference to the scalar evaluated outside the loop
10840 : for this case. */
10841 907 : gfc_conv_expr (se, expr);
10842 :
10843 907 : if (expr->ts.type == BT_CHARACTER
10844 114 : && expr->expr_type != EXPR_FUNCTION)
10845 102 : gfc_conv_string_parameter (se);
10846 : else
10847 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10848 :
10849 907 : return;
10850 : }
10851 :
10852 227451 : if (expr->ts.type == BT_CHARACTER)
10853 : {
10854 49855 : gfc_conv_expr (se, expr);
10855 49855 : gfc_conv_string_parameter (se);
10856 49855 : return;
10857 : }
10858 :
10859 177596 : if (expr->expr_type == EXPR_VARIABLE)
10860 : {
10861 70756 : se->want_pointer = 1;
10862 70756 : gfc_conv_expr (se, expr);
10863 70756 : if (se->post.head)
10864 : {
10865 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10866 0 : gfc_add_modify (&se->pre, var, se->expr);
10867 0 : gfc_add_block_to_block (&se->pre, &se->post);
10868 0 : se->expr = var;
10869 : }
10870 70756 : return;
10871 : }
10872 :
10873 106840 : if (expr->expr_type == EXPR_CONDITIONAL)
10874 : {
10875 18 : se->want_pointer = 1;
10876 18 : gfc_conv_expr (se, expr);
10877 18 : return;
10878 : }
10879 :
10880 106822 : if (expr->expr_type == EXPR_FUNCTION
10881 13782 : && ((expr->value.function.esym
10882 2101 : && expr->value.function.esym->result
10883 2100 : && expr->value.function.esym->result->attr.pointer
10884 83 : && !expr->value.function.esym->result->attr.dimension)
10885 13705 : || (!expr->value.function.esym && !expr->ref
10886 11575 : && expr->symtree->n.sym->attr.pointer
10887 0 : && !expr->symtree->n.sym->attr.dimension)))
10888 : {
10889 77 : se->want_pointer = 1;
10890 77 : gfc_conv_expr (se, expr);
10891 77 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10892 77 : gfc_add_modify (&se->pre, var, se->expr);
10893 77 : se->expr = var;
10894 77 : return;
10895 : }
10896 :
10897 106745 : gfc_conv_expr (se, expr);
10898 :
10899 : /* Create a temporary var to hold the value. */
10900 106745 : if (TREE_CONSTANT (se->expr))
10901 : {
10902 : tree tmp = se->expr;
10903 84404 : STRIP_TYPE_NOPS (tmp);
10904 84404 : var = build_decl (input_location,
10905 84404 : CONST_DECL, NULL, TREE_TYPE (tmp));
10906 84404 : DECL_INITIAL (var) = tmp;
10907 84404 : TREE_STATIC (var) = 1;
10908 84404 : pushdecl (var);
10909 : }
10910 : else
10911 : {
10912 22341 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10913 22341 : gfc_add_modify (&se->pre, var, se->expr);
10914 : }
10915 :
10916 106745 : if (!expr->must_finalize)
10917 106649 : gfc_add_block_to_block (&se->pre, &se->post);
10918 :
10919 : /* Take the address of that value. */
10920 106745 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
10921 : }
10922 :
10923 :
10924 : /* Get the _len component for an unlimited polymorphic expression. */
10925 :
10926 : static tree
10927 1800 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
10928 : {
10929 1800 : gfc_se se;
10930 1800 : gfc_ref *ref = expr->ref;
10931 :
10932 1800 : gfc_init_se (&se, NULL);
10933 3714 : while (ref && ref->next)
10934 : ref = ref->next;
10935 1800 : gfc_add_len_component (expr);
10936 1800 : gfc_conv_expr (&se, expr);
10937 1800 : gfc_add_block_to_block (block, &se.pre);
10938 1800 : gcc_assert (se.post.head == NULL_TREE);
10939 1800 : if (ref)
10940 : {
10941 262 : gfc_free_ref_list (ref->next);
10942 262 : ref->next = NULL;
10943 : }
10944 : else
10945 : {
10946 1538 : gfc_free_ref_list (expr->ref);
10947 1538 : expr->ref = NULL;
10948 : }
10949 1800 : return se.expr;
10950 : }
10951 :
10952 :
10953 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
10954 : statement-list outside of the scalarizer-loop. When code is generated, that
10955 : depends on the scalarized expression, it is added to RSE.PRE.
10956 : Returns le's _vptr tree and when set the len expressions in to_lenp and
10957 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
10958 : expression. */
10959 :
10960 : static tree
10961 4535 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
10962 : gfc_expr * re, gfc_se *rse,
10963 : tree * to_lenp, tree * from_lenp,
10964 : tree * from_vptrp)
10965 : {
10966 4535 : gfc_se se;
10967 4535 : gfc_expr * vptr_expr;
10968 4535 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
10969 4535 : bool set_vptr = false, temp_rhs = false;
10970 4535 : stmtblock_t *pre = block;
10971 4535 : tree class_expr = NULL_TREE;
10972 4535 : tree from_vptr = NULL_TREE;
10973 :
10974 : /* Create a temporary for complicated expressions. */
10975 4535 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
10976 1263 : && rse->expr != NULL_TREE)
10977 : {
10978 1263 : if (!DECL_P (rse->expr))
10979 : {
10980 392 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10981 37 : class_expr = gfc_get_class_from_expr (rse->expr);
10982 :
10983 392 : if (rse->loop)
10984 159 : pre = &rse->loop->pre;
10985 : else
10986 233 : pre = &rse->pre;
10987 :
10988 392 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
10989 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
10990 : else
10991 355 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
10992 :
10993 392 : rse->expr = tmp;
10994 : }
10995 : else
10996 871 : pre = &rse->pre;
10997 :
10998 : temp_rhs = true;
10999 : }
11000 :
11001 : /* Get the _vptr for the left-hand side expression. */
11002 4535 : gfc_init_se (&se, NULL);
11003 4535 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
11004 4535 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
11005 : {
11006 : /* Care about _len for unlimited polymorphic entities. */
11007 4535 : if (UNLIMITED_POLY (vptr_expr)
11008 3503 : || (vptr_expr->ts.type == BT_DERIVED
11009 2479 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11010 1516 : to_len = trans_get_upoly_len (block, vptr_expr);
11011 4535 : gfc_add_vptr_component (vptr_expr);
11012 4535 : set_vptr = true;
11013 : }
11014 : else
11015 0 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11016 4535 : se.want_pointer = 1;
11017 4535 : gfc_conv_expr (&se, vptr_expr);
11018 4535 : gfc_free_expr (vptr_expr);
11019 4535 : gfc_add_block_to_block (block, &se.pre);
11020 4535 : gcc_assert (se.post.head == NULL_TREE);
11021 4535 : lhs_vptr = se.expr;
11022 4535 : STRIP_NOPS (lhs_vptr);
11023 :
11024 : /* Set the _vptr only when the left-hand side of the assignment is a
11025 : class-object. */
11026 4535 : if (set_vptr)
11027 : {
11028 : /* Get the vptr from the rhs expression only, when it is variable.
11029 : Functions are expected to be assigned to a temporary beforehand. */
11030 3143 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
11031 5316 : ? gfc_find_and_cut_at_last_class_ref (re)
11032 : : NULL;
11033 781 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
11034 : {
11035 781 : if (to_len != NULL_TREE)
11036 : {
11037 : /* Get the _len information from the rhs. */
11038 299 : if (UNLIMITED_POLY (vptr_expr)
11039 : || (vptr_expr->ts.type == BT_DERIVED
11040 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11041 272 : from_len = trans_get_upoly_len (block, vptr_expr);
11042 : }
11043 781 : gfc_add_vptr_component (vptr_expr);
11044 : }
11045 : else
11046 : {
11047 3754 : if (re->expr_type == EXPR_VARIABLE
11048 2362 : && DECL_P (re->symtree->n.sym->backend_decl)
11049 2362 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
11050 834 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
11051 3821 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
11052 : re->symtree->n.sym->backend_decl))))
11053 : {
11054 43 : vptr_expr = NULL;
11055 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
11056 : re->symtree->n.sym->backend_decl));
11057 43 : if (to_len && UNLIMITED_POLY (re))
11058 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
11059 : re->symtree->n.sym->backend_decl));
11060 : }
11061 3711 : else if (temp_rhs && re->ts.type == BT_CLASS)
11062 : {
11063 215 : vptr_expr = NULL;
11064 215 : if (class_expr)
11065 : tmp = class_expr;
11066 178 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11067 0 : tmp = gfc_get_class_from_expr (rse->expr);
11068 : else
11069 : tmp = rse->expr;
11070 :
11071 215 : se.expr = gfc_class_vptr_get (tmp);
11072 215 : from_vptr = se.expr;
11073 215 : if (UNLIMITED_POLY (re))
11074 74 : from_len = gfc_class_len_get (tmp);
11075 :
11076 : }
11077 3496 : else if (re->expr_type != EXPR_NULL)
11078 : /* Only when rhs is non-NULL use its declared type for vptr
11079 : initialisation. */
11080 3367 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
11081 : else
11082 : /* When the rhs is NULL use the vtab of lhs' declared type. */
11083 129 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11084 : }
11085 :
11086 4351 : if (vptr_expr)
11087 : {
11088 4277 : gfc_init_se (&se, NULL);
11089 4277 : se.want_pointer = 1;
11090 4277 : gfc_conv_expr (&se, vptr_expr);
11091 4277 : gfc_free_expr (vptr_expr);
11092 4277 : gfc_add_block_to_block (block, &se.pre);
11093 4277 : gcc_assert (se.post.head == NULL_TREE);
11094 4277 : from_vptr = se.expr;
11095 : }
11096 4535 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
11097 : se.expr));
11098 :
11099 4535 : if (to_len != NULL_TREE)
11100 : {
11101 : /* The _len component needs to be set. Figure how to get the
11102 : value of the right-hand side. */
11103 1516 : if (from_len == NULL_TREE)
11104 : {
11105 1170 : if (rse->string_length != NULL_TREE)
11106 : from_len = rse->string_length;
11107 712 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
11108 : {
11109 0 : gfc_init_se (&se, NULL);
11110 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
11111 0 : gfc_add_block_to_block (block, &se.pre);
11112 0 : gcc_assert (se.post.head == NULL_TREE);
11113 0 : from_len = gfc_evaluate_now (se.expr, block);
11114 : }
11115 : else
11116 712 : from_len = build_zero_cst (gfc_charlen_type_node);
11117 : }
11118 1516 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
11119 : from_len));
11120 : }
11121 : }
11122 :
11123 : /* Return the _len and _vptr trees only, when requested. */
11124 4535 : if (to_lenp)
11125 3319 : *to_lenp = to_len;
11126 4535 : if (from_lenp)
11127 3319 : *from_lenp = from_len;
11128 4535 : if (from_vptrp)
11129 3319 : *from_vptrp = from_vptr;
11130 4535 : return lhs_vptr;
11131 : }
11132 :
11133 :
11134 : /* Assign tokens for pointer components. */
11135 :
11136 : static void
11137 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11138 : gfc_expr *expr2)
11139 : {
11140 12 : symbol_attribute lhs_attr, rhs_attr;
11141 12 : tree tmp, lhs_tok, rhs_tok;
11142 : /* Flag to indicated component refs on the rhs. */
11143 12 : bool rhs_cr;
11144 :
11145 12 : lhs_attr = gfc_caf_attr (expr1);
11146 12 : if (expr2->expr_type != EXPR_NULL)
11147 : {
11148 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11149 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11150 : {
11151 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11152 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11153 :
11154 4 : if (rhs_cr)
11155 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11156 : else
11157 : {
11158 4 : tree caf_decl;
11159 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11160 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11161 : NULL_TREE, NULL);
11162 : }
11163 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11164 : lhs_tok,
11165 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11166 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11167 : }
11168 : }
11169 4 : else if (lhs_attr.codimension)
11170 : {
11171 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11172 4 : if (!lhs_tok)
11173 : {
11174 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11175 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11176 : }
11177 : else
11178 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11179 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11180 : lhs_tok, null_pointer_node);
11181 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11182 : }
11183 12 : }
11184 :
11185 :
11186 : /* Do everything that is needed for a CLASS function expr2. */
11187 :
11188 : static tree
11189 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11190 : gfc_expr *expr1, gfc_expr *expr2)
11191 : {
11192 18 : tree expr1_vptr = NULL_TREE;
11193 18 : tree tmp;
11194 :
11195 18 : gfc_conv_function_expr (rse, expr2);
11196 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11197 :
11198 18 : if (expr1->ts.type != BT_CLASS)
11199 12 : rse->expr = gfc_class_data_get (rse->expr);
11200 : else
11201 : {
11202 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11203 : expr2, rse,
11204 : NULL, NULL, NULL);
11205 6 : gfc_add_block_to_block (block, &rse->pre);
11206 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11207 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11208 :
11209 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11210 6 : fold_convert (TREE_TYPE (expr1_vptr),
11211 : gfc_class_vptr_get (tmp)));
11212 6 : rse->expr = gfc_class_data_get (tmp);
11213 : }
11214 :
11215 18 : return expr1_vptr;
11216 : }
11217 :
11218 :
11219 : tree
11220 10151 : gfc_trans_pointer_assign (gfc_code * code)
11221 : {
11222 10151 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11223 : }
11224 :
11225 :
11226 : /* Generate code for a pointer assignment. */
11227 :
11228 : tree
11229 10206 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11230 : {
11231 10206 : gfc_se lse;
11232 10206 : gfc_se rse;
11233 10206 : stmtblock_t block;
11234 10206 : tree desc;
11235 10206 : tree tmp;
11236 10206 : tree expr1_vptr = NULL_TREE;
11237 10206 : bool scalar, non_proc_ptr_assign;
11238 10206 : gfc_ss *ss;
11239 :
11240 10206 : gfc_start_block (&block);
11241 :
11242 10206 : gfc_init_se (&lse, NULL);
11243 :
11244 : /* Usually testing whether this is not a proc pointer assignment. */
11245 10206 : non_proc_ptr_assign
11246 10206 : = !(gfc_expr_attr (expr1).proc_pointer
11247 1207 : && ((expr2->expr_type == EXPR_VARIABLE
11248 975 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11249 282 : || expr2->expr_type == EXPR_NULL));
11250 :
11251 : /* Check whether the expression is a scalar or not; we cannot use
11252 : expr1->rank as it can be nonzero for proc pointers. */
11253 10206 : ss = gfc_walk_expr (expr1);
11254 10206 : scalar = ss == gfc_ss_terminator;
11255 10206 : if (!scalar)
11256 4384 : gfc_free_ss_chain (ss);
11257 :
11258 10206 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11259 90 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11260 : {
11261 66 : gfc_add_data_component (expr2);
11262 : /* The following is required as gfc_add_data_component doesn't
11263 : update ts.type if there is a trailing REF_ARRAY. */
11264 66 : expr2->ts.type = BT_DERIVED;
11265 : }
11266 :
11267 10206 : if (scalar)
11268 : {
11269 : /* Scalar pointers. */
11270 5822 : lse.want_pointer = 1;
11271 5822 : gfc_conv_expr (&lse, expr1);
11272 5822 : gfc_init_se (&rse, NULL);
11273 5822 : rse.want_pointer = 1;
11274 5822 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11275 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11276 : else
11277 5816 : gfc_conv_expr (&rse, expr2);
11278 :
11279 5822 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11280 : {
11281 769 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11282 : NULL, NULL);
11283 769 : lse.expr = gfc_class_data_get (lse.expr);
11284 : }
11285 :
11286 5822 : if (expr1->symtree->n.sym->attr.proc_pointer
11287 863 : && expr1->symtree->n.sym->attr.dummy)
11288 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11289 : lse.expr);
11290 :
11291 5822 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11292 47 : && expr2->symtree->n.sym->attr.dummy)
11293 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11294 : rse.expr);
11295 :
11296 5822 : gfc_add_block_to_block (&block, &lse.pre);
11297 5822 : gfc_add_block_to_block (&block, &rse.pre);
11298 :
11299 : /* Check character lengths if character expression. The test is only
11300 : really added if -fbounds-check is enabled. Exclude deferred
11301 : character length lefthand sides. */
11302 954 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11303 780 : && !expr1->ts.deferred
11304 365 : && !expr1->symtree->n.sym->attr.proc_pointer
11305 6180 : && !gfc_is_proc_ptr_comp (expr1))
11306 : {
11307 339 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11308 339 : gcc_assert (lse.string_length && rse.string_length);
11309 339 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11310 : lse.string_length, rse.string_length,
11311 : &block);
11312 : }
11313 :
11314 : /* The assignment to an deferred character length sets the string
11315 : length to that of the rhs. */
11316 5822 : if (expr1->ts.deferred)
11317 : {
11318 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11319 413 : gfc_add_modify (&block, lse.string_length,
11320 413 : fold_convert (TREE_TYPE (lse.string_length),
11321 : rse.string_length));
11322 117 : else if (lse.string_length != NULL)
11323 115 : gfc_add_modify (&block, lse.string_length,
11324 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11325 : }
11326 :
11327 5822 : gfc_add_modify (&block, lse.expr,
11328 5822 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11329 :
11330 5822 : if (flag_coarray == GFC_FCOARRAY_LIB)
11331 : {
11332 342 : if (expr1->ref)
11333 : /* Also set the tokens for pointer components in derived typed
11334 : coarrays. */
11335 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11336 330 : else if (gfc_caf_attr (expr1).codimension)
11337 : {
11338 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11339 :
11340 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11341 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11342 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11343 : NULL_TREE, expr1);
11344 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11345 : NULL_TREE, expr2);
11346 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11347 : }
11348 : }
11349 :
11350 5822 : gfc_add_block_to_block (&block, &rse.post);
11351 5822 : gfc_add_block_to_block (&block, &lse.post);
11352 : }
11353 : else
11354 : {
11355 4384 : gfc_ref* remap;
11356 4384 : bool rank_remap;
11357 4384 : tree strlen_lhs;
11358 4384 : tree strlen_rhs = NULL_TREE;
11359 :
11360 : /* Array pointer. Find the last reference on the LHS and if it is an
11361 : array section ref, we're dealing with bounds remapping. In this case,
11362 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11363 : not see it and process the bounds remapping afterwards explicitly. */
11364 14130 : for (remap = expr1->ref; remap; remap = remap->next)
11365 5741 : if (!remap->next && remap->type == REF_ARRAY
11366 4384 : && remap->u.ar.type == AR_SECTION)
11367 : break;
11368 4384 : rank_remap = (remap && remap->u.ar.end[0]);
11369 :
11370 379 : if (remap && expr2->expr_type == EXPR_NULL)
11371 : {
11372 2 : gfc_error ("If bounds remapping is specified at %L, "
11373 : "the pointer target shall not be NULL", &expr1->where);
11374 2 : return NULL_TREE;
11375 : }
11376 :
11377 4382 : gfc_init_se (&lse, NULL);
11378 4382 : if (remap)
11379 377 : lse.descriptor_only = 1;
11380 4382 : gfc_conv_expr_descriptor (&lse, expr1);
11381 4382 : strlen_lhs = lse.string_length;
11382 4382 : desc = lse.expr;
11383 :
11384 4382 : if (expr2->expr_type == EXPR_NULL)
11385 : {
11386 : /* Just set the data pointer to null. */
11387 692 : gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
11388 : }
11389 3690 : else if (rank_remap)
11390 : {
11391 : /* If we are rank-remapping, just get the RHS's descriptor and
11392 : process this later on. */
11393 254 : gfc_init_se (&rse, NULL);
11394 254 : rse.direct_byref = 1;
11395 254 : rse.byref_noassign = 1;
11396 :
11397 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11398 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11399 : expr1, expr2);
11400 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11401 : {
11402 : tree bound[GFC_MAX_DIMENSIONS];
11403 : int i;
11404 :
11405 26 : for (i = 0; i < expr2->rank; i++)
11406 13 : bound[i] = NULL_TREE;
11407 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11408 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11409 : bound, bound, 0,
11410 : GFC_ARRAY_POINTER_CONT, false);
11411 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11412 13 : rse.descriptor_only = 0;
11413 13 : rse.expr = tmp;
11414 13 : rse.direct_byref = 1;
11415 13 : gfc_conv_expr_descriptor (&rse, expr2);
11416 13 : strlen_rhs = rse.string_length;
11417 13 : rse.expr = tmp;
11418 : }
11419 : else
11420 : {
11421 229 : gfc_conv_expr_descriptor (&rse, expr2);
11422 229 : strlen_rhs = rse.string_length;
11423 229 : if (expr1->ts.type == BT_CLASS)
11424 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11425 : expr2, &rse,
11426 : NULL, NULL,
11427 : NULL);
11428 : }
11429 : }
11430 3436 : else if (expr2->expr_type == EXPR_VARIABLE)
11431 : {
11432 : /* Assign directly to the LHS's descriptor. */
11433 3304 : lse.descriptor_only = 0;
11434 3304 : lse.direct_byref = 1;
11435 3304 : gfc_conv_expr_descriptor (&lse, expr2);
11436 3304 : strlen_rhs = lse.string_length;
11437 3304 : gfc_init_se (&rse, NULL);
11438 :
11439 3304 : if (expr1->ts.type == BT_CLASS)
11440 : {
11441 368 : rse.expr = NULL_TREE;
11442 368 : rse.string_length = strlen_rhs;
11443 368 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11444 : NULL, NULL, NULL);
11445 : }
11446 :
11447 3304 : if (remap == NULL)
11448 : {
11449 : /* If the target is not a whole array, use the target array
11450 : reference for remap. */
11451 6781 : for (remap = expr2->ref; remap; remap = remap->next)
11452 3750 : if (remap->type == REF_ARRAY
11453 3241 : && remap->u.ar.type == AR_FULL
11454 2548 : && remap->next)
11455 : break;
11456 : }
11457 : }
11458 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11459 : {
11460 25 : gfc_init_se (&rse, NULL);
11461 25 : rse.want_pointer = 1;
11462 25 : gfc_conv_function_expr (&rse, expr2);
11463 25 : if (expr1->ts.type != BT_CLASS)
11464 : {
11465 12 : rse.expr = gfc_class_data_get (rse.expr);
11466 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11467 : }
11468 : else
11469 : {
11470 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11471 : expr2, &rse, NULL,
11472 : NULL, NULL);
11473 13 : gfc_add_block_to_block (&block, &rse.pre);
11474 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11475 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11476 :
11477 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11478 13 : fold_convert (TREE_TYPE (expr1_vptr),
11479 : gfc_class_vptr_get (tmp)));
11480 13 : rse.expr = gfc_class_data_get (tmp);
11481 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11482 : }
11483 : }
11484 : else
11485 : {
11486 : /* Assign to a temporary descriptor and then copy that
11487 : temporary to the pointer. */
11488 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11489 107 : lse.descriptor_only = 0;
11490 107 : lse.expr = tmp;
11491 107 : lse.direct_byref = 1;
11492 107 : gfc_conv_expr_descriptor (&lse, expr2);
11493 107 : strlen_rhs = lse.string_length;
11494 107 : gfc_add_modify (&lse.pre, desc, tmp);
11495 : }
11496 :
11497 4382 : if (expr1->ts.type == BT_CHARACTER
11498 596 : && expr1->ts.deferred)
11499 : {
11500 338 : gfc_symbol *psym = expr1->symtree->n.sym;
11501 338 : tmp = NULL_TREE;
11502 338 : if (psym->ts.type == BT_CHARACTER
11503 337 : && psym->ts.u.cl->backend_decl)
11504 337 : tmp = psym->ts.u.cl->backend_decl;
11505 1 : else if (expr1->ts.u.cl->backend_decl
11506 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11507 0 : tmp = expr1->ts.u.cl->backend_decl;
11508 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11509 : {
11510 1 : gfc_ref *ref = expr1->ref;
11511 3 : for (;ref; ref = ref->next)
11512 : {
11513 2 : if (ref->type == REF_COMPONENT
11514 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11515 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11516 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11517 1 : TREE_TYPE (tmp),
11518 1 : TREE_OPERAND (lse.expr, 0),
11519 : tmp, NULL_TREE);
11520 : }
11521 : }
11522 :
11523 338 : gcc_assert (tmp);
11524 :
11525 338 : if (expr2->expr_type != EXPR_NULL)
11526 326 : gfc_add_modify (&block, tmp,
11527 326 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
11528 : else
11529 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
11530 : }
11531 :
11532 4382 : gfc_add_block_to_block (&block, &lse.pre);
11533 4382 : if (rank_remap)
11534 254 : gfc_add_block_to_block (&block, &rse.pre);
11535 :
11536 : /* If we do bounds remapping, update LHS descriptor accordingly. */
11537 4382 : if (remap)
11538 : {
11539 527 : int dim;
11540 527 : gcc_assert (remap->u.ar.dimen == expr1->rank);
11541 :
11542 : /* Always set dtype. */
11543 527 : tree dtype = gfc_conv_descriptor_dtype (desc);
11544 527 : tmp = gfc_get_dtype (TREE_TYPE (desc));
11545 527 : gfc_add_modify (&block, dtype, tmp);
11546 :
11547 : /* For unlimited polymorphic LHS use elem_len from RHS. */
11548 527 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11549 : {
11550 60 : tree elem_len;
11551 60 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11552 60 : elem_len = fold_convert (gfc_array_index_type, tmp);
11553 60 : elem_len = gfc_evaluate_now (elem_len, &block);
11554 60 : tmp = gfc_conv_descriptor_elem_len (desc);
11555 60 : gfc_add_modify (&block, tmp,
11556 60 : fold_convert (TREE_TYPE (tmp), elem_len));
11557 : }
11558 :
11559 527 : if (rank_remap)
11560 : {
11561 : /* Do rank remapping. We already have the RHS's descriptor
11562 : converted in rse and now have to build the correct LHS
11563 : descriptor for it. */
11564 :
11565 254 : tree data, span;
11566 254 : tree offs, stride;
11567 254 : tree lbound, ubound;
11568 :
11569 : /* Copy data pointer. */
11570 254 : data = gfc_conv_descriptor_data_get (rse.expr);
11571 254 : gfc_conv_descriptor_data_set (&block, desc, data);
11572 :
11573 : /* Copy the span. */
11574 254 : if (VAR_P (rse.expr)
11575 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
11576 12 : span = gfc_conv_descriptor_span_get (rse.expr);
11577 : else
11578 : {
11579 242 : tmp = TREE_TYPE (rse.expr);
11580 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
11581 242 : span = fold_convert (gfc_array_index_type, tmp);
11582 : }
11583 254 : gfc_conv_descriptor_span_set (&block, desc, span);
11584 :
11585 : /* Copy offset but adjust it such that it would correspond
11586 : to a lbound of zero. */
11587 254 : if (expr2->rank == -1)
11588 42 : gfc_conv_descriptor_offset_set (&block, desc,
11589 : gfc_index_zero_node);
11590 : else
11591 : {
11592 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
11593 654 : for (dim = 0; dim < expr2->rank; ++dim)
11594 : {
11595 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11596 : gfc_rank_cst[dim]);
11597 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
11598 : gfc_rank_cst[dim]);
11599 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11600 : gfc_array_index_type, stride,
11601 : lbound);
11602 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
11603 : gfc_array_index_type, offs, tmp);
11604 : }
11605 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11606 : }
11607 : /* Set the bounds as declared for the LHS and calculate strides as
11608 : well as another offset update accordingly. */
11609 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11610 : gfc_rank_cst[0]);
11611 641 : for (dim = 0; dim < expr1->rank; ++dim)
11612 : {
11613 387 : gfc_se lower_se;
11614 387 : gfc_se upper_se;
11615 :
11616 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
11617 :
11618 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
11619 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
11620 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
11621 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
11622 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
11623 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
11624 :
11625 : /* Convert declared bounds. */
11626 387 : gfc_init_se (&lower_se, NULL);
11627 387 : gfc_init_se (&upper_se, NULL);
11628 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
11629 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
11630 :
11631 387 : gfc_add_block_to_block (&block, &lower_se.pre);
11632 387 : gfc_add_block_to_block (&block, &upper_se.pre);
11633 :
11634 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
11635 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
11636 :
11637 387 : lbound = gfc_evaluate_now (lbound, &block);
11638 387 : ubound = gfc_evaluate_now (ubound, &block);
11639 :
11640 387 : gfc_add_block_to_block (&block, &lower_se.post);
11641 387 : gfc_add_block_to_block (&block, &upper_se.post);
11642 :
11643 : /* Set bounds in descriptor. */
11644 387 : gfc_conv_descriptor_lbound_set (&block, desc,
11645 : gfc_rank_cst[dim], lbound);
11646 387 : gfc_conv_descriptor_ubound_set (&block, desc,
11647 : gfc_rank_cst[dim], ubound);
11648 :
11649 : /* Set stride. */
11650 387 : stride = gfc_evaluate_now (stride, &block);
11651 387 : gfc_conv_descriptor_stride_set (&block, desc,
11652 : gfc_rank_cst[dim], stride);
11653 :
11654 : /* Update offset. */
11655 387 : offs = gfc_conv_descriptor_offset_get (desc);
11656 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11657 : gfc_array_index_type, lbound, stride);
11658 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
11659 : gfc_array_index_type, offs, tmp);
11660 387 : offs = gfc_evaluate_now (offs, &block);
11661 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11662 :
11663 : /* Update stride. */
11664 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11665 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
11666 : gfc_array_index_type, stride, tmp);
11667 : }
11668 : }
11669 : else
11670 : {
11671 : /* Bounds remapping. Just shift the lower bounds. */
11672 :
11673 273 : gcc_assert (expr1->rank == expr2->rank);
11674 :
11675 654 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
11676 : {
11677 381 : gfc_se lbound_se;
11678 :
11679 381 : gcc_assert (!remap->u.ar.end[dim]);
11680 381 : gfc_init_se (&lbound_se, NULL);
11681 381 : if (remap->u.ar.start[dim])
11682 : {
11683 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
11684 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
11685 : }
11686 : else
11687 : /* This remap arises from a target that is not a whole
11688 : array. The start expressions will be NULL but we need
11689 : the lbounds to be one. */
11690 156 : lbound_se.expr = gfc_index_one_node;
11691 381 : gfc_conv_shift_descriptor_lbound (&block, desc,
11692 : dim, lbound_se.expr);
11693 381 : gfc_add_block_to_block (&block, &lbound_se.post);
11694 : }
11695 : }
11696 : }
11697 :
11698 : /* If rank remapping was done, check with -fcheck=bounds that
11699 : the target is at least as large as the pointer. */
11700 4382 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
11701 72 : && expr2->rank != -1)
11702 : {
11703 54 : tree lsize, rsize;
11704 54 : tree fault;
11705 54 : const char* msg;
11706 :
11707 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
11708 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
11709 :
11710 54 : lsize = gfc_evaluate_now (lsize, &block);
11711 54 : rsize = gfc_evaluate_now (rsize, &block);
11712 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11713 : rsize, lsize);
11714 :
11715 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
11716 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
11717 : msg, rsize, lsize);
11718 : }
11719 :
11720 : /* Check string lengths if applicable. The check is only really added
11721 : to the output code if -fbounds-check is enabled. */
11722 4382 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
11723 : {
11724 530 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11725 530 : gcc_assert (strlen_lhs && strlen_rhs);
11726 530 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11727 : strlen_lhs, strlen_rhs, &block);
11728 : }
11729 :
11730 4382 : gfc_add_block_to_block (&block, &lse.post);
11731 4382 : if (rank_remap)
11732 254 : gfc_add_block_to_block (&block, &rse.post);
11733 : }
11734 :
11735 10204 : return gfc_finish_block (&block);
11736 : }
11737 :
11738 :
11739 : /* Makes sure se is suitable for passing as a function string parameter. */
11740 : /* TODO: Need to check all callers of this function. It may be abused. */
11741 :
11742 : void
11743 246946 : gfc_conv_string_parameter (gfc_se * se)
11744 : {
11745 246946 : tree type;
11746 :
11747 246946 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
11748 246946 : && integer_onep (se->string_length))
11749 : {
11750 691 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11751 691 : return;
11752 : }
11753 :
11754 246255 : if (TREE_CODE (se->expr) == STRING_CST)
11755 : {
11756 102871 : type = TREE_TYPE (TREE_TYPE (se->expr));
11757 102871 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11758 102871 : return;
11759 : }
11760 :
11761 143384 : if (TREE_CODE (se->expr) == COND_EXPR)
11762 : {
11763 478 : tree cond = TREE_OPERAND (se->expr, 0);
11764 478 : tree lhs = TREE_OPERAND (se->expr, 1);
11765 478 : tree rhs = TREE_OPERAND (se->expr, 2);
11766 :
11767 478 : gfc_se lse, rse;
11768 478 : gfc_init_se (&lse, NULL);
11769 478 : gfc_init_se (&rse, NULL);
11770 :
11771 478 : lse.expr = lhs;
11772 478 : lse.string_length = se->string_length;
11773 478 : gfc_conv_string_parameter (&lse);
11774 :
11775 478 : rse.expr = rhs;
11776 478 : rse.string_length = se->string_length;
11777 478 : gfc_conv_string_parameter (&rse);
11778 :
11779 478 : se->expr
11780 478 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
11781 : cond, lse.expr, rse.expr);
11782 : }
11783 :
11784 143384 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
11785 55994 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
11786 143480 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
11787 : {
11788 87486 : type = TREE_TYPE (se->expr);
11789 87486 : if (TREE_CODE (se->expr) != INDIRECT_REF)
11790 82411 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11791 : else
11792 : {
11793 5075 : if (TREE_CODE (type) == ARRAY_TYPE)
11794 5075 : type = TREE_TYPE (type);
11795 5075 : type = gfc_get_character_type_len_for_eltype (type,
11796 : se->string_length);
11797 5075 : type = build_pointer_type (type);
11798 5075 : se->expr = gfc_build_addr_expr (type, se->expr);
11799 : }
11800 : }
11801 :
11802 143384 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
11803 : }
11804 :
11805 :
11806 : /* Generate code for assignment of scalar variables. Includes character
11807 : strings and derived types with allocatable components.
11808 : If you know that the LHS has no allocations, set dealloc to false.
11809 :
11810 : DEEP_COPY has no effect if the typespec TS is not a derived type with
11811 : allocatable components. Otherwise, if it is set, an explicit copy of each
11812 : allocatable component is made. This is necessary as a simple copy of the
11813 : whole object would copy array descriptors as is, so that the lhs's
11814 : allocatable components would point to the rhs's after the assignment.
11815 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
11816 : necessary if the rhs is a non-pointer function, as the allocatable components
11817 : are not accessible by other means than the function's result after the
11818 : function has returned. It is even more subtle when temporaries are involved,
11819 : as the two following examples show:
11820 : 1. When we evaluate an array constructor, a temporary is created. Thus
11821 : there is theoretically no alias possible. However, no deep copy is
11822 : made for this temporary, so that if the constructor is made of one or
11823 : more variable with allocatable components, those components still point
11824 : to the variable's: DEEP_COPY should be set for the assignment from the
11825 : temporary to the lhs in that case.
11826 : 2. When assigning a scalar to an array, we evaluate the scalar value out
11827 : of the loop, store it into a temporary variable, and assign from that.
11828 : In that case, deep copying when assigning to the temporary would be a
11829 : waste of resources; however deep copies should happen when assigning from
11830 : the temporary to each array element: again DEEP_COPY should be set for
11831 : the assignment from the temporary to the lhs. */
11832 :
11833 : tree
11834 339246 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
11835 : bool deep_copy, bool dealloc, bool in_coarray,
11836 : bool assoc_assign)
11837 : {
11838 339246 : stmtblock_t block;
11839 339246 : tree tmp;
11840 339246 : tree cond;
11841 339246 : int caf_mode;
11842 :
11843 339246 : gfc_init_block (&block);
11844 :
11845 339246 : if (ts.type == BT_CHARACTER)
11846 : {
11847 33417 : tree rlen = NULL;
11848 33417 : tree llen = NULL;
11849 :
11850 33417 : if (lse->string_length != NULL_TREE)
11851 : {
11852 33417 : gfc_conv_string_parameter (lse);
11853 33417 : gfc_add_block_to_block (&block, &lse->pre);
11854 33417 : llen = lse->string_length;
11855 : }
11856 :
11857 33417 : if (rse->string_length != NULL_TREE)
11858 : {
11859 33417 : gfc_conv_string_parameter (rse);
11860 33417 : gfc_add_block_to_block (&block, &rse->pre);
11861 33417 : rlen = rse->string_length;
11862 : }
11863 :
11864 33417 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
11865 : rse->expr, ts.kind);
11866 : }
11867 286508 : else if (gfc_bt_struct (ts.type)
11868 305829 : && (ts.u.derived->attr.alloc_comp
11869 12612 : || (deep_copy && has_parameterized_comps (ts.u.derived))))
11870 : {
11871 6871 : tree tmp_var = NULL_TREE;
11872 6871 : cond = NULL_TREE;
11873 :
11874 : /* Are the rhs and the lhs the same? */
11875 6871 : if (deep_copy)
11876 : {
11877 4127 : if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
11878 2999 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11879 4127 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11880 : gfc_build_addr_expr (NULL_TREE, lse->expr),
11881 : gfc_build_addr_expr (NULL_TREE, rse->expr));
11882 4127 : cond = gfc_evaluate_now (cond, &lse->pre);
11883 : }
11884 :
11885 : /* Deallocate the lhs allocated components as long as it is not
11886 : the same as the rhs. This must be done following the assignment
11887 : to prevent deallocating data that could be used in the rhs
11888 : expression. */
11889 6871 : if (dealloc)
11890 : {
11891 1959 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
11892 1959 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
11893 1959 : 0, gfc_may_be_finalized (ts));
11894 1959 : if (deep_copy)
11895 833 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11896 : tmp);
11897 1959 : gfc_add_expr_to_block (&lse->post, tmp);
11898 : }
11899 :
11900 6871 : gfc_add_block_to_block (&block, &rse->pre);
11901 :
11902 : /* Skip finalization for self-assignment. */
11903 6871 : if (deep_copy && lse->finalblock.head)
11904 : {
11905 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11906 : gfc_finish_block (&lse->finalblock));
11907 24 : gfc_add_expr_to_block (&block, tmp);
11908 : }
11909 : else
11910 6847 : gfc_add_block_to_block (&block, &lse->finalblock);
11911 :
11912 6871 : gfc_add_block_to_block (&block, &lse->pre);
11913 :
11914 6871 : if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
11915 6871 : == TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)))
11916 6565 : gfc_add_modify (&block, lse->expr,
11917 6565 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11918 : else
11919 : {
11920 306 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11921 306 : TREE_TYPE (lse->expr), rse->expr);
11922 306 : gfc_add_modify (&block, lse->expr, tmp);
11923 : }
11924 :
11925 : /* Restore pointer address of coarray components. */
11926 6871 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
11927 : {
11928 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
11929 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11930 : tmp);
11931 5 : gfc_add_expr_to_block (&block, tmp);
11932 : }
11933 :
11934 : /* Do a deep copy if the rhs is a variable, if it is not the
11935 : same as the lhs. */
11936 6871 : if (deep_copy)
11937 : {
11938 4127 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11939 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
11940 4127 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
11941 : caf_mode);
11942 4127 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11943 : tmp);
11944 4127 : gfc_add_expr_to_block (&block, tmp);
11945 : }
11946 : }
11947 298958 : else if (gfc_bt_struct (ts.type))
11948 : {
11949 12450 : gfc_add_block_to_block (&block, &rse->pre);
11950 12450 : gfc_add_block_to_block (&block, &lse->finalblock);
11951 12450 : gfc_add_block_to_block (&block, &lse->pre);
11952 12450 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11953 12450 : TREE_TYPE (lse->expr), rse->expr);
11954 12450 : gfc_add_modify (&block, lse->expr, tmp);
11955 : }
11956 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
11957 286508 : else if (ts.type == BT_CLASS)
11958 : {
11959 788 : gfc_add_block_to_block (&block, &lse->pre);
11960 788 : gfc_add_block_to_block (&block, &rse->pre);
11961 788 : gfc_add_block_to_block (&block, &lse->finalblock);
11962 :
11963 788 : if (!trans_scalar_class_assign (&block, lse, rse))
11964 : {
11965 : /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
11966 : for the lhs which ensures that class data rhs cast as a string
11967 : assigns correctly. */
11968 642 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11969 642 : TREE_TYPE (rse->expr), lse->expr);
11970 642 : gfc_add_modify (&block, tmp, rse->expr);
11971 :
11972 : /* Copy allocatable components but guard against class pointer
11973 : assign, which arrives here. */
11974 : #define DATA_DT ts.u.derived->components->ts.u.derived
11975 642 : if (deep_copy
11976 195 : && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11977 43 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11978 152 : && ts.u.derived->components
11979 794 : && DATA_DT && DATA_DT->attr.alloc_comp)
11980 : {
11981 6 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11982 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
11983 : : 0;
11984 6 : tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
11985 : caf_mode);
11986 6 : gfc_add_expr_to_block (&block, tmp);
11987 : }
11988 : #undef DATA_DT
11989 : }
11990 : }
11991 285720 : else if (ts.type != BT_CLASS)
11992 : {
11993 285720 : gfc_add_block_to_block (&block, &lse->pre);
11994 285720 : gfc_add_block_to_block (&block, &rse->pre);
11995 :
11996 285720 : if (in_coarray)
11997 : {
11998 847 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
11999 : {
12000 0 : gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr),
12001 0 : TYPE_LANG_SPECIFIC (
12002 : TREE_TYPE (TREE_TYPE (rse->expr)))
12003 : ->caf_token);
12004 : }
12005 847 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
12006 0 : lse->expr = gfc_conv_array_data (lse->expr);
12007 276 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
12008 847 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
12009 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
12010 : }
12011 285720 : gfc_add_modify (&block, lse->expr,
12012 285720 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12013 : }
12014 :
12015 339246 : gfc_add_block_to_block (&block, &lse->post);
12016 339246 : gfc_add_block_to_block (&block, &rse->post);
12017 :
12018 339246 : return gfc_finish_block (&block);
12019 : }
12020 :
12021 :
12022 : /* There are quite a lot of restrictions on the optimisation in using an
12023 : array function assign without a temporary. */
12024 :
12025 : static bool
12026 14472 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
12027 : {
12028 14472 : gfc_ref * ref;
12029 14472 : bool seen_array_ref;
12030 14472 : bool c = false;
12031 14472 : gfc_symbol *sym = expr1->symtree->n.sym;
12032 :
12033 : /* Play it safe with class functions assigned to a derived type. */
12034 14472 : if (gfc_is_class_array_function (expr2)
12035 14472 : && expr1->ts.type == BT_DERIVED)
12036 : return true;
12037 :
12038 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
12039 14448 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
12040 : return true;
12041 :
12042 : /* Elemental functions are scalarized so that they don't need a
12043 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
12044 : they would need special treatment in gfc_trans_arrayfunc_assign. */
12045 8531 : if (expr2->value.function.esym != NULL
12046 1589 : && expr2->value.function.esym->attr.elemental)
12047 : return true;
12048 :
12049 : /* Need a temporary if rhs is not FULL or a contiguous section. */
12050 8172 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
12051 : return true;
12052 :
12053 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
12054 7922 : if (gfc_ref_needs_temporary_p (expr1->ref))
12055 : return true;
12056 :
12057 : /* Functions returning pointers or allocatables need temporaries. */
12058 7910 : if (gfc_expr_attr (expr2).pointer
12059 7910 : || gfc_expr_attr (expr2).allocatable)
12060 376 : return true;
12061 :
12062 : /* Character array functions need temporaries unless the
12063 : character lengths are the same. */
12064 7534 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
12065 : {
12066 562 : if (UNLIMITED_POLY (expr1))
12067 : return true;
12068 :
12069 556 : if (expr1->ts.u.cl->length == NULL
12070 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12071 : return true;
12072 :
12073 493 : if (expr2->ts.u.cl->length == NULL
12074 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12075 : return true;
12076 :
12077 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
12078 475 : expr2->ts.u.cl->length->value.integer) != 0)
12079 : return true;
12080 : }
12081 :
12082 : /* Check that no LHS component references appear during an array
12083 : reference. This is needed because we do not have the means to
12084 : span any arbitrary stride with an array descriptor. This check
12085 : is not needed for the rhs because the function result has to be
12086 : a complete type. */
12087 7441 : seen_array_ref = false;
12088 14882 : for (ref = expr1->ref; ref; ref = ref->next)
12089 : {
12090 7454 : if (ref->type == REF_ARRAY)
12091 : seen_array_ref= true;
12092 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
12093 : return true;
12094 : }
12095 :
12096 : /* Check for a dependency. */
12097 7428 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
12098 : expr2->value.function.esym,
12099 : expr2->value.function.actual,
12100 : NOT_ELEMENTAL))
12101 : return true;
12102 :
12103 : /* If we have reached here with an intrinsic function, we do not
12104 : need a temporary except in the particular case that reallocation
12105 : on assignment is active and the lhs is allocatable and a target,
12106 : or a pointer which may be a subref pointer. FIXME: The last
12107 : condition can go away when we use span in the intrinsics
12108 : directly.*/
12109 6991 : if (expr2->value.function.isym)
12110 6113 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
12111 12313 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
12112 :
12113 : /* If the LHS is a dummy, we need a temporary if it is not
12114 : INTENT(OUT). */
12115 803 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
12116 : return true;
12117 :
12118 : /* If the lhs has been host_associated, is in common, a pointer or is
12119 : a target and the function is not using a RESULT variable, aliasing
12120 : can occur and a temporary is needed. */
12121 797 : if ((sym->attr.host_assoc
12122 743 : || sym->attr.in_common
12123 737 : || sym->attr.pointer
12124 731 : || sym->attr.cray_pointee
12125 731 : || sym->attr.target)
12126 66 : && expr2->symtree != NULL
12127 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
12128 : return true;
12129 :
12130 : /* A PURE function can unconditionally be called without a temporary. */
12131 755 : if (expr2->value.function.esym != NULL
12132 730 : && expr2->value.function.esym->attr.pure)
12133 : return false;
12134 :
12135 : /* Implicit_pure functions are those which could legally be declared
12136 : to be PURE. */
12137 727 : if (expr2->value.function.esym != NULL
12138 702 : && expr2->value.function.esym->attr.implicit_pure)
12139 : return false;
12140 :
12141 444 : if (!sym->attr.use_assoc
12142 444 : && !sym->attr.in_common
12143 444 : && !sym->attr.pointer
12144 438 : && !sym->attr.target
12145 438 : && !sym->attr.cray_pointee
12146 438 : && expr2->value.function.esym)
12147 : {
12148 : /* A temporary is not needed if the function is not contained and
12149 : the variable is local or host associated and not a pointer or
12150 : a target. */
12151 413 : if (!expr2->value.function.esym->attr.contained)
12152 : return false;
12153 :
12154 : /* A temporary is not needed if the lhs has never been host
12155 : associated and the procedure is contained. */
12156 164 : else if (!sym->attr.host_assoc)
12157 : return false;
12158 :
12159 : /* A temporary is not needed if the variable is local and not
12160 : a pointer, a target or a result. */
12161 6 : if (sym->ns->parent
12162 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12163 : return false;
12164 : }
12165 :
12166 : /* Default to temporary use. */
12167 : return true;
12168 : }
12169 :
12170 :
12171 : /* Provide the loop info so that the lhs descriptor can be built for
12172 : reallocatable assignments from extrinsic function calls. */
12173 :
12174 : static void
12175 203 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12176 : gfc_loopinfo *loop)
12177 : {
12178 : /* Signal that the function call should not be made by
12179 : gfc_conv_loop_setup. */
12180 203 : se->ss->is_alloc_lhs = 1;
12181 203 : gfc_init_loopinfo (loop);
12182 203 : gfc_add_ss_to_loop (loop, *ss);
12183 203 : gfc_add_ss_to_loop (loop, se->ss);
12184 203 : gfc_conv_ss_startstride (loop);
12185 203 : gfc_conv_loop_setup (loop, where);
12186 203 : gfc_copy_loopinfo_to_se (se, loop);
12187 203 : gfc_add_block_to_block (&se->pre, &loop->pre);
12188 203 : gfc_add_block_to_block (&se->pre, &loop->post);
12189 203 : se->ss->is_alloc_lhs = 0;
12190 203 : }
12191 :
12192 :
12193 : /* For assignment to a reallocatable lhs from intrinsic functions,
12194 : replace the se.expr (ie. the result) with a temporary descriptor.
12195 : Null the data field so that the library allocates space for the
12196 : result. Free the data of the original descriptor after the function,
12197 : in case it appears in an argument expression and transfer the
12198 : result to the original descriptor. */
12199 :
12200 : static void
12201 2138 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12202 : {
12203 2138 : tree desc;
12204 2138 : tree res_desc;
12205 2138 : tree tmp;
12206 2138 : tree offset;
12207 2138 : tree zero_cond;
12208 2138 : tree not_same_shape;
12209 2138 : stmtblock_t shape_block;
12210 2138 : int n;
12211 :
12212 : /* Use the allocation done by the library. Substitute the lhs
12213 : descriptor with a copy, whose data field is nulled.*/
12214 2138 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12215 2138 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12216 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12217 :
12218 : /* Unallocated, the descriptor does not have a dtype. */
12219 2138 : tmp = gfc_conv_descriptor_dtype (desc);
12220 2138 : if (dtype != NULL_TREE)
12221 13 : gfc_add_modify (&se->pre, tmp, dtype);
12222 : else
12223 2125 : gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12224 :
12225 2138 : res_desc = gfc_evaluate_now (desc, &se->pre);
12226 2138 : gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
12227 2138 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12228 :
12229 : /* Free the lhs after the function call and copy the result data to
12230 : the lhs descriptor. */
12231 2138 : tmp = gfc_conv_descriptor_data_get (desc);
12232 2138 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12233 : logical_type_node, tmp,
12234 2138 : build_int_cst (TREE_TYPE (tmp), 0));
12235 2138 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12236 2138 : tmp = gfc_call_free (tmp);
12237 2138 : gfc_add_expr_to_block (&se->post, tmp);
12238 :
12239 2138 : tmp = gfc_conv_descriptor_data_get (res_desc);
12240 2138 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12241 :
12242 : /* Check that the shapes are the same between lhs and expression.
12243 : The evaluation of the shape is done in 'shape_block' to avoid
12244 : uninitialized warnings from the lhs bounds. */
12245 2138 : not_same_shape = boolean_false_node;
12246 2138 : gfc_start_block (&shape_block);
12247 6880 : for (n = 0 ; n < rank; n++)
12248 : {
12249 4742 : tree tmp1;
12250 4742 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12251 4742 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12252 4742 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12253 : gfc_array_index_type, tmp, tmp1);
12254 4742 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12255 4742 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12256 : gfc_array_index_type, tmp, tmp1);
12257 4742 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12258 4742 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12259 : gfc_array_index_type, tmp, tmp1);
12260 4742 : tmp = fold_build2_loc (input_location, NE_EXPR,
12261 : logical_type_node, tmp,
12262 : gfc_index_zero_node);
12263 4742 : tmp = gfc_evaluate_now (tmp, &shape_block);
12264 4742 : if (n == 0)
12265 : not_same_shape = tmp;
12266 : else
12267 2604 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12268 : logical_type_node, tmp,
12269 : not_same_shape);
12270 : }
12271 :
12272 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12273 : shapes being different. */
12274 2138 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12275 : zero_cond, not_same_shape);
12276 2138 : gfc_add_modify (&shape_block, zero_cond, tmp);
12277 2138 : tmp = gfc_finish_block (&shape_block);
12278 2138 : tmp = build3_v (COND_EXPR, zero_cond,
12279 : build_empty_stmt (input_location), tmp);
12280 2138 : gfc_add_expr_to_block (&se->post, tmp);
12281 :
12282 : /* Now reset the bounds returned from the function call to bounds based
12283 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12284 : of 'variable and 'expr' are different. Set the offset accordingly. */
12285 2138 : offset = gfc_index_zero_node;
12286 6880 : for (n = 0 ; n < rank; n++)
12287 : {
12288 4742 : tree lbound;
12289 :
12290 4742 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12291 4742 : lbound = fold_build3_loc (input_location, COND_EXPR,
12292 : gfc_array_index_type, zero_cond,
12293 : gfc_index_one_node, lbound);
12294 4742 : lbound = gfc_evaluate_now (lbound, &se->post);
12295 :
12296 4742 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12297 4742 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12298 : gfc_array_index_type, tmp, lbound);
12299 4742 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12300 : gfc_rank_cst[n], lbound);
12301 4742 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12302 : gfc_rank_cst[n], tmp);
12303 :
12304 : /* Set stride and accumulate the offset. */
12305 4742 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12306 4742 : gfc_conv_descriptor_stride_set (&se->post, desc,
12307 : gfc_rank_cst[n], tmp);
12308 4742 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12309 : gfc_array_index_type, lbound, tmp);
12310 4742 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12311 : gfc_array_index_type, offset, tmp);
12312 4742 : offset = gfc_evaluate_now (offset, &se->post);
12313 : }
12314 :
12315 2138 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12316 2138 : }
12317 :
12318 :
12319 :
12320 : /* Try to translate array(:) = func (...), where func is a transformational
12321 : array function, without using a temporary. Returns NULL if this isn't the
12322 : case. */
12323 :
12324 : static tree
12325 14512 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12326 : {
12327 14512 : gfc_se se;
12328 14512 : gfc_ss *ss = NULL;
12329 14512 : gfc_component *comp = NULL;
12330 14512 : gfc_loopinfo loop;
12331 14512 : tree tmp;
12332 14512 : tree lhs;
12333 14512 : gfc_se final_se;
12334 14512 : gfc_symbol *sym = expr1->symtree->n.sym;
12335 14512 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12336 :
12337 : /* If the symbol is host associated and has not been referenced in its name
12338 : space, it might be lacking a backend_decl and vtable. */
12339 14512 : if (sym->backend_decl == NULL_TREE)
12340 : return NULL_TREE;
12341 :
12342 14472 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12343 : return NULL_TREE;
12344 :
12345 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12346 : functions. */
12347 6873 : comp = gfc_get_proc_ptr_comp (expr2);
12348 :
12349 6873 : if (!(expr2->value.function.isym
12350 718 : || (comp && comp->attr.dimension)
12351 718 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12352 718 : && expr2->value.function.esym->result->attr.dimension)))
12353 0 : return NULL_TREE;
12354 :
12355 6873 : gfc_init_se (&se, NULL);
12356 6873 : gfc_start_block (&se.pre);
12357 6873 : se.want_pointer = 1;
12358 :
12359 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12360 : backend decl, stash the original away for the finalization so that the
12361 : value used is that before the assignment. This is necessary because
12362 : evaluation of the rhs expression using direct by reference can change
12363 : the value. However, the standard mandates that the finalization must occur
12364 : after evaluation of the rhs. */
12365 6873 : gfc_init_se (&final_se, NULL);
12366 :
12367 6873 : if (finalizable)
12368 : {
12369 45 : tmp = sym->backend_decl;
12370 45 : lhs = sym->backend_decl;
12371 45 : if (INDIRECT_REF_P (tmp))
12372 0 : tmp = TREE_OPERAND (tmp, 0);
12373 45 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12374 45 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12375 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12376 : {
12377 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12378 : expr1->rank, 0);
12379 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12380 : }
12381 : }
12382 :
12383 45 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12384 : {
12385 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12386 45 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12387 : }
12388 :
12389 6873 : if (finalizable)
12390 45 : sym->backend_decl = lhs;
12391 :
12392 6873 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12393 :
12394 6873 : if (expr1->ts.type == BT_DERIVED
12395 264 : && expr1->ts.u.derived->attr.alloc_comp)
12396 : {
12397 110 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12398 110 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12399 : expr1->rank);
12400 110 : gfc_add_expr_to_block (&se.pre, tmp);
12401 : }
12402 :
12403 6873 : se.direct_byref = 1;
12404 6873 : se.ss = gfc_walk_expr (expr2);
12405 6873 : gcc_assert (se.ss != gfc_ss_terminator);
12406 :
12407 : /* Since this is a direct by reference call, references to the lhs can be
12408 : used for finalization of the function result just as long as the blocks
12409 : from final_se are added at the right time. */
12410 6873 : gfc_init_se (&final_se, NULL);
12411 6873 : if (finalizable && expr2->value.function.esym)
12412 : {
12413 32 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12414 32 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12415 32 : expr2->value.function.esym->attr,
12416 : expr2->rank);
12417 : }
12418 :
12419 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12420 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12421 : Clearly, this cannot be done for an allocatable function result, since
12422 : the shape of the result is unknown and, in any case, the function must
12423 : correctly take care of the reallocation internally. For intrinsic
12424 : calls, the array data is freed and the library takes care of allocation.
12425 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12426 : to the library. */
12427 6873 : if (flag_realloc_lhs
12428 6798 : && gfc_is_reallocatable_lhs (expr1)
12429 9214 : && !gfc_expr_attr (expr1).codimension
12430 2341 : && !gfc_is_coindexed (expr1)
12431 9214 : && !(expr2->value.function.esym
12432 203 : && expr2->value.function.esym->result->attr.allocatable))
12433 : {
12434 2341 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12435 :
12436 2341 : if (!expr2->value.function.isym)
12437 : {
12438 203 : ss = gfc_walk_expr (expr1);
12439 203 : gcc_assert (ss != gfc_ss_terminator);
12440 :
12441 203 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12442 203 : ss->is_alloc_lhs = 1;
12443 : }
12444 : else
12445 : {
12446 2138 : tree dtype = NULL_TREE;
12447 2138 : tree type = gfc_typenode_for_spec (&expr2->ts);
12448 2138 : if (expr1->ts.type == BT_CLASS)
12449 : {
12450 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12451 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12452 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12453 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12454 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12455 : }
12456 2138 : fcncall_realloc_result (&se, expr1->rank, dtype);
12457 : }
12458 : }
12459 :
12460 6873 : gfc_conv_function_expr (&se, expr2);
12461 :
12462 : /* Fix the result. */
12463 6873 : gfc_add_block_to_block (&se.pre, &se.post);
12464 6873 : if (finalizable)
12465 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12466 :
12467 : /* Do the finalization, including final calls from function arguments. */
12468 45 : if (finalizable)
12469 : {
12470 45 : gfc_add_block_to_block (&se.pre, &final_se.post);
12471 45 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12472 45 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12473 : }
12474 :
12475 6873 : if (ss)
12476 203 : gfc_cleanup_loop (&loop);
12477 : else
12478 6670 : gfc_free_ss_chain (se.ss);
12479 :
12480 6873 : return gfc_finish_block (&se.pre);
12481 : }
12482 :
12483 :
12484 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12485 : can't be done. */
12486 :
12487 : static tree
12488 3951 : gfc_trans_zero_assign (gfc_expr * expr)
12489 : {
12490 3951 : tree dest, len, type;
12491 3951 : tree tmp;
12492 3951 : gfc_symbol *sym;
12493 :
12494 3951 : sym = expr->symtree->n.sym;
12495 3951 : dest = gfc_get_symbol_decl (sym);
12496 :
12497 3951 : type = TREE_TYPE (dest);
12498 3951 : if (POINTER_TYPE_P (type))
12499 249 : type = TREE_TYPE (type);
12500 3951 : if (GFC_ARRAY_TYPE_P (type))
12501 : {
12502 : /* Determine the length of the array. */
12503 2772 : len = GFC_TYPE_ARRAY_SIZE (type);
12504 2772 : if (!len || TREE_CODE (len) != INTEGER_CST)
12505 : return NULL_TREE;
12506 : }
12507 1179 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12508 1179 : && gfc_is_simply_contiguous (expr, false, false))
12509 : {
12510 1079 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12511 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12512 1079 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12513 1079 : dest = gfc_conv_descriptor_data_get (dest);
12514 : }
12515 : else
12516 100 : return NULL_TREE;
12517 :
12518 : /* If we are zeroing a local array avoid taking its address by emitting
12519 : a = {} instead. */
12520 3672 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12521 2550 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12522 2550 : dest, build_constructor (TREE_TYPE (dest),
12523 2550 : NULL));
12524 :
12525 : /* Multiply len by element size. */
12526 1122 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12527 1122 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12528 : len, fold_convert (gfc_array_index_type, tmp));
12529 :
12530 : /* Convert arguments to the correct types. */
12531 1122 : dest = fold_convert (pvoid_type_node, dest);
12532 1122 : len = fold_convert (size_type_node, len);
12533 :
12534 : /* Construct call to __builtin_memset. */
12535 1122 : tmp = build_call_expr_loc (input_location,
12536 : builtin_decl_explicit (BUILT_IN_MEMSET),
12537 : 3, dest, integer_zero_node, len);
12538 1122 : return fold_convert (void_type_node, tmp);
12539 : }
12540 :
12541 :
12542 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
12543 : that constructs the call to __builtin_memcpy. */
12544 :
12545 : tree
12546 8016 : gfc_build_memcpy_call (tree dst, tree src, tree len)
12547 : {
12548 8016 : tree tmp;
12549 :
12550 : /* Convert arguments to the correct types. */
12551 8016 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
12552 7715 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
12553 : else
12554 301 : dst = fold_convert (pvoid_type_node, dst);
12555 :
12556 8016 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
12557 7608 : src = gfc_build_addr_expr (pvoid_type_node, src);
12558 : else
12559 408 : src = fold_convert (pvoid_type_node, src);
12560 :
12561 8016 : len = fold_convert (size_type_node, len);
12562 :
12563 : /* Construct call to __builtin_memcpy. */
12564 8016 : tmp = build_call_expr_loc (input_location,
12565 : builtin_decl_explicit (BUILT_IN_MEMCPY),
12566 : 3, dst, src, len);
12567 8016 : return fold_convert (void_type_node, tmp);
12568 : }
12569 :
12570 :
12571 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
12572 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
12573 : source/rhs, both are gfc_full_array_ref_p which have been checked for
12574 : dependencies. */
12575 :
12576 : static tree
12577 2603 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
12578 : {
12579 2603 : tree dst, dlen, dtype;
12580 2603 : tree src, slen, stype;
12581 2603 : tree tmp;
12582 :
12583 2603 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12584 2603 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
12585 :
12586 2603 : dtype = TREE_TYPE (dst);
12587 2603 : if (POINTER_TYPE_P (dtype))
12588 265 : dtype = TREE_TYPE (dtype);
12589 2603 : stype = TREE_TYPE (src);
12590 2603 : if (POINTER_TYPE_P (stype))
12591 293 : stype = TREE_TYPE (stype);
12592 :
12593 2603 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
12594 : return NULL_TREE;
12595 :
12596 : /* Determine the lengths of the arrays. */
12597 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
12598 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
12599 : return NULL_TREE;
12600 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12601 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12602 : dlen, fold_convert (gfc_array_index_type, tmp));
12603 :
12604 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
12605 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
12606 : return NULL_TREE;
12607 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
12608 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12609 : slen, fold_convert (gfc_array_index_type, tmp));
12610 :
12611 : /* Sanity check that they are the same. This should always be
12612 : the case, as we should already have checked for conformance. */
12613 1486 : if (!tree_int_cst_equal (slen, dlen))
12614 : return NULL_TREE;
12615 :
12616 1486 : return gfc_build_memcpy_call (dst, src, dlen);
12617 : }
12618 :
12619 :
12620 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
12621 : this can't be done. EXPR1 is the destination/lhs for which
12622 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
12623 :
12624 : static tree
12625 8243 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
12626 : {
12627 8243 : unsigned HOST_WIDE_INT nelem;
12628 8243 : tree dst, dtype;
12629 8243 : tree src, stype;
12630 8243 : tree len;
12631 8243 : tree tmp;
12632 :
12633 8243 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
12634 8243 : if (nelem == 0)
12635 : return NULL_TREE;
12636 :
12637 6850 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12638 6850 : dtype = TREE_TYPE (dst);
12639 6850 : if (POINTER_TYPE_P (dtype))
12640 265 : dtype = TREE_TYPE (dtype);
12641 6850 : if (!GFC_ARRAY_TYPE_P (dtype))
12642 : return NULL_TREE;
12643 :
12644 : /* Determine the lengths of the array. */
12645 6003 : len = GFC_TYPE_ARRAY_SIZE (dtype);
12646 6003 : if (!len || TREE_CODE (len) != INTEGER_CST)
12647 : return NULL_TREE;
12648 :
12649 : /* Confirm that the constructor is the same size. */
12650 5899 : if (compare_tree_int (len, nelem) != 0)
12651 : return NULL_TREE;
12652 :
12653 5899 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12654 5899 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
12655 : fold_convert (gfc_array_index_type, tmp));
12656 :
12657 5899 : stype = gfc_typenode_for_spec (&expr2->ts);
12658 5899 : src = gfc_build_constant_array_constructor (expr2, stype);
12659 :
12660 5899 : return gfc_build_memcpy_call (dst, src, len);
12661 : }
12662 :
12663 :
12664 : /* Tells whether the expression is to be treated as a variable reference. */
12665 :
12666 : bool
12667 315609 : gfc_expr_is_variable (gfc_expr *expr)
12668 : {
12669 315881 : gfc_expr *arg;
12670 315881 : gfc_component *comp;
12671 315881 : gfc_symbol *func_ifc;
12672 :
12673 315881 : if (expr->expr_type == EXPR_VARIABLE)
12674 : return true;
12675 :
12676 280480 : arg = gfc_get_noncopying_intrinsic_argument (expr);
12677 280480 : if (arg)
12678 : {
12679 272 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
12680 : return gfc_expr_is_variable (arg);
12681 : }
12682 :
12683 : /* A data-pointer-returning function should be considered as a variable
12684 : too. */
12685 280208 : if (expr->expr_type == EXPR_FUNCTION
12686 37319 : && expr->ref == NULL)
12687 : {
12688 36930 : if (expr->value.function.isym != NULL)
12689 : return false;
12690 :
12691 9634 : if (expr->value.function.esym != NULL)
12692 : {
12693 9625 : func_ifc = expr->value.function.esym;
12694 9625 : goto found_ifc;
12695 : }
12696 9 : gcc_assert (expr->symtree);
12697 9 : func_ifc = expr->symtree->n.sym;
12698 9 : goto found_ifc;
12699 : }
12700 :
12701 243278 : comp = gfc_get_proc_ptr_comp (expr);
12702 243278 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
12703 389 : && comp)
12704 : {
12705 275 : func_ifc = comp->ts.interface;
12706 275 : goto found_ifc;
12707 : }
12708 :
12709 243003 : if (expr->expr_type == EXPR_COMPCALL)
12710 : {
12711 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
12712 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
12713 0 : goto found_ifc;
12714 : }
12715 :
12716 : return false;
12717 :
12718 9909 : found_ifc:
12719 9909 : gcc_assert (func_ifc->attr.function
12720 : && func_ifc->result != NULL);
12721 9909 : return func_ifc->result->attr.pointer;
12722 : }
12723 :
12724 :
12725 : /* Is the lhs OK for automatic reallocation? */
12726 :
12727 : static bool
12728 266950 : is_scalar_reallocatable_lhs (gfc_expr *expr)
12729 : {
12730 266950 : gfc_ref * ref;
12731 :
12732 : /* An allocatable variable with no reference. */
12733 266950 : if (expr->symtree->n.sym->attr.allocatable
12734 6801 : && !expr->ref)
12735 : return true;
12736 :
12737 : /* All that can be left are allocatable components. However, we do
12738 : not check for allocatable components here because the expression
12739 : could be an allocatable component of a pointer component. */
12740 264147 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
12741 241364 : && expr->symtree->n.sym->ts.type != BT_CLASS)
12742 : return false;
12743 :
12744 : /* Find an allocatable component ref last. */
12745 40280 : for (ref = expr->ref; ref; ref = ref->next)
12746 16541 : if (ref->type == REF_COMPONENT
12747 12221 : && !ref->next
12748 9419 : && ref->u.c.component->attr.allocatable)
12749 : return true;
12750 :
12751 : return false;
12752 : }
12753 :
12754 :
12755 : /* Allocate or reallocate scalar lhs, as necessary. */
12756 :
12757 : static void
12758 3655 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
12759 : tree string_length,
12760 : gfc_expr *expr1,
12761 : gfc_expr *expr2)
12762 :
12763 : {
12764 3655 : tree cond;
12765 3655 : tree tmp;
12766 3655 : tree size;
12767 3655 : tree size_in_bytes;
12768 3655 : tree jump_label1;
12769 3655 : tree jump_label2;
12770 3655 : gfc_se lse;
12771 3655 : gfc_ref *ref;
12772 :
12773 3655 : if (!expr1 || expr1->rank)
12774 0 : return;
12775 :
12776 3655 : if (!expr2 || expr2->rank)
12777 : return;
12778 :
12779 5115 : for (ref = expr1->ref; ref; ref = ref->next)
12780 1460 : if (ref->type == REF_SUBSTRING)
12781 : return;
12782 :
12783 3655 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
12784 :
12785 : /* Since this is a scalar lhs, we can afford to do this. That is,
12786 : there is no risk of side effects being repeated. */
12787 3655 : gfc_init_se (&lse, NULL);
12788 3655 : lse.want_pointer = 1;
12789 3655 : gfc_conv_expr (&lse, expr1);
12790 :
12791 3655 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12792 3655 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12793 :
12794 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
12795 3655 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
12796 3655 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
12797 : lse.expr, tmp);
12798 3655 : tmp = build3_v (COND_EXPR, cond,
12799 : build1_v (GOTO_EXPR, jump_label1),
12800 : build_empty_stmt (input_location));
12801 3655 : gfc_add_expr_to_block (block, tmp);
12802 :
12803 3655 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12804 : {
12805 : /* Use the rhs string length and the lhs element size. Note that 'size' is
12806 : used below for the string-length comparison, only. */
12807 1518 : size = string_length;
12808 1518 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12809 3036 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
12810 1518 : TREE_TYPE (tmp), tmp,
12811 1518 : fold_convert (TREE_TYPE (tmp), size));
12812 : }
12813 : else
12814 : {
12815 : /* Otherwise use the length in bytes of the rhs. */
12816 2137 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
12817 2137 : size_in_bytes = size;
12818 : }
12819 :
12820 3655 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12821 : size_in_bytes, size_one_node);
12822 :
12823 3655 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
12824 : {
12825 32 : tree caf_decl, token;
12826 32 : gfc_se caf_se;
12827 32 : symbol_attribute attr;
12828 :
12829 32 : gfc_clear_attr (&attr);
12830 32 : gfc_init_se (&caf_se, NULL);
12831 :
12832 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
12833 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
12834 : NULL);
12835 32 : gfc_add_block_to_block (block, &caf_se.pre);
12836 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
12837 : gfc_build_addr_expr (NULL_TREE, token),
12838 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
12839 : expr1, 1);
12840 : }
12841 3623 : else if (expr1->ts.type == BT_DERIVED
12842 3623 : && (expr1->ts.u.derived->attr.alloc_comp
12843 220 : || has_parameterized_comps (expr1->ts.u.derived)))
12844 : {
12845 116 : tmp = build_call_expr_loc (input_location,
12846 : builtin_decl_explicit (BUILT_IN_CALLOC),
12847 : 2, build_one_cst (size_type_node),
12848 : size_in_bytes);
12849 116 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12850 116 : gfc_add_modify (block, lse.expr, tmp);
12851 : }
12852 : else
12853 : {
12854 3507 : tmp = build_call_expr_loc (input_location,
12855 : builtin_decl_explicit (BUILT_IN_MALLOC),
12856 : 1, size_in_bytes);
12857 3507 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12858 3507 : gfc_add_modify (block, lse.expr, tmp);
12859 : }
12860 :
12861 3655 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12862 : {
12863 : /* Deferred characters need checking for lhs and rhs string
12864 : length. Other deferred parameter variables will have to
12865 : come here too. */
12866 1518 : tmp = build1_v (GOTO_EXPR, jump_label2);
12867 1518 : gfc_add_expr_to_block (block, tmp);
12868 : }
12869 3655 : tmp = build1_v (LABEL_EXPR, jump_label1);
12870 3655 : gfc_add_expr_to_block (block, tmp);
12871 :
12872 : /* For a deferred length character, reallocate if lengths of lhs and
12873 : rhs are different. */
12874 3655 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12875 : {
12876 1518 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12877 : lse.string_length,
12878 1518 : fold_convert (TREE_TYPE (lse.string_length),
12879 : size));
12880 : /* Jump past the realloc if the lengths are the same. */
12881 1518 : tmp = build3_v (COND_EXPR, cond,
12882 : build1_v (GOTO_EXPR, jump_label2),
12883 : build_empty_stmt (input_location));
12884 1518 : gfc_add_expr_to_block (block, tmp);
12885 1518 : tmp = build_call_expr_loc (input_location,
12886 : builtin_decl_explicit (BUILT_IN_REALLOC),
12887 : 2, fold_convert (pvoid_type_node, lse.expr),
12888 : size_in_bytes);
12889 1518 : tree omp_cond = NULL_TREE;
12890 1518 : if (flag_openmp_allocators)
12891 : {
12892 1 : tree omp_tmp;
12893 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
12894 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
12895 :
12896 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12897 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12898 : fold_convert (pvoid_type_node,
12899 : lse.expr), size_in_bytes,
12900 : build_zero_cst (ptr_type_node),
12901 : build_zero_cst (ptr_type_node));
12902 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
12903 : omp_cond, omp_tmp, tmp);
12904 : }
12905 1518 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12906 1518 : gfc_add_modify (block, lse.expr, tmp);
12907 1518 : if (omp_cond)
12908 1 : gfc_add_expr_to_block (block,
12909 : build3_loc (input_location, COND_EXPR,
12910 : void_type_node, omp_cond,
12911 : gfc_omp_call_add_alloc (lse.expr),
12912 : build_empty_stmt (input_location)));
12913 1518 : tmp = build1_v (LABEL_EXPR, jump_label2);
12914 1518 : gfc_add_expr_to_block (block, tmp);
12915 :
12916 : /* Update the lhs character length. */
12917 1518 : size = string_length;
12918 1518 : gfc_add_modify (block, lse.string_length,
12919 1518 : fold_convert (TREE_TYPE (lse.string_length), size));
12920 : }
12921 : }
12922 :
12923 : /* Check for assignments of the type
12924 :
12925 : a = a + 4
12926 :
12927 : to make sure we do not check for reallocation unnecessarily. */
12928 :
12929 :
12930 : /* Strip parentheses from an expression to get the underlying variable.
12931 : This is needed for self-assignment detection since (a) creates a
12932 : parentheses operator node. */
12933 :
12934 : static gfc_expr *
12935 7972 : strip_parentheses (gfc_expr *expr)
12936 : {
12937 0 : while (expr->expr_type == EXPR_OP
12938 317146 : && expr->value.op.op == INTRINSIC_PARENTHESES)
12939 590 : expr = expr->value.op.op1;
12940 315885 : return expr;
12941 : }
12942 :
12943 :
12944 : static bool
12945 7495 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
12946 : {
12947 7972 : gfc_actual_arglist *a;
12948 7972 : gfc_expr *e1, *e2;
12949 :
12950 : /* Strip parentheses to handle cases like a = (a). */
12951 15995 : expr1 = strip_parentheses (expr1);
12952 7972 : expr2 = strip_parentheses (expr2);
12953 :
12954 7972 : switch (expr2->expr_type)
12955 : {
12956 2176 : case EXPR_VARIABLE:
12957 2176 : return gfc_dep_compare_expr (expr1, expr2) == 0;
12958 :
12959 2839 : case EXPR_FUNCTION:
12960 2839 : if (expr2->value.function.esym
12961 305 : && expr2->value.function.esym->attr.elemental)
12962 : {
12963 75 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12964 : {
12965 74 : e1 = a->expr;
12966 74 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12967 : return false;
12968 : }
12969 : return true;
12970 : }
12971 2777 : else if (expr2->value.function.isym
12972 2520 : && expr2->value.function.isym->elemental)
12973 : {
12974 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12975 : {
12976 322 : e1 = a->expr;
12977 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12978 : return false;
12979 : }
12980 : return true;
12981 : }
12982 :
12983 : break;
12984 :
12985 671 : case EXPR_OP:
12986 671 : switch (expr2->value.op.op)
12987 : {
12988 19 : case INTRINSIC_NOT:
12989 19 : case INTRINSIC_UPLUS:
12990 19 : case INTRINSIC_UMINUS:
12991 19 : case INTRINSIC_PARENTHESES:
12992 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
12993 :
12994 627 : case INTRINSIC_PLUS:
12995 627 : case INTRINSIC_MINUS:
12996 627 : case INTRINSIC_TIMES:
12997 627 : case INTRINSIC_DIVIDE:
12998 627 : case INTRINSIC_POWER:
12999 627 : case INTRINSIC_AND:
13000 627 : case INTRINSIC_OR:
13001 627 : case INTRINSIC_EQV:
13002 627 : case INTRINSIC_NEQV:
13003 627 : case INTRINSIC_EQ:
13004 627 : case INTRINSIC_NE:
13005 627 : case INTRINSIC_GT:
13006 627 : case INTRINSIC_GE:
13007 627 : case INTRINSIC_LT:
13008 627 : case INTRINSIC_LE:
13009 627 : case INTRINSIC_EQ_OS:
13010 627 : case INTRINSIC_NE_OS:
13011 627 : case INTRINSIC_GT_OS:
13012 627 : case INTRINSIC_GE_OS:
13013 627 : case INTRINSIC_LT_OS:
13014 627 : case INTRINSIC_LE_OS:
13015 :
13016 627 : e1 = expr2->value.op.op1;
13017 627 : e2 = expr2->value.op.op2;
13018 :
13019 627 : if (e1->rank == 0 && e2->rank > 0)
13020 : return is_runtime_conformable (expr1, e2);
13021 569 : else if (e1->rank > 0 && e2->rank == 0)
13022 : return is_runtime_conformable (expr1, e1);
13023 169 : else if (e1->rank > 0 && e2->rank > 0)
13024 169 : return is_runtime_conformable (expr1, e1)
13025 169 : && is_runtime_conformable (expr1, e2);
13026 : break;
13027 :
13028 : default:
13029 : break;
13030 :
13031 : }
13032 :
13033 : break;
13034 :
13035 : default:
13036 : break;
13037 : }
13038 : return false;
13039 : }
13040 :
13041 :
13042 : static tree
13043 3319 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
13044 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
13045 : bool class_realloc)
13046 : {
13047 3319 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
13048 3319 : vec<tree, va_gc> *args = NULL;
13049 3319 : bool final_expr;
13050 :
13051 3319 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
13052 3319 : if (final_expr)
13053 : {
13054 473 : if (rse->loop)
13055 226 : gfc_prepend_expr_to_block (&rse->loop->pre,
13056 : gfc_finish_block (&lse->finalblock));
13057 : else
13058 247 : gfc_add_block_to_block (block, &lse->finalblock);
13059 : }
13060 :
13061 : /* Store the old vptr so that dynamic types can be compared for
13062 : reallocation to occur or not. */
13063 3319 : if (class_realloc)
13064 : {
13065 283 : tmp = lse->expr;
13066 283 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13067 0 : tmp = gfc_get_class_from_expr (tmp);
13068 : }
13069 :
13070 3319 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
13071 : &from_len, &rhs_vptr);
13072 3319 : if (rhs_vptr == NULL_TREE)
13073 43 : rhs_vptr = vptr;
13074 :
13075 : /* Generate (re)allocation of the lhs. */
13076 3319 : if (class_realloc)
13077 : {
13078 283 : stmtblock_t alloc, re_alloc;
13079 283 : tree class_han, re, size;
13080 :
13081 283 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13082 283 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
13083 : else
13084 0 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
13085 :
13086 283 : size = gfc_vptr_size_get (rhs_vptr);
13087 :
13088 : /* Take into account _len of unlimited polymorphic entities.
13089 : TODO: handle class(*) allocatable function results on rhs. */
13090 283 : if (UNLIMITED_POLY (rhs))
13091 : {
13092 18 : tree len;
13093 18 : if (rhs->expr_type == EXPR_VARIABLE)
13094 12 : len = trans_get_upoly_len (block, rhs);
13095 : else
13096 6 : len = gfc_class_len_get (tmp);
13097 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13098 : fold_convert (size_type_node, len),
13099 : size_one_node);
13100 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
13101 18 : size, fold_convert (TREE_TYPE (size), len));
13102 18 : }
13103 265 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
13104 27 : size = fold_build2_loc (input_location, MULT_EXPR,
13105 : gfc_charlen_type_node, size,
13106 : rse->string_length);
13107 :
13108 :
13109 283 : tmp = lse->expr;
13110 283 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
13111 283 : ? gfc_class_data_get (tmp) : tmp;
13112 :
13113 283 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
13114 0 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
13115 :
13116 : /* Allocate block. */
13117 283 : gfc_init_block (&alloc);
13118 283 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
13119 :
13120 : /* Reallocate if dynamic types are different. */
13121 283 : gfc_init_block (&re_alloc);
13122 283 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
13123 : {
13124 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
13125 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
13126 : }
13127 : else
13128 : {
13129 256 : tmp = fold_convert (pvoid_type_node, class_han);
13130 256 : re = build_call_expr_loc (input_location,
13131 : builtin_decl_explicit (BUILT_IN_REALLOC),
13132 : 2, tmp, size);
13133 256 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
13134 : tmp, re);
13135 256 : tmp = fold_build2_loc (input_location, NE_EXPR,
13136 : logical_type_node, rhs_vptr, old_vptr);
13137 256 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13138 : tmp, re, build_empty_stmt (input_location));
13139 256 : gfc_add_expr_to_block (&re_alloc, re);
13140 : }
13141 283 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
13142 283 : gfc_finish_block (&re_alloc) :
13143 0 : build_empty_stmt (input_location);
13144 :
13145 : /* Allocate if _data is NULL, reallocate otherwise. */
13146 283 : tmp = fold_build2_loc (input_location, EQ_EXPR,
13147 : logical_type_node, class_han,
13148 : build_int_cst (prvoid_type_node, 0));
13149 283 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13150 : gfc_unlikely (tmp,
13151 : PRED_FORTRAN_FAIL_ALLOC),
13152 : gfc_finish_block (&alloc),
13153 : realloc_expr);
13154 283 : gfc_add_expr_to_block (&lse->pre, tmp);
13155 : }
13156 :
13157 3319 : fcn = gfc_vptr_copy_get (vptr);
13158 :
13159 3319 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
13160 3319 : ? gfc_class_data_get (rse->expr) : rse->expr;
13161 3319 : if (use_vptr_copy)
13162 : {
13163 5584 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13164 524 : || INDIRECT_REF_P (tmp)
13165 403 : || (rhs->ts.type == BT_DERIVED
13166 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13167 0 : && !rhs->ts.u.derived->attr.pointer
13168 0 : && !rhs->ts.u.derived->attr.allocatable)
13169 3454 : || (UNLIMITED_POLY (rhs)
13170 134 : && !CLASS_DATA (rhs)->attr.pointer
13171 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13172 2648 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13173 : else
13174 403 : vec_safe_push (args, tmp);
13175 3051 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13176 3051 : ? gfc_class_data_get (lse->expr) : lse->expr;
13177 5322 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13178 780 : || INDIRECT_REF_P (tmp)
13179 283 : || (lhs->ts.type == BT_DERIVED
13180 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13181 0 : && !lhs->ts.u.derived->attr.pointer
13182 0 : && !lhs->ts.u.derived->attr.allocatable)
13183 3334 : || (UNLIMITED_POLY (lhs)
13184 119 : && !CLASS_DATA (lhs)->attr.pointer
13185 119 : && !CLASS_DATA (lhs)->attr.allocatable))
13186 2768 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13187 : else
13188 283 : vec_safe_push (args, tmp);
13189 :
13190 3051 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13191 :
13192 3051 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13193 : {
13194 406 : tree extcopy;
13195 406 : vec_safe_push (args, from_len);
13196 406 : vec_safe_push (args, to_len);
13197 406 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13198 :
13199 406 : tmp = fold_build2_loc (input_location, GT_EXPR,
13200 : logical_type_node, from_len,
13201 406 : build_zero_cst (TREE_TYPE (from_len)));
13202 406 : return fold_build3_loc (input_location, COND_EXPR,
13203 : void_type_node, tmp,
13204 406 : extcopy, stdcopy);
13205 : }
13206 : else
13207 2645 : return stdcopy;
13208 : }
13209 : else
13210 : {
13211 268 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13212 268 : ? gfc_class_data_get (lse->expr) : lse->expr;
13213 268 : stmtblock_t tblock;
13214 268 : gfc_init_block (&tblock);
13215 268 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13216 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13217 268 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13218 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13219 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13220 268 : gfc_add_modify_loc (input_location, &tblock, rhst,
13221 268 : fold_convert (TREE_TYPE (rhst), tmp));
13222 268 : return gfc_finish_block (&tblock);
13223 : }
13224 : }
13225 :
13226 : bool
13227 309845 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13228 : {
13229 309845 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13230 : return false;
13231 :
13232 31902 : return lhs->symtree->n.sym->assoc
13233 31902 : && lhs->symtree->n.sym->assoc->target == rhs;
13234 : }
13235 :
13236 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13237 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13238 : init_flag indicates initialization expressions and dealloc that no
13239 : deallocate prior assignment is needed (if in doubt, set true).
13240 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13241 : routine instead of a pointer assignment. Alias resolution is only done,
13242 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13243 : where it is known, that newly allocated memory on the lhs can never be
13244 : an alias of the rhs. */
13245 :
13246 : static tree
13247 309845 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13248 : bool dealloc, bool use_vptr_copy, bool may_alias)
13249 : {
13250 309845 : gfc_se lse;
13251 309845 : gfc_se rse;
13252 309845 : gfc_ss *lss;
13253 309845 : gfc_ss *lss_section;
13254 309845 : gfc_ss *rss;
13255 309845 : gfc_loopinfo loop;
13256 309845 : tree tmp;
13257 309845 : stmtblock_t block;
13258 309845 : stmtblock_t body;
13259 309845 : bool final_expr;
13260 309845 : bool l_is_temp;
13261 309845 : bool scalar_to_array;
13262 309845 : tree string_length;
13263 309845 : int n;
13264 309845 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13265 309845 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr, rhs_attr;
13266 309845 : bool is_poly_assign;
13267 309845 : bool realloc_flag;
13268 309845 : bool assoc_assign = false;
13269 309845 : bool dummy_class_array_copy;
13270 :
13271 : /* Assignment of the form lhs = rhs. */
13272 309845 : gfc_start_block (&block);
13273 :
13274 309845 : gfc_init_se (&lse, NULL);
13275 309845 : gfc_init_se (&rse, NULL);
13276 :
13277 309845 : gfc_fix_class_refs (expr1);
13278 :
13279 619690 : realloc_flag = flag_realloc_lhs
13280 303747 : && gfc_is_reallocatable_lhs (expr1)
13281 8302 : && expr2->rank
13282 316680 : && !is_runtime_conformable (expr1, expr2);
13283 :
13284 : /* Walk the lhs. */
13285 309845 : lss = gfc_walk_expr (expr1);
13286 309845 : if (realloc_flag)
13287 : {
13288 6452 : lss->no_bounds_check = 1;
13289 6452 : lss->is_alloc_lhs = 1;
13290 : }
13291 : else
13292 303393 : lss->no_bounds_check = expr1->no_bounds_check;
13293 :
13294 309845 : rss = NULL;
13295 :
13296 309845 : if (expr2->expr_type != EXPR_VARIABLE
13297 309845 : && expr2->expr_type != EXPR_CONSTANT
13298 309845 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13299 : {
13300 894 : expr2->must_finalize = 1;
13301 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13302 : function, the result is finalized after execution of the innermost
13303 : executable construct containing the reference. */
13304 894 : if (expr2->expr_type == EXPR_FUNCTION
13305 894 : && (gfc_expr_attr (expr2).pointer
13306 298 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13307 147 : expr2->must_finalize = 0;
13308 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13309 : structure constructor or array constructor, the entity created by
13310 : the constructor is finalized after execution of the innermost
13311 : executable construct containing the reference.
13312 : These finalizations were later deleted by the Combined Technical
13313 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13314 747 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13315 747 : && (expr2->expr_type == EXPR_STRUCTURE
13316 704 : || expr2->expr_type == EXPR_ARRAY))
13317 387 : expr2->must_finalize = 0;
13318 : }
13319 :
13320 :
13321 : /* Checking whether a class assignment is desired is quite complicated and
13322 : needed at two locations, so do it once only before the information is
13323 : needed. */
13324 309845 : lhs_attr = gfc_expr_attr (expr1);
13325 309845 : rhs_attr = gfc_expr_attr (expr2);
13326 309845 : dummy_class_array_copy
13327 619690 : = (expr2->expr_type == EXPR_VARIABLE
13328 31902 : && expr2->rank > 0
13329 8384 : && expr2->symtree != NULL
13330 8384 : && expr2->symtree->n.sym->attr.dummy
13331 1471 : && expr2->ts.type == BT_CLASS
13332 127 : && !rhs_attr.pointer
13333 127 : && !rhs_attr.allocatable
13334 114 : && !CLASS_DATA (expr2)->attr.class_pointer
13335 309959 : && !CLASS_DATA (expr2)->attr.allocatable);
13336 :
13337 : /* What can be sent to trans_class_assignment includes all the obvious
13338 : candidates but scalar assignment of a class expression to a derived type
13339 : must be done using gfc_trans_scalar_assign; partly because it is simpler
13340 : and partly because some cases fail, eg. class assignment to derived_type
13341 : select type temporaries. */
13342 309845 : is_poly_assign
13343 309845 : = (use_vptr_copy
13344 292848 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13345 22922 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13346 20847 : || gfc_is_class_scalar_expr (expr1)
13347 19536 : || gfc_is_class_array_ref (expr2, NULL)
13348 19536 : || (gfc_is_class_scalar_expr (expr2)
13349 30 : && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
13350 313231 : && lhs_attr.flavor != FL_PROCEDURE;
13351 :
13352 309845 : assoc_assign = is_assoc_assign (expr1, expr2);
13353 :
13354 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13355 : mode. Avoid false-positive uninitialized diagnostics with initializing
13356 : the codimension flag unconditionally. */
13357 309845 : lhs_caf_attr.codimension = false;
13358 309845 : rhs_caf_attr.codimension = false;
13359 309845 : if (flag_coarray == GFC_FCOARRAY_LIB)
13360 : {
13361 6687 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13362 6687 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13363 : }
13364 :
13365 309845 : tree reallocation = NULL_TREE;
13366 309845 : if (lss != gfc_ss_terminator)
13367 : {
13368 : /* The assignment needs scalarization. */
13369 : lss_section = lss;
13370 :
13371 : /* Find a non-scalar SS from the lhs. */
13372 : while (lss_section != gfc_ss_terminator
13373 40139 : && lss_section->info->type != GFC_SS_SECTION)
13374 0 : lss_section = lss_section->next;
13375 :
13376 40139 : gcc_assert (lss_section != gfc_ss_terminator);
13377 :
13378 : /* Initialize the scalarizer. */
13379 40139 : gfc_init_loopinfo (&loop);
13380 :
13381 : /* Walk the rhs. */
13382 40139 : rss = gfc_walk_expr (expr2);
13383 40139 : if (rss == gfc_ss_terminator)
13384 : {
13385 : /* The rhs is scalar. Add a ss for the expression. */
13386 15024 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13387 15024 : lss->is_alloc_lhs = 0;
13388 : }
13389 :
13390 : /* When doing a class assign, then the handle to the rhs needs to be a
13391 : pointer to allow for polymorphism. */
13392 40139 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13393 509 : rss->info->type = GFC_SS_REFERENCE;
13394 :
13395 40139 : rss->no_bounds_check = expr2->no_bounds_check;
13396 : /* Associate the SS with the loop. */
13397 40139 : gfc_add_ss_to_loop (&loop, lss);
13398 40139 : gfc_add_ss_to_loop (&loop, rss);
13399 :
13400 : /* Calculate the bounds of the scalarization. */
13401 40139 : gfc_conv_ss_startstride (&loop);
13402 : /* Enable loop reversal. */
13403 682363 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13404 602085 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13405 : /* Resolve any data dependencies in the statement. */
13406 40139 : if (may_alias)
13407 37854 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13408 : /* Setup the scalarizing loops. */
13409 40139 : gfc_conv_loop_setup (&loop, &expr2->where);
13410 :
13411 : /* Setup the gfc_se structures. */
13412 40139 : gfc_copy_loopinfo_to_se (&lse, &loop);
13413 40139 : gfc_copy_loopinfo_to_se (&rse, &loop);
13414 :
13415 40139 : rse.ss = rss;
13416 40139 : gfc_mark_ss_chain_used (rss, 1);
13417 40139 : if (loop.temp_ss == NULL)
13418 : {
13419 39025 : lse.ss = lss;
13420 39025 : gfc_mark_ss_chain_used (lss, 1);
13421 : }
13422 : else
13423 : {
13424 1114 : lse.ss = loop.temp_ss;
13425 1114 : gfc_mark_ss_chain_used (lss, 3);
13426 1114 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13427 : }
13428 :
13429 : /* Allow the scalarizer to workshare array assignments. */
13430 40139 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13431 : == OMPWS_WORKSHARE_FLAG
13432 85 : && loop.temp_ss == NULL)
13433 : {
13434 73 : maybe_workshare = true;
13435 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13436 : }
13437 :
13438 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13439 40139 : if (realloc_flag)
13440 : {
13441 6452 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13442 6452 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13443 6452 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13444 : expr2);
13445 : }
13446 :
13447 : /* Start the scalarized loop body. */
13448 40139 : gfc_start_scalarized_body (&loop, &body);
13449 : }
13450 : else
13451 269706 : gfc_init_block (&body);
13452 :
13453 309845 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13454 :
13455 : /* Translate the expression. */
13456 619690 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13457 309845 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13458 309845 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13459 309845 : gfc_conv_expr (&rse, expr2);
13460 :
13461 : /* Deal with the case of a scalar class function assigned to a derived type.
13462 : */
13463 309845 : if (gfc_is_alloc_class_scalar_function (expr2)
13464 309845 : && expr1->ts.type == BT_DERIVED)
13465 : {
13466 60 : rse.expr = gfc_class_data_get (rse.expr);
13467 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13468 : }
13469 :
13470 : /* Stabilize a string length for temporaries. */
13471 309845 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13472 24647 : && !(VAR_P (rse.string_length)
13473 : || TREE_CODE (rse.string_length) == PARM_DECL
13474 : || INDIRECT_REF_P (rse.string_length)))
13475 23777 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13476 286068 : else if (expr2->ts.type == BT_CHARACTER)
13477 : {
13478 4382 : if (expr1->ts.deferred
13479 6803 : && gfc_expr_attr (expr1).allocatable
13480 6923 : && gfc_check_dependency (expr1, expr2, true))
13481 120 : rse.string_length =
13482 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13483 4382 : string_length = rse.string_length;
13484 : }
13485 : else
13486 : string_length = NULL_TREE;
13487 :
13488 309845 : if (l_is_temp)
13489 : {
13490 1114 : gfc_conv_tmp_array_ref (&lse);
13491 1114 : if (expr2->ts.type == BT_CHARACTER)
13492 123 : lse.string_length = string_length;
13493 : }
13494 : else
13495 : {
13496 308731 : gfc_conv_expr (&lse, expr1);
13497 : /* For some expression (e.g. complex numbers) fold_convert uses a
13498 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13499 : not updated when assigned to. */
13500 308731 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13501 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13502 :
13503 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13504 314884 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13505 : {
13506 36 : tree cond;
13507 36 : const char* msg;
13508 :
13509 36 : tmp = INDIRECT_REF_P (lse.expr)
13510 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13511 36 : STRIP_NOPS (tmp);
13512 :
13513 : /* We should only get array references here. */
13514 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13515 : || TREE_CODE (tmp) == ARRAY_REF);
13516 :
13517 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13518 : or the array itself(ARRAY_REF). */
13519 36 : tmp = TREE_OPERAND (tmp, 0);
13520 :
13521 : /* Provide the address of the array. */
13522 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13523 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13524 :
13525 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13526 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13527 36 : msg = _("Assignment of scalar to unallocated array");
13528 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13529 : &expr1->where, msg);
13530 : }
13531 :
13532 : /* Deallocate the lhs parameterized components if required. */
13533 308731 : if (dealloc
13534 290175 : && !expr1->symtree->n.sym->attr.associate_var
13535 288194 : && expr2->expr_type != EXPR_ARRAY
13536 282180 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
13537 : {
13538 361 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
13539 :
13540 361 : tmp = lse.expr;
13541 361 : if (pdt_dep)
13542 : {
13543 : /* Create a temporary for deallocation after assignment. */
13544 168 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
13545 168 : gfc_add_modify (&lse.pre, tmp, lse.expr);
13546 : }
13547 :
13548 361 : if (expr1->ts.type == BT_DERIVED)
13549 361 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
13550 : expr1->rank);
13551 0 : else if (expr1->ts.type == BT_CLASS)
13552 : {
13553 0 : tmp = gfc_class_data_get (tmp);
13554 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
13555 : tmp, expr1->rank);
13556 : }
13557 :
13558 361 : if (tmp && pdt_dep)
13559 92 : gfc_add_expr_to_block (&rse.post, tmp);
13560 269 : else if (tmp)
13561 67 : gfc_add_expr_to_block (&lse.pre, tmp);
13562 : }
13563 : }
13564 :
13565 : /* Assignments of scalar derived types with allocatable components
13566 : to arrays must be done with a deep copy and the rhs temporary
13567 : must have its components deallocated afterwards. */
13568 619690 : scalar_to_array = (expr2->ts.type == BT_DERIVED
13569 19626 : && expr2->ts.u.derived->attr.alloc_comp
13570 6789 : && !gfc_expr_is_variable (expr2)
13571 313547 : && expr1->rank && !expr2->rank);
13572 619690 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
13573 19909 : && expr1->rank
13574 3833 : && expr1->ts.u.derived->attr.alloc_comp
13575 311273 : && gfc_is_alloc_class_scalar_function (expr2));
13576 309845 : if (scalar_to_array && dealloc)
13577 : {
13578 59 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
13579 59 : gfc_prepend_expr_to_block (&loop.post, tmp);
13580 : }
13581 :
13582 : /* When assigning a character function result to a deferred-length variable,
13583 : the function call must happen before the (re)allocation of the lhs -
13584 : otherwise the character length of the result is not known.
13585 : NOTE 1: This relies on having the exact dependence of the length type
13586 : parameter available to the caller; gfortran saves it in the .mod files.
13587 : NOTE 2: Vector array references generate an index temporary that must
13588 : not go outside the loop. Otherwise, variables should not generate
13589 : a pre block.
13590 : NOTE 3: The concatenation operation generates a temporary pointer,
13591 : whose allocation must go to the innermost loop.
13592 : NOTE 4: Elemental functions may generate a temporary, too. */
13593 309845 : if (flag_realloc_lhs
13594 303747 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
13595 2984 : && !(lss != gfc_ss_terminator
13596 928 : && rss != gfc_ss_terminator
13597 928 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
13598 741 : || (expr2->expr_type == EXPR_FUNCTION
13599 160 : && expr2->value.function.esym != NULL
13600 26 : && expr2->value.function.esym->attr.elemental)
13601 728 : || (expr2->expr_type == EXPR_FUNCTION
13602 147 : && expr2->value.function.isym != NULL
13603 134 : && expr2->value.function.isym->elemental)
13604 672 : || (expr2->expr_type == EXPR_OP
13605 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
13606 2703 : gfc_add_block_to_block (&block, &rse.pre);
13607 :
13608 : /* Nullify the allocatable components corresponding to those of the lhs
13609 : derived type, so that the finalization of the function result does not
13610 : affect the lhs of the assignment. Prepend is used to ensure that the
13611 : nullification occurs before the call to the finalizer. In the case of
13612 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
13613 : as part of the deep copy. */
13614 309018 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
13615 328927 : && (gfc_is_class_array_function (expr2)
13616 19058 : || gfc_is_alloc_class_scalar_function (expr2)))
13617 : {
13618 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
13619 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
13620 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
13621 0 : gfc_add_block_to_block (&loop.post, &rse.post);
13622 : }
13623 :
13624 309845 : tmp = NULL_TREE;
13625 :
13626 309845 : if (is_poly_assign)
13627 : {
13628 3319 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
13629 3319 : use_vptr_copy || (lhs_attr.allocatable
13630 283 : && !lhs_attr.dimension),
13631 3063 : !realloc_flag && flag_realloc_lhs
13632 3870 : && !lhs_attr.pointer);
13633 3319 : if (expr2->expr_type == EXPR_FUNCTION
13634 220 : && expr2->ts.type == BT_DERIVED
13635 18 : && expr2->ts.u.derived->attr.alloc_comp)
13636 : {
13637 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
13638 : rse.expr, expr2->rank);
13639 18 : if (lss == gfc_ss_terminator)
13640 18 : gfc_add_expr_to_block (&rse.post, tmp2);
13641 : else
13642 0 : gfc_add_expr_to_block (&loop.post, tmp2);
13643 : }
13644 :
13645 3319 : expr1->must_finalize = 0;
13646 : }
13647 306526 : else if (!is_poly_assign
13648 306526 : && expr1->ts.type == BT_CLASS
13649 442 : && expr2->ts.type == BT_CLASS
13650 255 : && (expr2->must_finalize || dummy_class_array_copy))
13651 : {
13652 : /* This case comes about when the scalarizer provides array element
13653 : references to class temporaries or nonpointer dummy arrays. Use the
13654 : vptr copy function, since this does a deep copy of allocatable
13655 : components. */
13656 132 : tmp = gfc_get_vptr_from_expr (rse.expr);
13657 132 : if (tmp == NULL_TREE && dummy_class_array_copy)
13658 12 : tmp = gfc_get_vptr_from_expr (gfc_get_class_from_gfc_expr (expr2));
13659 132 : if (tmp != NULL_TREE)
13660 : {
13661 132 : tree fcn = gfc_vptr_copy_get (tmp);
13662 132 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
13663 132 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
13664 132 : tmp = build_call_expr_loc (input_location,
13665 : fcn, 2,
13666 : gfc_build_addr_expr (NULL, rse.expr),
13667 : gfc_build_addr_expr (NULL, lse.expr));
13668 : }
13669 : }
13670 :
13671 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
13672 : after evaluation of the rhs and before reallocation.
13673 : Skip finalization for self-assignment to avoid use-after-free.
13674 : Strip parentheses from both sides to handle cases like a = (a). */
13675 309845 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
13676 309845 : if (final_expr
13677 666 : && gfc_dep_compare_expr (strip_parentheses (expr1),
13678 : strip_parentheses (expr2)) != 0
13679 310487 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
13680 211 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
13681 : {
13682 642 : if (lss == gfc_ss_terminator)
13683 : {
13684 183 : gfc_add_block_to_block (&block, &rse.pre);
13685 183 : gfc_add_block_to_block (&block, &lse.finalblock);
13686 : }
13687 : else
13688 : {
13689 459 : gfc_add_block_to_block (&body, &rse.pre);
13690 459 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
13691 : &lse.finalblock);
13692 : }
13693 : }
13694 : else
13695 309203 : gfc_add_block_to_block (&body, &rse.pre);
13696 :
13697 309845 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
13698 2994 : && assoc_assign)
13699 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
13700 :
13701 : /* If nothing else works, do it the old fashioned way! */
13702 309845 : if (tmp == NULL_TREE)
13703 : {
13704 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
13705 306394 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
13706 306394 : tmp
13707 306394 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13708 306394 : gfc_expr_is_variable (expr2_stripped)
13709 276233 : || scalar_to_array
13710 581890 : || expr2->expr_type == EXPR_ARRAY,
13711 306394 : !(l_is_temp || init_flag) && dealloc,
13712 306394 : expr1->symtree->n.sym->attr.codimension,
13713 : assoc_assign);
13714 : }
13715 :
13716 : /* Add the lse pre block to the body */
13717 309845 : gfc_add_block_to_block (&body, &lse.pre);
13718 309845 : gfc_add_expr_to_block (&body, tmp);
13719 :
13720 : /* Add the post blocks to the body. Scalar finalization must appear before
13721 : the post block in case any dellocations are done. */
13722 309845 : if (rse.finalblock.head
13723 309845 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
13724 14 : && gfc_expr_attr (expr2).elemental)))
13725 : {
13726 142 : gfc_add_block_to_block (&body, &rse.finalblock);
13727 142 : gfc_add_block_to_block (&body, &rse.post);
13728 : }
13729 : else
13730 309703 : gfc_add_block_to_block (&body, &rse.post);
13731 :
13732 309845 : gfc_add_block_to_block (&body, &lse.post);
13733 :
13734 309845 : if (lss == gfc_ss_terminator)
13735 : {
13736 : /* F2003: Add the code for reallocation on assignment. */
13737 266950 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
13738 273361 : && !is_poly_assign)
13739 3655 : alloc_scalar_allocatable_for_assignment (&block, string_length,
13740 : expr1, expr2);
13741 :
13742 : /* Use the scalar assignment as is. */
13743 269706 : gfc_add_block_to_block (&block, &body);
13744 : }
13745 : else
13746 : {
13747 40139 : gcc_assert (lse.ss == gfc_ss_terminator
13748 : && rse.ss == gfc_ss_terminator);
13749 :
13750 40139 : if (l_is_temp)
13751 : {
13752 1114 : gfc_trans_scalarized_loop_boundary (&loop, &body);
13753 :
13754 : /* We need to copy the temporary to the actual lhs. */
13755 1114 : gfc_init_se (&lse, NULL);
13756 1114 : gfc_init_se (&rse, NULL);
13757 1114 : gfc_copy_loopinfo_to_se (&lse, &loop);
13758 1114 : gfc_copy_loopinfo_to_se (&rse, &loop);
13759 :
13760 1114 : rse.ss = loop.temp_ss;
13761 1114 : lse.ss = lss;
13762 :
13763 1114 : gfc_conv_tmp_array_ref (&rse);
13764 1114 : gfc_conv_expr (&lse, expr1);
13765 :
13766 1114 : gcc_assert (lse.ss == gfc_ss_terminator
13767 : && rse.ss == gfc_ss_terminator);
13768 :
13769 1114 : if (expr2->ts.type == BT_CHARACTER)
13770 123 : rse.string_length = string_length;
13771 :
13772 1114 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13773 : false, dealloc);
13774 1114 : gfc_add_expr_to_block (&body, tmp);
13775 : }
13776 :
13777 40139 : if (reallocation != NULL_TREE)
13778 6452 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
13779 :
13780 40139 : if (maybe_workshare)
13781 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
13782 :
13783 : /* Generate the copying loops. */
13784 40139 : gfc_trans_scalarizing_loops (&loop, &body);
13785 :
13786 : /* Wrap the whole thing up. */
13787 40139 : gfc_add_block_to_block (&block, &loop.pre);
13788 40139 : gfc_add_block_to_block (&block, &loop.post);
13789 :
13790 40139 : gfc_cleanup_loop (&loop);
13791 : }
13792 :
13793 : /* Since parameterized components cannot have default initializers,
13794 : the default PDT constructor leaves them unallocated. Do the
13795 : allocation now. */
13796 309845 : if (init_flag && IS_PDT (expr1)
13797 359 : && !expr1->symtree->n.sym->attr.allocatable
13798 359 : && !expr1->symtree->n.sym->attr.dummy)
13799 : {
13800 73 : gfc_symbol *sym = expr1->symtree->n.sym;
13801 73 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
13802 : sym->backend_decl,
13803 73 : sym->as ? sym->as->rank : 0,
13804 73 : sym->param_list);
13805 73 : gfc_add_expr_to_block (&block, tmp);
13806 : }
13807 :
13808 309845 : return gfc_finish_block (&block);
13809 : }
13810 :
13811 :
13812 : /* Check whether EXPR is a copyable array. */
13813 :
13814 : static bool
13815 982070 : copyable_array_p (gfc_expr * expr)
13816 : {
13817 982070 : if (expr->expr_type != EXPR_VARIABLE)
13818 : return false;
13819 :
13820 : /* First check it's an array. */
13821 958213 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
13822 : return false;
13823 :
13824 148125 : if (!gfc_full_array_ref_p (expr->ref, NULL))
13825 : return false;
13826 :
13827 : /* Next check that it's of a simple enough type. */
13828 116563 : switch (expr->ts.type)
13829 : {
13830 : case BT_INTEGER:
13831 : case BT_REAL:
13832 : case BT_COMPLEX:
13833 : case BT_LOGICAL:
13834 : return true;
13835 :
13836 : case BT_CHARACTER:
13837 : return false;
13838 :
13839 6701 : case_bt_struct:
13840 6701 : return (!expr->ts.u.derived->attr.alloc_comp
13841 6701 : && !expr->ts.u.derived->attr.pdt_type);
13842 :
13843 : default:
13844 : break;
13845 : }
13846 :
13847 : return false;
13848 : }
13849 :
13850 : /* Translate an assignment. */
13851 :
13852 : tree
13853 327775 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13854 : bool dealloc, bool use_vptr_copy, bool may_alias)
13855 : {
13856 327775 : tree tmp;
13857 :
13858 : /* Special case a single function returning an array. */
13859 327775 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
13860 : {
13861 14512 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
13862 14512 : if (tmp)
13863 : return tmp;
13864 : }
13865 :
13866 : /* Special case assigning an array to zero. */
13867 320902 : if (copyable_array_p (expr1)
13868 320902 : && is_zero_initializer_p (expr2))
13869 : {
13870 3951 : tmp = gfc_trans_zero_assign (expr1);
13871 3951 : if (tmp)
13872 : return tmp;
13873 : }
13874 :
13875 : /* Special case copying one array to another. */
13876 317230 : if (copyable_array_p (expr1)
13877 28194 : && copyable_array_p (expr2)
13878 2699 : && gfc_compare_types (&expr1->ts, &expr2->ts)
13879 319929 : && !gfc_check_dependency (expr1, expr2, 0))
13880 : {
13881 2603 : tmp = gfc_trans_array_copy (expr1, expr2);
13882 2603 : if (tmp)
13883 : return tmp;
13884 : }
13885 :
13886 : /* Special case initializing an array from a constant array constructor. */
13887 315744 : if (copyable_array_p (expr1)
13888 26708 : && expr2->expr_type == EXPR_ARRAY
13889 323987 : && gfc_compare_types (&expr1->ts, &expr2->ts))
13890 : {
13891 8243 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
13892 8243 : if (tmp)
13893 : return tmp;
13894 : }
13895 :
13896 309845 : if (UNLIMITED_POLY (expr1) && expr1->rank)
13897 309845 : use_vptr_copy = true;
13898 :
13899 : /* Fallback to the scalarizer to generate explicit loops. */
13900 309845 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
13901 309845 : use_vptr_copy, may_alias);
13902 : }
13903 :
13904 : tree
13905 13169 : gfc_trans_init_assign (gfc_code * code)
13906 : {
13907 13169 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
13908 : }
13909 :
13910 : tree
13911 306242 : gfc_trans_assign (gfc_code * code)
13912 : {
13913 306242 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
13914 : }
13915 :
13916 : /* Generate a simple loop for internal use of the form
13917 : for (var = begin; var <cond> end; var += step)
13918 : body; */
13919 : void
13920 12171 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
13921 : enum tree_code cond, tree step, tree body)
13922 : {
13923 12171 : tree tmp;
13924 :
13925 : /* var = begin. */
13926 12171 : gfc_add_modify (block, var, begin);
13927 :
13928 : /* Loop: for (var = begin; var <cond> end; var += step). */
13929 12171 : tree label_loop = gfc_build_label_decl (NULL_TREE);
13930 12171 : tree label_cond = gfc_build_label_decl (NULL_TREE);
13931 12171 : TREE_USED (label_loop) = 1;
13932 12171 : TREE_USED (label_cond) = 1;
13933 :
13934 12171 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
13935 12171 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
13936 :
13937 : /* Loop body. */
13938 12171 : gfc_add_expr_to_block (block, body);
13939 :
13940 : /* End of loop body. */
13941 12171 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
13942 12171 : gfc_add_modify (block, var, tmp);
13943 12171 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
13944 12171 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
13945 12171 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
13946 : build_empty_stmt (input_location));
13947 12171 : gfc_add_expr_to_block (block, tmp);
13948 12171 : }
|
