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 36126 : gfc_get_character_len (tree type)
53 : {
54 36126 : tree len;
55 :
56 36126 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
57 : && TYPE_STRING_FLAG (type));
58 :
59 36126 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
60 36126 : len = (len) ? (len) : (integer_zero_node);
61 36126 : 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 36126 : gfc_get_character_len_in_bytes (tree type)
70 : {
71 36126 : tree tmp, len;
72 :
73 36126 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
74 : && TYPE_STRING_FLAG (type));
75 :
76 36126 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
77 72252 : tmp = (tmp && !integer_zerop (tmp))
78 72252 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
79 36126 : len = gfc_get_character_len (type);
80 36126 : if (tmp && len && !integer_zerop (len))
81 35366 : len = fold_build2_loc (input_location, MULT_EXPR,
82 : gfc_charlen_type_node, len, tmp);
83 36126 : 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 7274 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
92 : {
93 7274 : enum gfc_array_kind akind;
94 7274 : tree *lbound = NULL, *ubound = NULL;
95 7274 : int codim = 0;
96 :
97 7274 : if (attr.pointer)
98 : akind = GFC_ARRAY_POINTER_CONT;
99 6922 : else if (attr.allocatable)
100 : akind = GFC_ARRAY_ALLOCATABLE;
101 : else
102 5425 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
103 :
104 7274 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
105 6303 : scalar = TREE_TYPE (scalar);
106 7274 : if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
107 : {
108 5732 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
109 5732 : codim = lang_specific->corank;
110 5732 : lbound = lang_specific->lbound;
111 5732 : ubound = lang_specific->ubound;
112 : }
113 7724 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
114 : ubound, 1, akind,
115 7274 : !(attr.pointer || attr.target));
116 : }
117 :
118 : tree
119 6584 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
120 : {
121 6584 : tree desc, type, etype;
122 :
123 6584 : type = get_scalar_to_descriptor_type (scalar, attr);
124 6584 : etype = TREE_TYPE (scalar);
125 6584 : desc = gfc_create_var (type, "desc");
126 6584 : DECL_ARTIFICIAL (desc) = 1;
127 :
128 6584 : 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 6584 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
136 971 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
137 5613 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
138 158 : etype = TREE_TYPE (etype);
139 6584 : gfc_conv_descriptor_dtype_set (&se->pre, desc,
140 : gfc_get_dtype_rank_type (0, etype));
141 6584 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
142 6584 : gfc_conv_descriptor_span_set (&se->pre, desc,
143 : gfc_conv_descriptor_elem_len_get (desc));
144 :
145 : /* Copy pointer address back - but only if it could have changed and
146 : if the actual argument is a pointer and not, e.g., NULL(). */
147 6584 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
148 2302 : gfc_add_modify (&se->post, scalar,
149 1151 : fold_convert (TREE_TYPE (scalar),
150 : gfc_conv_descriptor_data_get (desc)));
151 6584 : 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 540 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
160 : {
161 540 : gfc_symbol *sym = expr->symtree->n.sym;
162 1080 : bool is_coarray = sym->ts.type == BT_CLASS
163 540 : ? CLASS_DATA (sym)->attr.codimension
164 495 : : sym->attr.codimension;
165 540 : gfc_expr *caf_expr = gfc_copy_expr (expr);
166 540 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
167 :
168 1692 : while (ref)
169 : {
170 1152 : if (ref->type == REF_COMPONENT
171 431 : && (ref->u.c.component->attr.allocatable
172 104 : || ref->u.c.component->attr.pointer)
173 429 : && (is_coarray || ref->u.c.component->attr.codimension))
174 1152 : last_caf_ref = ref;
175 1152 : ref = ref->next;
176 : }
177 :
178 540 : if (last_caf_ref == NULL)
179 : {
180 194 : gfc_free_expr (caf_expr);
181 194 : return NULL_TREE;
182 : }
183 :
184 143 : tree comp = last_caf_ref->u.c.component->caf_token
185 346 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
186 : : NULL_TREE,
187 : caf;
188 346 : gfc_se se;
189 346 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
190 346 : if (comp == NULL_TREE && comp_ref)
191 : {
192 60 : gfc_free_expr (caf_expr);
193 60 : return NULL_TREE;
194 : }
195 286 : gfc_init_se (&se, outerse);
196 286 : gfc_free_ref_list (last_caf_ref->next);
197 286 : last_caf_ref->next = NULL;
198 286 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
199 572 : caf_expr->corank = last_caf_ref->u.c.component->as
200 286 : ? last_caf_ref->u.c.component->as->corank
201 : : expr->corank;
202 286 : se.want_pointer = comp_ref;
203 286 : gfc_conv_expr (&se, caf_expr);
204 286 : gfc_add_block_to_block (&outerse->pre, &se.pre);
205 :
206 286 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
207 143 : se.expr = TREE_OPERAND (se.expr, 0);
208 286 : gfc_free_expr (caf_expr);
209 :
210 286 : if (comp_ref)
211 143 : caf = fold_build3_loc (input_location, COMPONENT_REF,
212 143 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
213 : else
214 143 : caf = gfc_conv_descriptor_token (se.expr);
215 286 : return gfc_build_addr_expr (NULL_TREE, caf);
216 : }
217 :
218 :
219 : /* This is the seed for an eventual trans-class.c
220 :
221 : The following parameters should not be used directly since they might
222 : in future implementations. Use the corresponding APIs. */
223 : #define CLASS_DATA_FIELD 0
224 : #define CLASS_VPTR_FIELD 1
225 : #define CLASS_LEN_FIELD 2
226 : #define VTABLE_HASH_FIELD 0
227 : #define VTABLE_SIZE_FIELD 1
228 : #define VTABLE_EXTENDS_FIELD 2
229 : #define VTABLE_DEF_INIT_FIELD 3
230 : #define VTABLE_COPY_FIELD 4
231 : #define VTABLE_FINAL_FIELD 5
232 : #define VTABLE_DEALLOCATE_FIELD 6
233 :
234 :
235 : tree
236 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
237 : {
238 40 : tree tmp;
239 40 : tree field;
240 40 : vec<constructor_elt, va_gc> *init = NULL;
241 :
242 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
243 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
244 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
245 :
246 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
247 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
248 :
249 40 : return build_constructor (TREE_TYPE (decl), init);
250 : }
251 :
252 :
253 : tree
254 33416 : gfc_class_data_get (tree decl)
255 : {
256 33416 : tree data;
257 33416 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
258 5591 : decl = build_fold_indirect_ref_loc (input_location, decl);
259 33416 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
260 : CLASS_DATA_FIELD);
261 33416 : return fold_build3_loc (input_location, COMPONENT_REF,
262 33416 : TREE_TYPE (data), decl, data,
263 33416 : NULL_TREE);
264 : }
265 :
266 :
267 : tree
268 47459 : gfc_class_vptr_get (tree decl)
269 : {
270 47459 : tree vptr;
271 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
272 : then available through the saved descriptor. */
273 29060 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
274 49481 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
275 1351 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
276 47459 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
277 2417 : decl = build_fold_indirect_ref_loc (input_location, decl);
278 47459 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
279 : CLASS_VPTR_FIELD);
280 47459 : return fold_build3_loc (input_location, COMPONENT_REF,
281 47459 : TREE_TYPE (vptr), decl, vptr,
282 47459 : NULL_TREE);
283 : }
284 :
285 :
286 : tree
287 7123 : gfc_class_len_get (tree decl)
288 : {
289 7123 : tree len;
290 : /* For class arrays decl may be a temporary descriptor handle, the len is
291 : then available through the saved descriptor. */
292 5051 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
293 7414 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
294 127 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
295 7123 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
296 704 : decl = build_fold_indirect_ref_loc (input_location, decl);
297 7123 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
298 : CLASS_LEN_FIELD);
299 7123 : return fold_build3_loc (input_location, COMPONENT_REF,
300 7123 : TREE_TYPE (len), decl, len,
301 7123 : NULL_TREE);
302 : }
303 :
304 :
305 : /* Try to get the _len component of a class. When the class is not unlimited
306 : poly, i.e. no _len field exists, then return a zero node. */
307 :
308 : static tree
309 8680 : gfc_class_len_or_zero_get (tree decl)
310 : {
311 8680 : tree len;
312 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
313 : then available through the saved descriptor. */
314 4282 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
315 8854 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
316 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
317 8680 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
318 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
319 8680 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
320 : CLASS_LEN_FIELD);
321 11160 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
322 2480 : TREE_TYPE (len), decl, len,
323 : NULL_TREE)
324 6200 : : build_zero_cst (gfc_charlen_type_node);
325 : }
326 :
327 :
328 : tree
329 8498 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
330 : {
331 8498 : tree tmp;
332 8498 : tree tmp2;
333 8498 : tree type;
334 :
335 8498 : tmp = gfc_class_len_or_zero_get (class_expr);
336 :
337 : /* Include the len value in the element size if present. */
338 8498 : if (!integer_zerop (tmp))
339 : {
340 2298 : type = TREE_TYPE (size);
341 2298 : if (block)
342 : {
343 1080 : size = gfc_evaluate_now (size, block);
344 1080 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
345 : }
346 : else
347 1218 : tmp = fold_convert (type , tmp);
348 2298 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
349 : type, size, tmp);
350 2298 : tmp = fold_build2_loc (input_location, GT_EXPR,
351 : logical_type_node, tmp,
352 : build_zero_cst (type));
353 2298 : size = fold_build3_loc (input_location, COND_EXPR,
354 : type, tmp, tmp2, size);
355 : }
356 : else
357 : return size;
358 :
359 2298 : if (block)
360 1080 : size = gfc_evaluate_now (size, block);
361 :
362 : return size;
363 : }
364 :
365 :
366 : /* Get the specified FIELD from the VPTR. */
367 :
368 : static tree
369 22270 : vptr_field_get (tree vptr, int fieldno)
370 : {
371 22270 : tree field;
372 22270 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
373 22270 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
374 : fieldno);
375 22270 : field = fold_build3_loc (input_location, COMPONENT_REF,
376 22270 : TREE_TYPE (field), vptr, field,
377 : NULL_TREE);
378 22270 : gcc_assert (field);
379 22270 : return field;
380 : }
381 :
382 :
383 : /* Get the field from the class' vptr. */
384 :
385 : static tree
386 10362 : class_vtab_field_get (tree decl, int fieldno)
387 : {
388 10362 : tree vptr;
389 10362 : vptr = gfc_class_vptr_get (decl);
390 10362 : return vptr_field_get (vptr, fieldno);
391 : }
392 :
393 :
394 : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
395 : unison. */
396 : #define VTAB_GET_FIELD_GEN(name, field) tree \
397 : gfc_class_vtab_## name ##_get (tree cl) \
398 : { \
399 : return class_vtab_field_get (cl, field); \
400 : } \
401 : \
402 : tree \
403 : gfc_vptr_## name ##_get (tree vptr) \
404 : { \
405 : return vptr_field_get (vptr, field); \
406 : }
407 :
408 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
409 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
410 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
411 4527 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
412 1914 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
413 1167 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
414 : #undef VTAB_GET_FIELD_GEN
415 :
416 : /* The size field is returned as an array index type. Therefore treat
417 : it and only it specially. */
418 :
419 : tree
420 8246 : gfc_class_vtab_size_get (tree cl)
421 : {
422 8246 : tree size;
423 8246 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
424 : /* Always return size as an array index type. */
425 8246 : size = fold_convert (gfc_array_index_type, size);
426 8246 : gcc_assert (size);
427 8246 : return size;
428 : }
429 :
430 : tree
431 6233 : gfc_vptr_size_get (tree vptr)
432 : {
433 6233 : tree size;
434 6233 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
435 : /* Always return size as an array index type. */
436 6233 : size = fold_convert (gfc_array_index_type, size);
437 6233 : gcc_assert (size);
438 6233 : return size;
439 : }
440 :
441 :
442 : #undef CLASS_DATA_FIELD
443 : #undef CLASS_VPTR_FIELD
444 : #undef CLASS_LEN_FIELD
445 : #undef VTABLE_HASH_FIELD
446 : #undef VTABLE_SIZE_FIELD
447 : #undef VTABLE_EXTENDS_FIELD
448 : #undef VTABLE_DEF_INIT_FIELD
449 : #undef VTABLE_COPY_FIELD
450 : #undef VTABLE_FINAL_FIELD
451 :
452 :
453 : /* IF ts is null (default), search for the last _class ref in the chain
454 : of references of the expression and cut the chain there. Although
455 : this routine is similar to class.cc:gfc_add_component_ref (), there
456 : is a significant difference: gfc_add_component_ref () concentrates
457 : on an array ref that is the last ref in the chain and is oblivious
458 : to the kind of refs following.
459 : ELSE IF ts is non-null the cut is at the class entity or component
460 : that is followed by an array reference, which is not an element.
461 : These calls come from trans-array.cc:build_class_array_ref, which
462 : handles scalarized class array references.*/
463 :
464 : gfc_expr *
465 9865 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
466 : gfc_typespec **ts)
467 : {
468 9865 : gfc_expr *base_expr;
469 9865 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
470 :
471 : /* Find the last class reference. */
472 9865 : class_ref = NULL;
473 9865 : array_ref = NULL;
474 :
475 9865 : if (ts)
476 : {
477 477 : if (e->symtree
478 452 : && e->symtree->n.sym->ts.type == BT_CLASS)
479 452 : *ts = &e->symtree->n.sym->ts;
480 : else
481 25 : *ts = NULL;
482 : }
483 :
484 24799 : for (ref = e->ref; ref; ref = ref->next)
485 : {
486 15396 : if (ts)
487 : {
488 1128 : if (ref->type == REF_COMPONENT
489 538 : && ref->u.c.component->ts.type == BT_CLASS
490 0 : && ref->next && ref->next->type == REF_COMPONENT
491 0 : && !strcmp (ref->next->u.c.component->name, "_data")
492 0 : && ref->next->next
493 0 : && ref->next->next->type == REF_ARRAY
494 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
495 : {
496 0 : *ts = &ref->u.c.component->ts;
497 0 : class_ref = ref;
498 0 : break;
499 : }
500 :
501 1128 : if (ref->next == NULL)
502 : break;
503 : }
504 : else
505 : {
506 14268 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
507 14268 : array_ref = ref;
508 :
509 14268 : if (ref->type == REF_COMPONENT
510 8589 : && ref->u.c.component->ts.type == BT_CLASS)
511 : {
512 : /* Component to the right of a part reference with nonzero
513 : rank must not have the ALLOCATABLE attribute. If attempts
514 : are made to reference such a component reference, an error
515 : results followed by an ICE. */
516 1690 : if (array_ref
517 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
518 : return NULL;
519 : class_ref = ref;
520 : }
521 : }
522 : }
523 :
524 9855 : if (ts && *ts == NULL)
525 : return NULL;
526 :
527 : /* Remove and store all subsequent references after the
528 : CLASS reference. */
529 9830 : if (class_ref)
530 : {
531 1488 : tail = class_ref->next;
532 1488 : class_ref->next = NULL;
533 : }
534 8342 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
535 : {
536 8342 : tail = e->ref;
537 8342 : e->ref = NULL;
538 : }
539 :
540 9830 : if (is_mold)
541 61 : base_expr = gfc_expr_to_initialize (e);
542 : else
543 9769 : base_expr = gfc_copy_expr (e);
544 :
545 : /* Restore the original tail expression. */
546 9830 : if (class_ref)
547 : {
548 1488 : gfc_free_ref_list (class_ref->next);
549 1488 : class_ref->next = tail;
550 : }
551 8342 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
552 : {
553 8342 : gfc_free_ref_list (e->ref);
554 8342 : e->ref = tail;
555 : }
556 : return base_expr;
557 : }
558 :
559 : /* Reset the vptr to the declared type, e.g. after deallocation.
560 : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
561 : one with e or class_type. At least one of the two has to be set. The
562 : generated assignment code is added at the end of BLOCK. */
563 :
564 : void
565 11578 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
566 : gfc_symbol *class_type)
567 : {
568 11578 : tree vptr = NULL_TREE;
569 :
570 11578 : if (class_container != NULL_TREE)
571 6890 : vptr = gfc_get_vptr_from_expr (class_container);
572 :
573 6890 : if (vptr == NULL_TREE)
574 : {
575 4695 : gfc_se se;
576 4695 : gcc_assert (e);
577 :
578 : /* Evaluate the expression and obtain the vptr from it. */
579 4695 : gfc_init_se (&se, NULL);
580 4695 : if (e->rank)
581 2333 : gfc_conv_expr_descriptor (&se, e);
582 : else
583 2362 : gfc_conv_expr (&se, e);
584 4695 : gfc_add_block_to_block (block, &se.pre);
585 :
586 4695 : vptr = gfc_get_vptr_from_expr (se.expr);
587 : }
588 :
589 : /* If a vptr is not found, we can do nothing more. */
590 4695 : if (vptr == NULL_TREE)
591 : return;
592 :
593 11568 : if (UNLIMITED_POLY (e)
594 10496 : || UNLIMITED_POLY (class_type)
595 : /* When the class_type's source is not a symbol (e.g. a component's ts),
596 : then look at the _data-components type. */
597 1583 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
598 1583 : && class_type->components && class_type->components->ts.u.derived
599 1577 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
600 1252 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
601 : else
602 : {
603 10316 : gfc_symbol *vtab, *type = nullptr;
604 10316 : tree vtable;
605 :
606 10316 : if (e)
607 8913 : type = e->ts.u.derived;
608 1403 : else if (class_type)
609 : {
610 1403 : if (class_type->ts.type == BT_CLASS)
611 0 : type = CLASS_DATA (class_type)->ts.u.derived;
612 : else
613 : type = class_type;
614 : }
615 8913 : gcc_assert (type);
616 : /* Return the vptr to the address of the declared type. */
617 10316 : vtab = gfc_find_derived_vtab (type);
618 10316 : vtable = vtab->backend_decl;
619 10316 : if (vtable == NULL_TREE)
620 100 : vtable = gfc_get_symbol_decl (vtab);
621 10316 : vtable = gfc_build_addr_expr (NULL, vtable);
622 10316 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
623 10316 : gfc_add_modify (block, vptr, vtable);
624 : }
625 : }
626 :
627 : /* Set the vptr of a class in to from the type given in from. If from is NULL,
628 : then reset the vptr to the default or to. */
629 :
630 : void
631 234 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
632 : {
633 234 : tree tmp, vptr_ref;
634 234 : gfc_symbol *type;
635 :
636 234 : vptr_ref = gfc_get_vptr_from_expr (to);
637 276 : if (POINTER_TYPE_P (TREE_TYPE (from))
638 234 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
639 : {
640 44 : gfc_add_modify (block, vptr_ref,
641 22 : fold_convert (TREE_TYPE (vptr_ref),
642 : gfc_get_vptr_from_expr (from)));
643 256 : return;
644 : }
645 212 : tmp = gfc_get_vptr_from_expr (from);
646 212 : if (tmp)
647 : {
648 170 : gfc_add_modify (block, vptr_ref,
649 170 : fold_convert (TREE_TYPE (vptr_ref), tmp));
650 170 : return;
651 : }
652 42 : if (VAR_P (from)
653 42 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
654 : {
655 42 : gfc_add_modify (block, vptr_ref,
656 42 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
657 42 : return;
658 : }
659 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
660 0 : && GFC_CLASS_TYPE_P (
661 : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
662 : {
663 0 : gfc_add_modify (block, vptr_ref,
664 0 : fold_convert (TREE_TYPE (vptr_ref),
665 : gfc_get_vptr_from_expr (TREE_OPERAND (
666 : TREE_OPERAND (from, 0), 0))));
667 0 : return;
668 : }
669 :
670 : /* If nothing of the above matches, set the vtype according to the type. */
671 0 : tmp = TREE_TYPE (from);
672 0 : if (POINTER_TYPE_P (tmp))
673 0 : tmp = TREE_TYPE (tmp);
674 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
675 : &type);
676 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
677 0 : gcc_assert (tmp);
678 0 : gfc_add_modify (block, vptr_ref,
679 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
680 : }
681 :
682 : /* Reset the len for unlimited polymorphic objects. */
683 :
684 : void
685 657 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
686 : {
687 657 : gfc_expr *e;
688 657 : gfc_se se_len;
689 657 : e = gfc_find_and_cut_at_last_class_ref (expr);
690 657 : if (e == NULL)
691 : return;
692 657 : gfc_add_len_component (e);
693 657 : gfc_init_se (&se_len, NULL);
694 657 : gfc_conv_expr (&se_len, e);
695 657 : gfc_add_modify (block, se_len.expr,
696 657 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
697 657 : gfc_free_expr (e);
698 : }
699 :
700 :
701 : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
702 : reference is found. Note that it is up to the caller to avoid using this
703 : for expressions other than variables. */
704 :
705 : tree
706 1559 : gfc_get_class_from_gfc_expr (gfc_expr *e)
707 : {
708 1559 : gfc_expr *class_expr;
709 1559 : gfc_se cse;
710 1559 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
711 1559 : if (class_expr == NULL)
712 : return NULL_TREE;
713 1559 : gfc_init_se (&cse, NULL);
714 1559 : gfc_conv_expr (&cse, class_expr);
715 1559 : gfc_free_expr (class_expr);
716 1559 : return cse.expr;
717 : }
718 :
719 :
720 : /* Obtain the last class reference in an expression.
721 : Return NULL_TREE if no class reference is found. */
722 :
723 : tree
724 109771 : gfc_get_class_from_expr (tree expr)
725 : {
726 109771 : tree tmp;
727 109771 : tree type;
728 109771 : bool array_descr_found = false;
729 109771 : bool comp_after_descr_found = false;
730 :
731 282749 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
732 : {
733 282749 : if (CONSTANT_CLASS_P (tmp))
734 : return NULL_TREE;
735 :
736 282712 : type = TREE_TYPE (tmp);
737 327708 : while (type)
738 : {
739 319860 : if (GFC_CLASS_TYPE_P (type))
740 : return tmp;
741 299360 : if (GFC_DESCRIPTOR_TYPE_P (type))
742 35815 : array_descr_found = true;
743 299360 : if (type != TYPE_CANONICAL (type))
744 44996 : type = TYPE_CANONICAL (type);
745 : else
746 : type = NULL_TREE;
747 : }
748 262212 : 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 172978 : if (array_descr_found)
758 : {
759 7641 : if (comp_after_descr_found)
760 : {
761 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
762 : return NULL_TREE;
763 : }
764 7629 : else if (TREE_CODE (tmp) == COMPONENT_REF)
765 7641 : comp_after_descr_found = true;
766 : }
767 : }
768 :
769 89234 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
770 59891 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
771 :
772 89234 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
773 20 : return tmp;
774 :
775 : return NULL_TREE;
776 : }
777 :
778 :
779 : /* Obtain the vptr of the last class reference in an expression.
780 : Return NULL_TREE if no class reference is found. */
781 :
782 : tree
783 12245 : gfc_get_vptr_from_expr (tree expr)
784 : {
785 12245 : tree tmp;
786 :
787 12245 : tmp = gfc_get_class_from_expr (expr);
788 :
789 12245 : if (tmp != NULL_TREE)
790 12174 : return gfc_class_vptr_get (tmp);
791 :
792 : return NULL_TREE;
793 : }
794 :
795 : static void
796 2305 : copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
797 : {
798 2305 : tree src_type = TREE_TYPE (src);
799 2305 : if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
800 : {
801 135 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
802 270 : for (int c = 0; c < lang_specific->corank; ++c)
803 : {
804 135 : int dim = lang_specific->rank + c;
805 135 : tree codim = gfc_rank_cst[dim];
806 :
807 135 : if (lang_specific->lbound[dim])
808 54 : gfc_conv_descriptor_lbound_set (block, dest, codim,
809 : lang_specific->lbound[dim]);
810 : else
811 81 : gfc_conv_descriptor_lbound_set (
812 : block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
813 135 : if (dim + 1 < lang_specific->corank)
814 : {
815 0 : if (lang_specific->ubound[dim])
816 0 : gfc_conv_descriptor_ubound_set (block, dest, codim,
817 : lang_specific->ubound[dim]);
818 : else
819 0 : gfc_conv_descriptor_ubound_set (
820 : block, dest, codim,
821 : gfc_conv_descriptor_ubound_get (src, codim));
822 : }
823 : }
824 : }
825 2305 : }
826 :
827 : void
828 1971 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
829 : bool lhs_type)
830 : {
831 1971 : tree lhs_dim, rhs_dim, type;
832 :
833 1971 : gfc_conv_descriptor_data_set (block, lhs_desc,
834 : gfc_conv_descriptor_data_get (rhs_desc));
835 1971 : gfc_conv_descriptor_offset_set (block, lhs_desc,
836 : gfc_conv_descriptor_offset_get (rhs_desc));
837 :
838 1971 : gfc_conv_descriptor_dtype_set (block, lhs_desc,
839 : gfc_conv_descriptor_dtype_get (rhs_desc));
840 1971 : gfc_conv_descriptor_span_set (block, lhs_desc,
841 : gfc_conv_descriptor_span_get (rhs_desc));
842 :
843 : /* Assign the dimension as range-ref. */
844 1971 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
845 1971 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
846 :
847 1971 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
848 1971 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
849 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
850 1971 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
851 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
852 1971 : gfc_add_modify (block, lhs_dim, rhs_dim);
853 :
854 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
855 1971 : copy_coarray_desc_part (block, lhs_desc, rhs_desc);
856 1971 : }
857 :
858 : /* Takes a derived type expression and returns the address of a temporary
859 : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
860 : used for the temporary class object.
861 : optional_alloc_ptr is false when the dummy is neither allocatable
862 : nor a pointer; that's only relevant for the optional handling.
863 : The optional argument 'derived_array' is used to preserve the parmse
864 : expression for deallocation of allocatable components. Assumed rank
865 : formal arguments made this necessary. */
866 : void
867 5313 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
868 : tree opt_vptr_src, bool optional,
869 : bool optional_alloc_ptr, const char *proc_name,
870 : tree *derived_array)
871 : {
872 5313 : tree cond_optional = NULL_TREE;
873 5313 : gfc_ss *ss;
874 5313 : tree ctree;
875 5313 : tree var;
876 5313 : tree tmp;
877 5313 : tree packed = NULL_TREE;
878 :
879 : /* The derived type needs to be converted to a temporary CLASS object. */
880 5313 : tmp = gfc_typenode_for_spec (&fsym->ts);
881 5313 : var = gfc_create_var (tmp, "class");
882 :
883 : /* Set the vptr. */
884 5313 : if (opt_vptr_src)
885 128 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
886 : else
887 5185 : gfc_reset_vptr (&parmse->pre, e, var);
888 :
889 : /* Now set the data field. */
890 5313 : ctree = gfc_class_data_get (var);
891 :
892 5313 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
893 : {
894 4 : tree token;
895 4 : tmp = gfc_get_tree_for_caf_expr (e);
896 4 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
897 2 : tmp = build_fold_indirect_ref (tmp);
898 4 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
899 4 : gfc_conv_descriptor_token_set (&parmse->pre, ctree, token);
900 : }
901 :
902 5313 : if (optional)
903 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
904 :
905 : /* Set the _len as early as possible. */
906 5313 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
907 5313 : && fsym->ts.u.derived->components->ts.u.derived->attr
908 5313 : .unlimited_polymorphic)
909 : {
910 : /* Take care about initializing the _len component correctly. */
911 386 : tree len_tree = gfc_class_len_get (var);
912 386 : if (UNLIMITED_POLY (e))
913 : {
914 12 : gfc_expr *len;
915 12 : gfc_se se;
916 :
917 12 : len = gfc_find_and_cut_at_last_class_ref (e);
918 12 : gfc_add_len_component (len);
919 12 : gfc_init_se (&se, NULL);
920 12 : gfc_conv_expr (&se, len);
921 12 : if (optional)
922 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
923 : cond_optional, se.expr,
924 0 : fold_convert (TREE_TYPE (se.expr),
925 : integer_zero_node));
926 : else
927 12 : tmp = se.expr;
928 12 : gfc_free_expr (len);
929 12 : }
930 : else
931 374 : tmp = integer_zero_node;
932 386 : gfc_add_modify (&parmse->pre, len_tree,
933 386 : fold_convert (TREE_TYPE (len_tree), tmp));
934 : }
935 :
936 5313 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
937 : {
938 : /* If there is a ready made pointer to a derived type, use it
939 : rather than evaluating the expression again. */
940 535 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
941 535 : gfc_add_modify (&parmse->pre, ctree, tmp);
942 : }
943 4778 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
944 : {
945 : /* For an array reference in an elemental procedure call we need
946 : to retain the ss to provide the scalarized array reference. */
947 445 : gfc_conv_expr_reference (parmse, e);
948 445 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
949 445 : if (optional)
950 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
951 : cond_optional, tmp,
952 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
953 445 : gfc_add_modify (&parmse->pre, ctree, tmp);
954 : }
955 : else
956 : {
957 4333 : ss = gfc_walk_expr (e);
958 4333 : if (ss == gfc_ss_terminator)
959 : {
960 3073 : parmse->ss = NULL;
961 3073 : gfc_conv_expr_reference (parmse, e);
962 :
963 : /* Scalar to an assumed-rank array. */
964 3073 : if (fsym->ts.u.derived->components->as)
965 : {
966 334 : tree type;
967 334 : type = get_scalar_to_descriptor_type (parmse->expr,
968 : gfc_expr_attr (e));
969 334 : gfc_conv_descriptor_dtype_set (&parmse->pre, ctree,
970 : gfc_get_dtype (type));
971 334 : copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
972 334 : if (optional)
973 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
974 96 : TREE_TYPE (parmse->expr),
975 : cond_optional, parmse->expr,
976 96 : fold_convert (TREE_TYPE (parmse->expr),
977 : null_pointer_node));
978 334 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
979 : }
980 : else
981 : {
982 2739 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
983 2739 : if (optional)
984 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
985 : cond_optional, tmp,
986 132 : fold_convert (TREE_TYPE (tmp),
987 : null_pointer_node));
988 2739 : gfc_add_modify (&parmse->pre, ctree, tmp);
989 : }
990 : }
991 : else
992 : {
993 1260 : stmtblock_t block;
994 1260 : gfc_init_block (&block);
995 1260 : gfc_ref *ref;
996 1260 : int dim;
997 1260 : tree lbshift = NULL_TREE;
998 :
999 : /* Array refs with sections indicate, that a for a formal argument
1000 : expecting contiguous repacking needs to be done. */
1001 2369 : for (ref = e->ref; ref; ref = ref->next)
1002 1259 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1003 : break;
1004 1260 : if (IS_CLASS_ARRAY (fsym)
1005 1152 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
1006 894 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
1007 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
1008 144 : fsym->attr.contiguous = 1;
1009 :
1010 : /* Detect any array references with vector subscripts. */
1011 2513 : for (ref = e->ref; ref; ref = ref->next)
1012 1259 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
1013 1217 : && ref->u.ar.type != AR_FULL)
1014 : {
1015 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
1016 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
1017 : break;
1018 150 : if (dim < ref->u.ar.dimen)
1019 : break;
1020 : }
1021 : /* Array references with vector subscripts and non-variable
1022 : expressions need be converted to a one-based descriptor. */
1023 1260 : if (ref || e->expr_type != EXPR_VARIABLE)
1024 49 : lbshift = gfc_index_one_node;
1025 :
1026 1260 : parmse->expr = var;
1027 1260 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
1028 : &lbshift, &packed);
1029 :
1030 1260 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
1031 : {
1032 1164 : *derived_array
1033 1164 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
1034 1164 : if (e->rank == -1)
1035 : {
1036 : /* Assumed-rank actual: parmse->expr physically holds only
1037 : dtype.rank dims; a full struct assign reads past the end.
1038 : Copy field-by-field with a runtime-sized dim[] memcpy.
1039 : PR fortran/60576. */
1040 78 : tree rank, dim_field, dim_size, copy_size, dst_ptr, src_ptr;
1041 :
1042 78 : gfc_conv_descriptor_data_set
1043 78 : (&block, *derived_array,
1044 : gfc_conv_descriptor_data_get (parmse->expr));
1045 78 : gfc_conv_descriptor_offset_set
1046 78 : (&block, *derived_array,
1047 : gfc_conv_descriptor_offset_get (parmse->expr));
1048 78 : tree dtype_val = gfc_conv_descriptor_dtype_get (parmse->expr);
1049 78 : gfc_conv_descriptor_dtype_set (&block, *derived_array,
1050 : dtype_val);
1051 78 : rank = gfc_conv_descriptor_rank_get (parmse->expr);
1052 78 : rank = fold_convert (size_type_node, rank);
1053 78 : dim_field = gfc_get_descriptor_dimension (parmse->expr);
1054 78 : dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dim_field)));
1055 78 : copy_size = fold_build2_loc (input_location, MULT_EXPR,
1056 : size_type_node, rank, dim_size);
1057 78 : dst_ptr = gfc_build_addr_expr
1058 78 : (pvoid_type_node, gfc_get_descriptor_dimension (*derived_array));
1059 78 : src_ptr = gfc_build_addr_expr (pvoid_type_node, dim_field);
1060 78 : gfc_add_expr_to_block (&block,
1061 : build_call_expr_loc (input_location,
1062 : builtin_decl_explicit (BUILT_IN_MEMCPY),
1063 : 3, dst_ptr, src_ptr, copy_size));
1064 : }
1065 : else
1066 1086 : gfc_add_modify (&block, *derived_array, parmse->expr);
1067 : }
1068 :
1069 1260 : if (optional)
1070 : {
1071 348 : tmp = gfc_finish_block (&block);
1072 :
1073 348 : gfc_init_block (&block);
1074 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
1075 348 : if (derived_array && *derived_array != NULL_TREE)
1076 348 : gfc_conv_descriptor_data_set (&block, *derived_array,
1077 : null_pointer_node);
1078 :
1079 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
1080 : gfc_finish_block (&block));
1081 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
1082 : }
1083 : else
1084 912 : gfc_add_block_to_block (&parmse->pre, &block);
1085 : }
1086 : }
1087 :
1088 : /* Pass the address of the class object. */
1089 5313 : if (packed)
1090 : parmse->expr = packed;
1091 : else
1092 5217 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1093 :
1094 5313 : if (optional && optional_alloc_ptr)
1095 84 : parmse->expr
1096 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1097 : cond_optional, parmse->expr,
1098 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1099 5313 : }
1100 :
1101 : /* Create a new class container, which is required as scalar coarrays
1102 : have an array descriptor while normal scalars haven't. Optionally,
1103 : NULL pointer checks are added if the argument is OPTIONAL. */
1104 :
1105 : static void
1106 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1107 : gfc_typespec class_ts, bool optional)
1108 : {
1109 48 : tree var, ctree, tmp;
1110 48 : stmtblock_t block;
1111 48 : gfc_ref *ref;
1112 48 : gfc_ref *class_ref;
1113 :
1114 48 : gfc_init_block (&block);
1115 :
1116 48 : class_ref = NULL;
1117 144 : for (ref = e->ref; ref; ref = ref->next)
1118 : {
1119 96 : if (ref->type == REF_COMPONENT
1120 48 : && ref->u.c.component->ts.type == BT_CLASS)
1121 96 : class_ref = ref;
1122 : }
1123 :
1124 48 : if (class_ref == NULL
1125 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1126 48 : tmp = e->symtree->n.sym->backend_decl;
1127 : else
1128 : {
1129 : /* Remove everything after the last class reference, convert the
1130 : expression and then recover its tailend once more. */
1131 0 : gfc_se tmpse;
1132 0 : ref = class_ref->next;
1133 0 : class_ref->next = NULL;
1134 0 : gfc_init_se (&tmpse, NULL);
1135 0 : gfc_conv_expr (&tmpse, e);
1136 0 : class_ref->next = ref;
1137 0 : tmp = tmpse.expr;
1138 : }
1139 :
1140 48 : var = gfc_typenode_for_spec (&class_ts);
1141 48 : var = gfc_create_var (var, "class");
1142 :
1143 48 : ctree = gfc_class_vptr_get (var);
1144 96 : gfc_add_modify (&block, ctree,
1145 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1146 :
1147 48 : ctree = gfc_class_data_get (var);
1148 48 : tmp = gfc_conv_descriptor_data_get (
1149 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1150 : ? tmp
1151 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1152 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1153 :
1154 : /* Pass the address of the class object. */
1155 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1156 :
1157 48 : if (optional)
1158 : {
1159 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1160 48 : tree tmp2;
1161 :
1162 48 : tmp = gfc_finish_block (&block);
1163 :
1164 48 : gfc_init_block (&block);
1165 48 : tmp2 = gfc_class_data_get (var);
1166 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1167 : null_pointer_node));
1168 48 : tmp2 = gfc_finish_block (&block);
1169 :
1170 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1171 : cond, tmp, tmp2);
1172 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1173 : }
1174 : else
1175 0 : gfc_add_block_to_block (&parmse->pre, &block);
1176 48 : }
1177 :
1178 :
1179 : /* Takes an intrinsic type expression and returns the address of a temporary
1180 : class object of the 'declared' type. */
1181 : void
1182 930 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1183 : gfc_typespec class_ts)
1184 : {
1185 930 : gfc_symbol *vtab;
1186 930 : gfc_ss *ss;
1187 930 : tree ctree;
1188 930 : tree var;
1189 930 : tree tmp;
1190 930 : int dim;
1191 930 : bool unlimited_poly;
1192 :
1193 1860 : unlimited_poly = class_ts.type == BT_CLASS
1194 930 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1195 930 : && class_ts.u.derived->components->ts.u.derived
1196 930 : ->attr.unlimited_polymorphic;
1197 :
1198 : /* The intrinsic type needs to be converted to a temporary
1199 : CLASS object. */
1200 930 : tmp = gfc_typenode_for_spec (&class_ts);
1201 930 : var = gfc_create_var (tmp, "class");
1202 :
1203 : /* Force a temporary for component or substring references. */
1204 930 : if (unlimited_poly
1205 930 : && class_ts.u.derived->components->attr.dimension
1206 671 : && !class_ts.u.derived->components->attr.allocatable
1207 671 : && !class_ts.u.derived->components->attr.class_pointer
1208 1601 : && is_subref_array (e))
1209 17 : parmse->force_tmp = 1;
1210 :
1211 : /* Set the vptr. */
1212 930 : ctree = gfc_class_vptr_get (var);
1213 :
1214 930 : vtab = gfc_find_vtab (&e->ts);
1215 930 : gcc_assert (vtab);
1216 930 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1217 930 : gfc_add_modify (&parmse->pre, ctree,
1218 930 : fold_convert (TREE_TYPE (ctree), tmp));
1219 :
1220 : /* Now set the data field. */
1221 930 : ctree = gfc_class_data_get (var);
1222 930 : if (parmse->ss && parmse->ss->info->useflags)
1223 : {
1224 : /* For an array reference in an elemental procedure call we need
1225 : to retain the ss to provide the scalarized array reference. */
1226 36 : gfc_conv_expr_reference (parmse, e);
1227 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1228 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1229 : }
1230 : else
1231 : {
1232 894 : ss = gfc_walk_expr (e);
1233 894 : if (ss == gfc_ss_terminator)
1234 : {
1235 247 : parmse->ss = NULL;
1236 247 : gfc_conv_expr_reference (parmse, e);
1237 247 : if (class_ts.u.derived->components->as
1238 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1239 : {
1240 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1241 : gfc_expr_attr (e));
1242 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1243 24 : TREE_TYPE (ctree), tmp);
1244 : }
1245 : else
1246 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1247 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1248 : }
1249 : else
1250 : {
1251 647 : parmse->ss = ss;
1252 647 : gfc_conv_expr_descriptor (parmse, e);
1253 :
1254 : /* Array references with vector subscripts and non-variable expressions
1255 : need be converted to a one-based descriptor. */
1256 647 : if (e->expr_type != EXPR_VARIABLE)
1257 : {
1258 416 : for (dim = 0; dim < e->rank; ++dim)
1259 217 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1260 : dim, gfc_index_one_node);
1261 : }
1262 :
1263 647 : if (class_ts.u.derived->components->as->rank != e->rank)
1264 : {
1265 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1266 49 : TREE_TYPE (ctree), parmse->expr);
1267 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1268 : }
1269 : else
1270 598 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1271 : }
1272 : }
1273 :
1274 930 : gcc_assert (class_ts.type == BT_CLASS);
1275 930 : if (unlimited_poly)
1276 : {
1277 930 : ctree = gfc_class_len_get (var);
1278 : /* When the actual arg is a char array, then set the _len component of the
1279 : unlimited polymorphic entity to the length of the string. */
1280 930 : if (e->ts.type == BT_CHARACTER)
1281 : {
1282 : /* Start with parmse->string_length because this seems to be set to a
1283 : correct value more often. */
1284 175 : if (parmse->string_length)
1285 : tmp = parmse->string_length;
1286 : /* When the string_length is not yet set, then try the backend_decl of
1287 : the cl. */
1288 0 : else if (e->ts.u.cl->backend_decl)
1289 : tmp = e->ts.u.cl->backend_decl;
1290 : /* If both of the above approaches fail, then try to generate an
1291 : expression from the input, which is only feasible currently, when the
1292 : expression can be evaluated to a constant one. */
1293 : else
1294 : {
1295 : /* Try to simplify the expression. */
1296 0 : gfc_simplify_expr (e, 0);
1297 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1298 : {
1299 : /* Amazingly all data is present to compute the length of a
1300 : constant string, but the expression is not yet there. */
1301 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1302 : gfc_charlen_int_kind,
1303 : &e->where);
1304 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1305 0 : e->value.character.length);
1306 0 : gfc_conv_const_charlen (e->ts.u.cl);
1307 0 : e->ts.u.cl->resolved = 1;
1308 0 : tmp = e->ts.u.cl->backend_decl;
1309 : }
1310 : else
1311 : {
1312 0 : gfc_error ("Cannot compute the length of the char array "
1313 : "at %L.", &e->where);
1314 : }
1315 : }
1316 : }
1317 : else
1318 755 : tmp = integer_zero_node;
1319 :
1320 930 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1321 : }
1322 :
1323 : /* Pass the address of the class object. */
1324 930 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1325 930 : }
1326 :
1327 :
1328 : /* Takes a scalarized class array expression and returns the
1329 : address of a temporary scalar class object of the 'declared'
1330 : type.
1331 : OOP-TODO: This could be improved by adding code that branched on
1332 : the dynamic type being the same as the declared type. In this case
1333 : the original class expression can be passed directly.
1334 : optional_alloc_ptr is false when the dummy is neither allocatable
1335 : nor a pointer; that's relevant for the optional handling.
1336 : Set copyback to true if class container's _data and _vtab pointers
1337 : might get modified. */
1338 :
1339 : void
1340 3714 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1341 : bool elemental, bool copyback, bool optional,
1342 : bool optional_alloc_ptr)
1343 : {
1344 3714 : tree ctree;
1345 3714 : tree var;
1346 3714 : tree tmp;
1347 3714 : tree vptr;
1348 3714 : tree cond = NULL_TREE;
1349 3714 : tree slen = NULL_TREE;
1350 3714 : gfc_ref *ref;
1351 3714 : gfc_ref *class_ref;
1352 3714 : stmtblock_t block;
1353 3714 : bool full_array = false;
1354 :
1355 : /* If this is the data field of a class temporary, the class expression
1356 : can be obtained and returned directly. */
1357 3714 : if (e->expr_type != EXPR_VARIABLE
1358 180 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1359 36 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))
1360 3750 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse->expr, 0))))
1361 : {
1362 36 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1363 36 : if (!VAR_P (parmse->expr))
1364 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1365 36 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1366 174 : return;
1367 : }
1368 :
1369 3678 : gfc_init_block (&block);
1370 :
1371 3678 : class_ref = NULL;
1372 7429 : for (ref = e->ref; ref; ref = ref->next)
1373 : {
1374 7053 : if (ref->type == REF_COMPONENT
1375 3784 : && ref->u.c.component->ts.type == BT_CLASS)
1376 7053 : class_ref = ref;
1377 :
1378 7053 : if (ref->next == NULL)
1379 : break;
1380 : }
1381 :
1382 3678 : if ((ref == NULL || class_ref == ref)
1383 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1384 4148 : && (!class_ts.u.derived->components->as
1385 379 : || class_ts.u.derived->components->as->rank != -1))
1386 : return;
1387 :
1388 : /* Test for FULL_ARRAY. */
1389 3540 : if (e->rank == 0
1390 3896 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1391 494 : || (class_ts.u.derived->components->as
1392 366 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1393 411 : full_array = true;
1394 : else
1395 3129 : gfc_is_class_array_ref (e, &full_array);
1396 :
1397 : /* The derived type needs to be converted to a temporary
1398 : CLASS object. */
1399 3540 : tmp = gfc_typenode_for_spec (&class_ts);
1400 3540 : var = gfc_create_var (tmp, "class");
1401 :
1402 : /* Set the data. */
1403 3540 : ctree = gfc_class_data_get (var);
1404 3540 : if (class_ts.u.derived->components->as
1405 3256 : && e->rank != class_ts.u.derived->components->as->rank)
1406 : {
1407 977 : if (e->rank == 0)
1408 : {
1409 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1410 : gfc_expr_attr (e));
1411 356 : gfc_conv_descriptor_dtype_set (&block, ctree,
1412 : gfc_get_dtype (type));
1413 :
1414 356 : tmp = gfc_class_data_get (parmse->expr);
1415 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1416 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1417 :
1418 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1419 : }
1420 : else
1421 621 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1422 : }
1423 : else
1424 : {
1425 2563 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1426 1499 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1427 1499 : TREE_TYPE (ctree), parmse->expr);
1428 2563 : gfc_add_modify (&block, ctree, parmse->expr);
1429 : }
1430 :
1431 : /* Return the data component, except in the case of scalarized array
1432 : references, where nullification of the cannot occur and so there
1433 : is no need. */
1434 3540 : if (!elemental && full_array && copyback)
1435 : {
1436 1188 : if (class_ts.u.derived->components->as
1437 1188 : && e->rank != class_ts.u.derived->components->as->rank)
1438 : {
1439 270 : if (e->rank == 0)
1440 : {
1441 102 : tmp = gfc_class_data_get (parmse->expr);
1442 204 : gfc_add_modify (&parmse->post, tmp,
1443 102 : fold_convert (TREE_TYPE (tmp),
1444 : gfc_conv_descriptor_data_get (ctree)));
1445 : }
1446 : else
1447 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1448 : true);
1449 : }
1450 : else
1451 918 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1452 : }
1453 :
1454 : /* Set the vptr. */
1455 3540 : ctree = gfc_class_vptr_get (var);
1456 :
1457 : /* The vptr is the second field of the actual argument.
1458 : First we have to find the corresponding class reference. */
1459 :
1460 3540 : tmp = NULL_TREE;
1461 3540 : if (gfc_is_class_array_function (e)
1462 3540 : && parmse->class_vptr != NULL_TREE)
1463 : tmp = parmse->class_vptr;
1464 3522 : else if (class_ref == NULL
1465 3023 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1466 : {
1467 3023 : tmp = e->symtree->n.sym->backend_decl;
1468 :
1469 3023 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1470 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1471 :
1472 3023 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1473 397 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1474 :
1475 3023 : slen = build_zero_cst (size_type_node);
1476 : }
1477 499 : else if (parmse->class_container != NULL_TREE)
1478 : /* Don't redundantly evaluate the expression if the required information
1479 : is already available. */
1480 : tmp = parmse->class_container;
1481 : else
1482 : {
1483 : /* Remove everything after the last class reference, convert the
1484 : expression and then recover its tailend once more. */
1485 18 : gfc_se tmpse;
1486 18 : ref = class_ref->next;
1487 18 : class_ref->next = NULL;
1488 18 : gfc_init_se (&tmpse, NULL);
1489 18 : gfc_conv_expr (&tmpse, e);
1490 18 : class_ref->next = ref;
1491 18 : tmp = tmpse.expr;
1492 18 : slen = tmpse.string_length;
1493 : }
1494 :
1495 3540 : gcc_assert (tmp != NULL_TREE);
1496 :
1497 : /* Dereference if needs be. */
1498 3540 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1499 345 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1500 :
1501 3540 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1502 3522 : vptr = gfc_class_vptr_get (tmp);
1503 : else
1504 : vptr = tmp;
1505 :
1506 3540 : gfc_add_modify (&block, ctree,
1507 3540 : fold_convert (TREE_TYPE (ctree), vptr));
1508 :
1509 : /* Return the vptr component, except in the case of scalarized array
1510 : references, where the dynamic type cannot change. */
1511 3540 : if (!elemental && full_array && copyback)
1512 1188 : gfc_add_modify (&parmse->post, vptr,
1513 1188 : fold_convert (TREE_TYPE (vptr), ctree));
1514 :
1515 : /* For unlimited polymorphic objects also set the _len component. */
1516 3540 : if (class_ts.type == BT_CLASS
1517 3540 : && class_ts.u.derived->components
1518 3540 : && class_ts.u.derived->components->ts.u
1519 3540 : .derived->attr.unlimited_polymorphic)
1520 : {
1521 1206 : ctree = gfc_class_len_get (var);
1522 1206 : if (UNLIMITED_POLY (e))
1523 1003 : tmp = gfc_class_len_get (tmp);
1524 203 : else if (e->ts.type == BT_CHARACTER)
1525 : {
1526 0 : gcc_assert (slen != NULL_TREE);
1527 : tmp = slen;
1528 : }
1529 : else
1530 203 : tmp = build_zero_cst (size_type_node);
1531 1206 : gfc_add_modify (&parmse->pre, ctree,
1532 1206 : fold_convert (TREE_TYPE (ctree), tmp));
1533 :
1534 : /* Return the len component, except in the case of scalarized array
1535 : references, where the dynamic type cannot change. */
1536 1206 : if (!elemental && full_array && copyback
1537 471 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1538 458 : gfc_add_modify (&parmse->post, tmp,
1539 458 : fold_convert (TREE_TYPE (tmp), ctree));
1540 : }
1541 :
1542 3540 : if (optional)
1543 : {
1544 510 : tree tmp2;
1545 :
1546 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1547 : /* parmse->pre may contain some preparatory instructions for the
1548 : temporary array descriptor. Those may only be executed when the
1549 : optional argument is set, therefore add parmse->pre's instructions
1550 : to block, which is later guarded by an if (optional_arg_given). */
1551 510 : gfc_add_block_to_block (&parmse->pre, &block);
1552 510 : block.head = parmse->pre.head;
1553 510 : parmse->pre.head = NULL_TREE;
1554 510 : tmp = gfc_finish_block (&block);
1555 :
1556 510 : if (optional_alloc_ptr)
1557 102 : tmp2 = build_empty_stmt (input_location);
1558 : else
1559 : {
1560 408 : gfc_init_block (&block);
1561 408 : gfc_conv_descriptor_data_set (&block, gfc_class_data_get (var),
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 3030 : gfc_add_block_to_block (&parmse->pre, &block);
1581 :
1582 : /* Pass the address of the class object. */
1583 3540 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1584 :
1585 3540 : 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 768 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1599 : bool unlimited)
1600 : {
1601 768 : tree data, size, tmp, ctmp, offset, ptr;
1602 :
1603 768 : data = data_comp != NULL_TREE ? data_comp :
1604 0 : gfc_class_data_get (class_decl);
1605 768 : size = gfc_class_vtab_size_get (class_decl);
1606 :
1607 768 : if (unlimited)
1608 : {
1609 244 : tmp = fold_convert (gfc_array_index_type,
1610 : gfc_class_len_get (class_decl));
1611 244 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1612 : gfc_array_index_type, size, tmp);
1613 244 : tmp = fold_build2_loc (input_location, GT_EXPR,
1614 : logical_type_node, tmp,
1615 244 : build_zero_cst (TREE_TYPE (tmp)));
1616 244 : size = fold_build3_loc (input_location, COND_EXPR,
1617 : gfc_array_index_type, tmp, ctmp, size);
1618 : }
1619 :
1620 768 : offset = fold_build2_loc (input_location, MULT_EXPR,
1621 : gfc_array_index_type,
1622 : index, size);
1623 :
1624 768 : data = gfc_conv_descriptor_data_get (data);
1625 768 : ptr = fold_convert (pvoid_type_node, data);
1626 768 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1627 768 : 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 816 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1638 : {
1639 816 : tree fcn;
1640 816 : tree fcn_type;
1641 816 : tree from_data;
1642 816 : tree from_len;
1643 816 : tree to_data;
1644 816 : tree to_len;
1645 816 : tree to_ref;
1646 816 : tree from_ref;
1647 816 : vec<tree, va_gc> *args;
1648 816 : tree tmp;
1649 816 : tree stdcopy;
1650 816 : tree extcopy;
1651 816 : tree index;
1652 816 : bool is_from_desc = false, is_to_class = false;
1653 :
1654 816 : args = NULL;
1655 : /* To prevent warnings on uninitialized variables. */
1656 816 : from_len = to_len = NULL_TREE;
1657 :
1658 816 : if (from != NULL_TREE)
1659 816 : fcn = gfc_class_vtab_copy_get (from);
1660 : else
1661 0 : fcn = gfc_class_vtab_copy_get (to);
1662 :
1663 816 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1664 :
1665 816 : if (from != NULL_TREE)
1666 : {
1667 816 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1668 816 : 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 1632 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1678 816 : ? build_fold_indirect_ref (from) : from;
1679 1632 : from_data =
1680 816 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1681 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1682 816 : ? gfc_class_data_get (from) : from;
1683 816 : 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 816 : if (unlimited)
1690 : {
1691 182 : if (from != NULL_TREE && unlimited)
1692 182 : from_len = gfc_class_len_or_zero_get (from);
1693 : else
1694 0 : from_len = build_zero_cst (size_type_node);
1695 : }
1696 :
1697 816 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1698 : {
1699 816 : is_to_class = true;
1700 816 : to_data = gfc_class_data_get (to);
1701 816 : if (unlimited)
1702 182 : 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 816 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1709 : {
1710 384 : stmtblock_t loopbody;
1711 384 : stmtblock_t body;
1712 384 : stmtblock_t ifbody;
1713 384 : gfc_loopinfo loop;
1714 :
1715 384 : gfc_init_block (&body);
1716 384 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1717 : gfc_array_index_type, nelems,
1718 : gfc_index_one_node);
1719 384 : nelems = gfc_evaluate_now (tmp, &body);
1720 384 : index = gfc_create_var (gfc_array_index_type, "S");
1721 :
1722 384 : if (is_from_desc)
1723 : {
1724 384 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1725 : unlimited);
1726 384 : vec_safe_push (args, from_ref);
1727 : }
1728 : else
1729 0 : vec_safe_push (args, from_data);
1730 :
1731 384 : if (is_to_class)
1732 384 : 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 384 : vec_safe_push (args, to_ref);
1741 :
1742 : /* Add bounds check. */
1743 384 : 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 384 : tmp = build_call_vec (fcn_type, fcn, args);
1773 :
1774 : /* Build the body of the loop. */
1775 384 : gfc_init_block (&loopbody);
1776 384 : gfc_add_expr_to_block (&loopbody, tmp);
1777 :
1778 : /* Build the loop and return. */
1779 384 : gfc_init_loopinfo (&loop);
1780 384 : loop.dimen = 1;
1781 384 : loop.from[0] = gfc_index_zero_node;
1782 384 : loop.loopvar[0] = index;
1783 384 : loop.to[0] = nelems;
1784 384 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1785 384 : gfc_init_block (&ifbody);
1786 384 : gfc_add_block_to_block (&ifbody, &loop.pre);
1787 384 : stdcopy = gfc_finish_block (&ifbody);
1788 : /* In initialization mode from_len is a constant zero. */
1789 384 : if (unlimited && !integer_zerop (from_len))
1790 : {
1791 122 : vec_safe_push (args, from_len);
1792 122 : vec_safe_push (args, to_len);
1793 122 : tmp = build_call_vec (fcn_type, fcn, args);
1794 : /* Build the body of the loop. */
1795 122 : gfc_init_block (&loopbody);
1796 122 : gfc_add_expr_to_block (&loopbody, tmp);
1797 :
1798 : /* Build the loop and return. */
1799 122 : gfc_init_loopinfo (&loop);
1800 122 : loop.dimen = 1;
1801 122 : loop.from[0] = gfc_index_zero_node;
1802 122 : loop.loopvar[0] = index;
1803 122 : loop.to[0] = nelems;
1804 122 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1805 122 : gfc_init_block (&ifbody);
1806 122 : gfc_add_block_to_block (&ifbody, &loop.pre);
1807 122 : extcopy = gfc_finish_block (&ifbody);
1808 :
1809 122 : tmp = fold_build2_loc (input_location, GT_EXPR,
1810 : logical_type_node, from_len,
1811 122 : build_zero_cst (TREE_TYPE (from_len)));
1812 122 : tmp = fold_build3_loc (input_location, COND_EXPR,
1813 : void_type_node, tmp, extcopy, stdcopy);
1814 122 : gfc_add_expr_to_block (&body, tmp);
1815 122 : 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 384 : gfc_cleanup_loop (&loop);
1823 : }
1824 : else
1825 : {
1826 432 : gcc_assert (!is_from_desc);
1827 432 : vec_safe_push (args, from_data);
1828 432 : vec_safe_push (args, to_data);
1829 432 : stdcopy = build_call_vec (fcn_type, fcn, args);
1830 :
1831 : /* In initialization mode from_len is a constant zero. */
1832 432 : 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 816 : 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 816 : 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 491 : gfc_trans_class_init_assign (gfc_code *code)
1913 : {
1914 491 : stmtblock_t block;
1915 491 : tree tmp;
1916 491 : bool cmp_flag = true;
1917 491 : gfc_se dst,src,memsz;
1918 491 : gfc_expr *lhs, *rhs, *sz;
1919 491 : gfc_component *cmp;
1920 491 : gfc_symbol *sym;
1921 491 : gfc_ref *ref;
1922 :
1923 491 : gfc_start_block (&block);
1924 :
1925 491 : lhs = gfc_copy_expr (code->expr1);
1926 :
1927 491 : rhs = gfc_copy_expr (code->expr1);
1928 491 : 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 491 : gfc_get_derived_type (rhs->ts.u.derived);
1934 491 : gfc_add_def_init_component (rhs);
1935 : /* The _def_init is always scalar. */
1936 491 : 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 491 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1943 : : NULL;
1944 491 : if (code->op != EXEC_ALLOCATE
1945 430 : && sym && sym->attr.dummy
1946 430 : && sym->attr.intent == INTENT_OUT)
1947 : {
1948 430 : ref = rhs->ref;
1949 860 : while (ref && ref->next)
1950 : ref = ref->next;
1951 430 : cmp = ref->u.c.component->ts.u.derived->components;
1952 665 : for (; cmp; cmp = cmp->next)
1953 : {
1954 458 : if (cmp->initializer)
1955 : break;
1956 235 : else if (!cmp->next)
1957 170 : cmp_flag = false;
1958 : }
1959 : }
1960 :
1961 491 : if (code->expr1->ts.type == BT_CLASS
1962 468 : && 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 385 : else if (cmp_flag)
1972 : {
1973 : /* Scalar initialization needs the _data component. */
1974 228 : gfc_add_data_component (lhs);
1975 228 : sz = gfc_copy_expr (code->expr1);
1976 228 : gfc_add_vptr_component (sz);
1977 228 : gfc_add_size_component (sz);
1978 :
1979 228 : gfc_init_se (&dst, NULL);
1980 228 : gfc_init_se (&src, NULL);
1981 228 : gfc_init_se (&memsz, NULL);
1982 228 : gfc_conv_expr (&dst, lhs);
1983 228 : gfc_conv_expr (&src, rhs);
1984 228 : gfc_conv_expr (&memsz, sz);
1985 228 : gfc_add_block_to_block (&block, &src.pre);
1986 228 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1987 :
1988 228 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1989 :
1990 228 : 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 157 : tmp = build_empty_stmt (input_location);
2003 :
2004 491 : if (code->expr1->symtree->n.sym->attr.dummy
2005 440 : && (code->expr1->symtree->n.sym->attr.optional
2006 434 : || 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 491 : gfc_add_expr_to_block (&block, tmp);
2015 491 : gfc_free_expr (lhs);
2016 491 : gfc_free_expr (rhs);
2017 :
2018 491 : 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 800 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
2028 : {
2029 800 : tree fcn;
2030 800 : tree rse_expr;
2031 800 : tree class_data;
2032 800 : tree tmp;
2033 800 : tree zero;
2034 800 : tree cond;
2035 800 : tree final_cond;
2036 800 : stmtblock_t inner_block;
2037 800 : bool is_descriptor;
2038 800 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
2039 800 : 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 800 : tmp = TREE_TYPE (lse->expr);
2045 800 : 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 752 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
2051 1079 : && 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 521 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
2058 521 : && 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 466 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
2063 466 : || not_call_expr)
2064 : {
2065 466 : tmp = gfc_get_class_from_expr (rse->expr);
2066 466 : 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 12954 : realloc_lhs_warning (bt type, bool array, locus *where)
2132 : {
2133 12954 : 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 12929 : 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 12954 : }
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 1293534 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2151 : {
2152 1293534 : dest->ss = src->ss;
2153 1293534 : dest->loop = src->loop;
2154 0 : }
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 4694443 : gfc_init_se (gfc_se * se, gfc_se * parent)
2165 : {
2166 4694443 : memset (se, 0, sizeof (gfc_se));
2167 4694443 : gfc_init_block (&se->pre);
2168 4694443 : gfc_init_block (&se->finalblock);
2169 4694443 : gfc_init_block (&se->post);
2170 :
2171 4694443 : se->parent = parent;
2172 :
2173 4694443 : if (parent)
2174 1293534 : gfc_copy_se_loopvars (se, parent);
2175 4694443 : }
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 245131 : gfc_advance_se_ss_chain (gfc_se * se)
2184 : {
2185 245131 : gfc_se *p;
2186 :
2187 245131 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2188 :
2189 : p = se;
2190 : /* Walk down the parent chain. */
2191 643356 : while (p != NULL)
2192 : {
2193 : /* Simple consistency check. */
2194 398225 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2195 : || p->parent->ss->nested_ss == p->ss);
2196 :
2197 398225 : p->ss = p->ss->next;
2198 :
2199 398225 : p = p->parent;
2200 : }
2201 245131 : }
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 11628 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2227 : {
2228 11628 : tree decl, orig_decl, cond;
2229 :
2230 11628 : gcc_assert (sym->attr.dummy);
2231 11628 : 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 11628 : 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 10576 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2262 : {
2263 828 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2264 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2265 828 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2266 : }
2267 :
2268 10576 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2269 10576 : 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 10576 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2281 7529 : && !sym->attr.allocatable
2282 6317 : && ((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 4228 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2287 6 : || sym->ts.type == BT_CLASS))
2288 : {
2289 4222 : tree tmp;
2290 :
2291 4222 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2292 1495 : || sym->as->type == AS_ASSUMED_RANK
2293 1407 : || sym->attr.codimension))
2294 3348 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2295 : {
2296 1045 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2297 1045 : if (sym->ts.type == BT_CLASS)
2298 171 : tmp = gfc_class_data_get (tmp);
2299 1045 : tmp = gfc_conv_array_data (tmp);
2300 : }
2301 3177 : else if (sym->ts.type == BT_CLASS)
2302 36 : tmp = gfc_class_data_get (decl);
2303 : else
2304 : tmp = NULL_TREE;
2305 :
2306 1081 : if (tmp != NULL_TREE)
2307 : {
2308 1081 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2309 1081 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2310 1081 : 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 20140 : gfc_get_expr_charlen (gfc_expr *e)
2382 : {
2383 20140 : gfc_ref *r;
2384 20140 : tree length;
2385 20140 : tree previous = NULL_TREE;
2386 20140 : gfc_se se;
2387 :
2388 20140 : gcc_assert (e->expr_type == EXPR_VARIABLE
2389 : && e->ts.type == BT_CHARACTER);
2390 :
2391 20140 : length = NULL; /* To silence compiler warning. */
2392 :
2393 20140 : if (is_subref_array (e) && e->ts.u.cl->length)
2394 : {
2395 773 : gfc_se tmpse;
2396 773 : gfc_init_se (&tmpse, NULL);
2397 773 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2398 773 : e->ts.u.cl->backend_decl = tmpse.expr;
2399 773 : 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 19367 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2406 19067 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2407 :
2408 : /* Look through the reference chain for component references. */
2409 38877 : for (r = e->ref; r; r = r->next)
2410 : {
2411 19510 : previous = length;
2412 19510 : 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 19510 : break;
2442 : }
2443 : }
2444 :
2445 19367 : 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 2124 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2454 : {
2455 2124 : tree caf_decl;
2456 2124 : bool found = false;
2457 2124 : gfc_ref *ref;
2458 :
2459 2124 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2460 :
2461 : /* Not-implemented diagnostic. */
2462 2124 : 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 4509 : for (ref = expr->ref; ref; ref = ref->next)
2469 2385 : if (ref->type == REF_COMPONENT)
2470 : {
2471 225 : 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 2124 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2480 2124 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2481 : : expr->symtree->n.sym->backend_decl;
2482 :
2483 2124 : 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 2094 : 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 76 : for (ref = expr->ref; ref; ref = ref->next)
2521 76 : if (ref->type == REF_COMPONENT)
2522 : {
2523 76 : gfc_component *comp = ref->u.c.component;
2524 :
2525 76 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2526 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2527 76 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2528 76 : TREE_TYPE (comp->backend_decl), caf_decl,
2529 : comp->backend_decl, NULL_TREE);
2530 76 : 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 76 : if (comp->attr.codimension)
2540 : {
2541 : found = true;
2542 : break;
2543 : }
2544 : }
2545 76 : 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 1995 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2554 : tree se_expr, gfc_expr *expr)
2555 : {
2556 1995 : tree tmp;
2557 :
2558 1995 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2559 :
2560 : /* Coarray token. */
2561 1995 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2562 620 : *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 1995 : 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 1706 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2668 : {
2669 1706 : gfc_ref *ref;
2670 1706 : tree lbound, ubound, extent, tmp, img_idx;
2671 1706 : gfc_se se;
2672 1706 : int i;
2673 :
2674 1767 : for (ref = e->ref; ref; ref = ref->next)
2675 1767 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2676 : break;
2677 1706 : gcc_assert (ref != NULL);
2678 :
2679 1706 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2680 167 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2681 167 : 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 3849 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2807 : {
2808 3849 : gfc_se se;
2809 :
2810 3849 : gfc_init_se (&se, NULL);
2811 :
2812 3849 : 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 2581 : 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 2405 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2840 2405 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2841 : gfc_charlen_type_node, se.expr,
2842 2405 : build_zero_cst (TREE_TYPE (se.expr)));
2843 2405 : gfc_add_block_to_block (pblock, &se.pre);
2844 : }
2845 :
2846 2488 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2847 1570 : 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 7309 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2855 : const char *name, locus *where)
2856 : {
2857 7309 : tree tmp;
2858 7309 : tree type;
2859 7309 : tree fault;
2860 7309 : gfc_se start;
2861 7309 : gfc_se end;
2862 7309 : char *msg;
2863 7309 : mpz_t length;
2864 :
2865 7309 : type = gfc_get_character_type (kind, ref->u.ss.length);
2866 7309 : type = build_pointer_type (type);
2867 :
2868 7309 : gfc_init_se (&start, se);
2869 7309 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2870 7309 : gfc_add_block_to_block (&se->pre, &start.pre);
2871 :
2872 7309 : if (integer_onep (start.expr))
2873 2774 : gfc_conv_string_parameter (se);
2874 : else
2875 : {
2876 4535 : tmp = start.expr;
2877 4535 : STRIP_NOPS (tmp);
2878 : /* Avoid multiple evaluation of substring start. */
2879 4535 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2880 1700 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2881 :
2882 : /* Change the start of the string. */
2883 4535 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2884 1197 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2885 3458 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2886 5612 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2887 1077 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2888 : tmp = se->expr;
2889 : else
2890 1069 : tmp = build_fold_indirect_ref_loc (input_location,
2891 : se->expr);
2892 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2893 4535 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2894 : {
2895 4407 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2896 4407 : 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 7309 : gfc_init_se (&end, se);
2911 7309 : if (ref->u.ss.end == NULL)
2912 202 : end.expr = se->string_length;
2913 : else
2914 : {
2915 7107 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2916 7107 : gfc_add_block_to_block (&se->pre, &end.pre);
2917 : }
2918 7309 : tmp = end.expr;
2919 7309 : STRIP_NOPS (tmp);
2920 7309 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2921 2304 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2922 :
2923 7309 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2924 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2925 7764 : && !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 7309 : if (ref->u.ss.end
2968 7309 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2969 : {
2970 6087 : HOST_WIDE_INT i_len;
2971 :
2972 6087 : i_len = gfc_mpz_get_hwi (length) + 1;
2973 6087 : if (i_len < 0)
2974 : i_len = 0;
2975 :
2976 6087 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2977 6087 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2978 : }
2979 : else
2980 : {
2981 1222 : 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 1222 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2985 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2986 1222 : 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 7309 : se->string_length = tmp;
2991 7309 : }
2992 :
2993 :
2994 : /* Convert a derived type component reference. */
2995 :
2996 : void
2997 181679 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2998 : {
2999 181679 : gfc_component *c;
3000 181679 : tree tmp;
3001 181679 : tree decl;
3002 181679 : tree field;
3003 181679 : tree context;
3004 :
3005 181679 : c = ref->u.c.component;
3006 :
3007 181679 : 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 181679 : field = c->backend_decl;
3012 181679 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
3013 181679 : decl = se->expr;
3014 181679 : 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 181679 : if (context != TREE_TYPE (decl)
3026 181679 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
3027 14104 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
3028 : {
3029 14104 : tree f2 = c->norestrict_decl;
3030 23952 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
3031 8491 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
3032 8491 : if (TREE_CODE (f2) == FIELD_DECL
3033 8491 : && DECL_NAME (f2) == DECL_NAME (field))
3034 : break;
3035 14104 : gcc_assert (f2);
3036 14104 : c->norestrict_decl = f2;
3037 14104 : field = f2;
3038 : }
3039 :
3040 181679 : 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 181679 : se->class_vptr = NULL_TREE;
3049 :
3050 181679 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
3051 : decl, field, NULL_TREE);
3052 :
3053 181679 : se->expr = tmp;
3054 :
3055 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
3056 : strlen () conditional below. */
3057 181679 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
3058 8820 : && !c->ts.deferred
3059 5662 : && !c->attr.pdt_string)
3060 : {
3061 5488 : tmp = c->ts.u.cl->backend_decl;
3062 : /* Components must always be constant length. */
3063 5488 : gcc_assert (tmp && INTEGER_CST_P (tmp));
3064 5488 : se->string_length = tmp;
3065 : }
3066 :
3067 181679 : 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 181679 : if (((c->attr.pointer || c->attr.allocatable)
3076 106390 : && (!c->attr.dimension && !c->attr.codimension)
3077 57406 : && c->ts.type != BT_CHARACTER)
3078 126496 : || c->attr.proc_pointer)
3079 61735 : se->expr = build_fold_indirect_ref_loc (input_location,
3080 : se->expr);
3081 181679 : }
3082 :
3083 :
3084 : /* This function deals with component references to components of the
3085 : parent type for derived type extensions. */
3086 : void
3087 66459 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
3088 : {
3089 66459 : gfc_component *c;
3090 66459 : gfc_component *cmp;
3091 66459 : gfc_symbol *dt;
3092 66459 : gfc_ref parent;
3093 :
3094 66459 : dt = ref->u.c.sym;
3095 66459 : c = ref->u.c.component;
3096 :
3097 : /* Return if the component is in this type, i.e. not in the parent type. */
3098 114534 : for (cmp = dt->components; cmp; cmp = cmp->next)
3099 103668 : if (c == cmp)
3100 55593 : return;
3101 :
3102 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3103 10866 : parent.type = REF_COMPONENT;
3104 10866 : parent.next = NULL;
3105 10866 : parent.u.c.sym = dt;
3106 10866 : parent.u.c.component = dt->components;
3107 :
3108 10866 : if (dt->backend_decl == NULL)
3109 0 : gfc_get_derived_type (dt);
3110 :
3111 : /* Build the reference and call self. */
3112 10866 : gfc_conv_component_ref (se, &parent);
3113 10866 : parent.u.c.sym = dt->components->ts.u.derived;
3114 10866 : parent.u.c.component = c;
3115 10866 : 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 1467398 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3159 : bool is_classarray)
3160 : {
3161 1467398 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3162 : return var;
3163 298542 : 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 286650 : if (sym->ts.type == BT_CHARACTER)
3169 : {
3170 : /* Dereference character pointer dummy arguments
3171 : or results. */
3172 32962 : if ((sym->attr.pointer || sym->attr.allocatable
3173 19022 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3174 14276 : && (sym->attr.dummy
3175 10960 : || sym->attr.function
3176 10562 : || sym->attr.result))
3177 4399 : var = build_fold_indirect_ref_loc (input_location, var);
3178 : }
3179 253688 : else if (!sym->attr.value)
3180 : {
3181 : /* Dereference temporaries for class array dummy arguments. */
3182 175181 : if (sym->attr.dummy && is_classarray
3183 260973 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3184 : {
3185 5649 : if (!descriptor_only_p)
3186 2926 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3187 :
3188 5649 : var = build_fold_indirect_ref_loc (input_location, var);
3189 : }
3190 :
3191 : /* Dereference non-character scalar dummy arguments. */
3192 252884 : if (sym->attr.dummy && !sym->attr.dimension
3193 106019 : && !(sym->attr.codimension && sym->attr.allocatable)
3194 105953 : && (sym->ts.type != BT_CLASS
3195 20351 : || (!CLASS_DATA (sym)->attr.dimension
3196 11780 : && !(CLASS_DATA (sym)->attr.codimension
3197 283 : && CLASS_DATA (sym)->attr.allocatable))))
3198 97241 : var = build_fold_indirect_ref_loc (input_location, var);
3199 :
3200 : /* Dereference scalar hidden result. */
3201 252884 : 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 252884 : if (!is_classarray
3210 244349 : && (sym->attr.pointer || sym->attr.allocatable
3211 194300 : || gfc_is_associate_pointer (sym)
3212 189456 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3213 331273 : && (sym->attr.dummy
3214 36949 : || sym->attr.function
3215 36019 : || sym->attr.result
3216 34913 : || (!sym->attr.dimension
3217 34908 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3218 78384 : var = build_fold_indirect_ref_loc (input_location, var);
3219 : /* Now treat the class array pointer variables accordingly. */
3220 174500 : else if (sym->ts.type == BT_CLASS
3221 20797 : && sym->attr.dummy
3222 20351 : && (CLASS_DATA (sym)->attr.dimension
3223 11780 : || CLASS_DATA (sym)->attr.codimension)
3224 8854 : && ((CLASS_DATA (sym)->as
3225 8854 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3226 7791 : || CLASS_DATA (sym)->attr.allocatable
3227 6382 : || CLASS_DATA (sym)->attr.class_pointer))
3228 3063 : 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 171437 : else if (sym->ts.type == BT_CLASS
3235 17734 : && !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 1621576 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3254 : {
3255 1621576 : gfc_ss *ss;
3256 1621576 : gfc_ref *ref;
3257 1621576 : gfc_symbol *sym;
3258 1621576 : tree parent_decl = NULL_TREE;
3259 1621576 : int parent_flag;
3260 1621576 : bool return_value;
3261 1621576 : bool alternate_entry;
3262 1621576 : bool entry_master;
3263 1621576 : bool is_classarray;
3264 1621576 : bool first_time = true;
3265 :
3266 1621576 : sym = expr->symtree->n.sym;
3267 1621576 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3268 1621576 : ss = se->ss;
3269 1621576 : if (ss != NULL)
3270 : {
3271 134227 : gfc_ss_info *ss_info = ss->info;
3272 :
3273 : /* Check that something hasn't gone horribly wrong. */
3274 134227 : gcc_assert (ss != gfc_ss_terminator);
3275 134227 : gcc_assert (ss_info->expr == expr);
3276 :
3277 : /* A scalarized term. We already know the descriptor. */
3278 134227 : se->expr = ss_info->data.array.descriptor;
3279 134227 : se->string_length = ss_info->string_length;
3280 134227 : ref = ss_info->data.array.ref;
3281 134227 : if (ref)
3282 133873 : 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 1487349 : tree se_expr = NULL_TREE;
3290 :
3291 1487349 : 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 1487349 : return_value = sym->attr.function && sym->result == sym;
3296 19405 : alternate_entry = sym->attr.function && sym->attr.entry
3297 1488488 : && sym->result == sym;
3298 2974698 : entry_master = sym->attr.result
3299 14812 : && sym->ns->proc_name->attr.entry_master
3300 1487730 : && !gfc_return_by_reference (sym->ns->proc_name);
3301 1487349 : if (current_function_decl)
3302 1468840 : parent_decl = DECL_CONTEXT (current_function_decl);
3303 :
3304 1487349 : if ((se->expr == parent_decl && return_value)
3305 1487232 : || (sym->ns && sym->ns->proc_name
3306 1482280 : && parent_decl
3307 1463771 : && sym->ns->proc_name->backend_decl == parent_decl
3308 38546 : && (alternate_entry || entry_master)))
3309 : parent_flag = 1;
3310 : else
3311 1487199 : 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 1487349 : if (return_value && (se->expr == current_function_decl || parent_flag))
3316 10448 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3317 :
3318 : /* Similarly for alternate entry points. */
3319 1476901 : 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 1475795 : 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 11849 : if (se_expr)
3339 11849 : se->expr = se_expr;
3340 :
3341 : /* Procedure actual arguments. Look out for temporary variables
3342 : with the same attributes as function values. */
3343 1475500 : else if (!sym->attr.temporary
3344 1475432 : && sym->attr.flavor == FL_PROCEDURE
3345 22096 : && se->expr != current_function_decl)
3346 : {
3347 22029 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3348 : {
3349 20317 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3350 20317 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3351 : }
3352 : return;
3353 : }
3354 :
3355 1465320 : if (sym->ts.type == BT_CLASS
3356 74724 : && sym->attr.class_ok
3357 74482 : && sym->ts.u.derived->attr.is_class)
3358 : {
3359 28957 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3360 82586 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3361 5791 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3362 : else
3363 68691 : se->class_container = se->expr;
3364 : }
3365 :
3366 : /* Dereference the expression, where needed. */
3367 1465320 : 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 1464443 : se->expr
3374 1464443 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3375 : is_classarray);
3376 :
3377 1465320 : ref = expr->ref;
3378 : }
3379 :
3380 : /* For character variables, also get the length. */
3381 1599547 : 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 166770 : 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 166770 : se->string_length = sym->ts.u.cl->backend_decl;
3389 166770 : 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 166776 : && 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 1599547 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3402 90708 : && (gfc_option.allow_std & GFC_STD_F202Y)
3403 1599781 : && 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_get (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 1599547 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3426 418 : gfc_fixup_inferred_type_refs (expr);
3427 :
3428 1599547 : gfc_typespec *ts = &sym->ts;
3429 2042074 : while (ref)
3430 : {
3431 795941 : switch (ref->type)
3432 : {
3433 617624 : case REF_ARRAY:
3434 : /* Return the descriptor if that's what we want and this is an array
3435 : section reference. */
3436 617624 : 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 273729 : if (se->want_pointer
3441 24311 : && ref->next == NULL && (se->descriptor_only))
3442 : return;
3443 :
3444 264210 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3445 : /* Return a pointer to an element. */
3446 264210 : break;
3447 :
3448 170717 : case REF_COMPONENT:
3449 170717 : ts = &ref->u.c.component->ts;
3450 170717 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3451 6129 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3452 3244 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3453 3244 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3454 2723 : && 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 167994 : if (ref->u.c.sym->attr.extension)
3461 55502 : conv_parent_component_references (se, ref);
3462 :
3463 167994 : gfc_conv_component_ref (se, ref);
3464 :
3465 167994 : if (ref->u.c.component->ts.type == BT_CLASS
3466 12497 : && ref->u.c.component->attr.class_ok
3467 12497 : && ref->u.c.component->ts.u.derived->attr.is_class)
3468 12497 : se->class_container = se->expr;
3469 155497 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3470 153003 : && ref->u.c.sym->attr.is_class))
3471 85422 : se->class_container = NULL_TREE;
3472 :
3473 167994 : if (!ref->next && ref->u.c.sym->attr.codimension
3474 0 : && se->want_pointer && se->descriptor_only)
3475 : return;
3476 :
3477 : break;
3478 :
3479 7051 : case REF_SUBSTRING:
3480 7051 : gfc_conv_substring (se, ref, expr->ts.kind,
3481 7051 : expr->symtree->name, &expr->where);
3482 7051 : 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 442527 : break;
3491 : }
3492 442527 : first_time = false;
3493 442527 : ref = ref->next;
3494 : }
3495 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3496 : separately. */
3497 1246133 : if (se->want_pointer)
3498 : {
3499 135298 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3500 8072 : gfc_conv_string_parameter (se);
3501 : else
3502 127226 : 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 28911 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3511 : {
3512 28911 : gfc_se operand;
3513 28911 : tree type;
3514 :
3515 28911 : gcc_assert (expr->ts.type != BT_CHARACTER);
3516 : /* Initialize the operand. */
3517 28911 : gfc_init_se (&operand, se);
3518 28911 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3519 28911 : gfc_add_block_to_block (&se->pre, &operand.pre);
3520 :
3521 28911 : 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 28911 : if (code == TRUTH_NOT_EXPR)
3527 20296 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3528 : build_int_cst (type, 0));
3529 : else
3530 8615 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3531 :
3532 28911 : }
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 : 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 182 : case 8:
4009 182 : ikind = 1;
4010 182 : 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 212 : case 8:
4037 212 : kind = 1;
4038 212 : 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 4898 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4166 : {
4167 4898 : tree var;
4168 4898 : tree tmp;
4169 :
4170 4898 : if (gfc_can_put_var_on_stack (len))
4171 : {
4172 : /* Create a temporary variable to hold the result. */
4173 4622 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4174 2311 : TREE_TYPE (len), len,
4175 2311 : build_int_cst (TREE_TYPE (len), 1));
4176 2311 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4177 :
4178 2311 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4179 2311 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4180 : else
4181 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
4182 :
4183 2311 : var = gfc_create_var (tmp, "str");
4184 2311 : 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 4898 : 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 510863 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4280 : {
4281 510863 : enum tree_code code;
4282 510863 : gfc_se lse;
4283 510863 : gfc_se rse;
4284 510863 : tree tmp, type;
4285 510863 : int lop;
4286 510863 : int checkstring;
4287 :
4288 510863 : checkstring = 0;
4289 510863 : lop = 0;
4290 510863 : switch (expr->value.op.op)
4291 : {
4292 15585 : case INTRINSIC_PARENTHESES:
4293 15585 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4294 3802 : && 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 91305 : return;
4299 : }
4300 :
4301 : /* Fallthrough. */
4302 11923 : case INTRINSIC_UPLUS:
4303 11923 : gfc_conv_expr (se, expr->value.op.op1);
4304 11923 : return;
4305 :
4306 4947 : case INTRINSIC_UMINUS:
4307 4947 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4308 4947 : return;
4309 :
4310 20296 : case INTRINSIC_NOT:
4311 20296 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4312 20296 : return;
4313 :
4314 : case INTRINSIC_PLUS:
4315 : code = PLUS_EXPR;
4316 : break;
4317 :
4318 29649 : case INTRINSIC_MINUS:
4319 29649 : code = MINUS_EXPR;
4320 29649 : break;
4321 :
4322 33337 : case INTRINSIC_TIMES:
4323 33337 : code = MULT_EXPR;
4324 33337 : break;
4325 :
4326 7083 : 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 7083 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4331 : code = TRUNC_DIV_EXPR;
4332 : else
4333 419558 : 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 4834 : case INTRINSIC_AND:
4345 4834 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4346 : lop = 1;
4347 : break;
4348 :
4349 56053 : case INTRINSIC_OR:
4350 56053 : 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 12689 : case INTRINSIC_EQ:
4357 12689 : case INTRINSIC_EQ_OS:
4358 12689 : case INTRINSIC_EQV:
4359 12689 : code = EQ_EXPR;
4360 12689 : checkstring = 1;
4361 12689 : lop = 1;
4362 12689 : break;
4363 :
4364 208312 : case INTRINSIC_NE:
4365 208312 : case INTRINSIC_NE_OS:
4366 208312 : case INTRINSIC_NEQV:
4367 208312 : code = NE_EXPR;
4368 208312 : checkstring = 1;
4369 208312 : lop = 1;
4370 208312 : break;
4371 :
4372 12096 : case INTRINSIC_GT:
4373 12096 : case INTRINSIC_GT_OS:
4374 12096 : code = GT_EXPR;
4375 12096 : checkstring = 1;
4376 12096 : lop = 1;
4377 12096 : 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 4369 : case INTRINSIC_LT:
4387 4369 : case INTRINSIC_LT_OS:
4388 4369 : code = LT_EXPR;
4389 4369 : checkstring = 1;
4390 4369 : lop = 1;
4391 4369 : break;
4392 :
4393 2610 : case INTRINSIC_LE:
4394 2610 : case INTRINSIC_LE_OS:
4395 2610 : code = LE_EXPR;
4396 2610 : checkstring = 1;
4397 2610 : lop = 1;
4398 2610 : 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 419558 : return;
4408 : }
4409 :
4410 : /* The only exception to this is **, which is handled separately anyway. */
4411 419558 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4412 :
4413 419558 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4414 385486 : checkstring = 0;
4415 :
4416 : /* lhs */
4417 419558 : gfc_init_se (&lse, se);
4418 419558 : gfc_conv_expr (&lse, expr->value.op.op1);
4419 419558 : gfc_add_block_to_block (&se->pre, &lse.pre);
4420 :
4421 : /* rhs */
4422 419558 : gfc_init_se (&rse, se);
4423 419558 : gfc_conv_expr (&rse, expr->value.op.op2);
4424 419558 : gfc_add_block_to_block (&se->pre, &rse.pre);
4425 :
4426 419558 : if (checkstring)
4427 : {
4428 34072 : gfc_conv_string_parameter (&lse);
4429 34072 : gfc_conv_string_parameter (&rse);
4430 :
4431 68144 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4432 : rse.string_length, rse.expr,
4433 34072 : expr->value.op.op1->ts.kind,
4434 : code);
4435 34072 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4436 34072 : gfc_add_block_to_block (&lse.post, &rse.post);
4437 : }
4438 :
4439 419558 : type = gfc_typenode_for_spec (&expr->ts);
4440 :
4441 419558 : if (lop)
4442 : {
4443 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4444 302634 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4445 170884 : && expr->value.op.op1->ts.type == BT_INTEGER
4446 73911 : && expr->value.op.op1->symtree
4447 73911 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4448 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4449 :
4450 302634 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4451 72442 : && expr->value.op.op2->ts.type == BT_INTEGER
4452 13051 : && expr->value.op.op2->symtree
4453 13051 : && 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 302634 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4458 : lse.expr, rse.expr);
4459 302634 : se->expr = convert (type, tmp);
4460 : }
4461 : else
4462 116924 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4463 :
4464 : /* Add the post blocks. */
4465 419558 : gfc_add_block_to_block (&se->post, &rse.post);
4466 419558 : 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 140710 : gfc_string_to_single_character (tree len, tree str, int kind)
4530 : {
4531 :
4532 140710 : if (len == NULL
4533 140710 : || !tree_fits_uhwi_p (len)
4534 258623 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4535 : return NULL_TREE;
4536 :
4537 117861 : if (TREE_INT_CST_LOW (len) == 1)
4538 : {
4539 22565 : str = fold_convert (gfc_get_pchar_type (kind), str);
4540 22565 : return build_fold_indirect_ref_loc (input_location, str);
4541 : }
4542 :
4543 95296 : if (kind == 1
4544 77926 : && TREE_CODE (str) == ADDR_EXPR
4545 67225 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4546 47985 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4547 29555 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4548 29555 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4549 29555 : && TREE_INT_CST_LOW (len) > 1
4550 123023 : && TREE_INT_CST_LOW (len)
4551 : == (unsigned HOST_WIDE_INT)
4552 27727 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4553 : {
4554 27727 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4555 27727 : ret = build_fold_indirect_ref_loc (input_location, ret);
4556 27727 : if (TREE_CODE (ret) == INTEGER_CST)
4557 : {
4558 27727 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4559 27727 : int i, length = TREE_STRING_LENGTH (string_cst);
4560 27727 : const char *ptr = TREE_STRING_POINTER (string_cst);
4561 :
4562 41843 : for (i = 1; i < length; i++)
4563 41163 : 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 32376 : gfc_optimize_len_trim (tree len, tree str, int kind)
4628 : {
4629 32376 : if (kind == 1
4630 27334 : && TREE_CODE (str) == ADDR_EXPR
4631 23986 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4632 15290 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4633 9854 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4634 9854 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4635 9854 : && tree_fits_uhwi_p (len)
4636 9854 : && tree_to_uhwi (len) >= 1
4637 32376 : && tree_to_uhwi (len)
4638 9810 : == (unsigned HOST_WIDE_INT)
4639 9810 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4640 : {
4641 9810 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4642 9810 : folded = build_fold_indirect_ref_loc (input_location, folded);
4643 9810 : if (TREE_CODE (folded) == INTEGER_CST)
4644 : {
4645 9810 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4646 9810 : int length = TREE_STRING_LENGTH (string_cst);
4647 9810 : const char *ptr = TREE_STRING_POINTER (string_cst);
4648 :
4649 14719 : for (; length > 0; length--)
4650 14719 : 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 13147 : build_memcmp_call (tree s1, tree s2, tree n)
4663 : {
4664 13147 : tree tmp;
4665 :
4666 13147 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4667 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4668 : else
4669 13147 : s1 = fold_convert (pvoid_type_node, s1);
4670 :
4671 13147 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4672 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4673 : else
4674 13147 : s2 = fold_convert (pvoid_type_node, s2);
4675 :
4676 13147 : n = fold_convert (size_type_node, n);
4677 :
4678 13147 : tmp = build_call_expr_loc (input_location,
4679 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4680 : 3, s1, s2, n);
4681 :
4682 13147 : 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 34171 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4690 : enum tree_code code)
4691 : {
4692 34171 : tree sc1;
4693 34171 : tree sc2;
4694 34171 : tree fndecl;
4695 :
4696 34171 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4697 34171 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4698 :
4699 34171 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4700 34171 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4701 :
4702 34171 : 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 29332 : if ((code == EQ_EXPR || code == NE_EXPR)
4712 28770 : && optimize
4713 24099 : && 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 16188 : int len = gfc_optimize_len_trim (len1, str1, kind);
4719 16188 : if (len > 0 && compare_tree_int (len2, len) < 0)
4720 0 : return integer_one_node;
4721 16188 : len = gfc_optimize_len_trim (len2, str2, kind);
4722 16188 : 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 19730 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4732 19392 : && tree_int_cst_equal (len1, len2)
4733 42539 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4734 : {
4735 13147 : tree tmp;
4736 13147 : tree chartype;
4737 :
4738 13147 : chartype = gfc_get_char_type (kind);
4739 13147 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4740 13147 : fold_convert (TREE_TYPE(len1),
4741 : TYPE_SIZE_UNIT(chartype)),
4742 : len1);
4743 13147 : return build_memcmp_call (str1, str2, tmp);
4744 : }
4745 :
4746 : /* Build a call for the comparison. */
4747 16185 : if (kind == 1)
4748 13342 : 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 16185 : return build_call_expr_loc (input_location, fndecl, 4,
4755 16185 : 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 129059 : get_builtin_fn (gfc_symbol * sym)
4808 : {
4809 129059 : if (!gfc_option.disable_omp_is_initial_device
4810 129055 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4811 631 : && !strcmp (sym->name, "omp_is_initial_device"))
4812 41 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4813 :
4814 129018 : if (!gfc_option.disable_omp_get_initial_device
4815 129011 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4816 4287 : && !strcmp (sym->name, "omp_get_initial_device"))
4817 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4818 :
4819 128989 : if (!gfc_option.disable_omp_get_num_devices
4820 128982 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4821 4258 : && !strcmp (sym->name, "omp_get_num_devices"))
4822 107 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4823 :
4824 128882 : if (!gfc_option.disable_acc_on_device
4825 128702 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4826 1169 : && !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 131799 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4856 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4857 : {
4858 131799 : tree tmp;
4859 :
4860 131799 : if (gfc_is_proc_ptr_comp (expr))
4861 1914 : tmp = get_proc_ptr_comp (expr);
4862 129885 : else if (sym->attr.dummy)
4863 : {
4864 826 : tmp = gfc_get_symbol_decl (sym);
4865 826 : if (sym->attr.proc_pointer)
4866 89 : tmp = build_fold_indirect_ref_loc (input_location,
4867 : tmp);
4868 826 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4869 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4870 : }
4871 : else
4872 : {
4873 129059 : if (!sym->backend_decl)
4874 32453 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4875 :
4876 129059 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4877 567 : *is_builtin = true;
4878 : else
4879 : {
4880 128492 : TREE_USED (sym->backend_decl) = 1;
4881 128492 : tmp = sym->backend_decl;
4882 : }
4883 :
4884 129059 : 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 129059 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4895 : {
4896 128431 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4897 128431 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4898 : }
4899 : }
4900 131799 : se->expr = tmp;
4901 131799 : }
4902 :
4903 :
4904 : /* Initialize MAPPING. */
4905 :
4906 : void
4907 131916 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4908 : {
4909 131916 : mapping->syms = NULL;
4910 131916 : mapping->charlens = NULL;
4911 131916 : }
4912 :
4913 :
4914 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4915 :
4916 : void
4917 131916 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4918 : {
4919 131916 : gfc_interface_sym_mapping *sym;
4920 131916 : gfc_interface_sym_mapping *nextsym;
4921 131916 : gfc_charlen *cl;
4922 131916 : gfc_charlen *nextcl;
4923 :
4924 172542 : for (sym = mapping->syms; sym; sym = nextsym)
4925 : {
4926 40626 : nextsym = sym->next;
4927 40626 : sym->new_sym->n.sym->formal = NULL;
4928 40626 : gfc_free_symbol (sym->new_sym->n.sym);
4929 40626 : gfc_free_expr (sym->expr);
4930 40626 : free (sym->new_sym);
4931 40626 : free (sym);
4932 : }
4933 136592 : for (cl = mapping->charlens; cl; cl = nextcl)
4934 : {
4935 4676 : nextcl = cl->next;
4936 4676 : gfc_free_expr (cl->length);
4937 4676 : free (cl);
4938 : }
4939 131916 : }
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 4676 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4947 : gfc_charlen * cl)
4948 : {
4949 4676 : gfc_charlen *new_charlen;
4950 :
4951 4676 : new_charlen = gfc_get_charlen ();
4952 4676 : new_charlen->next = mapping->charlens;
4953 4676 : new_charlen->length = gfc_copy_expr (cl->length);
4954 :
4955 4676 : mapping->charlens = new_charlen;
4956 4676 : 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 8381 : !sym->attr.target && !sym->attr.pointer
4985 8357 : && !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 40626 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
5047 : gfc_symbol * sym, gfc_se * se,
5048 : gfc_expr *expr)
5049 : {
5050 40626 : gfc_interface_sym_mapping *sm;
5051 40626 : tree desc;
5052 40626 : tree tmp;
5053 40626 : tree value;
5054 40626 : gfc_symbol *new_sym;
5055 40626 : gfc_symtree *root;
5056 40626 : gfc_symtree *new_symtree;
5057 :
5058 : /* Create a new symbol to represent the actual argument. */
5059 40626 : new_sym = gfc_new_symbol (sym->name, NULL);
5060 40626 : new_sym->ts = sym->ts;
5061 40626 : new_sym->as = gfc_copy_array_spec (sym->as);
5062 40626 : new_sym->attr.referenced = 1;
5063 40626 : new_sym->attr.dimension = sym->attr.dimension;
5064 40626 : new_sym->attr.contiguous = sym->attr.contiguous;
5065 40626 : new_sym->attr.codimension = sym->attr.codimension;
5066 40626 : new_sym->attr.pointer = sym->attr.pointer;
5067 40626 : new_sym->attr.allocatable = sym->attr.allocatable;
5068 40626 : new_sym->attr.flavor = sym->attr.flavor;
5069 40626 : new_sym->attr.function = sym->attr.function;
5070 40626 : new_sym->attr.dummy = 0;
5071 :
5072 : /* Ensure that the interface is available and that
5073 : descriptors are passed for array actual arguments. */
5074 40626 : 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 40626 : root = NULL;
5083 40626 : new_symtree = gfc_new_symtree (&root, sym->name);
5084 40626 : new_symtree->n.sym = new_sym;
5085 40626 : gcc_assert (new_symtree == root);
5086 :
5087 : /* Create a dummy->actual mapping. */
5088 40626 : sm = XCNEW (gfc_interface_sym_mapping);
5089 40626 : sm->next = mapping->syms;
5090 40626 : sm->old = sym;
5091 40626 : sm->new_sym = new_symtree;
5092 40626 : sm->expr = gfc_copy_expr (expr);
5093 40626 : mapping->syms = sm;
5094 :
5095 : /* Stabilize the argument's value. */
5096 40626 : if (!sym->attr.function && se)
5097 40528 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5098 :
5099 40626 : if (sym->ts.type == BT_CHARACTER)
5100 : {
5101 : /* Create a copy of the dummy argument's length. */
5102 2874 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
5103 2874 : 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 2874 : if (!new_sym->ts.u.cl->length && se)
5109 : {
5110 2646 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5111 2646 : new_sym->ts.u.cl->backend_decl = se->string_length;
5112 : }
5113 : }
5114 :
5115 40612 : if (!se)
5116 62 : return;
5117 :
5118 : /* Use the passed value as-is if the argument is a function. */
5119 40564 : 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 40528 : 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 40450 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5129 : {
5130 1305 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5131 1305 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5132 1305 : tmp = build_pointer_type (tmp);
5133 1305 : if (sym->attr.pointer)
5134 126 : value = build_fold_indirect_ref_loc (input_location,
5135 : se->expr);
5136 : else
5137 1179 : value = se->expr;
5138 1305 : 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 39145 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5144 29254 : 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 40564 : 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 131879 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5200 : stmtblock_t * pre, stmtblock_t * post)
5201 : {
5202 131879 : gfc_interface_sym_mapping *sym;
5203 131879 : gfc_expr *expr;
5204 131879 : gfc_se se;
5205 :
5206 172443 : for (sym = mapping->syms; sym; sym = sym->next)
5207 40564 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5208 2860 : && !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 131879 : }
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 12621 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5250 : gfc_ref * ref)
5251 : {
5252 12621 : int n;
5253 :
5254 14106 : 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 12621 : }
5276 :
5277 :
5278 : /* Convert intrinsic function calls into result expressions. */
5279 :
5280 : static bool
5281 2232 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5282 : {
5283 2232 : gfc_symbol *sym;
5284 2232 : gfc_expr *new_expr;
5285 2232 : gfc_expr *arg1;
5286 2232 : gfc_expr *arg2;
5287 2232 : int d, dup;
5288 :
5289 2232 : arg1 = expr->value.function.actual->expr;
5290 2232 : if (expr->value.function.actual->next)
5291 2111 : arg2 = expr->value.function.actual->next->expr;
5292 : else
5293 : arg2 = NULL;
5294 :
5295 2232 : sym = arg1->symtree->n.sym;
5296 :
5297 2232 : if (sym->attr.dummy)
5298 : return false;
5299 :
5300 2208 : new_expr = NULL;
5301 :
5302 2208 : switch (expr->value.function.isym->id)
5303 : {
5304 947 : case GFC_ISYM_LEN:
5305 : /* TODO figure out why this condition is necessary. */
5306 947 : 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 904 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5313 904 : 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 1337 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5391 1337 : 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 21208 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5451 : gfc_expr * expr)
5452 : {
5453 22773 : gfc_interface_sym_mapping *sym;
5454 22773 : gfc_actual_arglist *actual;
5455 :
5456 22773 : if (!expr)
5457 : return;
5458 :
5459 : /* Copying an expression does not copy its length, so do that here. */
5460 12621 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5461 : {
5462 1802 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5463 1802 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5464 : }
5465 :
5466 : /* Apply the mapping to any references. */
5467 12621 : 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 30014 : for (sym = mapping->syms; sym; sym = sym->next)
5473 17393 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5474 : {
5475 3388 : if (sym->new_sym->n.sym->backend_decl)
5476 3344 : 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 12621 : 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 2975 : case EXPR_FUNCTION:
5503 9556 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5504 6581 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5505 :
5506 2975 : if (expr->value.function.esym == NULL
5507 2662 : && expr->value.function.isym != NULL
5508 2650 : && expr->value.function.actual
5509 2649 : && expr->value.function.actual->expr
5510 2649 : && expr->value.function.actual->expr->symtree
5511 5207 : && gfc_map_intrinsic_function (expr, mapping))
5512 : break;
5513 :
5514 6190 : for (sym = mapping->syms; sym; sym = sym->next)
5515 3556 : 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 4034 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5544 : gfc_se * se, gfc_expr * expr)
5545 : {
5546 4034 : expr = gfc_copy_expr (expr);
5547 4034 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5548 4034 : gfc_conv_expr (se, expr);
5549 4034 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5550 4034 : gfc_free_expr (expr);
5551 4034 : }
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 2755 : 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 2755 : gfc_se lse;
5564 2755 : gfc_se rse;
5565 2755 : gfc_ss *lss;
5566 2755 : gfc_ss *rss;
5567 2755 : gfc_loopinfo loop;
5568 2755 : gfc_loopinfo loop2;
5569 2755 : gfc_array_info *info;
5570 2755 : tree offset;
5571 2755 : tree tmp_index;
5572 2755 : tree tmp;
5573 2755 : tree base_type;
5574 2755 : tree size;
5575 2755 : stmtblock_t body;
5576 2755 : int n;
5577 2755 : int dimen;
5578 2755 : gfc_se work_se;
5579 2755 : gfc_se *parmse;
5580 2755 : bool pass_optional;
5581 2755 : bool readonly;
5582 :
5583 2755 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5584 :
5585 2744 : if (pass_optional || check_contiguous)
5586 : {
5587 1442 : gfc_init_se (&work_se, NULL);
5588 1442 : parmse = &work_se;
5589 : }
5590 : else
5591 : parmse = se;
5592 :
5593 2755 : 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 2755 : gfc_init_se (&lse, NULL);
5611 2755 : gfc_init_se (&rse, NULL);
5612 :
5613 : /* Walk the argument expression. */
5614 2755 : rss = gfc_walk_expr (expr);
5615 :
5616 2755 : gcc_assert (rss != gfc_ss_terminator);
5617 :
5618 : /* Initialize the scalarizer. */
5619 2755 : gfc_init_loopinfo (&loop);
5620 2755 : gfc_add_ss_to_loop (&loop, rss);
5621 :
5622 : /* Calculate the bounds of the scalarization. */
5623 2755 : gfc_conv_ss_startstride (&loop);
5624 :
5625 : /* Build an ss for the temporary. */
5626 2755 : 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 2755 : base_type = gfc_typenode_for_spec (&expr->ts);
5630 2755 : if (GFC_ARRAY_TYPE_P (base_type)
5631 2755 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5632 0 : base_type = gfc_get_element_type (base_type);
5633 :
5634 2755 : if (expr->ts.type == BT_CLASS)
5635 127 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5636 :
5637 3919 : 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 2755 : parmse->string_length = loop.temp_ss->info->string_length;
5643 :
5644 : /* Associate the SS with the loop. */
5645 2755 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5646 :
5647 : /* Setup the scalarizing loops. */
5648 2755 : gfc_conv_loop_setup (&loop, &expr->where);
5649 :
5650 : /* Pass the temporary descriptor back to the caller. */
5651 2755 : info = &loop.temp_ss->info->data.array;
5652 2755 : parmse->expr = info->descriptor;
5653 :
5654 : /* Setup the gfc_se structures. */
5655 2755 : gfc_copy_loopinfo_to_se (&lse, &loop);
5656 2755 : gfc_copy_loopinfo_to_se (&rse, &loop);
5657 :
5658 2755 : rse.ss = rss;
5659 2755 : lse.ss = loop.temp_ss;
5660 2755 : gfc_mark_ss_chain_used (rss, 1);
5661 2755 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5662 :
5663 : /* Start the scalarized loop body. */
5664 2755 : gfc_start_scalarized_body (&loop, &body);
5665 :
5666 : /* Translate the expression. */
5667 2755 : gfc_conv_expr (&rse, expr);
5668 :
5669 2755 : gfc_conv_tmp_array_ref (&lse);
5670 :
5671 2755 : if (intent != INTENT_OUT)
5672 : {
5673 2717 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5674 2717 : gfc_add_expr_to_block (&body, tmp);
5675 2717 : gcc_assert (rse.ss == gfc_ss_terminator);
5676 2717 : 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 2755 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5693 :
5694 : /**********Copy the temporary back again.*********/
5695 :
5696 2755 : gfc_init_se (&lse, NULL);
5697 2755 : gfc_init_se (&rse, NULL);
5698 :
5699 : /* Walk the argument expression. */
5700 2755 : lss = gfc_walk_expr (expr);
5701 2755 : rse.ss = loop.temp_ss;
5702 2755 : lse.ss = lss;
5703 :
5704 : /* Initialize the scalarizer. */
5705 2755 : gfc_init_loopinfo (&loop2);
5706 2755 : gfc_add_ss_to_loop (&loop2, lss);
5707 :
5708 2755 : dimen = rse.ss->dimen;
5709 :
5710 : /* Skip the write-out loop for this case. */
5711 2755 : if (gfc_is_class_array_function (expr))
5712 13 : goto class_array_fcn;
5713 :
5714 : /* Calculate the bounds of the scalarization. */
5715 2742 : gfc_conv_ss_startstride (&loop2);
5716 :
5717 : /* Setup the scalarizing loops. */
5718 2742 : gfc_conv_loop_setup (&loop2, &expr->where);
5719 :
5720 2742 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5721 2742 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5722 :
5723 2742 : gfc_mark_ss_chain_used (lss, 1);
5724 2742 : 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 2742 : offset = gfc_create_var (gfc_array_index_type, NULL);
5729 2742 : 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 2742 : info = &rse.ss->info->data.array;
5737 :
5738 2742 : tmp_index = gfc_index_zero_node;
5739 4119 : for (n = dimen - 1; n > 0; n--)
5740 : {
5741 1377 : tree tmp_str;
5742 1377 : tmp = rse.loop->loopvar[n];
5743 1377 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5744 : tmp, rse.loop->from[n]);
5745 1377 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5746 : tmp, tmp_index);
5747 :
5748 2754 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5749 : gfc_array_index_type,
5750 1377 : rse.loop->to[n-1], rse.loop->from[n-1]);
5751 1377 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5752 : gfc_array_index_type,
5753 : tmp_str, gfc_index_one_node);
5754 :
5755 1377 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5756 : gfc_array_index_type, tmp, tmp_str);
5757 : }
5758 :
5759 5484 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5760 : gfc_array_index_type,
5761 2742 : tmp_index, rse.loop->from[0]);
5762 2742 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5763 :
5764 5484 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5765 : gfc_array_index_type,
5766 2742 : rse.loop->loopvar[0], offset);
5767 :
5768 : /* Now use the offset for the reference. */
5769 2742 : tmp = build_fold_indirect_ref_loc (input_location,
5770 : info->data);
5771 2742 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5772 :
5773 2742 : if (expr->ts.type == BT_CHARACTER)
5774 1164 : rse.string_length = expr->ts.u.cl->backend_decl;
5775 :
5776 2742 : gfc_conv_expr (&lse, expr);
5777 :
5778 2742 : gcc_assert (lse.ss == gfc_ss_terminator);
5779 :
5780 : /* Do not do deallocations when we are looking at a g77-style argument. */
5781 :
5782 2742 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, !g77);
5783 2742 : gfc_add_expr_to_block (&body, tmp);
5784 :
5785 : /* Generate the copying loops. */
5786 2742 : 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 5484 : readonly = (expr->expr_type == EXPR_VARIABLE
5794 2676 : && expr->symtree
5795 5418 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5796 :
5797 2742 : if ((intent != INTENT_IN) && !readonly)
5798 : {
5799 1255 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5800 1255 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5801 : }
5802 :
5803 1487 : class_array_fcn:
5804 :
5805 2755 : gfc_add_block_to_block (&parmse->post, &loop.post);
5806 :
5807 2755 : gfc_cleanup_loop (&loop);
5808 2755 : gfc_cleanup_loop (&loop2);
5809 :
5810 : /* Pass the string length to the argument expression. */
5811 2755 : 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 2755 : 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 2755 : if (g77)
5857 442 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5858 : else
5859 2313 : 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 2755 : if (pass_optional || check_contiguous)
5885 : {
5886 1442 : tree type;
5887 1442 : stmtblock_t else_block;
5888 1442 : tree pre_stmts, post_stmts;
5889 1442 : tree pointer;
5890 1442 : tree else_stmt;
5891 1442 : tree present_var = NULL_TREE;
5892 1442 : tree cont_var = NULL_TREE;
5893 1442 : tree post_cond;
5894 :
5895 1442 : type = TREE_TYPE (parmse->expr);
5896 1442 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5897 1105 : type = TREE_TYPE (type);
5898 1442 : pointer = gfc_create_var (type, "arg_ptr");
5899 :
5900 1442 : if (check_contiguous)
5901 : {
5902 1442 : gfc_se cont_se, array_se;
5903 1442 : stmtblock_t if_block, else_block;
5904 1442 : tree if_stmt, else_stmt;
5905 1442 : mpz_t size;
5906 1442 : bool size_set;
5907 :
5908 1442 : 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 1442 : size_set = gfc_array_size (expr, &size);
5917 1442 : 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 1436 : gfc_init_se (&cont_se, parmse);
5926 1436 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5927 1436 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5928 1436 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5929 1436 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5930 : }
5931 :
5932 1442 : if (size_set)
5933 1155 : mpz_clear (size);
5934 :
5935 : /* arrayse->expr = descriptor of a. */
5936 1442 : gfc_init_se (&array_se, se);
5937 1442 : gfc_conv_expr_descriptor (&array_se, expr);
5938 1442 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5939 1442 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5940 :
5941 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5942 1442 : gfc_init_block (&if_block);
5943 1442 : if (GFC_DESCRIPTOR_TYPE_P (type))
5944 1105 : gfc_add_modify (&if_block, pointer, array_se.expr);
5945 : else
5946 : {
5947 337 : tmp = gfc_conv_array_data (array_se.expr);
5948 337 : tmp = fold_convert (type, tmp);
5949 337 : gfc_add_modify (&if_block, pointer, tmp);
5950 : }
5951 1442 : if_stmt = gfc_finish_block (&if_block);
5952 :
5953 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5954 1442 : gfc_init_block (&else_block);
5955 1442 : gfc_add_block_to_block (&else_block, &parmse->pre);
5956 1779 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5957 1442 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5958 : : parmse->expr);
5959 1442 : gfc_add_modify (&else_block, pointer, tmp);
5960 1442 : else_stmt = gfc_finish_block (&else_block);
5961 :
5962 : /* And put the above into an if statement. */
5963 1442 : 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 1442 : 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 1431 : gfc_add_expr_to_block (&se->pre, pre_stmts);
6001 :
6002 1442 : post_stmts = gfc_finish_block (&parmse->post);
6003 :
6004 : /* Put together the post stuff, plus the optional
6005 : deallocation. */
6006 1442 : if (check_contiguous)
6007 : {
6008 : /* !cont_var. */
6009 1442 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6010 : cont_var,
6011 : build_zero_cst (boolean_type_node));
6012 1442 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
6013 :
6014 1442 : 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 1442 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
6032 : post_stmts, build_empty_stmt (input_location));
6033 1442 : gfc_add_expr_to_block (&se->post, tmp);
6034 1442 : if (GFC_DESCRIPTOR_TYPE_P (type))
6035 : {
6036 1105 : type = TREE_TYPE (parmse->expr);
6037 1105 : if (POINTER_TYPE_P (type))
6038 : {
6039 1105 : pointer = gfc_build_addr_expr (type, pointer);
6040 1105 : 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 1442 : se->expr = pointer;
6053 : }
6054 :
6055 2755 : 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 7716 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6108 : {
6109 7716 : gfc_constructor *c;
6110 :
6111 7716 : 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 160 : 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 : type = gfc_get_element_type (TREE_TYPE (desc));
6173 783 : gfc_conv_descriptor_dtype_set (&block, desc,
6174 : gfc_get_dtype_rank_type (e->rank, type));
6175 783 : cond = build3_v (COND_EXPR, cond,
6176 : gfc_finish_block (&block),
6177 : build_empty_stmt (input_location));
6178 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6179 : }
6180 :
6181 :
6182 :
6183 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6184 : ISO_Fortran_binding array descriptors. */
6185 :
6186 : static void
6187 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6188 : {
6189 6537 : stmtblock_t block, block2;
6190 6537 : tree cfi, gfc, tmp, tmp2;
6191 6537 : tree present = NULL;
6192 6537 : tree gfc_strlen = NULL;
6193 6537 : tree rank;
6194 6537 : gfc_se se;
6195 :
6196 6537 : if (fsym->attr.optional
6197 1094 : && e->expr_type == EXPR_VARIABLE
6198 1094 : && e->symtree->n.sym->attr.optional)
6199 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6200 :
6201 6537 : gfc_init_block (&block);
6202 :
6203 : /* Convert original argument to a tree. */
6204 6537 : gfc_init_se (&se, NULL);
6205 6537 : if (e->rank == 0)
6206 : {
6207 687 : se.want_pointer = 1;
6208 687 : gfc_conv_expr (&se, e);
6209 687 : gfc = se.expr;
6210 : }
6211 : else
6212 : {
6213 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6214 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6215 : length assumed-length/assumed-size CHARACTER array. This only
6216 : applies if the actual argument is a "variable"; if it's some
6217 : non-lvalue expression, we are going to evaluate it to a
6218 : temporary below anyway. */
6219 5850 : se.force_no_tmp = 1;
6220 5850 : if ((fsym->attr.contiguous
6221 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6222 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6223 937 : || fsym->as->type == AS_EXPLICIT)))
6224 2023 : && !gfc_is_simply_contiguous (e, false, true)
6225 6883 : && gfc_expr_is_variable (e))
6226 : {
6227 1027 : bool optional = fsym->attr.optional;
6228 1027 : fsym->attr.optional = 0;
6229 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6230 1027 : fsym->attr.pointer, fsym,
6231 1027 : fsym->ns->proc_name->name, NULL,
6232 : /* check_contiguous= */ true);
6233 1027 : fsym->attr.optional = optional;
6234 : }
6235 : else
6236 4823 : gfc_conv_expr_descriptor (&se, e);
6237 5850 : gfc = se.expr;
6238 : /* For dt(:)%var, the base_addr is that of the subobject and elem_len is
6239 : its size, see below. The descriptor built for a subreference of the
6240 : array provides both. While sm is fine as it uses span*stride and not
6241 : elem_len. */
6242 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6243 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6244 : }
6245 6537 : if (e->ts.type == BT_CHARACTER)
6246 : {
6247 3409 : if (se.string_length)
6248 : gfc_strlen = se.string_length;
6249 883 : else if (e->ts.u.cl->backend_decl)
6250 : gfc_strlen = e->ts.u.cl->backend_decl;
6251 : else
6252 0 : gcc_unreachable ();
6253 : }
6254 6537 : gfc_add_block_to_block (&block, &se.pre);
6255 :
6256 : /* Create array descriptor and set version, rank, attribute, type. */
6257 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6258 : ? GFC_MAX_DIMENSIONS : e->rank,
6259 : false), "cfi");
6260 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6261 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6262 : {
6263 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6264 2338 : tmp = build_pointer_type (tmp);
6265 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6266 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6267 : }
6268 : else
6269 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6270 :
6271 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6272 6537 : gfc_add_modify (&block, tmp,
6273 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6274 6537 : if (e->rank < 0)
6275 305 : rank = gfc_conv_descriptor_rank_get (gfc);
6276 : else
6277 6232 : rank = gfc_rank_cst[e->rank];
6278 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6279 6537 : gfc_add_modify (&block, tmp,
6280 6537 : fold_convert (TREE_TYPE (tmp), rank));
6281 6537 : int itype = CFI_type_other;
6282 6537 : if (e->ts.f90_type == BT_VOID)
6283 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6284 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6285 : else
6286 : {
6287 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6288 1 : e->ts = fsym->ts;
6289 6441 : switch (e->ts.type)
6290 : {
6291 2296 : case BT_INTEGER:
6292 2296 : case BT_LOGICAL:
6293 2296 : case BT_REAL:
6294 2296 : case BT_COMPLEX:
6295 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6296 2296 : break;
6297 3410 : case BT_CHARACTER:
6298 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6299 3410 : break;
6300 : case BT_DERIVED:
6301 6537 : itype = CFI_type_struct;
6302 : break;
6303 0 : case BT_VOID:
6304 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6305 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6306 : break;
6307 : case BT_ASSUMED:
6308 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6309 : break;
6310 1 : case BT_CLASS:
6311 1 : if (fsym->ts.type == BT_ASSUMED)
6312 : {
6313 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6314 : // type specifier is assumed-type and is an unlimited polymorphic
6315 : // entity." The actual argument _data component is passed.
6316 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6317 : break;
6318 : }
6319 : else
6320 0 : gcc_unreachable ();
6321 :
6322 0 : case BT_UNSIGNED:
6323 0 : gfc_internal_error ("Unsigned not yet implemented");
6324 :
6325 0 : case BT_PROCEDURE:
6326 0 : case BT_HOLLERITH:
6327 0 : case BT_UNION:
6328 0 : case BT_BOZ:
6329 0 : case BT_UNKNOWN:
6330 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6331 0 : gcc_unreachable ();
6332 : }
6333 : }
6334 :
6335 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6336 6537 : gfc_add_modify (&block, tmp,
6337 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6338 :
6339 6537 : int attr = CFI_attribute_other;
6340 6537 : if (fsym->attr.pointer)
6341 : attr = CFI_attribute_pointer;
6342 5774 : else if (fsym->attr.allocatable)
6343 433 : attr = CFI_attribute_allocatable;
6344 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6345 6537 : gfc_add_modify (&block, tmp,
6346 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6347 :
6348 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6349 : That is very sensible for undefined pointers, but the C code might assume
6350 : that the pointer retains the value, in particular, if it was NULL. */
6351 6537 : if (e->rank == 0)
6352 : {
6353 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6354 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6355 : }
6356 : else
6357 : {
6358 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6359 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6360 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6361 : }
6362 :
6363 : /* Set elem_len if known - must be before the next if block.
6364 : Note that allocatable implies 'len=:'. */
6365 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6366 : {
6367 : /* Length is known at compile time; use 'block' for it. */
6368 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6369 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6370 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6371 : }
6372 :
6373 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6374 91 : goto done;
6375 :
6376 : /* When allocatable + intent out, free the cfi descriptor. */
6377 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6378 : {
6379 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6380 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6381 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6382 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6383 90 : gfc_add_modify (&block, tmp,
6384 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6385 90 : goto done;
6386 : }
6387 :
6388 : /* If not unallocated/unassociated. */
6389 6356 : gfc_init_block (&block2);
6390 :
6391 : /* Set elem_len, which may be only known at run time. */
6392 6356 : if (e->ts.type == BT_CHARACTER
6393 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6394 : {
6395 3408 : gcc_assert (gfc_strlen);
6396 3409 : tmp = gfc_strlen;
6397 3409 : if (e->ts.kind != 1)
6398 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6399 : gfc_charlen_type_node, tmp,
6400 : build_int_cst (gfc_charlen_type_node,
6401 1117 : e->ts.kind));
6402 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6403 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6404 : }
6405 2947 : else if (e->ts.type == BT_ASSUMED)
6406 : {
6407 54 : tmp = gfc_conv_descriptor_elem_len_get (gfc);
6408 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6409 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6410 : }
6411 :
6412 6356 : if (e->ts.type == BT_ASSUMED)
6413 : {
6414 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6415 : an CFI descriptor. Use the type in the descriptor as it provide
6416 : mode information. (Quality of implementation feature.) */
6417 54 : tree cond;
6418 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6419 54 : tree type = fold_convert (TREE_TYPE (ctype),
6420 : gfc_conv_descriptor_type_get (gfc));
6421 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6422 : gfc_conv_descriptor_elem_len_get (gfc));
6423 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6424 54 : kind, build_int_cst (TREE_TYPE (type),
6425 : CFI_type_kind_shift));
6426 :
6427 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6428 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6429 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6430 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6431 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6432 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6433 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6434 : ctype,
6435 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6436 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6437 : tmp, tmp2);
6438 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6439 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6440 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6441 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6442 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6443 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6444 : tmp, tmp2);
6445 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6446 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6447 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6448 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6449 54 : tmp = build_int_cst (TREE_TYPE (type),
6450 : CFI_type_from_type_kind (CFI_type_Character, 1));
6451 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6452 : ctype, tmp);
6453 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6454 : tmp, tmp2);
6455 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6456 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6457 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6458 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6459 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6460 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6461 54 : build_int_cst (TREE_TYPE (type),
6462 : CFI_type_Complex));
6463 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6464 : ctype, tmp);
6465 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6466 : tmp, tmp2);
6467 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6468 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6469 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6470 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6471 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6472 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6473 : cond, tmp);
6474 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6475 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6476 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6477 : cond, tmp);
6478 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6479 : type, kind);
6480 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6481 : ctype, tmp);
6482 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6483 : tmp, tmp2);
6484 54 : gfc_add_expr_to_block (&block2, tmp2);
6485 : }
6486 :
6487 6356 : if (e->rank != 0)
6488 : {
6489 : /* Loop: for (i = 0; i < rank; ++i). */
6490 5735 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6491 : /* Loop body. */
6492 5735 : stmtblock_t loop_body;
6493 5735 : gfc_init_block (&loop_body);
6494 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6495 : ? gfc->dim[i].lbound : 0 */
6496 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6497 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6498 : else
6499 5087 : tmp = gfc_index_zero_node;
6500 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6501 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6502 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6503 : gfc_conv_descriptor_ubound_get (gfc, idx),
6504 : gfc_conv_descriptor_lbound_get (gfc, idx));
6505 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6506 : tmp, gfc_index_one_node);
6507 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6508 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6509 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6510 : gfc_conv_descriptor_stride_get (gfc, idx),
6511 : gfc_conv_descriptor_span_get (gfc));
6512 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6513 :
6514 : /* Generate loop. */
6515 5735 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6516 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6517 :
6518 5735 : if (e->expr_type == EXPR_VARIABLE
6519 5573 : && e->ref
6520 5573 : && e->ref->u.ar.type == AR_FULL
6521 2732 : && e->symtree->n.sym->attr.dummy
6522 988 : && e->symtree->n.sym->as
6523 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6524 : {
6525 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6526 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6527 : }
6528 : }
6529 :
6530 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6531 : {
6532 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6533 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6534 : tmp, null_pointer_node);
6535 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6536 : build_empty_stmt (input_location));
6537 1015 : gfc_add_expr_to_block (&block, tmp);
6538 : }
6539 : else
6540 5341 : gfc_add_block_to_block (&block, &block2);
6541 :
6542 :
6543 6537 : done:
6544 6537 : if (present)
6545 : {
6546 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6547 103 : TREE_TYPE (parmse->expr),
6548 : present, parmse->expr, null_pointer_node);
6549 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6550 : build_empty_stmt (input_location));
6551 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6552 : }
6553 : else
6554 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6555 :
6556 6537 : gfc_init_block (&block);
6557 :
6558 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6559 1196 : || fsym->attr.intent == INTENT_IN)
6560 5550 : goto post_call;
6561 :
6562 987 : gfc_init_block (&block2);
6563 987 : if (e->rank == 0)
6564 : {
6565 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6566 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6567 : }
6568 : else
6569 : {
6570 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6571 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6572 :
6573 559 : if (fsym->attr.allocatable)
6574 : {
6575 : /* gfc->span = cfi->elem_len. */
6576 252 : tmp = fold_convert (gfc_array_index_type,
6577 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6578 : }
6579 : else
6580 : {
6581 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6582 : ? cfi->dim[0].sm : cfi->elem_len). */
6583 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6584 307 : tmp2 = fold_convert (gfc_array_index_type,
6585 : gfc_get_cfi_desc_elem_len (cfi));
6586 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6587 : gfc_array_index_type, tmp, tmp2);
6588 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6589 : tmp, gfc_index_zero_node);
6590 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6591 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6592 : }
6593 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6594 :
6595 : /* Calculate offset + set lbound, ubound and stride. */
6596 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6597 : /* Loop: for (i = 0; i < rank; ++i). */
6598 559 : tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
6599 : /* Loop body. */
6600 559 : stmtblock_t loop_body;
6601 559 : gfc_init_block (&loop_body);
6602 : /* gfc->dim[i].lbound = ... */
6603 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6604 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6605 :
6606 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6607 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6608 : gfc_conv_descriptor_lbound_get (gfc, idx),
6609 : gfc_index_one_node);
6610 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6611 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6612 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6613 :
6614 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6615 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6616 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6617 : gfc_array_index_type, tmp,
6618 : fold_convert (gfc_array_index_type,
6619 : gfc_get_cfi_desc_elem_len (cfi)));
6620 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6621 :
6622 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6623 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6624 : gfc_conv_descriptor_stride_get (gfc, idx),
6625 : gfc_conv_descriptor_lbound_get (gfc, idx));
6626 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6627 : gfc_conv_descriptor_offset_get (gfc), tmp);
6628 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6629 : /* Generate loop. */
6630 559 : gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
6631 : gfc_rank_cst[1], gfc_finish_block (&loop_body));
6632 : }
6633 :
6634 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6635 : {
6636 60 : tmp = fold_convert (gfc_charlen_type_node,
6637 : gfc_get_cfi_desc_elem_len (cfi));
6638 60 : if (e->ts.kind != 1)
6639 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6640 : gfc_charlen_type_node, tmp,
6641 : build_int_cst (gfc_charlen_type_node,
6642 24 : e->ts.kind));
6643 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6644 : }
6645 :
6646 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6647 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6648 : tmp, null_pointer_node);
6649 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6650 : build_empty_stmt (input_location));
6651 987 : gfc_add_expr_to_block (&block, tmp);
6652 :
6653 6537 : post_call:
6654 6537 : gfc_add_block_to_block (&block, &se.post);
6655 6537 : if (present && block.head)
6656 : {
6657 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6658 : build_empty_stmt (input_location));
6659 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6660 : }
6661 6531 : else if (block.head)
6662 1564 : gfc_add_block_to_block (&parmse->post, &block);
6663 6537 : }
6664 :
6665 :
6666 : /* Create "conditional temporary" to handle scalar dummy variables with the
6667 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6668 : as fallback. Does not handle CLASS. */
6669 :
6670 : static void
6671 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6672 : {
6673 234 : tree temp;
6674 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6675 234 : gcc_assert (e->rank == 0);
6676 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6677 234 : TREE_STATIC (temp) = 1;
6678 234 : TREE_CONSTANT (temp) = 1;
6679 234 : TREE_READONLY (temp) = 1;
6680 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6681 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6682 234 : TREE_TYPE (parmse->expr),
6683 : cond, parmse->expr, temp);
6684 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6685 234 : }
6686 :
6687 :
6688 : /* Returns true if the type specified in TS is a character type whose length
6689 : is constant. Otherwise returns false. */
6690 :
6691 : static bool
6692 22156 : gfc_const_length_character_type_p (gfc_typespec *ts)
6693 : {
6694 22156 : return (ts->type == BT_CHARACTER
6695 467 : && ts->u.cl
6696 467 : && ts->u.cl->length
6697 467 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6698 22623 : && ts->u.cl->length->ts.type == BT_INTEGER);
6699 : }
6700 :
6701 :
6702 : /* Helper function for the handling of (currently) scalar dummy variables
6703 : with the VALUE attribute. Argument parmse should already be set up. */
6704 : static void
6705 22589 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6706 : vec<tree, va_gc> *& optionalargs)
6707 : {
6708 22589 : tree tmp;
6709 :
6710 22589 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6711 :
6712 22589 : if (IS_PDT (e))
6713 : {
6714 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6715 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6716 6 : gfc_add_expr_to_block (&parmse->pre,
6717 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6718 : parmse->expr, tmp,
6719 : e->rank, 0));
6720 6 : parmse->expr = tmp;
6721 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6722 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6723 6 : return;
6724 : }
6725 :
6726 : /* Absent actual argument for optional scalar dummy. */
6727 22583 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6728 : {
6729 : /* For scalar arguments with VALUE attribute which are passed by
6730 : value, pass "0" and a hidden argument for the optional status. */
6731 427 : if (fsym->ts.type == BT_CHARACTER)
6732 : {
6733 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6734 : zero. */
6735 90 : parmse->expr = null_pointer_node;
6736 90 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6737 : }
6738 337 : else if (gfc_bt_struct (fsym->ts.type)
6739 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6740 : {
6741 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6742 : are pointers and passed as such below. */
6743 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6744 24 : TREE_CONSTANT (temp) = 1;
6745 24 : TREE_READONLY (temp) = 1;
6746 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6747 24 : parmse->expr = temp;
6748 24 : }
6749 : else
6750 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6751 : integer_zero_node);
6752 427 : vec_safe_push (optionalargs, boolean_false_node);
6753 :
6754 427 : return;
6755 : }
6756 :
6757 : /* Truncate a too long constant character actual argument. */
6758 22156 : if (gfc_const_length_character_type_p (&fsym->ts)
6759 467 : && e->expr_type == EXPR_CONSTANT
6760 22239 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6761 : e->value.character.length) < 0)
6762 : {
6763 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6764 :
6765 : /* Truncate actual string argument. */
6766 17 : gfc_conv_expr (parmse, e);
6767 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6768 17 : e->value.character.string);
6769 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6770 :
6771 17 : if (flen == 1)
6772 : {
6773 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6774 14 : gfc_conv_string_parameter (parmse);
6775 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6776 : e->ts.kind);
6777 : }
6778 :
6779 : /* Indicate value,optional scalar dummy argument as present. */
6780 17 : if (fsym->attr.optional)
6781 1 : vec_safe_push (optionalargs, boolean_true_node);
6782 : return;
6783 : }
6784 :
6785 : /* gfortran argument passing conventions:
6786 : actual arguments to CHARACTER(len=1),VALUE
6787 : dummy arguments are actually passed by value.
6788 : Strings are truncated to length 1. */
6789 22139 : if (gfc_length_one_character_type_p (&fsym->ts))
6790 : {
6791 378 : if (e->expr_type == EXPR_CONSTANT
6792 54 : && e->value.character.length > 1)
6793 : {
6794 0 : e->value.character.length = 1;
6795 0 : gfc_conv_expr (parmse, e);
6796 : }
6797 :
6798 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6799 378 : gfc_conv_string_parameter (parmse);
6800 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6801 : e->ts.kind);
6802 : /* Truncate resulting string to length 1. */
6803 378 : parmse->string_length = slen1;
6804 : }
6805 :
6806 22139 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6807 : {
6808 : /* F2018:15.5.2.12 Argument presence and
6809 : restrictions on arguments not present. */
6810 823 : if (e->expr_type == EXPR_VARIABLE
6811 650 : && e->rank == 0
6812 1419 : && (gfc_expr_attr (e).allocatable
6813 596 : || gfc_expr_attr (e).pointer))
6814 : {
6815 198 : gfc_se argse;
6816 198 : tree cond;
6817 198 : gfc_init_se (&argse, NULL);
6818 198 : argse.want_pointer = 1;
6819 198 : gfc_conv_expr (&argse, e);
6820 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6821 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6822 : argse.expr, cond);
6823 198 : if (e->symtree->n.sym->attr.dummy)
6824 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6825 : logical_type_node,
6826 : gfc_conv_expr_present (e->symtree->n.sym),
6827 : cond);
6828 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
6829 : /* Create "conditional temporary". */
6830 198 : conv_cond_temp (parmse, e, cond);
6831 : }
6832 625 : else if (e->expr_type != EXPR_VARIABLE
6833 452 : || !e->symtree->n.sym->attr.optional
6834 260 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6835 365 : vec_safe_push (optionalargs, boolean_true_node);
6836 : else
6837 : {
6838 260 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6839 260 : if (gfc_bt_struct (fsym->ts.type)
6840 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6841 36 : conv_cond_temp (parmse, e, tmp);
6842 224 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6843 84 : parmse->expr
6844 168 : = fold_build3_loc (input_location, COND_EXPR,
6845 84 : TREE_TYPE (parmse->expr),
6846 : tmp, parmse->expr,
6847 84 : fold_convert (TREE_TYPE (parmse->expr),
6848 : integer_zero_node));
6849 :
6850 520 : vec_safe_push (optionalargs,
6851 260 : fold_convert (boolean_type_node, tmp));
6852 : }
6853 : }
6854 : }
6855 :
6856 :
6857 : /* Helper function for the handling of NULL() actual arguments associated with
6858 : non-optional dummy variables. Argument parmse should already be set up. */
6859 : static void
6860 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
6861 : {
6862 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
6863 :
6864 : /* Obtain the character length for a NULL() actual with a character
6865 : MOLD argument. Otherwise substitute a suitable dummy length.
6866 : Here we handle only non-optional dummies of non-bind(c) procedures. */
6867 426 : if (fsym->ts.type == BT_CHARACTER)
6868 : {
6869 216 : if (e->ts.type == BT_CHARACTER
6870 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
6871 : {
6872 : /* MOLD is present. Substitute a temporary character NULL pointer.
6873 : For an assumed-rank dummy we need a descriptor that passes the
6874 : correct rank. */
6875 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
6876 : {
6877 54 : tree tmp = parmse->expr;
6878 54 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6879 54 : gfc_conv_descriptor_rank_set (&parmse->pre, tmp, e->rank);
6880 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6881 54 : }
6882 : else
6883 : {
6884 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
6885 108 : gfc_add_modify (&parmse->pre, tmp,
6886 108 : build_zero_cst (TREE_TYPE (tmp)));
6887 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6888 : }
6889 :
6890 : /* Ensure that a usable length is available. */
6891 162 : if (parmse->string_length == NULL_TREE)
6892 : {
6893 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
6894 :
6895 162 : if (ts->u.cl->length != NULL
6896 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6897 108 : gfc_conv_const_charlen (ts->u.cl);
6898 :
6899 162 : if (ts->u.cl->backend_decl)
6900 162 : parmse->string_length = ts->u.cl->backend_decl;
6901 : }
6902 : }
6903 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
6904 : {
6905 : /* MOLD is not present. Pass length of associated dummy character
6906 : argument if constant, or zero. */
6907 54 : if (fsym->ts.u.cl->length != NULL
6908 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6909 : {
6910 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
6911 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
6912 : }
6913 : else
6914 : {
6915 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
6916 : "slen");
6917 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
6918 : build_zero_cst (gfc_charlen_type_node));
6919 : }
6920 : }
6921 : }
6922 210 : else if (fsym->ts.type == BT_DERIVED)
6923 : {
6924 210 : if (e->ts.type != BT_UNKNOWN)
6925 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
6926 : For an assumed-rank dummy we provide a descriptor that passes
6927 : the correct rank. */
6928 : {
6929 138 : tree tmp = parmse->expr;
6930 :
6931 138 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, gfc_expr_attr (e));
6932 138 : gfc_conv_descriptor_rank_set (&parmse->pre, tmp, e->rank);
6933 138 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6934 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6935 : }
6936 : else
6937 : /* MOLD is not present. Use attributes from dummy argument, which is
6938 : not allowed to be assumed-rank. */
6939 : {
6940 72 : int dummy_rank;
6941 72 : tree tmp = parmse->expr;
6942 :
6943 72 : if ((fsym->attr.allocatable || fsym->attr.pointer)
6944 72 : && fsym->attr.intent == INTENT_UNKNOWN)
6945 36 : fsym->attr.intent = INTENT_IN;
6946 72 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6947 72 : dummy_rank = fsym->as ? fsym->as->rank : 0;
6948 24 : if (dummy_rank > 0)
6949 24 : gfc_conv_descriptor_rank_set (&parmse->pre, tmp, dummy_rank);
6950 72 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6951 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6952 : }
6953 : }
6954 426 : }
6955 :
6956 :
6957 : /* Return true if a subobject of the elements of an array is referenced. */
6958 :
6959 : static bool
6960 97 : is_subobject_ref (gfc_expr *e)
6961 : {
6962 97 : bool seen_array = false;
6963 :
6964 206 : for (gfc_ref *ref = e->ref; ref; ref = ref->next)
6965 : {
6966 115 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
6967 : seen_array = true;
6968 18 : else if (seen_array)
6969 : return true;
6970 : }
6971 :
6972 : return false;
6973 : }
6974 :
6975 :
6976 : /* Return true if the actual argument E for the dummy FSYM may be passed as a
6977 : copy-in/copy-out temporary. A pointer associated with a TARGET or POINTER
6978 : dummy must remain valid after the call, so the actual argument is passed
6979 : directly, with a descriptor whose span provides the element spacing. An
6980 : actual argument with a vector subscript is not definable and its pointer
6981 : association is undefined on return, so it is still copied. */
6982 :
6983 : static bool
6984 1071 : copy_in_out_allowed (gfc_symbol *fsym, gfc_expr *e, bool nodesc_arg)
6985 : {
6986 1071 : if (fsym == NULL || nodesc_arg || gfc_has_vector_subscript (e))
6987 : return true;
6988 :
6989 953 : if (gfc_is_span_addressed_dummy (fsym))
6990 : return false;
6991 :
6992 857 : return !(fsym->attr.pointer && !fsym->attr.contiguous && fsym->as
6993 6 : && (fsym->as->type == AS_ASSUMED_SHAPE
6994 : || fsym->as->type == AS_ASSUMED_RANK
6995 : || fsym->as->type == AS_DEFERRED));
6996 : }
6997 :
6998 :
6999 : /* Generate code for a procedure call. Note can return se->post != NULL.
7000 : If se->direct_byref is set then se->expr contains the return parameter.
7001 : Return nonzero, if the call has alternate specifiers.
7002 : 'expr' is only needed for procedure pointer components. */
7003 :
7004 : int
7005 137675 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
7006 : gfc_actual_arglist * args, gfc_expr * expr,
7007 : vec<tree, va_gc> *append_args)
7008 : {
7009 137675 : gfc_interface_mapping mapping;
7010 137675 : vec<tree, va_gc> *arglist;
7011 137675 : vec<tree, va_gc> *retargs;
7012 137675 : tree tmp;
7013 137675 : tree fntype;
7014 137675 : gfc_se parmse;
7015 137675 : gfc_array_info *info;
7016 137675 : int byref;
7017 137675 : int parm_kind;
7018 137675 : tree type;
7019 137675 : tree var;
7020 137675 : tree len;
7021 137675 : tree base_object;
7022 137675 : vec<tree, va_gc> *stringargs;
7023 137675 : vec<tree, va_gc> *optionalargs;
7024 137675 : tree result = NULL;
7025 137675 : gfc_formal_arglist *formal;
7026 137675 : gfc_actual_arglist *arg;
7027 137675 : int has_alternate_specifier = 0;
7028 137675 : bool need_interface_mapping;
7029 137675 : bool is_builtin;
7030 137675 : bool callee_alloc;
7031 137675 : bool ulim_copy;
7032 137675 : gfc_typespec ts;
7033 137675 : gfc_charlen cl;
7034 137675 : gfc_expr *e;
7035 137675 : gfc_symbol *fsym;
7036 137675 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
7037 137675 : gfc_component *comp = NULL;
7038 137675 : int arglen;
7039 137675 : unsigned int argc;
7040 137675 : tree arg1_cntnr = NULL_TREE;
7041 137675 : bool call_needed_for_length = true;
7042 137675 : arglist = NULL;
7043 137675 : retargs = NULL;
7044 137675 : stringargs = NULL;
7045 137675 : optionalargs = NULL;
7046 137675 : var = NULL_TREE;
7047 137675 : len = NULL_TREE;
7048 137675 : gfc_clear_ts (&ts);
7049 137675 : gfc_intrinsic_sym *isym = expr && expr->rank ?
7050 : expr->value.function.isym : NULL;
7051 :
7052 137675 : comp = gfc_get_proc_ptr_comp (expr);
7053 :
7054 275350 : bool elemental_proc = (comp
7055 2043 : && comp->ts.interface
7056 1989 : && comp->ts.interface->attr.elemental)
7057 1844 : || (comp && comp->attr.elemental)
7058 139519 : || sym->attr.elemental;
7059 :
7060 137675 : if (se->ss != NULL)
7061 : {
7062 25083 : if (!elemental_proc)
7063 : {
7064 21524 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
7065 21524 : if (se->ss->info->useflags)
7066 : {
7067 5796 : gcc_assert ((!comp && gfc_return_by_reference (sym)
7068 : && sym->result->attr.dimension)
7069 : || (comp && comp->attr.dimension)
7070 : || gfc_is_class_array_function (expr));
7071 5796 : gcc_assert (se->loop != NULL);
7072 : /* Access the previously obtained result. */
7073 5796 : gfc_conv_tmp_array_ref (se);
7074 5796 : return 0;
7075 : }
7076 : }
7077 19287 : info = &se->ss->info->data.array;
7078 : }
7079 : else
7080 : info = NULL;
7081 :
7082 131879 : stmtblock_t post, clobbers, dealloc_blk;
7083 131879 : gfc_init_block (&post);
7084 131879 : gfc_init_block (&clobbers);
7085 131879 : gfc_init_block (&dealloc_blk);
7086 131879 : gfc_init_interface_mapping (&mapping);
7087 131879 : if (!comp)
7088 : {
7089 129885 : formal = gfc_sym_get_dummy_args (sym);
7090 129885 : need_interface_mapping = sym->attr.dimension ||
7091 114409 : (sym->ts.type == BT_CHARACTER
7092 3204 : && sym->ts.u.cl->length
7093 2452 : && sym->ts.u.cl->length->expr_type
7094 : != EXPR_CONSTANT);
7095 : }
7096 : else
7097 : {
7098 1994 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
7099 1994 : need_interface_mapping = comp->attr.dimension ||
7100 1925 : (comp->ts.type == BT_CHARACTER
7101 229 : && comp->ts.u.cl->length
7102 220 : && comp->ts.u.cl->length->expr_type
7103 : != EXPR_CONSTANT);
7104 : }
7105 :
7106 131879 : base_object = NULL_TREE;
7107 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7108 : is the third and fourth argument to such a function call a value
7109 : denoting the number of elements to copy (i.e., most of the time the
7110 : length of a deferred length string). */
7111 263758 : ulim_copy = (formal == NULL)
7112 32261 : && UNLIMITED_POLY (sym)
7113 131959 : && comp && (strcmp ("_copy", comp->name) == 0);
7114 :
7115 : /* Scan for allocatable actual arguments passed to allocatable dummy
7116 : arguments with INTENT(OUT). As the corresponding actual arguments are
7117 : deallocated before execution of the procedure, we evaluate actual
7118 : argument expressions to avoid problems with possible dependencies. */
7119 131879 : bool force_eval_args = false;
7120 131879 : gfc_formal_arglist *tmp_formal;
7121 403961 : for (arg = args, tmp_formal = formal; arg != NULL;
7122 238730 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7123 : {
7124 272605 : e = arg->expr;
7125 272605 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7126 259141 : if (e && fsym
7127 227216 : && e->expr_type == EXPR_VARIABLE
7128 100017 : && fsym->attr.intent == INTENT_OUT
7129 6462 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7130 6462 : ? CLASS_DATA (fsym)->attr.allocatable
7131 4814 : : fsym->attr.allocatable)
7132 523 : && e->symtree
7133 523 : && e->symtree->n.sym
7134 531746 : && gfc_variable_attr (e, NULL).allocatable)
7135 : {
7136 : force_eval_args = true;
7137 : break;
7138 : }
7139 : }
7140 :
7141 : /* Evaluate the arguments. */
7142 404898 : for (arg = args, argc = 0; arg != NULL;
7143 273019 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7144 : {
7145 273019 : bool finalized = false;
7146 273019 : tree derived_array = NULL_TREE;
7147 273019 : symbol_attribute *attr;
7148 :
7149 273019 : e = arg->expr;
7150 273019 : fsym = formal ? formal->sym : NULL;
7151 512686 : parm_kind = MISSING;
7152 :
7153 239667 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7154 : : fsym->attr)
7155 : : nullptr;
7156 : /* If the procedure requires an explicit interface, the actual
7157 : argument is passed according to the corresponding formal
7158 : argument. If the corresponding formal argument is a POINTER,
7159 : ALLOCATABLE or assumed shape, we do not use g77's calling
7160 : convention, and pass the address of the array descriptor
7161 : instead. Otherwise we use g77's calling convention, in other words
7162 : pass the array data pointer without descriptor. */
7163 239614 : bool nodesc_arg = fsym != NULL
7164 239614 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7165 230500 : && fsym->as
7166 41103 : && fsym->as->type != AS_ASSUMED_SHAPE
7167 24868 : && fsym->as->type != AS_ASSUMED_RANK;
7168 273019 : if (comp)
7169 2749 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7170 : else
7171 270270 : nodesc_arg
7172 : = nodesc_arg
7173 270270 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7174 :
7175 : /* Class array expressions are sometimes coming completely unadorned
7176 : with either arrayspec or _data component. Correct that here.
7177 : OOP-TODO: Move this to the frontend. */
7178 273019 : if (e && e->expr_type == EXPR_VARIABLE
7179 114141 : && !e->ref
7180 51992 : && e->ts.type == BT_CLASS
7181 2645 : && (CLASS_DATA (e)->attr.codimension
7182 2645 : || CLASS_DATA (e)->attr.dimension))
7183 : {
7184 0 : gfc_typespec temp_ts = e->ts;
7185 0 : gfc_add_class_array_ref (e);
7186 0 : e->ts = temp_ts;
7187 : }
7188 :
7189 273019 : if (e == NULL
7190 259549 : || (e->expr_type == EXPR_NULL
7191 745 : && fsym
7192 745 : && fsym->attr.value
7193 72 : && fsym->attr.optional
7194 72 : && !fsym->attr.dimension
7195 72 : && fsym->ts.type != BT_CLASS))
7196 : {
7197 13542 : if (se->ignore_optional)
7198 : {
7199 : /* Some intrinsics have already been resolved to the correct
7200 : parameters. */
7201 434 : continue;
7202 : }
7203 13344 : else if (arg->label)
7204 : {
7205 224 : has_alternate_specifier = 1;
7206 224 : continue;
7207 : }
7208 : else
7209 : {
7210 13120 : gfc_init_se (&parmse, NULL);
7211 :
7212 : /* For scalar arguments with VALUE attribute which are passed by
7213 : value, pass "0" and a hidden argument gives the optional
7214 : status. */
7215 13120 : if (fsym && fsym->attr.optional && fsym->attr.value
7216 427 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7217 : {
7218 427 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7219 : }
7220 : else
7221 : {
7222 : /* Pass a NULL pointer for an absent arg. */
7223 12693 : parmse.expr = null_pointer_node;
7224 :
7225 : /* Is it an absent character dummy? */
7226 12693 : bool absent_char = false;
7227 12693 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7228 :
7229 : /* Fall back to inferred type only if no formal. */
7230 12693 : if (fsym)
7231 11635 : absent_char = (fsym->ts.type == BT_CHARACTER);
7232 1058 : else if (dummy_arg)
7233 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7234 : == BT_CHARACTER);
7235 12693 : if (absent_char)
7236 1115 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7237 : 0);
7238 : }
7239 : }
7240 : }
7241 259477 : else if (e->expr_type == EXPR_NULL
7242 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7243 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7244 293 : && fsym->ts.type == BT_DERIVED)
7245 : {
7246 210 : gfc_init_se (&parmse, NULL);
7247 210 : gfc_conv_expr_reference (&parmse, e);
7248 210 : conv_null_actual (&parmse, e, fsym);
7249 : }
7250 259267 : else if (arg->expr->expr_type == EXPR_NULL
7251 463 : && fsym && !fsym->attr.pointer
7252 163 : && (fsym->ts.type != BT_CLASS
7253 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7254 : {
7255 : /* Pass a NULL pointer to denote an absent arg. */
7256 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7257 : && (fsym->ts.type != BT_CLASS
7258 : || !CLASS_DATA (fsym)->attr.allocatable));
7259 163 : gfc_init_se (&parmse, NULL);
7260 163 : parmse.expr = null_pointer_node;
7261 163 : if (fsym->ts.type == BT_CHARACTER)
7262 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7263 : }
7264 259104 : else if (fsym && fsym->ts.type == BT_CLASS
7265 11465 : && e->ts.type == BT_DERIVED)
7266 : {
7267 : /* The derived type needs to be converted to a temporary
7268 : CLASS object. */
7269 4778 : gfc_init_se (&parmse, se);
7270 4778 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7271 4778 : fsym->attr.optional
7272 1008 : && e->expr_type == EXPR_VARIABLE
7273 1008 : && e->symtree->n.sym->attr.optional,
7274 4778 : CLASS_DATA (fsym)->attr.class_pointer
7275 4597 : || CLASS_DATA (fsym)->attr.allocatable,
7276 : sym->name, &derived_array);
7277 : }
7278 222401 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7279 954 : && e->ts.type != BT_PROCEDURE
7280 930 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7281 930 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7282 : {
7283 : /* The intrinsic type needs to be converted to a temporary
7284 : CLASS object for the unlimited polymorphic formal. */
7285 930 : gfc_find_vtab (&e->ts);
7286 930 : gfc_init_se (&parmse, se);
7287 930 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7288 :
7289 : }
7290 253396 : else if (se->ss && se->ss->info->useflags)
7291 : {
7292 5837 : gfc_ss *ss;
7293 :
7294 5837 : ss = se->ss;
7295 :
7296 : /* An elemental function inside a scalarized loop. */
7297 5837 : gfc_init_se (&parmse, se);
7298 5837 : parm_kind = ELEMENTAL;
7299 :
7300 : /* When no fsym is present, ulim_copy is set and this is a third or
7301 : fourth argument, use call-by-value instead of by reference to
7302 : hand the length properties to the copy routine (i.e., most of the
7303 : time this will be a call to a __copy_character_* routine where the
7304 : third and fourth arguments are the lengths of a deferred length
7305 : char array). */
7306 5837 : if ((fsym && fsym->attr.value)
7307 5603 : || (ulim_copy && (argc == 2 || argc == 3)))
7308 234 : gfc_conv_expr (&parmse, e);
7309 5603 : else if (e->expr_type == EXPR_ARRAY)
7310 : {
7311 306 : gfc_conv_expr (&parmse, e);
7312 306 : if (e->ts.type != BT_CHARACTER)
7313 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7314 : }
7315 : else
7316 5297 : gfc_conv_expr_reference (&parmse, e);
7317 :
7318 5837 : if (e->ts.type == BT_CHARACTER && !e->rank
7319 174 : && e->expr_type == EXPR_FUNCTION)
7320 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7321 : parmse.expr);
7322 :
7323 5787 : if (fsym && fsym->ts.type == BT_DERIVED
7324 7459 : && gfc_is_class_container_ref (e))
7325 : {
7326 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7327 :
7328 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7329 24 : && e->symtree->n.sym->attr.optional)
7330 : {
7331 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7332 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7333 0 : TREE_TYPE (parmse.expr),
7334 : cond, parmse.expr,
7335 0 : fold_convert (TREE_TYPE (parmse.expr),
7336 : null_pointer_node));
7337 : }
7338 : }
7339 :
7340 : /* Scalar dummy arguments of intrinsic type or derived type with
7341 : VALUE attribute. */
7342 5837 : if (fsym
7343 5787 : && fsym->attr.value
7344 234 : && fsym->ts.type != BT_CLASS)
7345 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7346 :
7347 : /* If we are passing an absent array as optional dummy to an
7348 : elemental procedure, make sure that we pass NULL when the data
7349 : pointer is NULL. We need this extra conditional because of
7350 : scalarization which passes arrays elements to the procedure,
7351 : ignoring the fact that the array can be absent/unallocated/... */
7352 5603 : else if (ss->info->can_be_null_ref
7353 415 : && ss->info->type != GFC_SS_REFERENCE)
7354 : {
7355 193 : tree descriptor_data;
7356 :
7357 193 : descriptor_data = ss->info->data.array.data;
7358 193 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7359 : descriptor_data,
7360 193 : fold_convert (TREE_TYPE (descriptor_data),
7361 : null_pointer_node));
7362 193 : parmse.expr
7363 386 : = fold_build3_loc (input_location, COND_EXPR,
7364 193 : TREE_TYPE (parmse.expr),
7365 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7366 193 : fold_convert (TREE_TYPE (parmse.expr),
7367 : null_pointer_node),
7368 : parmse.expr);
7369 : }
7370 :
7371 : /* The scalarizer does not repackage the reference to a class
7372 : array - instead it returns a pointer to the data element. */
7373 5837 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7374 210 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7375 186 : fsym->attr.intent != INTENT_IN
7376 : && (CLASS_DATA (fsym)->attr.class_pointer
7377 24 : || CLASS_DATA (fsym)->attr.allocatable),
7378 186 : fsym->attr.optional
7379 0 : && e->expr_type == EXPR_VARIABLE
7380 0 : && e->symtree->n.sym->attr.optional,
7381 186 : CLASS_DATA (fsym)->attr.class_pointer
7382 186 : || CLASS_DATA (fsym)->attr.allocatable);
7383 : }
7384 : else
7385 : {
7386 247559 : bool scalar;
7387 247559 : gfc_ss *argss;
7388 :
7389 247559 : gfc_init_se (&parmse, NULL);
7390 :
7391 : /* Check whether the expression is a scalar or not; we cannot use
7392 : e->rank as it can be nonzero for functions arguments. */
7393 247559 : argss = gfc_walk_expr (e);
7394 247559 : scalar = argss == gfc_ss_terminator;
7395 247559 : if (!scalar)
7396 60979 : gfc_free_ss_chain (argss);
7397 :
7398 : /* Special handling for passing scalar polymorphic coarrays;
7399 : otherwise one passes "class->_data.data" instead of "&class". */
7400 247559 : if (e->rank == 0 && e->ts.type == BT_CLASS
7401 3599 : && fsym && fsym->ts.type == BT_CLASS
7402 3177 : && CLASS_DATA (fsym)->attr.codimension
7403 55 : && !CLASS_DATA (fsym)->attr.dimension)
7404 : {
7405 55 : gfc_add_class_array_ref (e);
7406 55 : parmse.want_coarray = 1;
7407 55 : scalar = false;
7408 : }
7409 :
7410 : /* A scalar or transformational function. */
7411 247559 : if (scalar)
7412 : {
7413 186525 : if (e->expr_type == EXPR_VARIABLE
7414 55348 : && e->symtree->n.sym->attr.cray_pointee
7415 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7416 : {
7417 : /* The Cray pointer needs to be converted to a pointer to
7418 : a type given by the expression. */
7419 6 : gfc_conv_expr (&parmse, e);
7420 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7421 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7422 6 : parmse.expr = convert (type, tmp);
7423 : }
7424 :
7425 186519 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7426 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7427 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7428 :
7429 185832 : else if (fsym && fsym->attr.value)
7430 : {
7431 22100 : if (fsym->ts.type == BT_CHARACTER
7432 543 : && fsym->ts.is_c_interop
7433 181 : && fsym->ns->proc_name != NULL
7434 181 : && fsym->ns->proc_name->attr.is_bind_c)
7435 : {
7436 172 : parmse.expr = NULL;
7437 172 : conv_scalar_char_value (fsym, &parmse, &e);
7438 172 : if (parmse.expr == NULL)
7439 166 : gfc_conv_expr (&parmse, e);
7440 : }
7441 : else
7442 : {
7443 21928 : gfc_conv_expr (&parmse, e);
7444 21928 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7445 : }
7446 : }
7447 :
7448 163732 : else if (arg->name && arg->name[0] == '%')
7449 : /* Argument list functions %VAL, %LOC and %REF are signalled
7450 : through arg->name. */
7451 5826 : conv_arglist_function (&parmse, arg->expr, arg->name);
7452 157906 : else if ((e->expr_type == EXPR_FUNCTION)
7453 8305 : && ((e->value.function.esym
7454 2154 : && e->value.function.esym->result->attr.pointer)
7455 8210 : || (!e->value.function.esym
7456 6151 : && e->symtree->n.sym->attr.pointer))
7457 95 : && fsym && fsym->attr.target)
7458 : /* Make sure the function only gets called once. */
7459 8 : gfc_conv_expr_reference (&parmse, e);
7460 157898 : else if (e->expr_type == EXPR_FUNCTION
7461 8297 : && e->symtree->n.sym->result
7462 7262 : && e->symtree->n.sym->result != e->symtree->n.sym
7463 138 : && e->symtree->n.sym->result->attr.proc_pointer)
7464 : {
7465 : /* Functions returning procedure pointers. */
7466 18 : gfc_conv_expr (&parmse, e);
7467 18 : if (fsym && fsym->attr.proc_pointer)
7468 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7469 : }
7470 :
7471 : else
7472 : {
7473 157880 : bool defer_to_dealloc_blk = false;
7474 157880 : if (e->ts.type == BT_CLASS && fsym
7475 3532 : && fsym->ts.type == BT_CLASS
7476 3110 : && (!CLASS_DATA (fsym)->as
7477 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7478 2754 : && CLASS_DATA (e)->attr.codimension)
7479 : {
7480 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7481 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7482 48 : gfc_add_class_array_ref (e);
7483 48 : parmse.want_coarray = 1;
7484 48 : gfc_conv_expr_reference (&parmse, e);
7485 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7486 48 : fsym->attr.optional
7487 48 : && e->expr_type == EXPR_VARIABLE);
7488 : }
7489 157832 : else if (e->ts.type == BT_CLASS && fsym
7490 3484 : && fsym->ts.type == BT_CLASS
7491 3062 : && !CLASS_DATA (fsym)->as
7492 2706 : && !CLASS_DATA (e)->as
7493 2596 : && strcmp (fsym->ts.u.derived->name,
7494 : e->ts.u.derived->name))
7495 : {
7496 1649 : type = gfc_typenode_for_spec (&fsym->ts);
7497 1649 : var = gfc_create_var (type, fsym->name);
7498 1649 : gfc_conv_expr (&parmse, e);
7499 1649 : if (fsym->attr.optional
7500 153 : && e->expr_type == EXPR_VARIABLE
7501 153 : && e->symtree->n.sym->attr.optional)
7502 : {
7503 66 : stmtblock_t block;
7504 66 : tree cond;
7505 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7506 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7507 : logical_type_node, tmp,
7508 66 : fold_convert (TREE_TYPE (tmp),
7509 : null_pointer_node));
7510 66 : gfc_start_block (&block);
7511 66 : gfc_add_modify (&block, var,
7512 : fold_build1_loc (input_location,
7513 : VIEW_CONVERT_EXPR,
7514 : type, parmse.expr));
7515 66 : gfc_add_expr_to_block (&parmse.pre,
7516 : fold_build3_loc (input_location,
7517 : COND_EXPR, void_type_node,
7518 : cond, gfc_finish_block (&block),
7519 : build_empty_stmt (input_location)));
7520 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7521 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7522 66 : TREE_TYPE (parmse.expr),
7523 : cond, parmse.expr,
7524 66 : fold_convert (TREE_TYPE (parmse.expr),
7525 : null_pointer_node));
7526 66 : }
7527 : else
7528 : {
7529 : /* Since the internal representation of unlimited
7530 : polymorphic expressions includes an extra field
7531 : that other class objects do not, a cast to the
7532 : formal type does not work. */
7533 1583 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7534 : {
7535 91 : tree efield;
7536 :
7537 : /* Evaluate arguments just once, when they have
7538 : side effects. */
7539 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7540 : {
7541 25 : tree cldata, zero;
7542 :
7543 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7544 : &parmse.pre);
7545 :
7546 : /* Prevent memory leak, when old component
7547 : was allocated already. */
7548 25 : cldata = gfc_class_data_get (parmse.expr);
7549 25 : zero = build_int_cst (TREE_TYPE (cldata),
7550 : 0);
7551 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7552 : logical_type_node,
7553 : cldata, zero);
7554 25 : tmp = build3_v (COND_EXPR, tmp,
7555 : gfc_call_free (cldata),
7556 : build_empty_stmt (
7557 : input_location));
7558 25 : gfc_add_expr_to_block (&parmse.finalblock,
7559 : tmp);
7560 25 : gfc_add_modify (&parmse.finalblock,
7561 : cldata, zero);
7562 : }
7563 :
7564 : /* Set the _data field. */
7565 91 : tmp = gfc_class_data_get (var);
7566 91 : efield = fold_convert (TREE_TYPE (tmp),
7567 : gfc_class_data_get (parmse.expr));
7568 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7569 :
7570 : /* Set the _vptr field. */
7571 91 : tmp = gfc_class_vptr_get (var);
7572 91 : efield = fold_convert (TREE_TYPE (tmp),
7573 : gfc_class_vptr_get (parmse.expr));
7574 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7575 :
7576 : /* Set the _len field. */
7577 91 : tmp = gfc_class_len_get (var);
7578 91 : gfc_add_modify (&parmse.pre, tmp,
7579 91 : build_int_cst (TREE_TYPE (tmp), 0));
7580 91 : }
7581 : else
7582 : {
7583 1492 : tmp = fold_build1_loc (input_location,
7584 : VIEW_CONVERT_EXPR,
7585 : type, parmse.expr);
7586 1492 : gfc_add_modify (&parmse.pre, var, tmp);
7587 1583 : ;
7588 : }
7589 1583 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7590 : }
7591 : }
7592 : else
7593 : {
7594 156183 : gfc_conv_expr_reference (&parmse, e);
7595 :
7596 156183 : gfc_symbol *dsym = fsym;
7597 156183 : gfc_dummy_arg *dummy;
7598 :
7599 : /* Use associated dummy as fallback for formal
7600 : argument if there is no explicit interface. */
7601 156183 : if (dsym == NULL
7602 27440 : && (dummy = arg->associated_dummy)
7603 24901 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7604 179677 : && dummy->u.non_intrinsic->sym)
7605 156183 : dsym = dummy->u.non_intrinsic->sym;
7606 :
7607 156183 : if (dsym
7608 152237 : && dsym->attr.intent == INTENT_OUT
7609 3273 : && !dsym->attr.allocatable
7610 3130 : && !dsym->attr.pointer
7611 3112 : && e->expr_type == EXPR_VARIABLE
7612 3111 : && e->ref == NULL
7613 3002 : && e->symtree
7614 3002 : && e->symtree->n.sym
7615 3002 : && !e->symtree->n.sym->attr.dimension
7616 3002 : && e->ts.type != BT_CHARACTER
7617 2900 : && e->ts.type != BT_CLASS
7618 2664 : && (e->ts.type != BT_DERIVED
7619 492 : || (dsym->ts.type == BT_DERIVED
7620 492 : && e->ts.u.derived == dsym->ts.u.derived
7621 : /* Types with allocatable components are
7622 : excluded from clobbering because we need
7623 : the unclobbered pointers to free the
7624 : allocatable components in the callee.
7625 : Same goes for finalizable types or types
7626 : with finalizable components, we need to
7627 : pass the unclobbered values to the
7628 : finalization routines.
7629 : For parameterized types, it's less clear
7630 : but they may not have a constant size
7631 : so better exclude them in any case. */
7632 477 : && !e->ts.u.derived->attr.alloc_comp
7633 351 : && !e->ts.u.derived->attr.pdt_type
7634 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7635 2481 : && e->ts.type != BT_PROCEDURE
7636 158628 : && !sym->attr.elemental)
7637 : {
7638 1112 : tree var;
7639 1112 : var = build_fold_indirect_ref_loc (input_location,
7640 : parmse.expr);
7641 1112 : tree clobber = build_clobber (TREE_TYPE (var));
7642 1112 : gfc_add_modify (&clobbers, var, clobber);
7643 : }
7644 : }
7645 : /* Catch base objects that are not variables. */
7646 157880 : if (e->ts.type == BT_CLASS
7647 3532 : && e->expr_type != EXPR_VARIABLE
7648 306 : && expr && e == expr->base_expr)
7649 80 : base_object = build_fold_indirect_ref_loc (input_location,
7650 : parmse.expr);
7651 :
7652 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7653 : allocated on entry, it must be deallocated. */
7654 130440 : if (fsym && fsym->attr.intent == INTENT_OUT
7655 3202 : && (fsym->attr.allocatable
7656 3059 : || (fsym->ts.type == BT_CLASS
7657 265 : && CLASS_DATA (fsym)->attr.allocatable))
7658 158178 : && !is_CFI_desc (fsym, NULL))
7659 : {
7660 298 : stmtblock_t block;
7661 298 : tree ptr;
7662 :
7663 298 : defer_to_dealloc_blk = true;
7664 :
7665 298 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7666 : &parmse.pre);
7667 :
7668 298 : if (parmse.class_container != NULL_TREE)
7669 162 : parmse.class_container
7670 162 : = gfc_evaluate_data_ref_now (parmse.class_container,
7671 : &parmse.pre);
7672 :
7673 298 : gfc_init_block (&block);
7674 298 : ptr = parmse.expr;
7675 298 : if (e->ts.type == BT_CLASS)
7676 162 : ptr = gfc_class_data_get (ptr);
7677 :
7678 298 : tree cls = parmse.class_container;
7679 298 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7680 : NULL_TREE, true,
7681 : e, e->ts, cls);
7682 298 : gfc_add_expr_to_block (&block, tmp);
7683 298 : gfc_add_modify (&block, ptr,
7684 298 : fold_convert (TREE_TYPE (ptr),
7685 : null_pointer_node));
7686 :
7687 298 : if (fsym->ts.type == BT_CLASS)
7688 155 : gfc_reset_vptr (&block, nullptr,
7689 : build_fold_indirect_ref (parmse.expr),
7690 155 : fsym->ts.u.derived);
7691 :
7692 298 : if (fsym->attr.optional
7693 42 : && e->expr_type == EXPR_VARIABLE
7694 42 : && e->symtree->n.sym->attr.optional)
7695 : {
7696 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7697 : void_type_node,
7698 18 : gfc_conv_expr_present (e->symtree->n.sym),
7699 : gfc_finish_block (&block),
7700 : build_empty_stmt (input_location));
7701 : }
7702 : else
7703 280 : tmp = gfc_finish_block (&block);
7704 :
7705 298 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7706 : }
7707 :
7708 : /* A class array element needs converting back to be a
7709 : class object, if the formal argument is a class object. */
7710 157880 : if (fsym && fsym->ts.type == BT_CLASS
7711 3134 : && e->ts.type == BT_CLASS
7712 3110 : && ((CLASS_DATA (fsym)->as
7713 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7714 2754 : || CLASS_DATA (e)->attr.dimension))
7715 : {
7716 466 : gfc_se class_se = parmse;
7717 466 : gfc_init_block (&class_se.pre);
7718 466 : gfc_init_block (&class_se.post);
7719 :
7720 733 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7721 466 : fsym->attr.intent != INTENT_IN
7722 : && (CLASS_DATA (fsym)->attr.class_pointer
7723 267 : || CLASS_DATA (fsym)->attr.allocatable),
7724 466 : fsym->attr.optional
7725 198 : && e->expr_type == EXPR_VARIABLE
7726 198 : && e->symtree->n.sym->attr.optional,
7727 466 : CLASS_DATA (fsym)->attr.class_pointer
7728 430 : || CLASS_DATA (fsym)->attr.allocatable);
7729 :
7730 466 : parmse.expr = class_se.expr;
7731 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7732 466 : ? &dealloc_blk
7733 : : &parmse.pre;
7734 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7735 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7736 : }
7737 :
7738 130440 : if (fsym && (fsym->ts.type == BT_DERIVED
7739 118494 : || fsym->ts.type == BT_ASSUMED)
7740 12813 : && e->ts.type == BT_CLASS
7741 410 : && !CLASS_DATA (e)->attr.dimension
7742 374 : && !CLASS_DATA (e)->attr.codimension)
7743 : {
7744 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7745 : /* The result is a class temporary, whose _data component
7746 : must be freed to avoid a memory leak. */
7747 374 : if (e->expr_type == EXPR_FUNCTION
7748 23 : && CLASS_DATA (e)->attr.allocatable)
7749 : {
7750 19 : tree zero;
7751 :
7752 : /* Finalize the expression. */
7753 19 : gfc_finalize_tree_expr (&parmse, NULL,
7754 19 : gfc_expr_attr (e), e->rank);
7755 19 : gfc_add_block_to_block (&parmse.post,
7756 : &parmse.finalblock);
7757 :
7758 : /* Then free the class _data. */
7759 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7760 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7761 : logical_type_node,
7762 : parmse.expr, zero);
7763 19 : tmp = build3_v (COND_EXPR, tmp,
7764 : gfc_call_free (parmse.expr),
7765 : build_empty_stmt (input_location));
7766 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7767 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7768 : }
7769 : }
7770 :
7771 : /* Wrap scalar variable in a descriptor. We need to convert
7772 : the address of a pointer back to the pointer itself before,
7773 : we can assign it to the data field. */
7774 :
7775 130440 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7776 1344 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7777 : {
7778 1272 : tmp = parmse.expr;
7779 1272 : if (TREE_CODE (tmp) == ADDR_EXPR)
7780 754 : tmp = TREE_OPERAND (tmp, 0);
7781 1272 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7782 : fsym->attr);
7783 1272 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
7784 : parmse.expr);
7785 : }
7786 129168 : else if (fsym && e->expr_type != EXPR_NULL
7787 128870 : && ((fsym->attr.pointer
7788 1740 : && fsym->attr.flavor != FL_PROCEDURE)
7789 127136 : || (fsym->attr.proc_pointer
7790 199 : && !(e->expr_type == EXPR_VARIABLE
7791 199 : && e->symtree->n.sym->attr.dummy))
7792 126949 : || (fsym->attr.proc_pointer
7793 12 : && e->expr_type == EXPR_VARIABLE
7794 12 : && gfc_is_proc_ptr_comp (e))
7795 126943 : || (fsym->attr.allocatable
7796 1041 : && fsym->attr.flavor != FL_PROCEDURE)))
7797 : {
7798 : /* Scalar pointer dummy args require an extra level of
7799 : indirection. The null pointer already contains
7800 : this level of indirection. */
7801 2962 : parm_kind = SCALAR_POINTER;
7802 2962 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7803 : }
7804 : }
7805 : }
7806 61034 : else if (e->ts.type == BT_CLASS
7807 2807 : && fsym && fsym->ts.type == BT_CLASS
7808 2425 : && (CLASS_DATA (fsym)->attr.dimension
7809 55 : || CLASS_DATA (fsym)->attr.codimension))
7810 : {
7811 : /* Pass a class array. */
7812 2425 : gfc_conv_expr_descriptor (&parmse, e);
7813 2425 : bool defer_to_dealloc_blk = false;
7814 :
7815 2425 : if (fsym->attr.optional
7816 798 : && e->expr_type == EXPR_VARIABLE
7817 798 : && e->symtree->n.sym->attr.optional)
7818 : {
7819 438 : stmtblock_t block;
7820 :
7821 438 : gfc_init_block (&block);
7822 438 : gfc_add_block_to_block (&block, &parmse.pre);
7823 :
7824 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
7825 : void_type_node,
7826 438 : gfc_conv_expr_present (e->symtree->n.sym),
7827 : gfc_finish_block (&block),
7828 : build_empty_stmt (input_location));
7829 :
7830 438 : gfc_add_expr_to_block (&parmse.pre, t);
7831 : }
7832 :
7833 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7834 : allocated on entry, it must be deallocated. */
7835 2425 : if (fsym->attr.intent == INTENT_OUT
7836 153 : && CLASS_DATA (fsym)->attr.allocatable)
7837 : {
7838 122 : stmtblock_t block;
7839 122 : tree ptr;
7840 :
7841 : /* In case the data reference to deallocate is dependent on
7842 : its own content, save the resulting pointer to a variable
7843 : and only use that variable from now on, before the
7844 : expression becomes invalid. */
7845 122 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7846 : &parmse.pre);
7847 :
7848 122 : if (parmse.class_container != NULL_TREE)
7849 122 : parmse.class_container
7850 122 : = gfc_evaluate_data_ref_now (parmse.class_container,
7851 : &parmse.pre);
7852 :
7853 122 : gfc_init_block (&block);
7854 122 : ptr = parmse.expr;
7855 122 : ptr = gfc_class_data_get (ptr);
7856 :
7857 122 : tree cls = parmse.class_container;
7858 122 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
7859 : NULL_TREE, NULL_TREE,
7860 : NULL_TREE, true, e,
7861 : GFC_CAF_COARRAY_NOCOARRAY,
7862 : cls);
7863 122 : gfc_add_expr_to_block (&block, tmp);
7864 122 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7865 : void_type_node, ptr,
7866 : null_pointer_node);
7867 122 : gfc_add_expr_to_block (&block, tmp);
7868 122 : gfc_reset_vptr (&block, e, parmse.class_container);
7869 :
7870 122 : if (fsym->attr.optional
7871 30 : && e->expr_type == EXPR_VARIABLE
7872 30 : && (!e->ref
7873 30 : || (e->ref->type == REF_ARRAY
7874 0 : && e->ref->u.ar.type != AR_FULL))
7875 0 : && e->symtree->n.sym->attr.optional)
7876 : {
7877 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7878 : void_type_node,
7879 0 : gfc_conv_expr_present (e->symtree->n.sym),
7880 : gfc_finish_block (&block),
7881 : build_empty_stmt (input_location));
7882 : }
7883 : else
7884 122 : tmp = gfc_finish_block (&block);
7885 :
7886 122 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7887 122 : defer_to_dealloc_blk = true;
7888 : }
7889 :
7890 2425 : gfc_se class_se = parmse;
7891 2425 : gfc_init_block (&class_se.pre);
7892 2425 : gfc_init_block (&class_se.post);
7893 :
7894 2425 : if (e->expr_type != EXPR_VARIABLE)
7895 : {
7896 : int n;
7897 : /* Set the bounds and offset correctly. */
7898 60 : for (n = 0; n < e->rank; n++)
7899 30 : gfc_conv_shift_descriptor_lbound (&class_se.pre,
7900 : class_se.expr,
7901 : n, gfc_index_one_node);
7902 : }
7903 :
7904 : /* The conversion does not repackage the reference to a class
7905 : array - _data descriptor. */
7906 3852 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7907 2425 : fsym->attr.intent != INTENT_IN
7908 : && (CLASS_DATA (fsym)->attr.class_pointer
7909 1241 : || CLASS_DATA (fsym)->attr.allocatable),
7910 2425 : fsym->attr.optional
7911 798 : && e->expr_type == EXPR_VARIABLE
7912 798 : && e->symtree->n.sym->attr.optional,
7913 2425 : CLASS_DATA (fsym)->attr.class_pointer
7914 1999 : || CLASS_DATA (fsym)->attr.allocatable);
7915 :
7916 2425 : parmse.expr = class_se.expr;
7917 2303 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7918 2425 : ? &dealloc_blk
7919 : : &parmse.pre;
7920 2425 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7921 2425 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7922 :
7923 2425 : if (e->expr_type == EXPR_OP
7924 12 : && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
7925 2437 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
7926 : {
7927 12 : tree cond;
7928 12 : tree dealloc_expr = gfc_finish_block (&parmse.post);
7929 12 : tmp = TREE_OPERAND (parmse.expr, 0);
7930 12 : gfc_init_block (&parmse.post);
7931 12 : cond = gfc_class_data_get (tmp);
7932 12 : tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
7933 : tmp, e->rank, true);
7934 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7935 12 : cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
7936 12 : cond = gfc_conv_descriptor_data_get (cond);
7937 12 : cond = fold_build2_loc (input_location, NE_EXPR,
7938 : logical_type_node, cond,
7939 12 : build_int_cst (TREE_TYPE (cond), 0));
7940 12 : tmp = build3_v (COND_EXPR, cond, dealloc_expr,
7941 : build_empty_stmt (input_location));
7942 :
7943 : /* This specific case should not be processed further and so
7944 : bundle everything up and proceed to the next argument. */
7945 12 : if (fsym && need_interface_mapping && e)
7946 12 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
7947 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7948 12 : gfc_add_block_to_block (&se->pre, &parmse.pre);
7949 12 : gfc_add_block_to_block (&post, &parmse.post);
7950 12 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
7951 12 : vec_safe_push (arglist, parmse.expr);
7952 12 : continue;
7953 12 : }
7954 2413 : }
7955 : else
7956 : {
7957 : /* If the argument is a function call that may not create
7958 : a temporary for the result, we have to check that we
7959 : can do it, i.e. that there is no alias between this
7960 : argument and another one. */
7961 58609 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7962 : {
7963 406 : gfc_expr *iarg;
7964 406 : sym_intent intent;
7965 :
7966 406 : if (fsym != NULL)
7967 397 : intent = fsym->attr.intent;
7968 : else
7969 : intent = INTENT_UNKNOWN;
7970 :
7971 406 : if (gfc_check_fncall_dependency (e, intent, sym, args,
7972 : NOT_ELEMENTAL))
7973 21 : parmse.force_tmp = 1;
7974 :
7975 406 : iarg = e->value.function.actual->expr;
7976 :
7977 : /* Temporary needed if aliasing due to host association. */
7978 406 : if (sym->attr.contained
7979 168 : && !sym->attr.pure
7980 168 : && !sym->attr.implicit_pure
7981 84 : && !sym->attr.use_assoc
7982 84 : && iarg->expr_type == EXPR_VARIABLE
7983 84 : && sym->ns == iarg->symtree->n.sym->ns)
7984 36 : parmse.force_tmp = 1;
7985 :
7986 : /* Ditto within module. */
7987 406 : if (sym->attr.use_assoc
7988 6 : && !sym->attr.pure
7989 6 : && !sym->attr.implicit_pure
7990 0 : && iarg->expr_type == EXPR_VARIABLE
7991 0 : && sym->module == iarg->symtree->n.sym->module)
7992 0 : parmse.force_tmp = 1;
7993 : }
7994 :
7995 : /* Special case for assumed-rank arrays: when passing an
7996 : argument to a nonallocatable/nonpointer dummy, the bounds have
7997 : to be reset as otherwise a last-dim ubound of -1 is
7998 : indistinguishable from an assumed-size array in the callee. */
7999 58609 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
8000 35530 : && fsym->as->type == AS_ASSUMED_RANK
8001 11978 : && e->rank != -1
8002 11664 : && e->expr_type == EXPR_VARIABLE
8003 11199 : && ((fsym->ts.type == BT_CLASS
8004 0 : && !CLASS_DATA (fsym)->attr.class_pointer
8005 0 : && !CLASS_DATA (fsym)->attr.allocatable)
8006 11199 : || (fsym->ts.type != BT_CLASS
8007 11199 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
8008 : {
8009 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
8010 10656 : gfc_ref *ref;
8011 10920 : for (ref = e->ref; ref->next; ref = ref->next)
8012 : {
8013 342 : if (ref->next->type == REF_INQUIRY)
8014 : break;
8015 294 : if (ref->type == REF_ARRAY
8016 30 : && ref->u.ar.type != AR_ELEMENT)
8017 : break;
8018 10656 : };
8019 10656 : if (ref->u.ar.type == AR_FULL
8020 9906 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
8021 9786 : ref->u.ar.type = AR_SECTION;
8022 : }
8023 :
8024 58609 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
8025 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
8026 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
8027 :
8028 52759 : else if (e->expr_type == EXPR_VARIABLE
8029 41175 : && is_subref_array (e)
8030 1179 : && !(fsym && fsym->attr.pointer)
8031 53673 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8032 : /* The actual argument is a component reference to an
8033 : array of derived types. In this case, the argument
8034 : is converted to a temporary, which is passed and then
8035 : written back after the procedure call. The elements of
8036 : a span addressed dummy passed on as a whole are usually
8037 : contiguous, so the copy is made conditional. */
8038 2484 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8039 800 : fsym ? fsym->attr.intent : INTENT_INOUT,
8040 800 : fsym && fsym->attr.pointer, fsym, sym->name,
8041 : NULL,
8042 842 : gfc_is_span_addressed_dummy (e->symtree->n.sym)
8043 97 : && !is_subobject_ref (e));
8044 :
8045 51917 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
8046 381 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
8047 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
8048 : /* An assumed size class actual argument being passed to
8049 : a 'no descriptor' formal argument just requires the
8050 : data pointer to be passed. For class dummy arguments
8051 : this is stored in the symbol backend decl.. */
8052 6 : parmse.expr = e->symtree->n.sym->backend_decl;
8053 :
8054 51911 : else if (gfc_is_class_array_ref (e, NULL)
8055 368 : && fsym && fsym->ts.type == BT_DERIVED
8056 52055 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8057 : /* The actual argument is a component reference to an
8058 : array of derived types. In this case, the argument
8059 : is converted to a temporary, which is passed and then
8060 : written back after the procedure call. */
8061 114 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8062 114 : fsym->attr.intent,
8063 114 : fsym->attr.pointer);
8064 :
8065 51797 : else if (gfc_is_class_array_function (e)
8066 13 : && fsym && fsym->ts.type == BT_DERIVED
8067 51810 : && copy_in_out_allowed (fsym, e, nodesc_arg))
8068 : /* See previous comment. For function actual argument,
8069 : the write out is not needed so the intent is set as
8070 : intent in. */
8071 : {
8072 13 : e->must_finalize = 1;
8073 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8074 13 : INTENT_IN, fsym->attr.pointer);
8075 : }
8076 48203 : else if (fsym && fsym->attr.contiguous
8077 84 : && (fsym->attr.target
8078 1756 : ? gfc_is_not_contiguous (e)
8079 1672 : : !gfc_is_simply_contiguous (e, false, true))
8080 357 : && gfc_expr_is_variable (e)
8081 53885 : && e->rank != -1)
8082 : {
8083 333 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
8084 333 : fsym->attr.intent,
8085 333 : fsym->attr.pointer);
8086 : }
8087 : else
8088 : {
8089 : /* Having declined copy-in/copy-out above, a subobject of an
8090 : array is described by a spanned descriptor. */
8091 51451 : if (e->expr_type == EXPR_VARIABLE && is_subref_array (e))
8092 337 : parmse.force_no_tmp = 1;
8093 :
8094 : /* This is where we introduce a temporary to store the
8095 : result of a non-lvalue array expression. */
8096 51451 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
8097 : sym->name, NULL);
8098 : }
8099 :
8100 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8101 : allocated on entry, it must be deallocated.
8102 : CFI descriptors are handled elsewhere. */
8103 54986 : if (fsym && fsym->attr.allocatable
8104 1787 : && fsym->attr.intent == INTENT_OUT
8105 58352 : && !is_CFI_desc (fsym, NULL))
8106 : {
8107 161 : if (fsym->ts.type == BT_DERIVED
8108 47 : && fsym->ts.u.derived->attr.alloc_comp)
8109 : {
8110 : // deallocate the components first
8111 11 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
8112 : parmse.expr, e->rank);
8113 : /* But check whether dummy argument is optional. */
8114 11 : if (tmp != NULL_TREE
8115 11 : && fsym->attr.optional
8116 6 : && e->expr_type == EXPR_VARIABLE
8117 6 : && e->symtree->n.sym->attr.optional)
8118 : {
8119 6 : tree present;
8120 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
8121 6 : tmp = build3_v (COND_EXPR, present, tmp,
8122 : build_empty_stmt (input_location));
8123 : }
8124 11 : if (tmp != NULL_TREE)
8125 11 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8126 : }
8127 :
8128 161 : tmp = parmse.expr;
8129 : /* With bind(C), the actual argument is replaced by a bind-C
8130 : descriptor; in this case, the data component arrives here,
8131 : which shall not be dereferenced, but still freed and
8132 : nullified. */
8133 161 : if (TREE_TYPE(tmp) != pvoid_type_node)
8134 161 : tmp = build_fold_indirect_ref_loc (input_location,
8135 : parmse.expr);
8136 161 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8137 : NULL_TREE, NULL_TREE, true,
8138 : e,
8139 : GFC_CAF_COARRAY_NOCOARRAY);
8140 161 : if (fsym->attr.optional
8141 48 : && e->expr_type == EXPR_VARIABLE
8142 48 : && e->symtree->n.sym->attr.optional)
8143 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
8144 : void_type_node,
8145 24 : gfc_conv_expr_present (e->symtree->n.sym),
8146 : tmp, build_empty_stmt (input_location));
8147 161 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8148 : }
8149 : }
8150 : }
8151 : /* Special case for an assumed-rank dummy argument. */
8152 272585 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
8153 57384 : && (fsym->ts.type == BT_CLASS
8154 57384 : ? (CLASS_DATA (fsym)->as
8155 4696 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
8156 52688 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8157 : {
8158 12815 : if (fsym->ts.type == BT_CLASS
8159 12815 : ? (CLASS_DATA (fsym)->attr.class_pointer
8160 1067 : || CLASS_DATA (fsym)->attr.allocatable)
8161 11748 : : (fsym->attr.pointer || fsym->attr.allocatable))
8162 : {
8163 : /* Unallocated allocatable arrays and unassociated pointer
8164 : arrays need their dtype setting if they are argument
8165 : associated with assumed rank dummies to set the rank. */
8166 891 : set_dtype_for_unallocated (&parmse, e);
8167 : }
8168 11924 : else if (e->expr_type == EXPR_VARIABLE
8169 11421 : && e->symtree->n.sym->attr.dummy
8170 722 : && (e->ts.type == BT_CLASS
8171 915 : ? (e->ref && e->ref->next
8172 193 : && e->ref->next->type == REF_ARRAY
8173 193 : && e->ref->next->u.ar.type == AR_FULL
8174 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8175 529 : : (e->ref && e->ref->type == REF_ARRAY
8176 529 : && e->ref->u.ar.type == AR_FULL
8177 757 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8178 : {
8179 : /* Assumed-size actual to assumed-rank dummy requires
8180 : dim[rank-1].ubound = -1. */
8181 180 : tree minus_one;
8182 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8183 180 : if (fsym->ts.type == BT_CLASS)
8184 60 : tmp = gfc_class_data_get (tmp);
8185 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8186 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8187 180 : gfc_rank_cst[e->rank - 1],
8188 : minus_one);
8189 : }
8190 : }
8191 :
8192 : /* The case with fsym->attr.optional is that of a user subroutine
8193 : with an interface indicating an optional argument. When we call
8194 : an intrinsic subroutine, however, fsym is NULL, but we might still
8195 : have an optional argument, so we proceed to the substitution
8196 : just in case. Arguments passed to bind(c) procedures via CFI
8197 : descriptors are handled elsewhere. */
8198 259537 : if (e && (fsym == NULL || fsym->attr.optional)
8199 333053 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8200 : {
8201 : /* If an optional argument is itself an optional dummy argument,
8202 : check its presence and substitute a null if absent. This is
8203 : only needed when passing an array to an elemental procedure
8204 : as then array elements are accessed - or no NULL pointer is
8205 : allowed and a "1" or "0" should be passed if not present.
8206 : When passing a non-array-descriptor full array to a
8207 : non-array-descriptor dummy, no check is needed. For
8208 : array-descriptor actual to array-descriptor dummy, see
8209 : PR 41911 for why a check has to be inserted.
8210 : fsym == NULL is checked as intrinsics required the descriptor
8211 : but do not always set fsym.
8212 : Also, it is necessary to pass a NULL pointer to library routines
8213 : which usually ignore optional arguments, so they can handle
8214 : these themselves. */
8215 59374 : if (e->expr_type == EXPR_VARIABLE
8216 26463 : && e->symtree->n.sym->attr.optional
8217 2421 : && (((e->rank != 0 && elemental_proc)
8218 2246 : || e->representation.length || e->ts.type == BT_CHARACTER
8219 2020 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8220 1910 : || (e->rank != 0
8221 1070 : && (fsym == NULL
8222 1034 : || (fsym->as
8223 272 : && (fsym->as->type == AS_ASSUMED_SHAPE
8224 235 : || fsym->as->type == AS_ASSUMED_RANK
8225 117 : || fsym->as->type == AS_DEFERRED)))))
8226 1685 : || se->ignore_optional))
8227 764 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8228 764 : e->representation.length);
8229 : }
8230 :
8231 : /* Make the class container for the first argument available with class
8232 : valued transformational functions. */
8233 272585 : if (argc == 0 && e && e->ts.type == BT_CLASS
8234 5093 : && isym && isym->transformational
8235 84 : && se->ss && se->ss->info)
8236 : {
8237 84 : arg1_cntnr = parmse.expr;
8238 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8239 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8240 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8241 84 : se->ss->info->class_container = arg1_cntnr;
8242 : }
8243 :
8244 : /* Obtain the character length of an assumed character length procedure
8245 : from the typespec of the actual argument. */
8246 272585 : if (e
8247 259537 : && parmse.string_length == NULL_TREE
8248 223915 : && e->ts.type == BT_PROCEDURE
8249 1941 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8250 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8251 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8252 : {
8253 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8254 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8255 : }
8256 :
8257 272585 : if (fsym && e)
8258 : {
8259 : /* Obtain the character length for a NULL() actual with a character
8260 : MOLD argument. Otherwise substitute a suitable dummy length.
8261 : Here we handle non-optional dummies of non-bind(c) procedures. */
8262 227612 : if (e->expr_type == EXPR_NULL
8263 745 : && fsym->ts.type == BT_CHARACTER
8264 296 : && !fsym->attr.optional
8265 227830 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8266 216 : conv_null_actual (&parmse, e, fsym);
8267 : }
8268 :
8269 : /* If any actual argument of the procedure is allocatable and passed
8270 : to an allocatable dummy with INTENT(OUT), we conservatively
8271 : evaluate actual argument expressions before deallocations are
8272 : performed and the procedure is executed. May create temporaries.
8273 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8274 259537 : if (e && fsym && force_eval_args
8275 1144 : && fsym->attr.intent != INTENT_OUT
8276 273012 : && !gfc_is_constant_expr (e))
8277 274 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8278 :
8279 272585 : if (fsym && need_interface_mapping && e)
8280 40552 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8281 :
8282 272585 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8283 272585 : gfc_add_block_to_block (&post, &parmse.post);
8284 272585 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8285 :
8286 : /* Allocated allocatable components of derived types must be
8287 : deallocated for non-variable scalars, array arguments to elemental
8288 : procedures, and array arguments with descriptor to non-elemental
8289 : procedures. As bounds information for descriptorless arrays is no
8290 : longer available here, they are dealt with in trans-array.cc
8291 : (gfc_conv_array_parameter). */
8292 259537 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8293 28697 : && e->ts.u.derived->attr.alloc_comp
8294 7665 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8295 280112 : && !expr_may_alias_variables (e, elemental_proc))
8296 : {
8297 372 : int parm_rank;
8298 : /* It is known the e returns a structure type with at least one
8299 : allocatable component. When e is a function, ensure that the
8300 : function is called once only by using a temporary variable. */
8301 372 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8302 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8303 : parmse.expr, &se->pre);
8304 :
8305 372 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8306 152 : tmp = parmse.expr;
8307 : else
8308 220 : tmp = build_fold_indirect_ref_loc (input_location,
8309 : parmse.expr);
8310 :
8311 372 : parm_rank = e->rank;
8312 372 : switch (parm_kind)
8313 : {
8314 : case (ELEMENTAL):
8315 : case (SCALAR):
8316 372 : parm_rank = 0;
8317 : break;
8318 :
8319 0 : case (SCALAR_POINTER):
8320 0 : tmp = build_fold_indirect_ref_loc (input_location,
8321 : tmp);
8322 0 : break;
8323 : }
8324 :
8325 372 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8326 : {
8327 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8328 : Therefore, class actuals can be handled correctly but derived
8329 : types passed to class formals need the _data component. */
8330 82 : tmp = gfc_class_data_get (tmp);
8331 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8332 : {
8333 56 : if (UNLIMITED_POLY (fsym))
8334 : {
8335 12 : tree type = gfc_typenode_for_spec (&e->ts);
8336 12 : type = build_pointer_type (type);
8337 12 : tmp = fold_convert (type, tmp);
8338 : }
8339 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8340 : }
8341 : }
8342 :
8343 372 : if (e->expr_type == EXPR_OP
8344 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8345 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8346 : {
8347 24 : tree local_tmp;
8348 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8349 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8350 : parm_rank, 0);
8351 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8352 : }
8353 :
8354 : /* Items of array expressions passed to a polymorphic formal arguments
8355 : create their own clean up, so prevent double free. */
8356 372 : if (!finalized && !e->must_finalize
8357 371 : && !(e->expr_type == EXPR_ARRAY && fsym
8358 86 : && fsym->ts.type == BT_CLASS))
8359 : {
8360 351 : bool scalar_res_outside_loop;
8361 1041 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8362 151 : && parm_rank == 0
8363 490 : && parmse.loop;
8364 :
8365 : /* Scalars passed to an assumed rank argument are converted to
8366 : a descriptor. Obtain the data field before deallocating any
8367 : allocatable components. */
8368 298 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8369 612 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8370 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8371 :
8372 351 : if (scalar_res_outside_loop)
8373 : {
8374 : /* Go through the ss chain to find the argument and use
8375 : the stored value. */
8376 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8377 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8378 60 : if (tmp_ss->info
8379 48 : && tmp_ss->info->expr == e
8380 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8381 : {
8382 18 : tmp = tmp_ss->info->data.scalar.value;
8383 18 : break;
8384 : }
8385 : }
8386 :
8387 351 : STRIP_NOPS (tmp);
8388 :
8389 351 : if (derived_array != NULL_TREE)
8390 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8391 : derived_array,
8392 : parm_rank);
8393 351 : else if ((e->ts.type == BT_CLASS
8394 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8395 351 : || e->ts.type == BT_DERIVED)
8396 351 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8397 : parm_rank, 0, true);
8398 0 : else if (e->ts.type == BT_CLASS)
8399 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8400 : tmp, parm_rank);
8401 :
8402 351 : if (scalar_res_outside_loop)
8403 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8404 : else
8405 321 : gfc_prepend_expr_to_block (&post, tmp);
8406 : }
8407 : }
8408 :
8409 : /* Add argument checking of passing an unallocated/NULL actual to
8410 : a nonallocatable/nonpointer dummy. */
8411 :
8412 272585 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8413 : {
8414 6546 : symbol_attribute attr;
8415 6546 : char *msg;
8416 6546 : tree cond;
8417 6546 : tree tmp;
8418 6546 : symbol_attribute fsym_attr;
8419 :
8420 6546 : if (fsym)
8421 : {
8422 6385 : if (fsym->ts.type == BT_CLASS)
8423 : {
8424 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8425 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8426 : }
8427 : else
8428 6064 : fsym_attr = fsym->attr;
8429 : }
8430 :
8431 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8432 4094 : attr = gfc_expr_attr (e);
8433 : else
8434 6081 : goto end_pointer_check;
8435 :
8436 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8437 : allocatable to an optional dummy, cf. 12.5.2.12. */
8438 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8439 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8440 1032 : goto end_pointer_check;
8441 :
8442 3062 : if (attr.optional)
8443 : {
8444 : /* If the actual argument is an optional pointer/allocatable and
8445 : the formal argument takes an nonpointer optional value,
8446 : it is invalid to pass a non-present argument on, even
8447 : though there is no technical reason for this in gfortran.
8448 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8449 60 : tree present, null_ptr, type;
8450 :
8451 60 : if (attr.allocatable
8452 0 : && (fsym == NULL || !fsym_attr.allocatable))
8453 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8454 : "allocated or not present",
8455 0 : e->symtree->n.sym->name);
8456 60 : else if (attr.pointer
8457 12 : && (fsym == NULL || !fsym_attr.pointer))
8458 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8459 : "associated or not present",
8460 12 : e->symtree->n.sym->name);
8461 48 : else if (attr.proc_pointer && !e->value.function.actual
8462 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8463 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8464 : "associated or not present",
8465 0 : e->symtree->n.sym->name);
8466 : else
8467 48 : goto end_pointer_check;
8468 :
8469 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8470 12 : type = TREE_TYPE (present);
8471 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8472 : logical_type_node, present,
8473 : fold_convert (type,
8474 : null_pointer_node));
8475 12 : type = TREE_TYPE (parmse.expr);
8476 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8477 : logical_type_node, parmse.expr,
8478 : fold_convert (type,
8479 : null_pointer_node));
8480 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8481 : logical_type_node, present, null_ptr);
8482 : }
8483 : else
8484 : {
8485 3002 : if (attr.allocatable
8486 256 : && (fsym == NULL || !fsym_attr.allocatable))
8487 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8488 190 : "allocated", e->symtree->n.sym->name);
8489 2812 : else if (attr.pointer
8490 272 : && (fsym == NULL || !fsym_attr.pointer))
8491 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8492 184 : "associated", e->symtree->n.sym->name);
8493 2628 : else if (attr.proc_pointer && !e->value.function.actual
8494 80 : && (fsym == NULL
8495 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8496 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8497 79 : "associated", e->symtree->n.sym->name);
8498 : else
8499 2549 : goto end_pointer_check;
8500 :
8501 453 : tmp = parmse.expr;
8502 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8503 : {
8504 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8505 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8506 76 : tmp = gfc_class_data_get (tmp);
8507 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8508 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8509 : }
8510 :
8511 : /* If the argument is passed by value, we need to strip the
8512 : INDIRECT_REF. */
8513 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8514 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8515 :
8516 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8517 : logical_type_node, tmp,
8518 453 : fold_convert (TREE_TYPE (tmp),
8519 : null_pointer_node));
8520 : }
8521 :
8522 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8523 : msg);
8524 465 : free (msg);
8525 : }
8526 266039 : end_pointer_check:
8527 :
8528 : /* Deferred length dummies pass the character length by reference
8529 : so that the value can be returned. */
8530 272585 : if (parmse.string_length && fsym && fsym->ts.deferred)
8531 : {
8532 795 : if (INDIRECT_REF_P (parmse.string_length))
8533 : {
8534 : /* In chains of functions/procedure calls the string_length already
8535 : is a pointer to the variable holding the length. Therefore
8536 : remove the deref on call. */
8537 90 : tmp = parmse.string_length;
8538 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8539 : }
8540 : else
8541 : {
8542 705 : tmp = parmse.string_length;
8543 705 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8544 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8545 705 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8546 : }
8547 :
8548 795 : if (e && e->expr_type == EXPR_VARIABLE
8549 638 : && fsym->attr.allocatable
8550 368 : && e->ts.u.cl->backend_decl
8551 368 : && VAR_P (e->ts.u.cl->backend_decl))
8552 : {
8553 284 : if (INDIRECT_REF_P (tmp))
8554 0 : tmp = TREE_OPERAND (tmp, 0);
8555 284 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8556 : fold_convert (gfc_charlen_type_node, tmp));
8557 : }
8558 : }
8559 :
8560 : /* Character strings are passed as two parameters, a length and a
8561 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8562 : An unlimited polymorphic formal argument likewise does not
8563 : need the length. */
8564 272585 : if (parmse.string_length != NULL_TREE
8565 37020 : && !sym->attr.is_bind_c
8566 36324 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8567 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8568 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8569 30439 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8570 30330 : && !(fsym && UNLIMITED_POLY (fsym)))
8571 36034 : vec_safe_push (stringargs, parmse.string_length);
8572 :
8573 : /* When calling __copy for character expressions to unlimited
8574 : polymorphic entities, the dst argument needs a string length. */
8575 52002 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8576 5326 : && startswith (sym->name, "__vtab_CHARACTER")
8577 0 : && arg->next && arg->next->expr
8578 0 : && (arg->next->expr->ts.type == BT_DERIVED
8579 0 : || arg->next->expr->ts.type == BT_CLASS)
8580 272585 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8581 0 : vec_safe_push (stringargs, parmse.string_length);
8582 :
8583 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8584 : pass the token and the offset as additional arguments. */
8585 272585 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8586 122 : && attr->codimension && !attr->allocatable)
8587 : {
8588 : /* Token and offset. */
8589 5 : vec_safe_push (stringargs, null_pointer_node);
8590 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8591 5 : gcc_assert (fsym->attr.optional);
8592 : }
8593 239597 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8594 145 : && !attr->allocatable)
8595 : {
8596 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8597 123 : tree offset, tmp2;
8598 :
8599 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8600 123 : caf_type = TREE_TYPE (caf_decl);
8601 123 : if (POINTER_TYPE_P (caf_type)
8602 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8603 3 : caf_desc = TREE_TYPE (caf_type);
8604 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8605 : caf_desc = caf_type;
8606 :
8607 51 : if (caf_desc
8608 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8609 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8610 : {
8611 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8612 54 : ? build_fold_indirect_ref (caf_decl)
8613 : : caf_decl;
8614 51 : tmp = gfc_conv_descriptor_token (tmp);
8615 : }
8616 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8617 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8618 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8619 : else
8620 : {
8621 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8622 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8623 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8624 : }
8625 :
8626 123 : vec_safe_push (stringargs, tmp);
8627 :
8628 123 : if (caf_desc
8629 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8630 51 : offset = build_int_cst (gfc_array_index_type, 0);
8631 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8632 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8633 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8634 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8635 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8636 : else
8637 60 : offset = build_int_cst (gfc_array_index_type, 0);
8638 :
8639 123 : if (caf_desc)
8640 : {
8641 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8642 54 : ? build_fold_indirect_ref (caf_decl)
8643 : : caf_decl;
8644 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8645 : }
8646 : else
8647 : {
8648 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8649 72 : tmp = caf_decl;
8650 : }
8651 :
8652 108 : tmp2 = fsym->ts.type == BT_CLASS
8653 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8654 123 : if ((fsym->ts.type != BT_CLASS
8655 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8656 59 : || fsym->as->type == AS_ASSUMED_RANK))
8657 74 : || (fsym->ts.type == BT_CLASS
8658 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8659 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8660 : {
8661 54 : if (fsym->ts.type == BT_CLASS)
8662 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8663 : else
8664 : {
8665 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8666 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8667 : }
8668 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8669 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8670 : }
8671 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8672 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8673 : else
8674 : {
8675 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8676 : }
8677 :
8678 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8679 : gfc_array_index_type,
8680 : fold_convert (gfc_array_index_type, tmp2),
8681 : fold_convert (gfc_array_index_type, tmp));
8682 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8683 : gfc_array_index_type, offset, tmp);
8684 :
8685 123 : vec_safe_push (stringargs, offset);
8686 : }
8687 :
8688 272585 : vec_safe_push (arglist, parmse.expr);
8689 : }
8690 :
8691 131879 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8692 131879 : gfc_add_block_to_block (&se->pre, &clobbers);
8693 131879 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8694 :
8695 131879 : if (comp)
8696 1994 : ts = comp->ts;
8697 129885 : else if (sym->ts.type == BT_CLASS)
8698 863 : ts = CLASS_DATA (sym)->ts;
8699 : else
8700 129022 : ts = sym->ts;
8701 :
8702 131879 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8703 210 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8704 131669 : else if (ts.type == BT_CHARACTER)
8705 : {
8706 5046 : if (ts.u.cl->length == NULL)
8707 : {
8708 : /* Assumed character length results are not allowed by C418 of the 2003
8709 : standard and are trapped in resolve.cc; except in the case of SPREAD
8710 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8711 : we take the character length of the first argument for the result.
8712 : For dummies, we have to look through the formal argument list for
8713 : this function and use the character length found there.
8714 : Likewise, we handle the case of deferred-length character dummy
8715 : arguments to intrinsics that determine the characteristics of
8716 : the result, which cannot be deferred-length. */
8717 2315 : if (expr->value.function.isym)
8718 1703 : ts.deferred = false;
8719 2315 : if (ts.deferred)
8720 605 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8721 1710 : else if (!sym->attr.dummy)
8722 1703 : cl.backend_decl = (*stringargs)[0];
8723 : else
8724 : {
8725 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8726 26 : for (; formal; formal = formal->next)
8727 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8728 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8729 : }
8730 : len = cl.backend_decl;
8731 : }
8732 : else
8733 : {
8734 2731 : tree tmp;
8735 :
8736 : /* Calculate the length of the returned string. */
8737 2731 : gfc_init_se (&parmse, NULL);
8738 2731 : if (need_interface_mapping)
8739 1885 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8740 : else
8741 846 : gfc_conv_expr (&parmse, ts.u.cl->length);
8742 2731 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8743 2731 : gfc_add_block_to_block (&se->post, &parmse.post);
8744 2731 : tmp = parmse.expr;
8745 : /* TODO: It would be better to have the charlens as
8746 : gfc_charlen_type_node already when the interface is
8747 : created instead of converting it here (see PR 84615). */
8748 2731 : tmp = fold_build2_loc (input_location, MAX_EXPR,
8749 : gfc_charlen_type_node,
8750 : fold_convert (gfc_charlen_type_node, tmp),
8751 : build_zero_cst (gfc_charlen_type_node));
8752 2731 : cl.backend_decl = tmp;
8753 :
8754 : /* The length was fully computed above from the specification
8755 : expression, without needing the callee to actually run. */
8756 2731 : call_needed_for_length = false;
8757 : }
8758 :
8759 : /* Set up a charlen structure for it. */
8760 5046 : cl.next = NULL;
8761 5046 : cl.length = NULL;
8762 5046 : ts.u.cl = &cl;
8763 :
8764 5046 : len = cl.backend_decl;
8765 : }
8766 :
8767 1994 : byref = (comp && (comp->attr.dimension
8768 1925 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
8769 131879 : || (!comp && gfc_return_by_reference (sym));
8770 :
8771 : if (byref)
8772 : {
8773 18829 : if (se->direct_byref)
8774 : {
8775 : /* Sometimes, too much indirection can be applied; e.g. for
8776 : function_result = array_valued_recursive_function. */
8777 6993 : if (TREE_TYPE (TREE_TYPE (se->expr))
8778 6993 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
8779 7011 : && GFC_DESCRIPTOR_TYPE_P
8780 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
8781 18 : se->expr = build_fold_indirect_ref_loc (input_location,
8782 : se->expr);
8783 :
8784 : /* If the lhs of an assignment x = f(..) is allocatable and
8785 : f2003 is allowed, we must do the automatic reallocation.
8786 : TODO - deal with intrinsics, without using a temporary. */
8787 6993 : if (flag_realloc_lhs
8788 6918 : && se->ss && se->ss->loop_chain
8789 203 : && se->ss->loop_chain->is_alloc_lhs
8790 203 : && !expr->value.function.isym
8791 203 : && sym->result->as != NULL)
8792 : {
8793 : /* Evaluate the bounds of the result, if known. */
8794 203 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
8795 : sym->result->as);
8796 :
8797 : /* Perform the automatic reallocation. */
8798 203 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
8799 : expr, NULL);
8800 203 : gfc_add_expr_to_block (&se->pre, tmp);
8801 :
8802 : /* Pass the temporary as the first argument. */
8803 203 : result = info->descriptor;
8804 : }
8805 : else
8806 6790 : result = build_fold_indirect_ref_loc (input_location,
8807 : se->expr);
8808 6993 : vec_safe_push (retargs, se->expr);
8809 : }
8810 11836 : else if (comp && comp->attr.dimension)
8811 : {
8812 66 : gcc_assert (se->loop && info);
8813 :
8814 : /* Set the type of the array. vtable charlens are not always reliable.
8815 : Use the interface, if possible. */
8816 66 : if (comp->ts.type == BT_CHARACTER
8817 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
8818 1 : && comp->ts.interface && comp->ts.interface->result)
8819 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
8820 : else
8821 65 : tmp = gfc_typenode_for_spec (&comp->ts);
8822 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
8823 :
8824 : /* Evaluate the bounds of the result, if known. */
8825 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
8826 :
8827 : /* If the lhs of an assignment x = f(..) is allocatable and
8828 : f2003 is allowed, we must not generate the function call
8829 : here but should just send back the results of the mapping.
8830 : This is signalled by the function ss being flagged. */
8831 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8832 : {
8833 0 : gfc_free_interface_mapping (&mapping);
8834 0 : return has_alternate_specifier;
8835 : }
8836 :
8837 : /* Create a temporary to store the result. In case the function
8838 : returns a pointer, the temporary will be a shallow copy and
8839 : mustn't be deallocated. */
8840 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
8841 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8842 : tmp, NULL_TREE, false,
8843 : !comp->attr.pointer, callee_alloc,
8844 66 : &se->ss->info->expr->where);
8845 :
8846 : /* Pass the temporary as the first argument. */
8847 66 : result = info->descriptor;
8848 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8849 66 : vec_safe_push (retargs, tmp);
8850 : }
8851 11541 : else if (!comp && sym->result->attr.dimension)
8852 : {
8853 8486 : gcc_assert (se->loop && info);
8854 :
8855 : /* Set the type of the array. */
8856 8486 : tmp = gfc_typenode_for_spec (&ts);
8857 8486 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
8858 8486 : gcc_assert (se->ss->dimen == se->loop->dimen);
8859 :
8860 : /* Evaluate the bounds of the result, if known. */
8861 8486 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
8862 :
8863 : /* If the lhs of an assignment x = f(..) is allocatable and
8864 : f2003 is allowed, we must not generate the function call
8865 : here but should just send back the results of the mapping.
8866 : This is signalled by the function ss being flagged. */
8867 8486 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8868 : {
8869 0 : gfc_free_interface_mapping (&mapping);
8870 0 : return has_alternate_specifier;
8871 : }
8872 :
8873 : /* Create a temporary to store the result. In case the function
8874 : returns a pointer, the temporary will be a shallow copy and
8875 : mustn't be deallocated. */
8876 8486 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
8877 8486 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8878 : tmp, NULL_TREE, false,
8879 : !sym->attr.pointer, callee_alloc,
8880 8486 : &se->ss->info->expr->where);
8881 :
8882 : /* Pass the temporary as the first argument. */
8883 8486 : result = info->descriptor;
8884 8486 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8885 8486 : vec_safe_push (retargs, tmp);
8886 : }
8887 3284 : else if (ts.type == BT_CHARACTER)
8888 : {
8889 : /* Pass the string length. */
8890 3223 : type = gfc_get_character_type (ts.kind, ts.u.cl);
8891 3223 : type = build_pointer_type (type);
8892 :
8893 : /* Emit a DECL_EXPR for the VLA type. */
8894 3223 : tmp = TREE_TYPE (type);
8895 3223 : if (TYPE_SIZE (tmp)
8896 3223 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
8897 : {
8898 1935 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
8899 1935 : DECL_ARTIFICIAL (tmp) = 1;
8900 1935 : DECL_IGNORED_P (tmp) = 1;
8901 1935 : tmp = fold_build1_loc (input_location, DECL_EXPR,
8902 1935 : TREE_TYPE (tmp), tmp);
8903 1935 : gfc_add_expr_to_block (&se->pre, tmp);
8904 : }
8905 :
8906 : /* Return an address to a char[0:len-1]* temporary for
8907 : character pointers. */
8908 3223 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8909 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8910 : {
8911 648 : var = gfc_create_var (type, "pstr");
8912 :
8913 648 : if ((!comp && sym->attr.allocatable)
8914 21 : || (comp && comp->attr.allocatable))
8915 : {
8916 361 : gfc_add_modify (&se->pre, var,
8917 361 : fold_convert (TREE_TYPE (var),
8918 : null_pointer_node));
8919 361 : tmp = gfc_call_free (var);
8920 361 : gfc_add_expr_to_block (&se->post, tmp);
8921 : }
8922 :
8923 : /* Provide an address expression for the function arguments. */
8924 648 : var = gfc_build_addr_expr (NULL_TREE, var);
8925 : }
8926 : else
8927 2575 : var = gfc_conv_string_tmp (se, type, len);
8928 :
8929 3223 : vec_safe_push (retargs, var);
8930 : }
8931 : else
8932 : {
8933 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
8934 :
8935 61 : type = gfc_get_complex_type (ts.kind);
8936 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
8937 61 : vec_safe_push (retargs, var);
8938 : }
8939 :
8940 : /* Add the string length to the argument list. */
8941 18829 : if (ts.type == BT_CHARACTER && ts.deferred)
8942 : {
8943 605 : tmp = len;
8944 605 : if (!VAR_P (tmp))
8945 0 : tmp = gfc_evaluate_now (len, &se->pre);
8946 605 : TREE_STATIC (tmp) = 1;
8947 605 : gfc_add_modify (&se->pre, tmp,
8948 605 : build_int_cst (TREE_TYPE (tmp), 0));
8949 605 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8950 605 : vec_safe_push (retargs, tmp);
8951 : }
8952 18224 : else if (ts.type == BT_CHARACTER)
8953 4441 : vec_safe_push (retargs, len);
8954 : }
8955 :
8956 131879 : gfc_free_interface_mapping (&mapping);
8957 :
8958 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
8959 245387 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
8960 157320 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
8961 131879 : vec_safe_reserve (retargs, arglen);
8962 :
8963 : /* Add the return arguments. */
8964 131879 : vec_safe_splice (retargs, arglist);
8965 :
8966 : /* Add the hidden present status for optional+value to the arguments. */
8967 131879 : vec_safe_splice (retargs, optionalargs);
8968 :
8969 : /* Add the hidden string length parameters to the arguments. */
8970 131879 : vec_safe_splice (retargs, stringargs);
8971 :
8972 : /* We may want to append extra arguments here. This is used e.g. for
8973 : calls to libgfortran_matmul_??, which need extra information. */
8974 131879 : vec_safe_splice (retargs, append_args);
8975 :
8976 131879 : arglist = retargs;
8977 :
8978 : /* Generate the actual call. */
8979 131879 : is_builtin = false;
8980 131879 : if (base_object == NULL_TREE)
8981 131799 : conv_function_val (se, &is_builtin, sym, expr, args);
8982 : else
8983 80 : conv_base_obj_fcn_val (se, base_object, expr);
8984 :
8985 : /* If there are alternate return labels, function type should be
8986 : integer. Can't modify the type in place though, since it can be shared
8987 : with other functions. For dummy arguments, the typing is done to
8988 : this result, even if it has to be repeated for each call. */
8989 131879 : if (has_alternate_specifier
8990 131879 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
8991 : {
8992 7 : if (!sym->attr.dummy)
8993 : {
8994 0 : TREE_TYPE (sym->backend_decl)
8995 0 : = build_function_type (integer_type_node,
8996 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
8997 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
8998 : }
8999 : else
9000 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
9001 : }
9002 :
9003 131879 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
9004 131879 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
9005 :
9006 131879 : if (is_builtin)
9007 567 : se->expr = update_builtin_function (se->expr, sym);
9008 :
9009 : /* Allocatable scalar function results must be freed and nullified
9010 : after use. This necessitates the creation of a temporary to
9011 : hold the result to prevent duplicate calls. */
9012 131879 : symbol_attribute attr = comp ? comp->attr : sym->attr;
9013 131879 : bool allocatable = attr.allocatable && !attr.dimension;
9014 135219 : gfc_symbol *der = comp ?
9015 1994 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
9016 : :
9017 129885 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
9018 3340 : bool finalizable = der != NULL && der->ns->proc_name
9019 6677 : && gfc_is_finalizable (der, NULL);
9020 :
9021 131879 : if (!byref && finalizable)
9022 188 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9023 :
9024 131879 : if (!byref && sym->ts.type != BT_CHARACTER
9025 112840 : && allocatable && !finalizable)
9026 : {
9027 236 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
9028 236 : gfc_add_modify (&se->pre, tmp, se->expr);
9029 236 : se->expr = tmp;
9030 236 : tmp = gfc_call_free (tmp);
9031 236 : gfc_add_expr_to_block (&post, tmp);
9032 236 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
9033 : }
9034 :
9035 : /* If we have a pointer function, but we don't want a pointer, e.g.
9036 : something like
9037 : x = f()
9038 : where f is pointer valued, we have to dereference the result. */
9039 131879 : if (!se->want_pointer && !byref
9040 112448 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9041 1652 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
9042 462 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9043 :
9044 : /* f2c calling conventions require a scalar default real function to
9045 : return a double precision result. Convert this back to default
9046 : real. We only care about the cases that can happen in Fortran 77.
9047 : */
9048 131879 : if (flag_f2c && sym->ts.type == BT_REAL
9049 98 : && sym->ts.kind == gfc_default_real_kind
9050 74 : && !sym->attr.pointer
9051 55 : && !sym->attr.allocatable
9052 43 : && !sym->attr.always_explicit)
9053 43 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
9054 :
9055 : /* A pure function may still have side-effects - it may modify its
9056 : parameters. */
9057 131879 : TREE_SIDE_EFFECTS (se->expr) = 1;
9058 : #if 0
9059 : if (!sym->attr.pure)
9060 : TREE_SIDE_EFFECTS (se->expr) = 1;
9061 : #endif
9062 :
9063 131879 : if (byref)
9064 : {
9065 : /* Add the function call to the pre chain. There is no expression. */
9066 18829 : if (!se->no_function_call || call_needed_for_length)
9067 18797 : gfc_add_expr_to_block (&se->pre, se->expr);
9068 :
9069 18829 : se->expr = NULL_TREE;
9070 :
9071 18829 : if (!se->direct_byref)
9072 : {
9073 11836 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
9074 : {
9075 8552 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
9076 : {
9077 : /* Check the data pointer hasn't been modified. This would
9078 : happen in a function returning a pointer. */
9079 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
9080 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
9081 : logical_type_node,
9082 : tmp, info->data);
9083 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
9084 : gfc_msg_fault);
9085 : }
9086 8552 : se->expr = info->descriptor;
9087 : /* Bundle in the string length. */
9088 8552 : se->string_length = len;
9089 :
9090 8552 : if (finalizable)
9091 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
9092 : }
9093 3284 : else if (ts.type == BT_CHARACTER)
9094 : {
9095 : /* Dereference for character pointer results. */
9096 3223 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
9097 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9098 648 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9099 : else
9100 2575 : se->expr = var;
9101 :
9102 3223 : se->string_length = len;
9103 : }
9104 : else
9105 : {
9106 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
9107 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9108 : }
9109 : }
9110 : }
9111 :
9112 : /* Associate the rhs class object's meta-data with the result, when the
9113 : result is a temporary. */
9114 113513 : if (args && args->expr && args->expr->ts.type == BT_CLASS
9115 5105 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
9116 131911 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
9117 : {
9118 32 : gfc_se parmse;
9119 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
9120 :
9121 32 : gfc_init_se (&parmse, NULL);
9122 32 : parmse.data_not_needed = 1;
9123 32 : gfc_conv_expr (&parmse, class_expr);
9124 32 : if (!DECL_LANG_SPECIFIC (result))
9125 32 : gfc_allocate_lang_decl (result);
9126 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
9127 32 : gfc_free_expr (class_expr);
9128 : /* -fcheck= can add diagnostic code, which has to be placed before
9129 : the call. */
9130 32 : if (parmse.pre.head != NULL)
9131 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
9132 32 : gcc_assert (parmse.post.head == NULL_TREE);
9133 : }
9134 :
9135 : /* Follow the function call with the argument post block. */
9136 131879 : if (byref)
9137 : {
9138 : /* Transformational functions of derived types with allocatable
9139 : components must have the result allocatable components copied
9140 : BEFORE the argument post block is appended. Copying the result
9141 : first, then freeing the argument, gives the correct order. */
9142 18829 : arg = expr->value.function.actual;
9143 18829 : if (result && arg && expr->rank
9144 14698 : && isym && isym->transformational
9145 13117 : && isym->id != GFC_ISYM_REDUCE
9146 12991 : && arg->expr
9147 12931 : && arg->expr->ts.type == BT_DERIVED
9148 241 : && arg->expr->ts.u.derived->attr.alloc_comp)
9149 : {
9150 48 : tree tmp2;
9151 : /* Copy the allocatable components. We have to use a
9152 : temporary here to prevent source allocatable components
9153 : from being corrupted. */
9154 48 : tmp2 = gfc_evaluate_now (result, &se->pre);
9155 48 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
9156 : result, tmp2, expr->rank, 0);
9157 48 : gfc_add_expr_to_block (&se->pre, tmp);
9158 48 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
9159 : expr->rank);
9160 48 : gfc_add_expr_to_block (&se->pre, tmp);
9161 :
9162 : /* Finally free the temporary's data field. */
9163 48 : tmp = gfc_conv_descriptor_data_get (tmp2);
9164 48 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9165 : NULL_TREE, NULL_TREE, true,
9166 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9167 48 : gfc_add_expr_to_block (&se->pre, tmp);
9168 : }
9169 :
9170 18829 : gfc_add_block_to_block (&se->pre, &post);
9171 : }
9172 : else
9173 : {
9174 : /* For a function with a class array result, save the result as
9175 : a temporary, set the info fields needed by the scalarizer and
9176 : call the finalization function of the temporary. Note that the
9177 : nullification of allocatable components needed by the result
9178 : is done in gfc_trans_assignment_1. */
9179 35322 : if (expr && (gfc_is_class_array_function (expr)
9180 35000 : || gfc_is_alloc_class_scalar_function (expr))
9181 853 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9182 113891 : && expr->must_finalize)
9183 : {
9184 : /* TODO Eliminate the doubling of temporaries. This
9185 : one is necessary to ensure no memory leakage. */
9186 333 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9187 :
9188 : /* Finalize the result, if necessary. */
9189 666 : attr = expr->value.function.esym
9190 333 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9191 14 : : CLASS_DATA (expr)->attr;
9192 333 : if (!((gfc_is_class_array_function (expr)
9193 120 : || gfc_is_alloc_class_scalar_function (expr))
9194 333 : && attr.pointer))
9195 288 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9196 : }
9197 113050 : gfc_add_block_to_block (&se->post, &post);
9198 : }
9199 :
9200 : return has_alternate_specifier;
9201 : }
9202 :
9203 :
9204 : /* Fill a character string with spaces. */
9205 :
9206 : static tree
9207 30810 : fill_with_spaces (tree start, tree type, tree size)
9208 : {
9209 30810 : stmtblock_t block, loop;
9210 30810 : tree i, el, exit_label, cond, tmp;
9211 :
9212 : /* For a simple char type, we can call memset(). */
9213 30810 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9214 51032 : return build_call_expr_loc (input_location,
9215 : builtin_decl_explicit (BUILT_IN_MEMSET),
9216 : 3, start,
9217 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9218 25516 : lang_hooks.to_target_charset (' ')),
9219 : fold_convert (size_type_node, size));
9220 :
9221 : /* Otherwise, we use a loop:
9222 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9223 : *el = (type) ' ';
9224 : */
9225 :
9226 : /* Initialize variables. */
9227 5294 : gfc_init_block (&block);
9228 5294 : i = gfc_create_var (sizetype, "i");
9229 5294 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9230 5294 : el = gfc_create_var (build_pointer_type (type), "el");
9231 5294 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9232 5294 : exit_label = gfc_build_label_decl (NULL_TREE);
9233 5294 : TREE_USED (exit_label) = 1;
9234 :
9235 :
9236 : /* Loop body. */
9237 5294 : gfc_init_block (&loop);
9238 :
9239 : /* Exit condition. */
9240 5294 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9241 : build_zero_cst (sizetype));
9242 5294 : tmp = build1_v (GOTO_EXPR, exit_label);
9243 5294 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9244 : build_empty_stmt (input_location));
9245 5294 : gfc_add_expr_to_block (&loop, tmp);
9246 :
9247 : /* Assignment. */
9248 5294 : gfc_add_modify (&loop,
9249 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9250 5294 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9251 :
9252 : /* Increment loop variables. */
9253 5294 : gfc_add_modify (&loop, i,
9254 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9255 5294 : TYPE_SIZE_UNIT (type)));
9256 5294 : gfc_add_modify (&loop, el,
9257 : fold_build_pointer_plus_loc (input_location,
9258 5294 : el, TYPE_SIZE_UNIT (type)));
9259 :
9260 : /* Making the loop... actually loop! */
9261 5294 : tmp = gfc_finish_block (&loop);
9262 5294 : tmp = build1_v (LOOP_EXPR, tmp);
9263 5294 : gfc_add_expr_to_block (&block, tmp);
9264 :
9265 : /* The exit label. */
9266 5294 : tmp = build1_v (LABEL_EXPR, exit_label);
9267 5294 : gfc_add_expr_to_block (&block, tmp);
9268 :
9269 :
9270 5294 : return gfc_finish_block (&block);
9271 : }
9272 :
9273 :
9274 : /* Generate code to copy a string. */
9275 :
9276 : void
9277 35977 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9278 : int dkind, tree slength, tree src, int skind)
9279 : {
9280 35977 : tree tmp, dlen, slen;
9281 35977 : tree dsc;
9282 35977 : tree ssc;
9283 35977 : tree cond;
9284 35977 : tree cond2;
9285 35977 : tree tmp2;
9286 35977 : tree tmp3;
9287 35977 : tree tmp4;
9288 35977 : tree chartype;
9289 35977 : stmtblock_t tempblock;
9290 :
9291 35977 : gcc_assert (dkind == skind);
9292 :
9293 35977 : if (slength != NULL_TREE)
9294 : {
9295 35977 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9296 35977 : ssc = gfc_string_to_single_character (slen, src, skind);
9297 : }
9298 : else
9299 : {
9300 0 : slen = build_one_cst (gfc_charlen_type_node);
9301 0 : ssc = src;
9302 : }
9303 :
9304 35977 : if (dlength != NULL_TREE)
9305 : {
9306 35977 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9307 35977 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9308 : }
9309 : else
9310 : {
9311 0 : dlen = build_one_cst (gfc_charlen_type_node);
9312 0 : dsc = dest;
9313 : }
9314 :
9315 : /* Assign directly if the types are compatible. */
9316 35977 : if (dsc != NULL_TREE && ssc != NULL_TREE
9317 35977 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9318 : {
9319 5167 : gfc_add_modify (block, dsc, ssc);
9320 5167 : return;
9321 : }
9322 :
9323 : /* The string copy algorithm below generates code like
9324 :
9325 : if (destlen > 0)
9326 : {
9327 : if (srclen < destlen)
9328 : {
9329 : memmove (dest, src, srclen);
9330 : // Pad with spaces.
9331 : memset (&dest[srclen], ' ', destlen - srclen);
9332 : }
9333 : else
9334 : {
9335 : // Truncate if too long.
9336 : memmove (dest, src, destlen);
9337 : }
9338 : }
9339 : */
9340 :
9341 : /* Do nothing if the destination length is zero. */
9342 30810 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9343 30810 : build_zero_cst (TREE_TYPE (dlen)));
9344 :
9345 : /* For non-default character kinds, we have to multiply the string
9346 : length by the base type size. */
9347 30810 : chartype = gfc_get_char_type (dkind);
9348 30810 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9349 : slen,
9350 30810 : fold_convert (TREE_TYPE (slen),
9351 : TYPE_SIZE_UNIT (chartype)));
9352 30810 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9353 : dlen,
9354 30810 : fold_convert (TREE_TYPE (dlen),
9355 : TYPE_SIZE_UNIT (chartype)));
9356 :
9357 30810 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9358 30762 : dest = fold_convert (pvoid_type_node, dest);
9359 : else
9360 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9361 :
9362 30810 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9363 30806 : src = fold_convert (pvoid_type_node, src);
9364 : else
9365 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9366 :
9367 : /* Truncate string if source is too long. */
9368 30810 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9369 : dlen);
9370 :
9371 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9372 30810 : if (!CONSTANT_CLASS_P (cond2))
9373 : {
9374 9406 : dest = gfc_evaluate_now (dest, block);
9375 9406 : src = gfc_evaluate_now (src, block);
9376 : }
9377 :
9378 : /* Copy and pad with spaces. */
9379 30810 : tmp3 = build_call_expr_loc (input_location,
9380 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9381 : 3, dest, src,
9382 : fold_convert (size_type_node, slen));
9383 :
9384 : /* Wstringop-overflow appears at -O3 even though this warning is not
9385 : explicitly available in fortran nor can it be switched off. If the
9386 : source length is a constant, its negative appears as a very large
9387 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9388 : the result of the MINUS_EXPR suppresses this spurious warning. */
9389 30810 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9390 30810 : TREE_TYPE(dlen), dlen, slen);
9391 30810 : if (slength && TREE_CONSTANT (slength))
9392 27272 : tmp = gfc_evaluate_now (tmp, block);
9393 :
9394 30810 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9395 30810 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9396 :
9397 30810 : gfc_init_block (&tempblock);
9398 30810 : gfc_add_expr_to_block (&tempblock, tmp3);
9399 30810 : gfc_add_expr_to_block (&tempblock, tmp4);
9400 30810 : tmp3 = gfc_finish_block (&tempblock);
9401 :
9402 : /* The truncated memmove if the slen >= dlen. */
9403 30810 : tmp2 = build_call_expr_loc (input_location,
9404 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9405 : 3, dest, src,
9406 : fold_convert (size_type_node, dlen));
9407 :
9408 : /* The whole copy_string function is there. */
9409 30810 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9410 : tmp3, tmp2);
9411 30810 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9412 : build_empty_stmt (input_location));
9413 30810 : gfc_add_expr_to_block (block, tmp);
9414 : }
9415 :
9416 :
9417 : /* Translate a statement function.
9418 : The value of a statement function reference is obtained by evaluating the
9419 : expression using the values of the actual arguments for the values of the
9420 : corresponding dummy arguments. */
9421 :
9422 : static void
9423 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9424 : {
9425 269 : gfc_symbol *sym;
9426 269 : gfc_symbol *fsym;
9427 269 : gfc_formal_arglist *fargs;
9428 269 : gfc_actual_arglist *args;
9429 269 : gfc_se lse;
9430 269 : gfc_se rse;
9431 269 : gfc_saved_var *saved_vars;
9432 269 : tree *temp_vars;
9433 269 : tree type;
9434 269 : tree tmp;
9435 269 : int n;
9436 :
9437 269 : sym = expr->symtree->n.sym;
9438 269 : args = expr->value.function.actual;
9439 269 : gfc_init_se (&lse, NULL);
9440 269 : gfc_init_se (&rse, NULL);
9441 :
9442 269 : n = 0;
9443 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9444 458 : n++;
9445 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9446 269 : temp_vars = XCNEWVEC (tree, n);
9447 :
9448 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9449 458 : fargs = fargs->next, n++)
9450 : {
9451 : /* Each dummy shall be specified, explicitly or implicitly, to be
9452 : scalar. */
9453 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9454 458 : fsym = fargs->sym;
9455 :
9456 458 : if (fsym->ts.type == BT_CHARACTER)
9457 : {
9458 : /* Copy string arguments. */
9459 48 : tree arglen;
9460 :
9461 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9462 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9463 :
9464 : /* Create a temporary to hold the value. */
9465 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9466 1 : fsym->ts.u.cl->backend_decl
9467 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9468 :
9469 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9470 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9471 :
9472 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9473 :
9474 48 : gfc_conv_expr (&rse, args->expr);
9475 48 : gfc_conv_string_parameter (&rse);
9476 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9477 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9478 :
9479 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9480 : rse.string_length, rse.expr, fsym->ts.kind);
9481 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9482 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9483 : }
9484 : else
9485 : {
9486 : /* For everything else, just evaluate the expression. */
9487 :
9488 : /* Create a temporary to hold the value. */
9489 410 : type = gfc_typenode_for_spec (&fsym->ts);
9490 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9491 :
9492 410 : gfc_conv_expr (&lse, args->expr);
9493 :
9494 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9495 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9496 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9497 : }
9498 :
9499 458 : args = args->next;
9500 : }
9501 :
9502 : /* Use the temporary variables in place of the real ones. */
9503 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9504 458 : fargs = fargs->next, n++)
9505 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9506 :
9507 269 : gfc_conv_expr (se, sym->value);
9508 :
9509 269 : if (sym->ts.type == BT_CHARACTER)
9510 : {
9511 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9512 :
9513 : /* Force the expression to the correct length. */
9514 55 : if (!INTEGER_CST_P (se->string_length)
9515 101 : || tree_int_cst_lt (se->string_length,
9516 46 : sym->ts.u.cl->backend_decl))
9517 : {
9518 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9519 31 : tmp = gfc_create_var (type, sym->name);
9520 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9521 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9522 : sym->ts.kind, se->string_length, se->expr,
9523 : sym->ts.kind);
9524 31 : se->expr = tmp;
9525 : }
9526 55 : se->string_length = sym->ts.u.cl->backend_decl;
9527 : }
9528 :
9529 : /* Restore the original variables. */
9530 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9531 458 : fargs = fargs->next, n++)
9532 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9533 269 : free (temp_vars);
9534 269 : free (saved_vars);
9535 269 : }
9536 :
9537 :
9538 : /* Translate a function expression. */
9539 :
9540 : static void
9541 316348 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9542 : {
9543 316348 : gfc_symbol *sym;
9544 :
9545 316348 : if (expr->value.function.isym)
9546 : {
9547 265220 : gfc_conv_intrinsic_function (se, expr);
9548 265220 : return;
9549 : }
9550 :
9551 : /* expr.value.function.esym is the resolved (specific) function symbol for
9552 : most functions. However this isn't set for dummy procedures. */
9553 51128 : sym = expr->value.function.esym;
9554 51128 : if (!sym)
9555 1634 : sym = expr->symtree->n.sym;
9556 :
9557 : /* The IEEE_ARITHMETIC functions are caught here. */
9558 51128 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9559 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9560 : return;
9561 :
9562 : /* We distinguish statement functions from general functions to improve
9563 : runtime performance. */
9564 38671 : if (sym->attr.proc == PROC_ST_FUNCTION)
9565 : {
9566 269 : gfc_conv_statement_function (se, expr);
9567 269 : return;
9568 : }
9569 :
9570 38402 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9571 : NULL);
9572 : }
9573 :
9574 :
9575 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9576 :
9577 : static bool
9578 40024 : is_zero_initializer_p (gfc_expr * expr)
9579 : {
9580 40024 : if (expr->expr_type != EXPR_CONSTANT)
9581 : return false;
9582 :
9583 : /* We ignore constants with prescribed memory representations for now. */
9584 11465 : if (expr->representation.string)
9585 : return false;
9586 :
9587 11447 : switch (expr->ts.type)
9588 : {
9589 5296 : case BT_INTEGER:
9590 5296 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9591 :
9592 4843 : case BT_REAL:
9593 4843 : return mpfr_zero_p (expr->value.real)
9594 4843 : && MPFR_SIGN (expr->value.real) >= 0;
9595 :
9596 931 : case BT_LOGICAL:
9597 931 : return expr->value.logical == 0;
9598 :
9599 243 : case BT_COMPLEX:
9600 243 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9601 155 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9602 155 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9603 386 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9604 :
9605 : default:
9606 : break;
9607 : }
9608 : return false;
9609 : }
9610 :
9611 :
9612 : static void
9613 36255 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9614 : {
9615 36255 : gfc_ss *ss;
9616 :
9617 36255 : ss = se->ss;
9618 36255 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9619 36255 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9620 :
9621 36255 : gfc_conv_tmp_array_ref (se);
9622 36255 : }
9623 :
9624 :
9625 : /* Build a static initializer. EXPR is the expression for the initial value.
9626 : The other parameters describe the variable of the component being
9627 : initialized. EXPR may be null. */
9628 :
9629 : tree
9630 136568 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9631 : bool array, bool pointer, bool procptr)
9632 : {
9633 136568 : gfc_se se;
9634 :
9635 136568 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9636 42688 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9637 171 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9638 59 : return build_constructor (type, NULL);
9639 :
9640 136509 : if (!(expr || pointer || procptr))
9641 : return NULL_TREE;
9642 :
9643 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9644 : (these are the only two iso_c_binding derived types that can be
9645 : used as initialization expressions). If so, we need to modify
9646 : the 'expr' to be that for a (void *). */
9647 128134 : if (expr != NULL && expr->ts.type == BT_DERIVED
9648 38473 : && expr->ts.is_iso_c && expr->ts.u.derived)
9649 : {
9650 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9651 4 : return build_constructor (type, NULL);
9652 182 : else if (POINTER_TYPE_P (type))
9653 182 : return build_int_cst (type, 0);
9654 : else
9655 0 : gcc_unreachable ();
9656 : }
9657 :
9658 127948 : if (array && !procptr)
9659 : {
9660 8795 : tree ctor;
9661 : /* Arrays need special handling. */
9662 8795 : if (pointer)
9663 791 : ctor = gfc_build_null_descriptor (type);
9664 : /* Special case assigning an array to zero. */
9665 8004 : else if (is_zero_initializer_p (expr))
9666 226 : ctor = build_constructor (type, NULL);
9667 : else
9668 7778 : ctor = gfc_conv_array_initializer (type, expr);
9669 8795 : TREE_STATIC (ctor) = 1;
9670 8795 : return ctor;
9671 : }
9672 119153 : else if (pointer || procptr)
9673 : {
9674 55684 : if (ts->type == BT_CLASS && !procptr)
9675 : {
9676 1786 : gfc_init_se (&se, NULL);
9677 1786 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9678 1786 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9679 1786 : TREE_STATIC (se.expr) = 1;
9680 1786 : return se.expr;
9681 : }
9682 53898 : else if (!expr || expr->expr_type == EXPR_NULL)
9683 28647 : return fold_convert (type, null_pointer_node);
9684 : else
9685 : {
9686 25251 : gfc_init_se (&se, NULL);
9687 25251 : se.want_pointer = 1;
9688 25251 : gfc_conv_expr (&se, expr);
9689 25251 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9690 : return se.expr;
9691 : }
9692 : }
9693 : else
9694 : {
9695 63469 : switch (ts->type)
9696 : {
9697 18534 : case_bt_struct:
9698 18534 : case BT_CLASS:
9699 18534 : gfc_init_se (&se, NULL);
9700 18534 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9701 809 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9702 : else
9703 17725 : gfc_conv_structure (&se, expr, 1);
9704 18534 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9705 18534 : TREE_STATIC (se.expr) = 1;
9706 18534 : return se.expr;
9707 :
9708 2705 : case BT_CHARACTER:
9709 2705 : if (expr->expr_type == EXPR_CONSTANT)
9710 : {
9711 2704 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9712 2704 : TREE_STATIC (ctor) = 1;
9713 2704 : return ctor;
9714 : }
9715 :
9716 : /* Fallthrough. */
9717 42231 : default:
9718 42231 : gfc_init_se (&se, NULL);
9719 42231 : gfc_conv_constant (&se, expr);
9720 42231 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9721 : return se.expr;
9722 : }
9723 : }
9724 : }
9725 :
9726 : static tree
9727 956 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9728 : {
9729 956 : gfc_se rse;
9730 956 : gfc_se lse;
9731 956 : gfc_ss *rss;
9732 956 : gfc_ss *lss;
9733 956 : gfc_array_info *lss_array;
9734 956 : stmtblock_t body;
9735 956 : stmtblock_t block;
9736 956 : gfc_loopinfo loop;
9737 956 : int n;
9738 956 : tree tmp;
9739 :
9740 956 : gfc_start_block (&block);
9741 :
9742 : /* Initialize the scalarizer. */
9743 956 : gfc_init_loopinfo (&loop);
9744 :
9745 956 : gfc_init_se (&lse, NULL);
9746 956 : gfc_init_se (&rse, NULL);
9747 :
9748 : /* Walk the rhs. */
9749 956 : rss = gfc_walk_expr (expr);
9750 956 : if (rss == gfc_ss_terminator)
9751 : /* The rhs is scalar. Add a ss for the expression. */
9752 208 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
9753 :
9754 : /* Create a SS for the destination. */
9755 956 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
9756 : GFC_SS_COMPONENT);
9757 956 : lss_array = &lss->info->data.array;
9758 956 : lss_array->shape = gfc_get_shape (cm->as->rank);
9759 956 : lss_array->descriptor = dest;
9760 956 : lss_array->data = gfc_conv_array_data (dest);
9761 956 : lss_array->offset = gfc_conv_array_offset (dest);
9762 1969 : for (n = 0; n < cm->as->rank; n++)
9763 : {
9764 1013 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
9765 1013 : lss_array->stride[n] = gfc_index_one_node;
9766 :
9767 1013 : mpz_init (lss_array->shape[n]);
9768 1013 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
9769 1013 : cm->as->lower[n]->value.integer);
9770 1013 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
9771 : }
9772 :
9773 : /* Associate the SS with the loop. */
9774 956 : gfc_add_ss_to_loop (&loop, lss);
9775 956 : gfc_add_ss_to_loop (&loop, rss);
9776 :
9777 : /* Calculate the bounds of the scalarization. */
9778 956 : gfc_conv_ss_startstride (&loop);
9779 :
9780 : /* Setup the scalarizing loops. */
9781 956 : gfc_conv_loop_setup (&loop, &expr->where);
9782 :
9783 : /* Setup the gfc_se structures. */
9784 956 : gfc_copy_loopinfo_to_se (&lse, &loop);
9785 956 : gfc_copy_loopinfo_to_se (&rse, &loop);
9786 :
9787 956 : rse.ss = rss;
9788 956 : gfc_mark_ss_chain_used (rss, 1);
9789 956 : lse.ss = lss;
9790 956 : gfc_mark_ss_chain_used (lss, 1);
9791 :
9792 : /* Start the scalarized loop body. */
9793 956 : gfc_start_scalarized_body (&loop, &body);
9794 :
9795 956 : gfc_conv_tmp_array_ref (&lse);
9796 956 : if (cm->ts.type == BT_CHARACTER)
9797 176 : lse.string_length = cm->ts.u.cl->backend_decl;
9798 :
9799 956 : gfc_conv_expr (&rse, expr);
9800 :
9801 956 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
9802 956 : gfc_add_expr_to_block (&body, tmp);
9803 :
9804 956 : gcc_assert (rse.ss == gfc_ss_terminator);
9805 :
9806 : /* Generate the copying loops. */
9807 956 : gfc_trans_scalarizing_loops (&loop, &body);
9808 :
9809 : /* Wrap the whole thing up. */
9810 956 : gfc_add_block_to_block (&block, &loop.pre);
9811 956 : gfc_add_block_to_block (&block, &loop.post);
9812 :
9813 956 : gcc_assert (lss_array->shape != NULL);
9814 956 : gfc_free_shape (&lss_array->shape, cm->as->rank);
9815 956 : gfc_cleanup_loop (&loop);
9816 :
9817 956 : return gfc_finish_block (&block);
9818 : }
9819 :
9820 :
9821 : static stmtblock_t *final_block;
9822 : static tree
9823 1312 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
9824 : gfc_expr * expr)
9825 : {
9826 1312 : gfc_se se;
9827 1312 : stmtblock_t block;
9828 1312 : tree offset;
9829 1312 : int n;
9830 1312 : tree tmp;
9831 1312 : tree tmp2;
9832 1312 : gfc_array_spec *as;
9833 1312 : gfc_expr *arg = NULL;
9834 :
9835 1312 : gfc_start_block (&block);
9836 1312 : gfc_init_se (&se, NULL);
9837 :
9838 : /* Get the descriptor for the expressions. */
9839 1312 : se.want_pointer = 0;
9840 1312 : gfc_conv_expr_descriptor (&se, expr);
9841 1312 : gfc_add_block_to_block (&block, &se.pre);
9842 1312 : gfc_add_modify (&block, dest, se.expr);
9843 1312 : if (cm->ts.type == BT_CHARACTER
9844 1312 : && gfc_deferred_strlen (cm, &tmp))
9845 : {
9846 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
9847 30 : TREE_TYPE (tmp),
9848 30 : TREE_OPERAND (dest, 0),
9849 : tmp, NULL_TREE);
9850 30 : gfc_add_modify (&block, tmp,
9851 30 : fold_convert (TREE_TYPE (tmp),
9852 : se.string_length));
9853 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
9854 : "slen");
9855 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
9856 : }
9857 :
9858 : /* Deal with arrays of derived types with allocatable components. */
9859 1312 : if (gfc_bt_struct (cm->ts.type)
9860 199 : && cm->ts.u.derived->attr.alloc_comp)
9861 : // TODO: Fix caf_mode
9862 113 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
9863 : se.expr, dest,
9864 113 : cm->as->rank, 0);
9865 1199 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
9866 36 : && CLASS_DATA(cm)->attr.allocatable)
9867 : {
9868 36 : if (cm->ts.u.derived->attr.alloc_comp)
9869 : // TODO: Fix caf_mode
9870 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
9871 : se.expr, dest,
9872 : expr->rank, 0);
9873 : else
9874 : {
9875 36 : tmp = TREE_TYPE (dest);
9876 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9877 : tmp, expr->rank, NULL_TREE);
9878 : }
9879 : }
9880 1163 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9881 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9882 : gfc_typenode_for_spec (&cm->ts),
9883 30 : cm->as->rank, NULL_TREE);
9884 : else
9885 1133 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9886 1133 : TREE_TYPE(cm->backend_decl),
9887 1133 : cm->as->rank, NULL_TREE);
9888 :
9889 :
9890 1312 : gfc_add_expr_to_block (&block, tmp);
9891 1312 : gfc_add_block_to_block (&block, &se.post);
9892 :
9893 1312 : if (final_block && !cm->attr.allocatable
9894 96 : && expr->expr_type == EXPR_ARRAY)
9895 : {
9896 96 : tree data_ptr;
9897 96 : data_ptr = gfc_conv_descriptor_data_get (dest);
9898 96 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
9899 96 : }
9900 1216 : else if (final_block && cm->attr.allocatable)
9901 162 : gfc_add_block_to_block (final_block, &se.finalblock);
9902 :
9903 1312 : if (expr->expr_type != EXPR_VARIABLE)
9904 : {
9905 1191 : if (gfc_bt_struct (cm->ts.type) && cm->ts.u.derived->attr.alloc_comp)
9906 : {
9907 214 : tmp = gfc_deallocate_alloc_comp_no_caf (cm->ts.u.derived,
9908 107 : se.expr, cm->as->rank, true);
9909 107 : gfc_add_expr_to_block (&block, tmp);
9910 : }
9911 1191 : gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
9912 : }
9913 :
9914 : /* We need to know if the argument of a conversion function is a
9915 : variable, so that the correct lower bound can be used. */
9916 1312 : if (expr->expr_type == EXPR_FUNCTION
9917 68 : && expr->value.function.isym
9918 56 : && expr->value.function.isym->conversion
9919 56 : && expr->value.function.actual->expr
9920 56 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
9921 56 : arg = expr->value.function.actual->expr;
9922 :
9923 : /* Obtain the array spec of full array references. */
9924 56 : if (arg)
9925 56 : as = gfc_get_full_arrayspec_from_expr (arg);
9926 : else
9927 1256 : as = gfc_get_full_arrayspec_from_expr (expr);
9928 :
9929 : /* Shift the lbound and ubound of temporaries to being unity,
9930 : rather than zero, based. Always calculate the offset. */
9931 1312 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
9932 1312 : offset = gfc_conv_descriptor_offset_get (dest);
9933 1312 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
9934 :
9935 3992 : for (n = 0; n < expr->rank; n++)
9936 : {
9937 1368 : tree span;
9938 1368 : tree lbound;
9939 :
9940 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
9941 : TODO It looks as if gfc_conv_expr_descriptor should return
9942 : the correct bounds and that the following should not be
9943 : necessary. This would simplify gfc_conv_intrinsic_bound
9944 : as well. */
9945 1368 : if (as && as->lower[n])
9946 : {
9947 92 : gfc_se lbse;
9948 92 : gfc_init_se (&lbse, NULL);
9949 92 : gfc_conv_expr (&lbse, as->lower[n]);
9950 92 : gfc_add_block_to_block (&block, &lbse.pre);
9951 92 : lbound = gfc_evaluate_now (lbse.expr, &block);
9952 92 : }
9953 1276 : else if (as && arg)
9954 : {
9955 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
9956 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
9957 : gfc_rank_cst[n]);
9958 : }
9959 1242 : else if (as)
9960 64 : lbound = gfc_conv_descriptor_lbound_get (dest,
9961 : gfc_rank_cst[n]);
9962 : else
9963 1178 : lbound = gfc_index_one_node;
9964 :
9965 1368 : lbound = fold_convert (gfc_array_index_type, lbound);
9966 :
9967 : /* Shift the bounds and set the offset accordingly. */
9968 1368 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
9969 1368 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9970 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
9971 1368 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9972 : span, lbound);
9973 1368 : gfc_conv_descriptor_ubound_set (&block, dest,
9974 : gfc_rank_cst[n], tmp);
9975 1368 : gfc_conv_descriptor_lbound_set (&block, dest,
9976 : gfc_rank_cst[n], lbound);
9977 :
9978 1368 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9979 : gfc_conv_descriptor_lbound_get (dest,
9980 : gfc_rank_cst[n]),
9981 : gfc_conv_descriptor_stride_get (dest,
9982 : gfc_rank_cst[n]));
9983 1368 : gfc_add_modify (&block, tmp2, tmp);
9984 1368 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9985 : offset, tmp2);
9986 1368 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
9987 : }
9988 :
9989 1312 : if (arg)
9990 : {
9991 : /* If a conversion expression has a null data pointer
9992 : argument, nullify the allocatable component. */
9993 56 : tree non_null_expr;
9994 56 : tree null_expr;
9995 :
9996 56 : if (arg->symtree->n.sym->attr.allocatable
9997 24 : || arg->symtree->n.sym->attr.pointer)
9998 : {
9999 32 : non_null_expr = gfc_finish_block (&block);
10000 32 : gfc_start_block (&block);
10001 32 : gfc_conv_descriptor_data_set (&block, dest,
10002 : null_pointer_node);
10003 32 : null_expr = gfc_finish_block (&block);
10004 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
10005 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
10006 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
10007 32 : return build3_v (COND_EXPR, tmp,
10008 : null_expr, non_null_expr);
10009 : }
10010 : }
10011 :
10012 1280 : return gfc_finish_block (&block);
10013 : }
10014 :
10015 :
10016 : /* Allocate or reallocate scalar component, as necessary. */
10017 :
10018 : static void
10019 428 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
10020 : gfc_component *cm, gfc_expr *expr2,
10021 : tree slen)
10022 : {
10023 428 : tree tmp;
10024 428 : tree ptr;
10025 428 : tree size;
10026 428 : tree size_in_bytes;
10027 428 : tree lhs_cl_size = NULL_TREE;
10028 428 : gfc_se se;
10029 :
10030 428 : if (!comp)
10031 0 : return;
10032 :
10033 428 : if (!expr2 || expr2->rank)
10034 : return;
10035 :
10036 428 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10037 :
10038 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10039 : {
10040 145 : gcc_assert (expr2->ts.type == BT_CHARACTER);
10041 145 : size = expr2->ts.u.cl->backend_decl;
10042 145 : if (!size || !VAR_P (size))
10043 145 : size = gfc_create_var (TREE_TYPE (slen), "slen");
10044 145 : gfc_add_modify (block, size, slen);
10045 :
10046 145 : gfc_deferred_strlen (cm, &tmp);
10047 145 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
10048 : gfc_charlen_type_node,
10049 145 : TREE_OPERAND (comp, 0),
10050 : tmp, NULL_TREE);
10051 :
10052 145 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
10053 145 : tmp = TYPE_SIZE_UNIT (tmp);
10054 290 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10055 145 : TREE_TYPE (tmp), tmp,
10056 145 : fold_convert (TREE_TYPE (tmp), size));
10057 : }
10058 283 : else if (cm->ts.type == BT_CLASS)
10059 : {
10060 109 : if (expr2->ts.type != BT_CLASS)
10061 : {
10062 109 : if (expr2->ts.type == BT_CHARACTER)
10063 : {
10064 24 : gfc_init_se (&se, NULL);
10065 24 : gfc_conv_expr (&se, expr2);
10066 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
10067 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10068 : gfc_charlen_type_node,
10069 : se.string_length, size);
10070 24 : size = fold_convert (size_type_node, size);
10071 : }
10072 : else
10073 : {
10074 85 : if (expr2->ts.type == BT_DERIVED)
10075 54 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
10076 : else
10077 31 : tmp = gfc_typenode_for_spec (&expr2->ts);
10078 85 : size = TYPE_SIZE_UNIT (tmp);
10079 : }
10080 : }
10081 : else
10082 : {
10083 0 : gfc_expr *e2vtab;
10084 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
10085 0 : gfc_add_vptr_component (e2vtab);
10086 0 : gfc_add_size_component (e2vtab);
10087 0 : gfc_init_se (&se, NULL);
10088 0 : gfc_conv_expr (&se, e2vtab);
10089 0 : gfc_add_block_to_block (block, &se.pre);
10090 0 : size = fold_convert (size_type_node, se.expr);
10091 0 : gfc_free_expr (e2vtab);
10092 : }
10093 : size_in_bytes = size;
10094 : }
10095 : else
10096 : {
10097 : /* Otherwise use the length in bytes of the rhs. */
10098 174 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
10099 174 : size_in_bytes = size;
10100 : }
10101 :
10102 428 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10103 : size_in_bytes, size_one_node);
10104 :
10105 428 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
10106 : {
10107 6 : tmp = build_call_expr_loc (input_location,
10108 : builtin_decl_explicit (BUILT_IN_CALLOC),
10109 : 2, build_one_cst (size_type_node),
10110 : size_in_bytes);
10111 6 : tmp = fold_convert (TREE_TYPE (comp), tmp);
10112 6 : gfc_add_modify (block, comp, tmp);
10113 : }
10114 : else
10115 : {
10116 422 : tmp = build_call_expr_loc (input_location,
10117 : builtin_decl_explicit (BUILT_IN_MALLOC),
10118 : 1, size_in_bytes);
10119 422 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
10120 109 : ptr = gfc_class_data_get (comp);
10121 : else
10122 : ptr = comp;
10123 422 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
10124 422 : gfc_add_modify (block, ptr, tmp);
10125 : }
10126 :
10127 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10128 : /* Update the lhs character length. */
10129 145 : gfc_add_modify (block, lhs_cl_size,
10130 145 : fold_convert (TREE_TYPE (lhs_cl_size), size));
10131 : }
10132 :
10133 :
10134 : /* Assign a single component of a derived type constructor. */
10135 :
10136 : static tree
10137 30772 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
10138 : gfc_expr * expr, bool init)
10139 : {
10140 30772 : gfc_se se;
10141 30772 : gfc_se lse;
10142 30772 : stmtblock_t block;
10143 30772 : tree tmp;
10144 30772 : tree vtab;
10145 :
10146 30772 : gfc_start_block (&block);
10147 :
10148 30772 : if (cm->attr.pointer || cm->attr.proc_pointer)
10149 : {
10150 : /* Only care about pointers here, not about allocatables. */
10151 2704 : gfc_init_se (&se, NULL);
10152 : /* Pointer component. */
10153 2704 : if ((cm->attr.dimension || cm->attr.codimension)
10154 682 : && !cm->attr.proc_pointer)
10155 : {
10156 : /* Array pointer. */
10157 666 : if (expr->expr_type == EXPR_NULL)
10158 660 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10159 : else
10160 : {
10161 6 : se.direct_byref = 1;
10162 6 : se.expr = dest;
10163 6 : gfc_conv_expr_descriptor (&se, expr);
10164 6 : gfc_add_block_to_block (&block, &se.pre);
10165 6 : gfc_add_block_to_block (&block, &se.post);
10166 : }
10167 : }
10168 : else
10169 : {
10170 : /* Scalar pointers. */
10171 2038 : se.want_pointer = 1;
10172 2038 : gfc_conv_expr (&se, expr);
10173 2038 : gfc_add_block_to_block (&block, &se.pre);
10174 :
10175 2038 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10176 12 : && expr->symtree->n.sym->attr.dummy)
10177 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10178 :
10179 2038 : gfc_add_modify (&block, dest,
10180 2038 : fold_convert (TREE_TYPE (dest), se.expr));
10181 2038 : gfc_add_block_to_block (&block, &se.post);
10182 : }
10183 : }
10184 28068 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10185 : {
10186 : /* NULL initialization for CLASS components. */
10187 976 : tmp = gfc_trans_structure_assign (dest,
10188 : gfc_class_initializer (&cm->ts, expr),
10189 : false);
10190 976 : gfc_add_expr_to_block (&block, tmp);
10191 : }
10192 27092 : else if ((cm->attr.dimension || cm->attr.codimension)
10193 : && !cm->attr.proc_pointer)
10194 : {
10195 5069 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10196 : {
10197 2837 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10198 2837 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10199 2 : gfc_conv_descriptor_token_set (&block, dest, null_pointer_node);
10200 : }
10201 2232 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10202 : {
10203 1276 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10204 1276 : gfc_add_expr_to_block (&block, tmp);
10205 : }
10206 : else
10207 : {
10208 956 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10209 956 : gfc_add_expr_to_block (&block, tmp);
10210 : }
10211 : }
10212 22023 : else if (cm->ts.type == BT_CLASS
10213 157 : && CLASS_DATA (cm)->attr.dimension
10214 36 : && CLASS_DATA (cm)->attr.allocatable
10215 36 : && expr->ts.type == BT_DERIVED)
10216 : {
10217 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10218 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10219 36 : tmp = gfc_class_vptr_get (dest);
10220 36 : gfc_add_modify (&block, tmp,
10221 36 : fold_convert (TREE_TYPE (tmp), vtab));
10222 36 : tmp = gfc_class_data_get (dest);
10223 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10224 36 : gfc_add_expr_to_block (&block, tmp);
10225 : }
10226 21987 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10227 1844 : && (init
10228 1717 : || (cm->ts.type == BT_CHARACTER
10229 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10230 : {
10231 : /* NULL initialization for allocatable components.
10232 : Deferred-length character is dealt with later. */
10233 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10234 : null_pointer_node));
10235 : }
10236 21836 : else if (init && (cm->attr.allocatable
10237 13919 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10238 121 : && expr->ts.type != BT_CLASS)))
10239 : {
10240 428 : tree size;
10241 428 : tree tmp2;
10242 :
10243 428 : gfc_init_se (&se, NULL);
10244 428 : gfc_conv_expr (&se, expr);
10245 :
10246 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10247 : if (!cm->attr.dimension) part above. */
10248 428 : gfc_add_block_to_block (&block, &se.pre);
10249 : /* Take care about non-array allocatable components here. The alloc_*
10250 : routine below is motivated by the alloc_scalar_allocatable_for_
10251 : assignment() routine, but with the realloc portions removed and
10252 : different input. */
10253 428 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10254 : se.string_length);
10255 :
10256 428 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10257 0 : && expr->symtree->n.sym->attr.dummy)
10258 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10259 :
10260 428 : if (cm->ts.type == BT_CLASS)
10261 : {
10262 109 : tmp = gfc_class_data_get (dest);
10263 109 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10264 109 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10265 109 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10266 109 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10267 109 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10268 : }
10269 : else
10270 319 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10271 :
10272 : /* For deferred strings insert a memcpy. */
10273 428 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10274 : {
10275 145 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10276 145 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10277 : ? se.string_length
10278 0 : : expr->ts.u.cl->backend_decl);
10279 145 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10280 145 : gfc_add_expr_to_block (&block, tmp);
10281 : }
10282 283 : else if (cm->ts.type == BT_CLASS)
10283 : {
10284 : /* Fix the expression for memcpy. */
10285 109 : if (expr->expr_type != EXPR_VARIABLE)
10286 73 : se.expr = gfc_evaluate_now (se.expr, &block);
10287 :
10288 109 : if (expr->ts.type == BT_CHARACTER)
10289 : {
10290 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10291 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10292 : gfc_charlen_type_node,
10293 : se.string_length, size);
10294 24 : size = fold_convert (size_type_node, size);
10295 : }
10296 : else
10297 85 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10298 :
10299 : /* Now copy the expression to the constructor component _data. */
10300 109 : gfc_add_expr_to_block (&block,
10301 : gfc_build_memcpy_call (tmp, se.expr, size));
10302 :
10303 109 : if (expr->ts.type == BT_DERIVED
10304 54 : && expr->ts.u.derived->attr.alloc_comp
10305 6 : && expr->expr_type != EXPR_NULL)
10306 : {
10307 6 : tmp2 = gfc_class_data_get (dest);
10308 6 : tmp2 = gfc_copy_alloc_comp (expr->ts.u.derived, tmp2,
10309 : gfc_class_data_get (dest),
10310 : expr->rank, 0);
10311 6 : gfc_add_expr_to_block (&block, tmp2);
10312 : }
10313 :
10314 : /* Fill the unlimited polymorphic _len field. */
10315 109 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10316 : {
10317 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10318 24 : gfc_add_modify (&block, tmp,
10319 24 : fold_convert (TREE_TYPE (tmp),
10320 : se.string_length));
10321 : }
10322 : }
10323 : else
10324 : {
10325 174 : gfc_add_modify (&block, tmp,
10326 174 : fold_convert (TREE_TYPE (tmp), se.expr));
10327 174 : if (expr->ts.type == BT_DERIVED
10328 32 : && expr->ts.u.derived->attr.alloc_comp
10329 6 : && expr->expr_type != EXPR_NULL)
10330 : {
10331 6 : tmp2 = build_fold_indirect_ref_loc (input_location, dest);
10332 6 : tmp2 = gfc_copy_alloc_comp (cm->ts.u.derived, tmp2,
10333 : se.expr, expr->rank, 0);
10334 6 : gfc_add_expr_to_block (&block, tmp2);
10335 : }
10336 : }
10337 :
10338 428 : gfc_add_block_to_block (&block, &se.post);
10339 428 : }
10340 21408 : else if (expr->ts.type == BT_UNION)
10341 : {
10342 13 : tree tmp;
10343 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10344 : /* We mark that the entire union should be initialized with a contrived
10345 : EXPR_NULL expression at the beginning. */
10346 13 : if (c != NULL && c->n.component == NULL
10347 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10348 : {
10349 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10350 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10351 6 : gfc_add_expr_to_block (&block, tmp);
10352 6 : c = gfc_constructor_next (c);
10353 : }
10354 : /* The following constructor expression, if any, represents a specific
10355 : map initializer, as given by the user. */
10356 13 : if (c != NULL && c->expr != NULL)
10357 : {
10358 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10359 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10360 6 : gfc_add_expr_to_block (&block, tmp);
10361 : }
10362 : }
10363 21395 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10364 : {
10365 3537 : if (expr->expr_type != EXPR_STRUCTURE)
10366 : {
10367 494 : tree dealloc = NULL_TREE;
10368 494 : gfc_init_se (&se, NULL);
10369 494 : gfc_conv_expr (&se, expr);
10370 494 : gfc_add_block_to_block (&block, &se.pre);
10371 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10372 : expression in a temporary variable and deallocate the allocatable
10373 : components. Then we can the copy the expression to the result. */
10374 494 : if (cm->ts.u.derived->attr.alloc_comp
10375 372 : && expr->expr_type != EXPR_VARIABLE)
10376 : {
10377 336 : se.expr = gfc_evaluate_now (se.expr, &block);
10378 336 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10379 : expr->rank);
10380 : }
10381 494 : gfc_add_modify (&block, dest,
10382 494 : fold_convert (TREE_TYPE (dest), se.expr));
10383 494 : if (cm->ts.u.derived->attr.alloc_comp
10384 372 : && expr->expr_type != EXPR_NULL)
10385 : {
10386 : // TODO: Fix caf_mode
10387 54 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10388 : dest, expr->rank, 0);
10389 54 : gfc_add_expr_to_block (&block, tmp);
10390 54 : if (dealloc != NULL_TREE)
10391 18 : gfc_add_expr_to_block (&block, dealloc);
10392 : }
10393 494 : gfc_add_block_to_block (&block, &se.post);
10394 : }
10395 : else
10396 : {
10397 : /* Nested constructors. */
10398 3043 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10399 3043 : gfc_add_expr_to_block (&block, tmp);
10400 : }
10401 : }
10402 17858 : else if (gfc_deferred_strlen (cm, &tmp))
10403 : {
10404 125 : tree strlen;
10405 125 : strlen = tmp;
10406 125 : gcc_assert (strlen);
10407 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10408 125 : TREE_TYPE (strlen),
10409 125 : TREE_OPERAND (dest, 0),
10410 : strlen, NULL_TREE);
10411 :
10412 125 : if (expr->expr_type == EXPR_NULL)
10413 : {
10414 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10415 107 : gfc_add_modify (&block, dest, tmp);
10416 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10417 107 : gfc_add_modify (&block, strlen, tmp);
10418 : }
10419 : else
10420 : {
10421 18 : tree size;
10422 18 : gfc_init_se (&se, NULL);
10423 18 : gfc_conv_expr (&se, expr);
10424 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10425 18 : size = fold_convert (size_type_node, size);
10426 18 : tmp = build_call_expr_loc (input_location,
10427 : builtin_decl_explicit (BUILT_IN_MALLOC),
10428 : 1, size);
10429 18 : gfc_add_modify (&block, dest,
10430 18 : fold_convert (TREE_TYPE (dest), tmp));
10431 18 : gfc_add_modify (&block, strlen,
10432 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10433 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10434 18 : gfc_add_expr_to_block (&block, tmp);
10435 : }
10436 : }
10437 17733 : else if (cm->ts.type == BT_CLASS
10438 12 : && !CLASS_DATA (cm)->as
10439 12 : && expr->ts.type == BT_CLASS)
10440 : {
10441 12 : tree vptr1, vptr2;
10442 12 : tree data1, data2;
10443 12 : tree size, fcn;
10444 :
10445 12 : gfc_init_se (&se, NULL);
10446 :
10447 12 : gfc_conv_expr (&se, expr);
10448 :
10449 : /* Copy the _vptr to the destination.... */
10450 12 : vptr1 = gfc_class_vptr_get (dest);
10451 12 : vptr2 = gfc_class_vptr_get (se.expr);
10452 12 : gfc_add_modify (&block, vptr1,
10453 12 : fold_convert (TREE_TYPE (vptr1), vptr2));
10454 :
10455 : /* ....and the _len field if necessary. */
10456 12 : size = gfc_vptr_size_get (vptr2);
10457 12 : if (UNLIMITED_POLY (cm) && UNLIMITED_POLY (expr))
10458 : {
10459 0 : gfc_add_modify (&block, gfc_class_len_get (dest),
10460 : gfc_class_len_get (se.expr));
10461 0 : size = gfc_resize_class_size_with_len (&block, se.expr, size);
10462 : }
10463 :
10464 : /* Allocate the destination data. */
10465 12 : data1 = gfc_class_data_get (dest);
10466 12 : data2 = gfc_class_data_get (se.expr);
10467 12 : tmp = gfc_call_malloc (&block, TREE_TYPE (data1), size);
10468 12 : gfc_add_modify (&block, data1, tmp);
10469 :
10470 : /* Now call the copy function. */
10471 12 : fcn = gfc_vptr_copy_get (vptr2);
10472 12 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10473 12 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
10474 12 : tmp = build_call_expr_loc (input_location, fcn, 2,
10475 : data2, data1);
10476 12 : gfc_add_expr_to_block (&block, tmp);
10477 12 : }
10478 17721 : else if (!cm->attr.artificial)
10479 : {
10480 : /* Scalar component (excluding deferred parameters). */
10481 17600 : gfc_init_se (&se, NULL);
10482 17600 : gfc_init_se (&lse, NULL);
10483 :
10484 17600 : gfc_conv_expr (&se, expr);
10485 17600 : if (cm->ts.type == BT_CHARACTER)
10486 1057 : lse.string_length = cm->ts.u.cl->backend_decl;
10487 17600 : lse.expr = dest;
10488 17600 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10489 17600 : gfc_add_expr_to_block (&block, tmp);
10490 : }
10491 30772 : return gfc_finish_block (&block);
10492 : }
10493 :
10494 : /* Assign a derived type constructor to a variable. */
10495 :
10496 : tree
10497 21256 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10498 : {
10499 21256 : gfc_constructor *c;
10500 21256 : gfc_component *cm;
10501 21256 : stmtblock_t block;
10502 21256 : tree field;
10503 21256 : tree tmp;
10504 21256 : gfc_se se;
10505 :
10506 21256 : gfc_start_block (&block);
10507 :
10508 21256 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10509 179 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10510 13 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10511 : {
10512 179 : gfc_se lse;
10513 :
10514 179 : gfc_init_se (&se, NULL);
10515 179 : gfc_init_se (&lse, NULL);
10516 179 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10517 179 : lse.expr = dest;
10518 179 : gfc_add_modify (&block, lse.expr,
10519 179 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10520 :
10521 179 : return gfc_finish_block (&block);
10522 : }
10523 :
10524 : /* Make sure that the derived type has been completely built. */
10525 21077 : if (!expr->ts.u.derived->backend_decl
10526 21077 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10527 : {
10528 230 : tmp = gfc_typenode_for_spec (&expr->ts);
10529 230 : gcc_assert (tmp);
10530 : }
10531 :
10532 21077 : cm = expr->ts.u.derived->components;
10533 :
10534 :
10535 21077 : if (coarray)
10536 225 : gfc_init_se (&se, NULL);
10537 :
10538 21077 : for (c = gfc_constructor_first (expr->value.constructor);
10539 55005 : c; c = gfc_constructor_next (c), cm = cm->next)
10540 : {
10541 : /* Skip absent members in default initializers. */
10542 33928 : if (!c->expr && !cm->attr.allocatable)
10543 3156 : continue;
10544 :
10545 : /* Register the component with the caf-lib before it is initialized.
10546 : Register only allocatable components, that are not coarray'ed
10547 : components (%comp[*]). Only register when the constructor is the
10548 : null-expression. */
10549 30772 : if (coarray && !cm->attr.codimension
10550 515 : && (cm->attr.allocatable || cm->attr.pointer)
10551 179 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10552 : {
10553 177 : tree token, desc, size;
10554 354 : bool is_array = cm->ts.type == BT_CLASS
10555 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10556 :
10557 177 : field = cm->backend_decl;
10558 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
10559 177 : TREE_TYPE (field), dest, field, NULL_TREE);
10560 177 : if (cm->ts.type == BT_CLASS)
10561 0 : field = gfc_class_data_get (field);
10562 :
10563 177 : token
10564 : = is_array
10565 177 : ? gfc_conv_descriptor_token (field)
10566 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10567 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10568 52 : gfc_comp_caf_token (cm), NULL_TREE);
10569 :
10570 177 : if (is_array)
10571 : {
10572 : /* The _caf_register routine looks at the rank of the array
10573 : descriptor to decide whether the data registered is an array
10574 : or not. */
10575 125 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10576 125 : : cm->as->rank;
10577 : /* When the rank is not known just set a positive rank, which
10578 : suffices to recognize the data as array. */
10579 125 : if (rank < 0)
10580 0 : rank = 1;
10581 125 : size = build_zero_cst (size_type_node);
10582 125 : desc = field;
10583 125 : gfc_conv_descriptor_rank_set (&block, desc, rank);
10584 : }
10585 : else
10586 : {
10587 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10588 52 : cm->ts.type == BT_CLASS
10589 52 : ? CLASS_DATA (cm)->attr
10590 : : cm->attr);
10591 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10592 : }
10593 177 : gfc_add_block_to_block (&block, &se.pre);
10594 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10595 : 7, size, build_int_cst (
10596 : integer_type_node,
10597 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10598 : gfc_build_addr_expr (pvoid_type_node,
10599 : token),
10600 : gfc_build_addr_expr (NULL_TREE, desc),
10601 : null_pointer_node, null_pointer_node,
10602 : integer_zero_node);
10603 177 : gfc_add_expr_to_block (&block, tmp);
10604 : }
10605 30772 : field = cm->backend_decl;
10606 30772 : gcc_assert(field);
10607 30772 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10608 : dest, field, NULL_TREE);
10609 30772 : if (!c->expr)
10610 : {
10611 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10612 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10613 0 : gfc_free_expr (e);
10614 : }
10615 : else
10616 30772 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10617 30772 : gfc_add_expr_to_block (&block, tmp);
10618 : }
10619 21077 : return gfc_finish_block (&block);
10620 : }
10621 :
10622 : static void
10623 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10624 : gfc_component *un, gfc_expr *init)
10625 : {
10626 21 : gfc_constructor *ctor;
10627 :
10628 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
10629 : return;
10630 :
10631 21 : ctor = gfc_constructor_first (init->value.constructor);
10632 :
10633 21 : if (ctor == NULL || ctor->expr == NULL)
10634 : return;
10635 :
10636 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
10637 :
10638 : /* If we have an 'initialize all' constructor, do it first. */
10639 21 : if (ctor->expr->expr_type == EXPR_NULL)
10640 : {
10641 9 : tree union_type = TREE_TYPE (un->backend_decl);
10642 9 : tree val = build_constructor (union_type, NULL);
10643 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10644 9 : ctor = gfc_constructor_next (ctor);
10645 : }
10646 :
10647 : /* Add the map initializer on top. */
10648 21 : if (ctor != NULL && ctor->expr != NULL)
10649 : {
10650 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
10651 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
10652 12 : TREE_TYPE (un->backend_decl),
10653 12 : un->attr.dimension, un->attr.pointer,
10654 12 : un->attr.proc_pointer);
10655 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10656 : }
10657 : }
10658 :
10659 : /* Build an expression for a constructor. If init is nonzero then
10660 : this is part of a static variable initializer. */
10661 :
10662 : void
10663 38997 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
10664 : {
10665 38997 : gfc_constructor *c;
10666 38997 : gfc_component *cm;
10667 38997 : tree val;
10668 38997 : tree type;
10669 38997 : tree tmp;
10670 38997 : vec<constructor_elt, va_gc> *v = NULL;
10671 :
10672 38997 : gcc_assert (se->ss == NULL);
10673 38997 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10674 38997 : type = gfc_typenode_for_spec (&expr->ts);
10675 :
10676 38997 : if (!init)
10677 : {
10678 16428 : if (IS_PDT (expr) && expr->must_finalize)
10679 276 : final_block = &se->finalblock;
10680 :
10681 : /* Create a temporary variable and fill it in. */
10682 16428 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
10683 : /* The symtree in expr is NULL, if the code to generate is for
10684 : initializing the static members only. */
10685 32856 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
10686 16428 : se->want_coarray);
10687 16428 : gfc_add_expr_to_block (&se->pre, tmp);
10688 16428 : final_block = NULL;
10689 16428 : return;
10690 : }
10691 :
10692 22569 : cm = expr->ts.u.derived->components;
10693 :
10694 22569 : for (c = gfc_constructor_first (expr->value.constructor);
10695 115337 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
10696 : {
10697 : /* Skip absent members in default initializers and allocatable
10698 : components. Although the latter have a default initializer
10699 : of EXPR_NULL,... by default, the static nullify is not needed
10700 : since this is done every time we come into scope. */
10701 101579 : if (!c->expr
10702 90338 : || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)
10703 176815 : || (IS_PDT (cm) && has_parameterized_comps (cm->ts.u.derived)))
10704 8811 : continue;
10705 :
10706 83957 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
10707 48841 : && strcmp (cm->name, "_extends") == 0
10708 1356 : && cm->initializer->symtree)
10709 : {
10710 1356 : tree vtab;
10711 1356 : gfc_symbol *vtabs;
10712 1356 : vtabs = cm->initializer->symtree->n.sym;
10713 1356 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
10714 1356 : vtab = unshare_expr_without_location (vtab);
10715 1356 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
10716 1356 : }
10717 82601 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
10718 : {
10719 8920 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
10720 8920 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10721 : fold_convert (TREE_TYPE (cm->backend_decl),
10722 : val));
10723 8920 : }
10724 73681 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
10725 425 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10726 : fold_convert (TREE_TYPE (cm->backend_decl),
10727 425 : integer_zero_node));
10728 73256 : else if (cm->ts.type == BT_UNION)
10729 21 : gfc_conv_union_initializer (v, cm, c->expr);
10730 : else
10731 : {
10732 73235 : val = gfc_conv_initializer (c->expr, &cm->ts,
10733 73235 : TREE_TYPE (cm->backend_decl),
10734 73235 : cm->attr.dimension, cm->attr.pointer,
10735 73235 : cm->attr.proc_pointer);
10736 73235 : val = unshare_expr_without_location (val);
10737 :
10738 : /* Append it to the constructor list. */
10739 166003 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
10740 : }
10741 : }
10742 :
10743 22569 : se->expr = build_constructor (type, v);
10744 22569 : if (init)
10745 22569 : TREE_CONSTANT (se->expr) = 1;
10746 : }
10747 :
10748 :
10749 : /* Translate a substring expression. */
10750 :
10751 : static void
10752 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
10753 : {
10754 258 : gfc_ref *ref;
10755 :
10756 258 : ref = expr->ref;
10757 :
10758 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
10759 :
10760 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
10761 258 : expr->value.character.length,
10762 258 : expr->value.character.string);
10763 :
10764 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
10765 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
10766 :
10767 258 : if (ref)
10768 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
10769 258 : }
10770 :
10771 :
10772 : /* Entry point for expression translation. Evaluates a scalar quantity.
10773 : EXPR is the expression to be translated, and SE is the state structure if
10774 : called from within the scalarized. */
10775 :
10776 : void
10777 3688633 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
10778 : {
10779 3688633 : gfc_ss *ss;
10780 :
10781 3688633 : ss = se->ss;
10782 3688633 : if (ss && ss->info->expr == expr
10783 240592 : && (ss->info->type == GFC_SS_SCALAR
10784 : || ss->info->type == GFC_SS_REFERENCE))
10785 : {
10786 40741 : gfc_ss_info *ss_info;
10787 :
10788 40741 : ss_info = ss->info;
10789 : /* Substitute a scalar expression evaluated outside the scalarization
10790 : loop. */
10791 40741 : se->expr = ss_info->data.scalar.value;
10792 40741 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
10793 844 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
10794 :
10795 40741 : se->string_length = ss_info->string_length;
10796 40741 : gfc_advance_se_ss_chain (se);
10797 40741 : return;
10798 : }
10799 :
10800 : /* We need to convert the expressions for the iso_c_binding derived types.
10801 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
10802 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
10803 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
10804 : updated to be an integer with a kind equal to the size of a (void *). */
10805 3647892 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
10806 14924 : && expr->ts.u.derived->attr.is_bind_c)
10807 : {
10808 14015 : if (expr->expr_type == EXPR_VARIABLE
10809 9563 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
10810 9563 : || expr->symtree->n.sym->intmod_sym_id
10811 : == ISOCBINDING_NULL_FUNPTR))
10812 : {
10813 : /* Set expr_type to EXPR_NULL, which will result in
10814 : null_pointer_node being used below. */
10815 0 : expr->expr_type = EXPR_NULL;
10816 : }
10817 : else
10818 : {
10819 : /* Update the type/kind of the expression to be what the new
10820 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
10821 14015 : expr->ts.type = BT_INTEGER;
10822 14015 : expr->ts.f90_type = BT_VOID;
10823 14015 : expr->ts.kind = gfc_index_integer_kind;
10824 : }
10825 : }
10826 :
10827 3647892 : gfc_fix_class_refs (expr);
10828 :
10829 3647892 : switch (expr->expr_type)
10830 : {
10831 510863 : case EXPR_OP:
10832 510863 : gfc_conv_expr_op (se, expr);
10833 510863 : break;
10834 :
10835 159 : case EXPR_CONDITIONAL:
10836 159 : gfc_conv_conditional_expr (se, expr);
10837 159 : break;
10838 :
10839 309438 : case EXPR_FUNCTION:
10840 309438 : gfc_conv_function_expr (se, expr);
10841 309438 : break;
10842 :
10843 1148632 : case EXPR_CONSTANT:
10844 1148632 : gfc_conv_constant (se, expr);
10845 1148632 : break;
10846 :
10847 1621576 : case EXPR_VARIABLE:
10848 1621576 : gfc_conv_variable (se, expr);
10849 1621576 : break;
10850 :
10851 4283 : case EXPR_NULL:
10852 4283 : se->expr = null_pointer_node;
10853 4283 : break;
10854 :
10855 258 : case EXPR_SUBSTRING:
10856 258 : gfc_conv_substring_expr (se, expr);
10857 258 : break;
10858 :
10859 16428 : case EXPR_STRUCTURE:
10860 16428 : gfc_conv_structure (se, expr, 0);
10861 : /* F2008 4.5.6.3 para 5: If an executable construct references a
10862 : structure constructor or array constructor, the entity created by
10863 : the constructor is finalized after execution of the innermost
10864 : executable construct containing the reference. This, in fact,
10865 : was later deleted by the Combined Technical Corrigenda 1 TO 4 for
10866 : fortran 2008 (f08/0011). */
10867 16428 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
10868 16428 : && !(gfc_option.allow_std & GFC_STD_GNU)
10869 139 : && expr->must_finalize
10870 16440 : && gfc_may_be_finalized (expr->ts))
10871 : {
10872 12 : locus loc;
10873 12 : gfc_locus_from_location (&loc, input_location);
10874 12 : gfc_warning (0, "The structure constructor at %L has been"
10875 : " finalized. This feature was removed by f08/0011."
10876 : " Use -std=f2018 or -std=gnu to eliminate the"
10877 : " finalization.", &loc);
10878 12 : symbol_attribute attr;
10879 12 : attr.allocatable = attr.pointer = 0;
10880 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
10881 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
10882 : }
10883 : break;
10884 :
10885 36255 : case EXPR_ARRAY:
10886 36255 : gfc_conv_array_constructor_expr (se, expr);
10887 36255 : gfc_add_block_to_block (&se->post, &se->finalblock);
10888 36255 : break;
10889 :
10890 0 : default:
10891 0 : gcc_unreachable ();
10892 3688633 : break;
10893 : }
10894 : }
10895 :
10896 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
10897 : of an assignment. */
10898 : void
10899 377353 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
10900 : {
10901 377353 : gfc_conv_expr (se, expr);
10902 : /* All numeric lvalues should have empty post chains. If not we need to
10903 : figure out a way of rewriting an lvalue so that it has no post chain. */
10904 377353 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
10905 377353 : }
10906 :
10907 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
10908 : numeric expressions. Used for scalar values where inserting cleanup code
10909 : is inconvenient. */
10910 : void
10911 1044362 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
10912 : {
10913 1044362 : tree val;
10914 :
10915 1044362 : gcc_assert (expr->ts.type != BT_CHARACTER);
10916 1044362 : gfc_conv_expr (se, expr);
10917 1044362 : if (se->post.head)
10918 : {
10919 2559 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
10920 2559 : gfc_add_modify (&se->pre, val, se->expr);
10921 2559 : se->expr = val;
10922 2559 : gfc_add_block_to_block (&se->pre, &se->post);
10923 : }
10924 1044362 : }
10925 :
10926 : /* Helper to translate an expression and convert it to a particular type. */
10927 : void
10928 296271 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
10929 : {
10930 296271 : gfc_conv_expr_val (se, expr);
10931 296271 : se->expr = convert (type, se->expr);
10932 296271 : }
10933 :
10934 :
10935 : /* Converts an expression so that it can be passed by reference. Scalar
10936 : values only. */
10937 :
10938 : void
10939 229670 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
10940 : {
10941 229670 : gfc_ss *ss;
10942 229670 : tree var;
10943 :
10944 229670 : ss = se->ss;
10945 229670 : if (ss && ss->info->expr == expr
10946 8029 : && ss->info->type == GFC_SS_REFERENCE)
10947 : {
10948 : /* Returns a reference to the scalar evaluated outside the loop
10949 : for this case. */
10950 907 : gfc_conv_expr (se, expr);
10951 :
10952 907 : if (expr->ts.type == BT_CHARACTER
10953 114 : && expr->expr_type != EXPR_FUNCTION)
10954 102 : gfc_conv_string_parameter (se);
10955 : else
10956 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10957 :
10958 : return;
10959 : }
10960 :
10961 228763 : if (expr->ts.type == BT_CHARACTER)
10962 : {
10963 49903 : gfc_conv_expr (se, expr);
10964 49903 : gfc_conv_string_parameter (se);
10965 49903 : return;
10966 : }
10967 :
10968 178860 : if (expr->expr_type == EXPR_VARIABLE)
10969 : {
10970 71390 : se->want_pointer = 1;
10971 71390 : gfc_conv_expr (se, expr);
10972 71390 : if (se->post.head)
10973 : {
10974 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10975 0 : gfc_add_modify (&se->pre, var, se->expr);
10976 0 : gfc_add_block_to_block (&se->pre, &se->post);
10977 0 : se->expr = var;
10978 : }
10979 : return;
10980 : }
10981 :
10982 107470 : if (expr->expr_type == EXPR_CONDITIONAL)
10983 : {
10984 18 : se->want_pointer = 1;
10985 18 : gfc_conv_expr (se, expr);
10986 18 : return;
10987 : }
10988 :
10989 107452 : if (expr->expr_type == EXPR_FUNCTION
10990 13850 : && ((expr->value.function.esym
10991 2107 : && expr->value.function.esym->result
10992 2106 : && expr->value.function.esym->result->attr.pointer
10993 83 : && !expr->value.function.esym->result->attr.dimension)
10994 13773 : || (!expr->value.function.esym && !expr->ref
10995 11637 : && expr->symtree->n.sym->attr.pointer
10996 0 : && !expr->symtree->n.sym->attr.dimension)))
10997 : {
10998 77 : se->want_pointer = 1;
10999 77 : gfc_conv_expr (se, expr);
11000 77 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11001 77 : gfc_add_modify (&se->pre, var, se->expr);
11002 77 : se->expr = var;
11003 77 : return;
11004 : }
11005 :
11006 107375 : gfc_conv_expr (se, expr);
11007 :
11008 : /* Create a temporary var to hold the value. */
11009 107375 : if (TREE_CONSTANT (se->expr))
11010 : {
11011 : tree tmp = se->expr;
11012 84936 : STRIP_TYPE_NOPS (tmp);
11013 84936 : var = build_decl (input_location,
11014 84936 : CONST_DECL, NULL, TREE_TYPE (tmp));
11015 84936 : DECL_INITIAL (var) = tmp;
11016 84936 : TREE_STATIC (var) = 1;
11017 84936 : pushdecl (var);
11018 : }
11019 : else
11020 : {
11021 22439 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
11022 22439 : gfc_add_modify (&se->pre, var, se->expr);
11023 : }
11024 :
11025 107375 : if (!expr->must_finalize)
11026 107279 : gfc_add_block_to_block (&se->pre, &se->post);
11027 :
11028 : /* Take the address of that value. */
11029 107375 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
11030 : }
11031 :
11032 :
11033 : /* Get the _len component for an unlimited polymorphic expression. */
11034 :
11035 : static tree
11036 1872 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
11037 : {
11038 1872 : gfc_se se;
11039 1872 : gfc_ref *ref = expr->ref;
11040 :
11041 1872 : gfc_init_se (&se, NULL);
11042 3858 : while (ref && ref->next)
11043 : ref = ref->next;
11044 1872 : gfc_add_len_component (expr);
11045 1872 : gfc_conv_expr (&se, expr);
11046 1872 : gfc_add_block_to_block (block, &se.pre);
11047 1872 : gcc_assert (se.post.head == NULL_TREE);
11048 1872 : if (ref)
11049 : {
11050 286 : gfc_free_ref_list (ref->next);
11051 286 : ref->next = NULL;
11052 : }
11053 : else
11054 : {
11055 1586 : gfc_free_ref_list (expr->ref);
11056 1586 : expr->ref = NULL;
11057 : }
11058 1872 : return se.expr;
11059 : }
11060 :
11061 :
11062 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
11063 : statement-list outside of the scalarizer-loop. When code is generated, that
11064 : depends on the scalarized expression, it is added to RSE.PRE.
11065 : Returns le's _vptr tree and when set the len expressions in to_lenp and
11066 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
11067 : expression. */
11068 :
11069 : static tree
11070 4637 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
11071 : gfc_expr * re, gfc_se *rse,
11072 : tree * to_lenp, tree * from_lenp,
11073 : tree * from_vptrp)
11074 : {
11075 4637 : gfc_se se;
11076 4637 : gfc_expr * vptr_expr;
11077 4637 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
11078 4637 : bool set_vptr = false, temp_rhs = false;
11079 4637 : stmtblock_t *pre = block;
11080 4637 : tree class_expr = NULL_TREE;
11081 4637 : tree from_vptr = NULL_TREE;
11082 :
11083 : /* Create a temporary for complicated expressions. */
11084 4637 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
11085 1311 : && rse->expr != NULL_TREE)
11086 : {
11087 1311 : if (!DECL_P (rse->expr))
11088 : {
11089 392 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11090 37 : class_expr = gfc_get_class_from_expr (rse->expr);
11091 :
11092 392 : if (rse->loop)
11093 159 : pre = &rse->loop->pre;
11094 : else
11095 233 : pre = &rse->pre;
11096 :
11097 392 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
11098 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
11099 : else
11100 355 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
11101 :
11102 392 : rse->expr = tmp;
11103 : }
11104 : else
11105 919 : pre = &rse->pre;
11106 :
11107 : temp_rhs = true;
11108 : }
11109 :
11110 : /* Get the _vptr for the left-hand side expression. */
11111 4637 : gfc_init_se (&se, NULL);
11112 4637 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
11113 4637 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
11114 : {
11115 : /* Care about _len for unlimited polymorphic entities. */
11116 4637 : if (UNLIMITED_POLY (vptr_expr)
11117 3587 : || (vptr_expr->ts.type == BT_DERIVED
11118 2539 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11119 1552 : to_len = trans_get_upoly_len (block, vptr_expr);
11120 4637 : gfc_add_vptr_component (vptr_expr);
11121 4637 : set_vptr = true;
11122 : }
11123 : else
11124 0 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11125 4637 : se.want_pointer = 1;
11126 4637 : gfc_conv_expr (&se, vptr_expr);
11127 4637 : gfc_free_expr (vptr_expr);
11128 4637 : gfc_add_block_to_block (block, &se.pre);
11129 4637 : gcc_assert (se.post.head == NULL_TREE);
11130 4637 : lhs_vptr = se.expr;
11131 4637 : STRIP_NOPS (lhs_vptr);
11132 :
11133 : /* Set the _vptr only when the left-hand side of the assignment is a
11134 : class-object. */
11135 4637 : if (set_vptr)
11136 : {
11137 : /* Get the vptr from the rhs expression only, when it is variable.
11138 : Functions are expected to be assigned to a temporary beforehand. */
11139 3197 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
11140 5466 : ? gfc_find_and_cut_at_last_class_ref (re)
11141 : : NULL;
11142 829 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
11143 : {
11144 829 : if (to_len != NULL_TREE)
11145 : {
11146 : /* Get the _len information from the rhs. */
11147 335 : if (UNLIMITED_POLY (vptr_expr)
11148 : || (vptr_expr->ts.type == BT_DERIVED
11149 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
11150 308 : from_len = trans_get_upoly_len (block, vptr_expr);
11151 : }
11152 829 : gfc_add_vptr_component (vptr_expr);
11153 : }
11154 : else
11155 : {
11156 3808 : if (re->expr_type == EXPR_VARIABLE
11157 2368 : && DECL_P (re->symtree->n.sym->backend_decl)
11158 2368 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
11159 834 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
11160 3875 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
11161 : re->symtree->n.sym->backend_decl))))
11162 : {
11163 43 : vptr_expr = NULL;
11164 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
11165 : re->symtree->n.sym->backend_decl));
11166 43 : if (to_len && UNLIMITED_POLY (re))
11167 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
11168 : re->symtree->n.sym->backend_decl));
11169 : }
11170 3765 : else if (temp_rhs && re->ts.type == BT_CLASS)
11171 : {
11172 227 : vptr_expr = NULL;
11173 227 : if (class_expr)
11174 : tmp = class_expr;
11175 190 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11176 0 : tmp = gfc_get_class_from_expr (rse->expr);
11177 : else
11178 : tmp = rse->expr;
11179 :
11180 227 : se.expr = gfc_class_vptr_get (tmp);
11181 227 : from_vptr = se.expr;
11182 227 : if (UNLIMITED_POLY (re))
11183 74 : from_len = gfc_class_len_get (tmp);
11184 :
11185 : }
11186 3538 : else if (re->expr_type != EXPR_NULL)
11187 : /* Only when rhs is non-NULL use its declared type for vptr
11188 : initialisation. */
11189 3409 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
11190 : else
11191 : /* When the rhs is NULL use the vtab of lhs' declared type. */
11192 129 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11193 : }
11194 :
11195 4441 : if (vptr_expr)
11196 : {
11197 4367 : gfc_init_se (&se, NULL);
11198 4367 : se.want_pointer = 1;
11199 4367 : gfc_conv_expr (&se, vptr_expr);
11200 4367 : gfc_free_expr (vptr_expr);
11201 4367 : gfc_add_block_to_block (block, &se.pre);
11202 4367 : gcc_assert (se.post.head == NULL_TREE);
11203 4367 : from_vptr = se.expr;
11204 : }
11205 4637 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
11206 : se.expr));
11207 :
11208 4637 : if (to_len != NULL_TREE)
11209 : {
11210 : /* The _len component needs to be set. Figure how to get the
11211 : value of the right-hand side. */
11212 1552 : if (from_len == NULL_TREE)
11213 : {
11214 1170 : if (rse->string_length != NULL_TREE)
11215 : from_len = rse->string_length;
11216 712 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
11217 : {
11218 0 : gfc_init_se (&se, NULL);
11219 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
11220 0 : gfc_add_block_to_block (block, &se.pre);
11221 0 : gcc_assert (se.post.head == NULL_TREE);
11222 0 : from_len = gfc_evaluate_now (se.expr, block);
11223 : }
11224 : else
11225 712 : from_len = build_zero_cst (gfc_charlen_type_node);
11226 : }
11227 1552 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
11228 : from_len));
11229 : }
11230 : }
11231 :
11232 : /* Return the _len and _vptr trees only, when requested. */
11233 4637 : if (to_lenp)
11234 3421 : *to_lenp = to_len;
11235 4637 : if (from_lenp)
11236 3421 : *from_lenp = from_len;
11237 4637 : if (from_vptrp)
11238 3421 : *from_vptrp = from_vptr;
11239 4637 : return lhs_vptr;
11240 : }
11241 :
11242 :
11243 : /* Assign tokens for pointer components. */
11244 :
11245 : static void
11246 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11247 : gfc_expr *expr2)
11248 : {
11249 12 : symbol_attribute lhs_attr, rhs_attr;
11250 12 : tree tmp, lhs_tok, rhs_tok;
11251 : /* Flag to indicated component refs on the rhs. */
11252 12 : bool rhs_cr;
11253 :
11254 12 : lhs_attr = gfc_caf_attr (expr1);
11255 12 : if (expr2->expr_type != EXPR_NULL)
11256 : {
11257 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11258 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11259 : {
11260 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11261 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11262 :
11263 4 : if (rhs_cr)
11264 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11265 : else
11266 : {
11267 4 : tree caf_decl;
11268 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11269 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11270 : NULL_TREE, NULL);
11271 : }
11272 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11273 : lhs_tok,
11274 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11275 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11276 : }
11277 : }
11278 4 : else if (lhs_attr.codimension)
11279 : {
11280 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11281 4 : if (!lhs_tok)
11282 : {
11283 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11284 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11285 : }
11286 : else
11287 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11288 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11289 : lhs_tok, null_pointer_node);
11290 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11291 : }
11292 12 : }
11293 :
11294 :
11295 : /* Do everything that is needed for a CLASS function expr2. */
11296 :
11297 : static tree
11298 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11299 : gfc_expr *expr1, gfc_expr *expr2)
11300 : {
11301 18 : tree expr1_vptr = NULL_TREE;
11302 18 : tree tmp;
11303 :
11304 18 : gfc_conv_function_expr (rse, expr2);
11305 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11306 :
11307 18 : if (expr1->ts.type != BT_CLASS)
11308 12 : rse->expr = gfc_class_data_get (rse->expr);
11309 : else
11310 : {
11311 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11312 : expr2, rse,
11313 : NULL, NULL, NULL);
11314 6 : gfc_add_block_to_block (block, &rse->pre);
11315 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11316 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11317 :
11318 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11319 6 : fold_convert (TREE_TYPE (expr1_vptr),
11320 : gfc_class_vptr_get (tmp)));
11321 6 : rse->expr = gfc_class_data_get (tmp);
11322 : }
11323 :
11324 18 : return expr1_vptr;
11325 : }
11326 :
11327 :
11328 : tree
11329 10211 : gfc_trans_pointer_assign (gfc_code * code)
11330 : {
11331 10211 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11332 : }
11333 :
11334 :
11335 : /* Generate code for a pointer assignment. */
11336 :
11337 : tree
11338 10266 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11339 : {
11340 10266 : gfc_se lse;
11341 10266 : gfc_se rse;
11342 10266 : stmtblock_t block;
11343 10266 : tree desc;
11344 10266 : tree tmp;
11345 10266 : tree expr1_vptr = NULL_TREE;
11346 10266 : bool scalar, non_proc_ptr_assign;
11347 10266 : gfc_ss *ss;
11348 :
11349 10266 : gfc_start_block (&block);
11350 :
11351 10266 : gfc_init_se (&lse, NULL);
11352 :
11353 : /* Usually testing whether this is not a proc pointer assignment. */
11354 10266 : non_proc_ptr_assign
11355 10266 : = !(gfc_expr_attr (expr1).proc_pointer
11356 1207 : && ((expr2->expr_type == EXPR_VARIABLE
11357 975 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11358 282 : || expr2->expr_type == EXPR_NULL));
11359 :
11360 : /* Check whether the expression is a scalar or not; we cannot use
11361 : expr1->rank as it can be nonzero for proc pointers. */
11362 10266 : ss = gfc_walk_expr (expr1);
11363 10266 : scalar = ss == gfc_ss_terminator;
11364 10266 : if (!scalar)
11365 4402 : gfc_free_ss_chain (ss);
11366 :
11367 10266 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11368 90 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11369 : {
11370 66 : gfc_add_data_component (expr2);
11371 : /* The following is required as gfc_add_data_component doesn't
11372 : update ts.type if there is a trailing REF_ARRAY. */
11373 66 : expr2->ts.type = BT_DERIVED;
11374 : }
11375 :
11376 10266 : if (scalar)
11377 : {
11378 : /* Scalar pointers. */
11379 5864 : lse.want_pointer = 1;
11380 5864 : gfc_conv_expr (&lse, expr1);
11381 5864 : gfc_init_se (&rse, NULL);
11382 5864 : rse.want_pointer = 1;
11383 5864 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11384 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11385 : else
11386 5858 : gfc_conv_expr (&rse, expr2);
11387 :
11388 5864 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11389 : {
11390 769 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11391 : NULL, NULL);
11392 769 : lse.expr = gfc_class_data_get (lse.expr);
11393 : }
11394 :
11395 5864 : if (expr1->symtree->n.sym->attr.proc_pointer
11396 863 : && expr1->symtree->n.sym->attr.dummy)
11397 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11398 : lse.expr);
11399 :
11400 5864 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11401 47 : && expr2->symtree->n.sym->attr.dummy)
11402 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11403 : rse.expr);
11404 :
11405 5864 : gfc_add_block_to_block (&block, &lse.pre);
11406 5864 : gfc_add_block_to_block (&block, &rse.pre);
11407 :
11408 : /* Check character lengths if character expression. The test is only
11409 : really added if -fbounds-check is enabled. Exclude deferred
11410 : character length lefthand sides. */
11411 960 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11412 786 : && !expr1->ts.deferred
11413 371 : && !expr1->symtree->n.sym->attr.proc_pointer
11414 6228 : && !gfc_is_proc_ptr_comp (expr1))
11415 : {
11416 345 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11417 345 : gcc_assert (lse.string_length && rse.string_length);
11418 345 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11419 : lse.string_length, rse.string_length,
11420 : &block);
11421 : }
11422 :
11423 : /* The assignment to an deferred character length sets the string
11424 : length to that of the rhs. */
11425 5864 : if (expr1->ts.deferred)
11426 : {
11427 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11428 413 : gfc_add_modify (&block, lse.string_length,
11429 413 : fold_convert (TREE_TYPE (lse.string_length),
11430 : rse.string_length));
11431 117 : else if (lse.string_length != NULL)
11432 115 : gfc_add_modify (&block, lse.string_length,
11433 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11434 : }
11435 :
11436 5864 : gfc_add_modify (&block, lse.expr,
11437 5864 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11438 :
11439 5864 : if (flag_coarray == GFC_FCOARRAY_LIB)
11440 : {
11441 342 : if (expr1->ref)
11442 : /* Also set the tokens for pointer components in derived typed
11443 : coarrays. */
11444 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11445 330 : else if (gfc_caf_attr (expr1).codimension)
11446 : {
11447 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11448 :
11449 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11450 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11451 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11452 : NULL_TREE, expr1);
11453 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11454 : NULL_TREE, expr2);
11455 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11456 : }
11457 : }
11458 :
11459 5864 : gfc_add_block_to_block (&block, &rse.post);
11460 5864 : gfc_add_block_to_block (&block, &lse.post);
11461 : }
11462 : else
11463 : {
11464 4402 : gfc_ref* remap;
11465 4402 : bool rank_remap;
11466 4402 : tree strlen_lhs;
11467 4402 : tree strlen_rhs = NULL_TREE;
11468 :
11469 : /* Array pointer. Find the last reference on the LHS and if it is an
11470 : array section ref, we're dealing with bounds remapping. In this case,
11471 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11472 : not see it and process the bounds remapping afterwards explicitly. */
11473 9782 : for (remap = expr1->ref; remap; remap = remap->next)
11474 5759 : if (!remap->next && remap->type == REF_ARRAY
11475 4402 : && remap->u.ar.type == AR_SECTION)
11476 : break;
11477 4402 : rank_remap = (remap && remap->u.ar.end[0]);
11478 :
11479 379 : if (remap && expr2->expr_type == EXPR_NULL)
11480 : {
11481 2 : gfc_error ("If bounds remapping is specified at %L, "
11482 : "the pointer target shall not be NULL", &expr1->where);
11483 2 : return NULL_TREE;
11484 : }
11485 :
11486 4400 : gfc_init_se (&lse, NULL);
11487 4400 : if (remap)
11488 377 : lse.descriptor_only = 1;
11489 4400 : gfc_conv_expr_descriptor (&lse, expr1);
11490 4400 : strlen_lhs = lse.string_length;
11491 4400 : desc = lse.expr;
11492 :
11493 4400 : if (expr2->expr_type == EXPR_NULL)
11494 : {
11495 : /* Just set the data pointer to null. */
11496 692 : gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
11497 : }
11498 3708 : else if (rank_remap)
11499 : {
11500 : /* If we are rank-remapping, just get the RHS's descriptor and
11501 : process this later on. */
11502 254 : gfc_init_se (&rse, NULL);
11503 254 : rse.direct_byref = 1;
11504 254 : rse.byref_noassign = 1;
11505 :
11506 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11507 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11508 : expr1, expr2);
11509 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11510 : {
11511 : tree bound[GFC_MAX_DIMENSIONS];
11512 : int i;
11513 :
11514 26 : for (i = 0; i < expr2->rank; i++)
11515 13 : bound[i] = NULL_TREE;
11516 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11517 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11518 : bound, bound, 0,
11519 : GFC_ARRAY_POINTER_CONT, false);
11520 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11521 13 : rse.descriptor_only = 0;
11522 13 : rse.expr = tmp;
11523 13 : rse.direct_byref = 1;
11524 13 : gfc_conv_expr_descriptor (&rse, expr2);
11525 13 : strlen_rhs = rse.string_length;
11526 13 : rse.expr = tmp;
11527 : }
11528 : else
11529 : {
11530 229 : gfc_conv_expr_descriptor (&rse, expr2);
11531 229 : strlen_rhs = rse.string_length;
11532 229 : if (expr1->ts.type == BT_CLASS)
11533 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11534 : expr2, &rse,
11535 : NULL, NULL,
11536 : NULL);
11537 : }
11538 : }
11539 3454 : else if (expr2->expr_type == EXPR_VARIABLE)
11540 : {
11541 : /* Assign directly to the LHS's descriptor. */
11542 3322 : lse.descriptor_only = 0;
11543 3322 : lse.direct_byref = 1;
11544 3322 : gfc_conv_expr_descriptor (&lse, expr2);
11545 3322 : strlen_rhs = lse.string_length;
11546 3322 : gfc_init_se (&rse, NULL);
11547 :
11548 3322 : if (expr1->ts.type == BT_CLASS)
11549 : {
11550 368 : rse.expr = NULL_TREE;
11551 368 : rse.string_length = strlen_rhs;
11552 368 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11553 : NULL, NULL, NULL);
11554 : }
11555 :
11556 3322 : if (remap == NULL)
11557 : {
11558 : /* If the target is not a whole array, use the target array
11559 : reference for remap. */
11560 6811 : for (remap = expr2->ref; remap; remap = remap->next)
11561 3768 : if (remap->type == REF_ARRAY
11562 3259 : && remap->u.ar.type == AR_FULL
11563 2566 : && remap->next)
11564 : break;
11565 : }
11566 : }
11567 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11568 : {
11569 25 : gfc_init_se (&rse, NULL);
11570 25 : rse.want_pointer = 1;
11571 25 : gfc_conv_function_expr (&rse, expr2);
11572 25 : if (expr1->ts.type != BT_CLASS)
11573 : {
11574 12 : rse.expr = gfc_class_data_get (rse.expr);
11575 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11576 : }
11577 : else
11578 : {
11579 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11580 : expr2, &rse, NULL,
11581 : NULL, NULL);
11582 13 : gfc_add_block_to_block (&block, &rse.pre);
11583 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11584 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11585 :
11586 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11587 13 : fold_convert (TREE_TYPE (expr1_vptr),
11588 : gfc_class_vptr_get (tmp)));
11589 13 : rse.expr = gfc_class_data_get (tmp);
11590 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11591 : }
11592 : }
11593 : else
11594 : {
11595 : /* Assign to a temporary descriptor and then copy that
11596 : temporary to the pointer. */
11597 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11598 107 : lse.descriptor_only = 0;
11599 107 : lse.expr = tmp;
11600 107 : lse.direct_byref = 1;
11601 107 : gfc_conv_expr_descriptor (&lse, expr2);
11602 107 : strlen_rhs = lse.string_length;
11603 107 : gfc_add_modify (&lse.pre, desc, tmp);
11604 : }
11605 :
11606 4400 : if (expr1->ts.type == BT_CHARACTER
11607 596 : && expr1->ts.deferred)
11608 : {
11609 338 : gfc_symbol *psym = expr1->symtree->n.sym;
11610 338 : tmp = NULL_TREE;
11611 338 : if (psym->ts.type == BT_CHARACTER
11612 337 : && psym->ts.u.cl->backend_decl)
11613 337 : tmp = psym->ts.u.cl->backend_decl;
11614 1 : else if (expr1->ts.u.cl->backend_decl
11615 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11616 0 : tmp = expr1->ts.u.cl->backend_decl;
11617 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11618 : {
11619 1 : gfc_ref *ref = expr1->ref;
11620 3 : for (;ref; ref = ref->next)
11621 : {
11622 2 : if (ref->type == REF_COMPONENT
11623 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11624 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11625 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11626 1 : TREE_TYPE (tmp),
11627 1 : TREE_OPERAND (lse.expr, 0),
11628 : tmp, NULL_TREE);
11629 : }
11630 : }
11631 :
11632 338 : gcc_assert (tmp);
11633 :
11634 338 : if (expr2->expr_type != EXPR_NULL)
11635 326 : gfc_add_modify (&block, tmp,
11636 326 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
11637 : else
11638 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
11639 : }
11640 :
11641 4400 : gfc_add_block_to_block (&block, &lse.pre);
11642 4400 : if (rank_remap)
11643 254 : gfc_add_block_to_block (&block, &rse.pre);
11644 :
11645 : /* If we do bounds remapping, update LHS descriptor accordingly. */
11646 4400 : if (remap)
11647 : {
11648 533 : int dim;
11649 533 : gcc_assert (remap->u.ar.dimen == expr1->rank);
11650 :
11651 : /* Always set dtype. */
11652 533 : gfc_conv_descriptor_dtype_set (&block, desc,
11653 533 : gfc_get_dtype (TREE_TYPE (desc)));
11654 :
11655 : /* For unlimited polymorphic LHS use elem_len from RHS. */
11656 533 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11657 : {
11658 60 : tree elem_len;
11659 60 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11660 60 : elem_len = fold_convert (gfc_array_index_type, tmp);
11661 60 : elem_len = gfc_evaluate_now (elem_len, &block);
11662 60 : gfc_conv_descriptor_elem_len_set (&block, desc, elem_len);
11663 : }
11664 :
11665 533 : if (rank_remap)
11666 : {
11667 : /* Do rank remapping. We already have the RHS's descriptor
11668 : converted in rse and now have to build the correct LHS
11669 : descriptor for it. */
11670 :
11671 254 : tree data, span;
11672 254 : tree offs, stride;
11673 254 : tree lbound, ubound;
11674 :
11675 : /* Copy data pointer. */
11676 254 : data = gfc_conv_descriptor_data_get (rse.expr);
11677 254 : gfc_conv_descriptor_data_set (&block, desc, data);
11678 :
11679 : /* Copy the span. */
11680 254 : if (VAR_P (rse.expr)
11681 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
11682 12 : span = gfc_conv_descriptor_span_get (rse.expr);
11683 : else
11684 : {
11685 242 : tmp = TREE_TYPE (rse.expr);
11686 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
11687 242 : span = fold_convert (gfc_array_index_type, tmp);
11688 : }
11689 254 : gfc_conv_descriptor_span_set (&block, desc, span);
11690 :
11691 : /* Copy offset but adjust it such that it would correspond
11692 : to a lbound of zero. */
11693 254 : if (expr2->rank == -1)
11694 42 : gfc_conv_descriptor_offset_set (&block, desc,
11695 : gfc_index_zero_node);
11696 : else
11697 : {
11698 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
11699 654 : for (dim = 0; dim < expr2->rank; ++dim)
11700 : {
11701 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11702 : gfc_rank_cst[dim]);
11703 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
11704 : gfc_rank_cst[dim]);
11705 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11706 : gfc_array_index_type, stride,
11707 : lbound);
11708 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
11709 : gfc_array_index_type, offs, tmp);
11710 : }
11711 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11712 : }
11713 : /* Set the bounds as declared for the LHS and calculate strides as
11714 : well as another offset update accordingly. */
11715 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11716 : gfc_rank_cst[0]);
11717 895 : for (dim = 0; dim < expr1->rank; ++dim)
11718 : {
11719 387 : gfc_se lower_se;
11720 387 : gfc_se upper_se;
11721 :
11722 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
11723 :
11724 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
11725 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
11726 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
11727 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
11728 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
11729 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
11730 :
11731 : /* Convert declared bounds. */
11732 387 : gfc_init_se (&lower_se, NULL);
11733 387 : gfc_init_se (&upper_se, NULL);
11734 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
11735 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
11736 :
11737 387 : gfc_add_block_to_block (&block, &lower_se.pre);
11738 387 : gfc_add_block_to_block (&block, &upper_se.pre);
11739 :
11740 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
11741 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
11742 :
11743 387 : lbound = gfc_evaluate_now (lbound, &block);
11744 387 : ubound = gfc_evaluate_now (ubound, &block);
11745 :
11746 387 : gfc_add_block_to_block (&block, &lower_se.post);
11747 387 : gfc_add_block_to_block (&block, &upper_se.post);
11748 :
11749 : /* Set bounds in descriptor. */
11750 387 : gfc_conv_descriptor_lbound_set (&block, desc,
11751 : gfc_rank_cst[dim], lbound);
11752 387 : gfc_conv_descriptor_ubound_set (&block, desc,
11753 : gfc_rank_cst[dim], ubound);
11754 :
11755 : /* Set stride. */
11756 387 : stride = gfc_evaluate_now (stride, &block);
11757 387 : gfc_conv_descriptor_stride_set (&block, desc,
11758 : gfc_rank_cst[dim], stride);
11759 :
11760 : /* Update offset. */
11761 387 : offs = gfc_conv_descriptor_offset_get (desc);
11762 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11763 : gfc_array_index_type, lbound, stride);
11764 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
11765 : gfc_array_index_type, offs, tmp);
11766 387 : offs = gfc_evaluate_now (offs, &block);
11767 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11768 :
11769 : /* Update stride. */
11770 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11771 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
11772 : gfc_array_index_type, stride, tmp);
11773 : }
11774 : }
11775 : else
11776 : {
11777 : /* Bounds remapping. Just shift the lower bounds. */
11778 :
11779 279 : gcc_assert (expr1->rank == expr2->rank);
11780 :
11781 666 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
11782 : {
11783 387 : gfc_se lbound_se;
11784 :
11785 387 : gcc_assert (!remap->u.ar.end[dim]);
11786 387 : gfc_init_se (&lbound_se, NULL);
11787 387 : if (remap->u.ar.start[dim])
11788 : {
11789 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
11790 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
11791 : }
11792 : else
11793 : /* This remap arises from a target that is not a whole
11794 : array. The start expressions will be NULL but we need
11795 : the lbounds to be one. */
11796 162 : lbound_se.expr = gfc_index_one_node;
11797 387 : gfc_conv_shift_descriptor_lbound (&block, desc,
11798 : dim, lbound_se.expr);
11799 387 : gfc_add_block_to_block (&block, &lbound_se.post);
11800 : }
11801 : }
11802 : }
11803 :
11804 : /* If rank remapping was done, check with -fcheck=bounds that
11805 : the target is at least as large as the pointer. */
11806 4400 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
11807 72 : && expr2->rank != -1)
11808 : {
11809 54 : tree lsize, rsize;
11810 54 : tree fault;
11811 54 : const char* msg;
11812 :
11813 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
11814 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
11815 :
11816 54 : lsize = gfc_evaluate_now (lsize, &block);
11817 54 : rsize = gfc_evaluate_now (rsize, &block);
11818 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11819 : rsize, lsize);
11820 :
11821 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
11822 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
11823 : msg, rsize, lsize);
11824 : }
11825 :
11826 : /* Check string lengths if applicable. The check is only really added
11827 : to the output code if -fbounds-check is enabled. */
11828 4400 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
11829 : {
11830 530 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11831 530 : gcc_assert (strlen_lhs && strlen_rhs);
11832 530 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11833 : strlen_lhs, strlen_rhs, &block);
11834 : }
11835 :
11836 4400 : gfc_add_block_to_block (&block, &lse.post);
11837 4400 : if (rank_remap)
11838 254 : gfc_add_block_to_block (&block, &rse.post);
11839 : }
11840 :
11841 10264 : return gfc_finish_block (&block);
11842 : }
11843 :
11844 :
11845 : /* Makes sure se is suitable for passing as a function string parameter. */
11846 : /* TODO: Need to check all callers of this function. It may be abused. */
11847 :
11848 : void
11849 247588 : gfc_conv_string_parameter (gfc_se * se)
11850 : {
11851 247588 : tree type;
11852 :
11853 247588 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
11854 247588 : && integer_onep (se->string_length))
11855 : {
11856 691 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11857 691 : return;
11858 : }
11859 :
11860 246897 : if (TREE_CODE (se->expr) == STRING_CST)
11861 : {
11862 103138 : type = TREE_TYPE (TREE_TYPE (se->expr));
11863 103138 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11864 103138 : return;
11865 : }
11866 :
11867 143759 : if (TREE_CODE (se->expr) == COND_EXPR)
11868 : {
11869 478 : tree cond = TREE_OPERAND (se->expr, 0);
11870 478 : tree lhs = TREE_OPERAND (se->expr, 1);
11871 478 : tree rhs = TREE_OPERAND (se->expr, 2);
11872 :
11873 478 : gfc_se lse, rse;
11874 478 : gfc_init_se (&lse, NULL);
11875 478 : gfc_init_se (&rse, NULL);
11876 :
11877 478 : lse.expr = lhs;
11878 478 : lse.string_length = se->string_length;
11879 478 : gfc_conv_string_parameter (&lse);
11880 :
11881 478 : rse.expr = rhs;
11882 478 : rse.string_length = se->string_length;
11883 478 : gfc_conv_string_parameter (&rse);
11884 :
11885 478 : se->expr
11886 478 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
11887 : cond, lse.expr, rse.expr);
11888 : }
11889 :
11890 143759 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
11891 56102 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
11892 143855 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
11893 : {
11894 87753 : type = TREE_TYPE (se->expr);
11895 87753 : if (TREE_CODE (se->expr) != INDIRECT_REF)
11896 82683 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11897 : else
11898 : {
11899 5070 : if (TREE_CODE (type) == ARRAY_TYPE)
11900 5070 : type = TREE_TYPE (type);
11901 5070 : type = gfc_get_character_type_len_for_eltype (type,
11902 : se->string_length);
11903 5070 : type = build_pointer_type (type);
11904 5070 : se->expr = gfc_build_addr_expr (type, se->expr);
11905 : }
11906 : }
11907 :
11908 143759 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
11909 : }
11910 :
11911 :
11912 : /* Generate code for assignment of scalar variables. Includes character
11913 : strings and derived types with allocatable components.
11914 : If you know that the LHS has no allocations, set dealloc to false.
11915 :
11916 : DEEP_COPY has no effect if the typespec TS is not a derived type with
11917 : allocatable components. Otherwise, if it is set, an explicit copy of each
11918 : allocatable component is made. This is necessary as a simple copy of the
11919 : whole object would copy array descriptors as is, so that the lhs's
11920 : allocatable components would point to the rhs's after the assignment.
11921 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
11922 : necessary if the rhs is a non-pointer function, as the allocatable components
11923 : are not accessible by other means than the function's result after the
11924 : function has returned. It is even more subtle when temporaries are involved,
11925 : as the two following examples show:
11926 : 1. When we evaluate an array constructor, a temporary is created. Thus
11927 : there is theoretically no alias possible. However, no deep copy is
11928 : made for this temporary, so that if the constructor is made of one or
11929 : more variable with allocatable components, those components still point
11930 : to the variable's: DEEP_COPY should be set for the assignment from the
11931 : temporary to the lhs in that case.
11932 : 2. When assigning a scalar to an array, we evaluate the scalar value out
11933 : of the loop, store it into a temporary variable, and assign from that.
11934 : In that case, deep copying when assigning to the temporary would be a
11935 : waste of resources; however deep copies should happen when assigning from
11936 : the temporary to each array element: again DEEP_COPY should be set for
11937 : the assignment from the temporary to the lhs. */
11938 :
11939 : tree
11940 342422 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
11941 : bool deep_copy, bool dealloc, bool in_coarray,
11942 : bool assoc_assign)
11943 : {
11944 342422 : stmtblock_t block;
11945 342422 : tree tmp;
11946 342422 : tree cond;
11947 342422 : int caf_mode;
11948 :
11949 342422 : gfc_init_block (&block);
11950 :
11951 342422 : if (ts.type == BT_CHARACTER)
11952 : {
11953 33555 : tree rlen = NULL;
11954 33555 : tree llen = NULL;
11955 :
11956 33555 : if (lse->string_length != NULL_TREE)
11957 : {
11958 33555 : gfc_conv_string_parameter (lse);
11959 33555 : gfc_add_block_to_block (&block, &lse->pre);
11960 33555 : llen = lse->string_length;
11961 : }
11962 :
11963 33555 : if (rse->string_length != NULL_TREE)
11964 : {
11965 33555 : gfc_conv_string_parameter (rse);
11966 33555 : gfc_add_block_to_block (&block, &rse->pre);
11967 33555 : rlen = rse->string_length;
11968 : }
11969 :
11970 33555 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
11971 : rse->expr, ts.kind);
11972 : }
11973 289306 : else if (gfc_bt_struct (ts.type)
11974 308867 : && (ts.u.derived->attr.alloc_comp
11975 12719 : || (deep_copy && has_parameterized_comps (ts.u.derived))))
11976 : {
11977 7004 : tree tmp_var = NULL_TREE;
11978 7004 : cond = NULL_TREE;
11979 :
11980 : /* Are the rhs and the lhs the same? */
11981 7004 : if (deep_copy)
11982 : {
11983 4212 : if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
11984 3065 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11985 4212 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11986 : gfc_build_addr_expr (NULL_TREE, lse->expr),
11987 : gfc_build_addr_expr (NULL_TREE, rse->expr));
11988 4212 : cond = gfc_evaluate_now (cond, &lse->pre);
11989 : }
11990 :
11991 : /* Deallocate the lhs allocated components as long as it is not
11992 : the same as the rhs. This must be done following the assignment
11993 : to prevent deallocating data that could be used in the rhs
11994 : expression. */
11995 7004 : if (dealloc)
11996 : {
11997 1971 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
11998 1971 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
11999 : 0, gfc_may_be_finalized (ts));
12000 1971 : if (deep_copy)
12001 845 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12002 : tmp);
12003 1971 : gfc_add_expr_to_block (&lse->post, tmp);
12004 : }
12005 :
12006 7004 : gfc_add_block_to_block (&block, &rse->pre);
12007 :
12008 : /* Skip finalization for self-assignment. */
12009 7004 : if (deep_copy && lse->finalblock.head)
12010 : {
12011 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12012 : gfc_finish_block (&lse->finalblock));
12013 24 : gfc_add_expr_to_block (&block, tmp);
12014 : }
12015 : else
12016 6980 : gfc_add_block_to_block (&block, &lse->finalblock);
12017 :
12018 7004 : gfc_add_block_to_block (&block, &lse->pre);
12019 :
12020 7004 : if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
12021 7004 : == TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)))
12022 6662 : gfc_add_modify (&block, lse->expr,
12023 6662 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12024 : else
12025 : {
12026 342 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12027 342 : TREE_TYPE (lse->expr), rse->expr);
12028 342 : gfc_add_modify (&block, lse->expr, tmp);
12029 : }
12030 :
12031 : /* Restore pointer address of coarray components. */
12032 7004 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
12033 : {
12034 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
12035 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12036 : tmp);
12037 5 : gfc_add_expr_to_block (&block, tmp);
12038 : }
12039 :
12040 : /* Do a deep copy if the rhs is a variable, if it is not the
12041 : same as the lhs. */
12042 7004 : if (deep_copy)
12043 : {
12044 4212 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
12045 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
12046 4212 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
12047 : caf_mode);
12048 4212 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
12049 : tmp);
12050 4212 : gfc_add_expr_to_block (&block, tmp);
12051 : }
12052 : }
12053 301863 : else if (gfc_bt_struct (ts.type))
12054 : {
12055 12557 : gfc_add_block_to_block (&block, &rse->pre);
12056 12557 : gfc_add_block_to_block (&block, &lse->finalblock);
12057 12557 : gfc_add_block_to_block (&block, &lse->pre);
12058 12557 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12059 12557 : TREE_TYPE (lse->expr), rse->expr);
12060 12557 : gfc_add_modify (&block, lse->expr, tmp);
12061 : }
12062 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
12063 289306 : else if (ts.type == BT_CLASS)
12064 : {
12065 800 : gfc_add_block_to_block (&block, &lse->pre);
12066 800 : gfc_add_block_to_block (&block, &rse->pre);
12067 800 : gfc_add_block_to_block (&block, &lse->finalblock);
12068 :
12069 800 : if (!trans_scalar_class_assign (&block, lse, rse))
12070 : {
12071 : /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
12072 : for the lhs which ensures that class data rhs cast as a string
12073 : assigns correctly. */
12074 654 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
12075 654 : TREE_TYPE (rse->expr), lse->expr);
12076 654 : gfc_add_modify (&block, tmp, rse->expr);
12077 :
12078 : /* Copy allocatable components but guard against class pointer
12079 : assign, which arrives here. */
12080 : #define DATA_DT ts.u.derived->components->ts.u.derived
12081 654 : if (deep_copy
12082 201 : && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
12083 43 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
12084 158 : && ts.u.derived->components
12085 812 : && DATA_DT && DATA_DT->attr.alloc_comp)
12086 : {
12087 6 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
12088 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
12089 : : 0;
12090 6 : tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
12091 : caf_mode);
12092 6 : gfc_add_expr_to_block (&block, tmp);
12093 : }
12094 : #undef DATA_DT
12095 : }
12096 : }
12097 288506 : else if (ts.type != BT_CLASS)
12098 : {
12099 288506 : gfc_add_block_to_block (&block, &lse->pre);
12100 288506 : gfc_add_block_to_block (&block, &rse->pre);
12101 :
12102 288506 : if (in_coarray)
12103 : {
12104 861 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
12105 : {
12106 0 : tree rtype = TREE_TYPE (TREE_TYPE (rse->expr));
12107 0 : tree rtoken = TYPE_LANG_SPECIFIC (rtype)->caf_token;
12108 0 : gfc_conv_descriptor_token_set (&block, lse->expr, rtoken);
12109 : }
12110 861 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
12111 0 : lse->expr = gfc_conv_array_data (lse->expr);
12112 276 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
12113 861 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
12114 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
12115 : }
12116 288506 : gfc_add_modify (&block, lse->expr,
12117 288506 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
12118 : }
12119 :
12120 342422 : gfc_add_block_to_block (&block, &lse->post);
12121 342422 : gfc_add_block_to_block (&block, &rse->post);
12122 :
12123 342422 : return gfc_finish_block (&block);
12124 : }
12125 :
12126 :
12127 : /* There are quite a lot of restrictions on the optimisation in using an
12128 : array function assign without a temporary. */
12129 :
12130 : static bool
12131 14472 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
12132 : {
12133 14472 : gfc_ref * ref;
12134 14472 : bool seen_array_ref;
12135 14472 : bool c = false;
12136 14472 : gfc_symbol *sym = expr1->symtree->n.sym;
12137 :
12138 : /* Play it safe with class functions assigned to a derived type. */
12139 14472 : if (gfc_is_class_array_function (expr2)
12140 14472 : && expr1->ts.type == BT_DERIVED)
12141 : return true;
12142 :
12143 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
12144 14448 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
12145 : return true;
12146 :
12147 : /* Elemental functions are scalarized so that they don't need a
12148 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
12149 : they would need special treatment in gfc_trans_arrayfunc_assign. */
12150 8525 : if (expr2->value.function.esym != NULL
12151 1589 : && expr2->value.function.esym->attr.elemental)
12152 : return true;
12153 :
12154 : /* Need a temporary if rhs is not FULL or a contiguous section. */
12155 8166 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
12156 : return true;
12157 :
12158 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
12159 7916 : if (gfc_ref_needs_temporary_p (expr1->ref))
12160 : return true;
12161 :
12162 : /* Functions returning pointers or allocatables need temporaries. */
12163 7904 : if (gfc_expr_attr (expr2).pointer
12164 7904 : || gfc_expr_attr (expr2).allocatable)
12165 : return true;
12166 :
12167 : /* Character array functions need temporaries unless the
12168 : character lengths are the same. */
12169 7528 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
12170 : {
12171 562 : if (UNLIMITED_POLY (expr1))
12172 : return true;
12173 :
12174 556 : if (expr1->ts.u.cl->length == NULL
12175 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12176 : return true;
12177 :
12178 493 : if (expr2->ts.u.cl->length == NULL
12179 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12180 : return true;
12181 :
12182 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
12183 475 : expr2->ts.u.cl->length->value.integer) != 0)
12184 : return true;
12185 : }
12186 :
12187 : /* Check that no LHS component references appear during an array
12188 : reference. This is needed because we do not have the means to
12189 : span any arbitrary stride with an array descriptor. This check
12190 : is not needed for the rhs because the function result has to be
12191 : a complete type. */
12192 7435 : seen_array_ref = false;
12193 14870 : for (ref = expr1->ref; ref; ref = ref->next)
12194 : {
12195 7448 : if (ref->type == REF_ARRAY)
12196 : seen_array_ref= true;
12197 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
12198 : return true;
12199 : }
12200 :
12201 : /* Check for a dependency. */
12202 7422 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
12203 : expr2->value.function.esym,
12204 : expr2->value.function.actual,
12205 : NOT_ELEMENTAL))
12206 : return true;
12207 :
12208 : /* If we have reached here with an intrinsic function, we do not
12209 : need a temporary except in the particular case that reallocation
12210 : on assignment is active and the lhs is allocatable and a target,
12211 : or a pointer which may be a subref pointer. FIXME: The last
12212 : condition can go away when we use span in the intrinsics
12213 : directly.*/
12214 6985 : if (expr2->value.function.isym)
12215 6107 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
12216 12268 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
12217 :
12218 : /* If the LHS is a dummy, we need a temporary if it is not
12219 : INTENT(OUT). */
12220 803 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
12221 : return true;
12222 :
12223 : /* If the lhs has been host_associated, is in common, a pointer or is
12224 : a target and the function is not using a RESULT variable, aliasing
12225 : can occur and a temporary is needed. */
12226 797 : if ((sym->attr.host_assoc
12227 743 : || sym->attr.in_common
12228 737 : || sym->attr.pointer
12229 731 : || sym->attr.cray_pointee
12230 731 : || sym->attr.target)
12231 66 : && expr2->symtree != NULL
12232 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
12233 : return true;
12234 :
12235 : /* A PURE function can unconditionally be called without a temporary. */
12236 755 : if (expr2->value.function.esym != NULL
12237 730 : && expr2->value.function.esym->attr.pure)
12238 : return false;
12239 :
12240 : /* Implicit_pure functions are those which could legally be declared
12241 : to be PURE. */
12242 727 : if (expr2->value.function.esym != NULL
12243 702 : && expr2->value.function.esym->attr.implicit_pure)
12244 : return false;
12245 :
12246 444 : if (!sym->attr.use_assoc
12247 444 : && !sym->attr.in_common
12248 444 : && !sym->attr.pointer
12249 438 : && !sym->attr.target
12250 438 : && !sym->attr.cray_pointee
12251 438 : && expr2->value.function.esym)
12252 : {
12253 : /* A temporary is not needed if the function is not contained and
12254 : the variable is local or host associated and not a pointer or
12255 : a target. */
12256 413 : if (!expr2->value.function.esym->attr.contained)
12257 : return false;
12258 :
12259 : /* A temporary is not needed if the lhs has never been host
12260 : associated and the procedure is contained. */
12261 164 : else if (!sym->attr.host_assoc)
12262 : return false;
12263 :
12264 : /* A temporary is not needed if the variable is local and not
12265 : a pointer, a target or a result. */
12266 6 : if (sym->ns->parent
12267 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12268 0 : return false;
12269 : }
12270 :
12271 : /* Default to temporary use. */
12272 : return true;
12273 : }
12274 :
12275 :
12276 : /* Provide the loop info so that the lhs descriptor can be built for
12277 : reallocatable assignments from extrinsic function calls. */
12278 :
12279 : static void
12280 203 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12281 : gfc_loopinfo *loop)
12282 : {
12283 : /* Signal that the function call should not be made by
12284 : gfc_conv_loop_setup. */
12285 203 : se->ss->is_alloc_lhs = 1;
12286 203 : gfc_init_loopinfo (loop);
12287 203 : gfc_add_ss_to_loop (loop, *ss);
12288 203 : gfc_add_ss_to_loop (loop, se->ss);
12289 203 : gfc_conv_ss_startstride (loop);
12290 203 : gfc_conv_loop_setup (loop, where);
12291 203 : gfc_copy_loopinfo_to_se (se, loop);
12292 203 : gfc_add_block_to_block (&se->pre, &loop->pre);
12293 203 : gfc_add_block_to_block (&se->pre, &loop->post);
12294 203 : se->ss->is_alloc_lhs = 0;
12295 203 : }
12296 :
12297 :
12298 : /* For assignment to a reallocatable lhs from intrinsic functions,
12299 : replace the se.expr (ie. the result) with a temporary descriptor.
12300 : Null the data field so that the library allocates space for the
12301 : result. Free the data of the original descriptor after the function,
12302 : in case it appears in an argument expression and transfer the
12303 : result to the original descriptor. */
12304 :
12305 : static void
12306 2137 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12307 : {
12308 2137 : tree desc;
12309 2137 : tree res_desc;
12310 2137 : tree tmp;
12311 2137 : tree offset;
12312 2137 : tree zero_cond;
12313 2137 : tree not_same_shape;
12314 2137 : stmtblock_t shape_block;
12315 2137 : int n;
12316 :
12317 : /* Use the allocation done by the library. Substitute the lhs
12318 : descriptor with a copy, whose data field is nulled.*/
12319 2137 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12320 2137 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12321 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12322 :
12323 : /* Unallocated, the descriptor does not have a dtype. */
12324 2137 : if (dtype != NULL_TREE)
12325 13 : gfc_conv_descriptor_dtype_set (&se->pre, desc, dtype);
12326 : else
12327 2124 : gfc_conv_descriptor_dtype_set (&se->pre, desc,
12328 2124 : gfc_get_dtype (TREE_TYPE (desc)));
12329 :
12330 2137 : res_desc = gfc_evaluate_now (desc, &se->pre);
12331 2137 : gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
12332 2137 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12333 :
12334 : /* Free the lhs after the function call and copy the result data to
12335 : the lhs descriptor. */
12336 2137 : tmp = gfc_conv_descriptor_data_get (desc);
12337 2137 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12338 : logical_type_node, tmp,
12339 2137 : build_int_cst (TREE_TYPE (tmp), 0));
12340 2137 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12341 2137 : tmp = gfc_call_free (tmp);
12342 2137 : gfc_add_expr_to_block (&se->post, tmp);
12343 :
12344 2137 : tmp = gfc_conv_descriptor_data_get (res_desc);
12345 2137 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12346 :
12347 : /* Check that the shapes are the same between lhs and expression.
12348 : The evaluation of the shape is done in 'shape_block' to avoid
12349 : uninitialized warnings from the lhs bounds. */
12350 2137 : not_same_shape = boolean_false_node;
12351 2137 : gfc_start_block (&shape_block);
12352 9015 : for (n = 0 ; n < rank; n++)
12353 : {
12354 4741 : tree tmp1;
12355 4741 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12356 4741 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12357 4741 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12358 : gfc_array_index_type, tmp, tmp1);
12359 4741 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12360 4741 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12361 : gfc_array_index_type, tmp, tmp1);
12362 4741 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12363 4741 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12364 : gfc_array_index_type, tmp, tmp1);
12365 4741 : tmp = fold_build2_loc (input_location, NE_EXPR,
12366 : logical_type_node, tmp,
12367 : gfc_index_zero_node);
12368 4741 : tmp = gfc_evaluate_now (tmp, &shape_block);
12369 4741 : if (n == 0)
12370 : not_same_shape = tmp;
12371 : else
12372 2604 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12373 : logical_type_node, tmp,
12374 : not_same_shape);
12375 : }
12376 :
12377 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12378 : shapes being different. */
12379 2137 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12380 : zero_cond, not_same_shape);
12381 2137 : gfc_add_modify (&shape_block, zero_cond, tmp);
12382 2137 : tmp = gfc_finish_block (&shape_block);
12383 2137 : tmp = build3_v (COND_EXPR, zero_cond,
12384 : build_empty_stmt (input_location), tmp);
12385 2137 : gfc_add_expr_to_block (&se->post, tmp);
12386 :
12387 : /* Now reset the bounds returned from the function call to bounds based
12388 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12389 : of 'variable and 'expr' are different. Set the offset accordingly. */
12390 2137 : offset = gfc_index_zero_node;
12391 6878 : for (n = 0 ; n < rank; n++)
12392 : {
12393 4741 : tree lbound;
12394 :
12395 4741 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12396 4741 : lbound = fold_build3_loc (input_location, COND_EXPR,
12397 : gfc_array_index_type, zero_cond,
12398 : gfc_index_one_node, lbound);
12399 4741 : lbound = gfc_evaluate_now (lbound, &se->post);
12400 :
12401 4741 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12402 4741 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12403 : gfc_array_index_type, tmp, lbound);
12404 4741 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12405 : gfc_rank_cst[n], lbound);
12406 4741 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12407 : gfc_rank_cst[n], tmp);
12408 :
12409 : /* Set stride and accumulate the offset. */
12410 4741 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12411 4741 : gfc_conv_descriptor_stride_set (&se->post, desc,
12412 : gfc_rank_cst[n], tmp);
12413 4741 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12414 : gfc_array_index_type, lbound, tmp);
12415 4741 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12416 : gfc_array_index_type, offset, tmp);
12417 4741 : offset = gfc_evaluate_now (offset, &se->post);
12418 : }
12419 :
12420 2137 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12421 2137 : }
12422 :
12423 :
12424 :
12425 : /* Try to translate array(:) = func (...), where func is a transformational
12426 : array function, without using a temporary. Returns NULL if this isn't the
12427 : case. */
12428 :
12429 : static tree
12430 14512 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12431 : {
12432 14512 : gfc_se se;
12433 14512 : gfc_ss *ss = NULL;
12434 14512 : gfc_component *comp = NULL;
12435 14512 : gfc_loopinfo loop;
12436 14512 : tree tmp;
12437 14512 : tree lhs;
12438 14512 : gfc_se final_se;
12439 14512 : gfc_symbol *sym = expr1->symtree->n.sym;
12440 14512 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12441 :
12442 : /* If the symbol is host associated and has not been referenced in its name
12443 : space, it might be lacking a backend_decl and vtable. */
12444 14512 : if (sym->backend_decl == NULL_TREE)
12445 : return NULL_TREE;
12446 :
12447 14472 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12448 : return NULL_TREE;
12449 :
12450 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12451 : functions. */
12452 6867 : comp = gfc_get_proc_ptr_comp (expr2);
12453 :
12454 6867 : if (!(expr2->value.function.isym
12455 718 : || (comp && comp->attr.dimension)
12456 718 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12457 718 : && expr2->value.function.esym->result->attr.dimension)))
12458 : return NULL_TREE;
12459 :
12460 6867 : gfc_init_se (&se, NULL);
12461 6867 : gfc_start_block (&se.pre);
12462 6867 : se.want_pointer = 1;
12463 :
12464 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12465 : backend decl, stash the original away for the finalization so that the
12466 : value used is that before the assignment. This is necessary because
12467 : evaluation of the rhs expression using direct by reference can change
12468 : the value. However, the standard mandates that the finalization must occur
12469 : after evaluation of the rhs. */
12470 6867 : gfc_init_se (&final_se, NULL);
12471 :
12472 6867 : if (finalizable)
12473 : {
12474 45 : tmp = sym->backend_decl;
12475 45 : lhs = sym->backend_decl;
12476 45 : if (INDIRECT_REF_P (tmp))
12477 0 : tmp = TREE_OPERAND (tmp, 0);
12478 45 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12479 45 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12480 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12481 : {
12482 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12483 : expr1->rank, 0);
12484 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12485 : }
12486 : }
12487 :
12488 45 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12489 : {
12490 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12491 45 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12492 : }
12493 :
12494 6867 : if (finalizable)
12495 45 : sym->backend_decl = lhs;
12496 :
12497 6867 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12498 :
12499 6867 : if (expr1->ts.type == BT_DERIVED
12500 264 : && expr1->ts.u.derived->attr.alloc_comp)
12501 : {
12502 110 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12503 110 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12504 : expr1->rank);
12505 110 : gfc_add_expr_to_block (&se.pre, tmp);
12506 : }
12507 :
12508 6867 : se.direct_byref = 1;
12509 6867 : se.ss = gfc_walk_expr (expr2);
12510 6867 : gcc_assert (se.ss != gfc_ss_terminator);
12511 :
12512 : /* Since this is a direct by reference call, references to the lhs can be
12513 : used for finalization of the function result just as long as the blocks
12514 : from final_se are added at the right time. */
12515 6867 : gfc_init_se (&final_se, NULL);
12516 6867 : if (finalizable && expr2->value.function.esym)
12517 : {
12518 32 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12519 32 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12520 32 : expr2->value.function.esym->attr,
12521 : expr2->rank);
12522 : }
12523 :
12524 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12525 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12526 : Clearly, this cannot be done for an allocatable function result, since
12527 : the shape of the result is unknown and, in any case, the function must
12528 : correctly take care of the reallocation internally. For intrinsic
12529 : calls, the array data is freed and the library takes care of allocation.
12530 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12531 : to the library. */
12532 6867 : if (flag_realloc_lhs
12533 6792 : && gfc_is_reallocatable_lhs (expr1)
12534 9207 : && !gfc_expr_attr (expr1).codimension
12535 2340 : && !gfc_is_coindexed (expr1)
12536 9207 : && !(expr2->value.function.esym
12537 203 : && expr2->value.function.esym->result->attr.allocatable))
12538 : {
12539 2340 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12540 :
12541 2340 : if (!expr2->value.function.isym)
12542 : {
12543 203 : ss = gfc_walk_expr (expr1);
12544 203 : gcc_assert (ss != gfc_ss_terminator);
12545 :
12546 203 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12547 203 : ss->is_alloc_lhs = 1;
12548 : }
12549 : else
12550 : {
12551 2137 : tree dtype = NULL_TREE;
12552 2137 : tree type = gfc_typenode_for_spec (&expr2->ts);
12553 2137 : if (expr1->ts.type == BT_CLASS)
12554 : {
12555 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12556 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12557 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12558 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12559 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12560 : }
12561 2137 : fcncall_realloc_result (&se, expr1->rank, dtype);
12562 : }
12563 : }
12564 :
12565 6867 : gfc_conv_function_expr (&se, expr2);
12566 :
12567 : /* Fix the result. */
12568 6867 : gfc_add_block_to_block (&se.pre, &se.post);
12569 6867 : if (finalizable)
12570 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12571 :
12572 : /* Do the finalization, including final calls from function arguments. */
12573 45 : if (finalizable)
12574 : {
12575 45 : gfc_add_block_to_block (&se.pre, &final_se.post);
12576 45 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12577 45 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12578 : }
12579 :
12580 6867 : if (ss)
12581 203 : gfc_cleanup_loop (&loop);
12582 : else
12583 6664 : gfc_free_ss_chain (se.ss);
12584 :
12585 6867 : return gfc_finish_block (&se.pre);
12586 : }
12587 :
12588 :
12589 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12590 : can't be done. */
12591 :
12592 : static tree
12593 3988 : gfc_trans_zero_assign (gfc_expr * expr)
12594 : {
12595 3988 : tree dest, len, type;
12596 3988 : tree tmp;
12597 3988 : gfc_symbol *sym;
12598 :
12599 3988 : sym = expr->symtree->n.sym;
12600 3988 : dest = gfc_get_symbol_decl (sym);
12601 :
12602 3988 : type = TREE_TYPE (dest);
12603 3988 : if (POINTER_TYPE_P (type))
12604 249 : type = TREE_TYPE (type);
12605 3988 : if (GFC_ARRAY_TYPE_P (type))
12606 : {
12607 : /* Determine the length of the array. */
12608 2790 : len = GFC_TYPE_ARRAY_SIZE (type);
12609 2790 : if (!len || TREE_CODE (len) != INTEGER_CST)
12610 : return NULL_TREE;
12611 : }
12612 1198 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12613 1198 : && gfc_is_simply_contiguous (expr, false, false))
12614 : {
12615 1092 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12616 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12617 1092 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12618 1092 : dest = gfc_conv_descriptor_data_get (dest);
12619 : }
12620 : else
12621 : return NULL_TREE;
12622 :
12623 : /* If we are zeroing a local array avoid taking its address by emitting
12624 : a = {} instead. */
12625 3703 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12626 2568 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12627 2568 : dest, build_constructor (TREE_TYPE (dest),
12628 2568 : NULL));
12629 :
12630 : /* Multiply len by element size. */
12631 1135 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12632 1135 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12633 : len, fold_convert (gfc_array_index_type, tmp));
12634 :
12635 : /* Convert arguments to the correct types. */
12636 1135 : dest = fold_convert (pvoid_type_node, dest);
12637 1135 : len = fold_convert (size_type_node, len);
12638 :
12639 : /* Construct call to __builtin_memset. */
12640 1135 : tmp = build_call_expr_loc (input_location,
12641 : builtin_decl_explicit (BUILT_IN_MEMSET),
12642 : 3, dest, integer_zero_node, len);
12643 1135 : return fold_convert (void_type_node, tmp);
12644 : }
12645 :
12646 :
12647 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
12648 : that constructs the call to __builtin_memcpy. */
12649 :
12650 : tree
12651 8040 : gfc_build_memcpy_call (tree dst, tree src, tree len)
12652 : {
12653 8040 : tree tmp;
12654 :
12655 : /* Convert arguments to the correct types. */
12656 8040 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
12657 7739 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
12658 : else
12659 301 : dst = fold_convert (pvoid_type_node, dst);
12660 :
12661 8040 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
12662 7626 : src = gfc_build_addr_expr (pvoid_type_node, src);
12663 : else
12664 414 : src = fold_convert (pvoid_type_node, src);
12665 :
12666 8040 : len = fold_convert (size_type_node, len);
12667 :
12668 : /* Construct call to __builtin_memcpy. */
12669 8040 : tmp = build_call_expr_loc (input_location,
12670 : builtin_decl_explicit (BUILT_IN_MEMCPY),
12671 : 3, dst, src, len);
12672 8040 : return fold_convert (void_type_node, tmp);
12673 : }
12674 :
12675 :
12676 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
12677 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
12678 : source/rhs, both are gfc_full_array_ref_p which have been checked for
12679 : dependencies. */
12680 :
12681 : static tree
12682 2603 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
12683 : {
12684 2603 : tree dst, dlen, dtype;
12685 2603 : tree src, slen, stype;
12686 2603 : tree tmp;
12687 :
12688 2603 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12689 2603 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
12690 :
12691 2603 : dtype = TREE_TYPE (dst);
12692 2603 : if (POINTER_TYPE_P (dtype))
12693 265 : dtype = TREE_TYPE (dtype);
12694 2603 : stype = TREE_TYPE (src);
12695 2603 : if (POINTER_TYPE_P (stype))
12696 293 : stype = TREE_TYPE (stype);
12697 :
12698 2603 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
12699 : return NULL_TREE;
12700 :
12701 : /* Determine the lengths of the arrays. */
12702 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
12703 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
12704 : return NULL_TREE;
12705 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12706 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12707 : dlen, fold_convert (gfc_array_index_type, tmp));
12708 :
12709 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
12710 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
12711 : return NULL_TREE;
12712 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
12713 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12714 : slen, fold_convert (gfc_array_index_type, tmp));
12715 :
12716 : /* Sanity check that they are the same. This should always be
12717 : the case, as we should already have checked for conformance. */
12718 1486 : if (!tree_int_cst_equal (slen, dlen))
12719 : return NULL_TREE;
12720 :
12721 1486 : return gfc_build_memcpy_call (dst, src, dlen);
12722 : }
12723 :
12724 :
12725 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
12726 : this can't be done. EXPR1 is the destination/lhs for which
12727 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
12728 :
12729 : static tree
12730 8289 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
12731 : {
12732 8289 : unsigned HOST_WIDE_INT nelem;
12733 8289 : tree dst, dtype;
12734 8289 : tree src, stype;
12735 8289 : tree len;
12736 8289 : tree tmp;
12737 :
12738 8289 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
12739 8289 : if (nelem == 0)
12740 : return NULL_TREE;
12741 :
12742 6863 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12743 6863 : dtype = TREE_TYPE (dst);
12744 6863 : if (POINTER_TYPE_P (dtype))
12745 265 : dtype = TREE_TYPE (dtype);
12746 6863 : if (!GFC_ARRAY_TYPE_P (dtype))
12747 : return NULL_TREE;
12748 :
12749 : /* Determine the lengths of the array. */
12750 6015 : len = GFC_TYPE_ARRAY_SIZE (dtype);
12751 6015 : if (!len || TREE_CODE (len) != INTEGER_CST)
12752 : return NULL_TREE;
12753 :
12754 : /* Confirm that the constructor is the same size. */
12755 5911 : if (compare_tree_int (len, nelem) != 0)
12756 : return NULL_TREE;
12757 :
12758 5911 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12759 5911 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
12760 : fold_convert (gfc_array_index_type, tmp));
12761 :
12762 5911 : stype = gfc_typenode_for_spec (&expr2->ts);
12763 5911 : src = gfc_build_constant_array_constructor (expr2, stype);
12764 :
12765 5911 : return gfc_build_memcpy_call (dst, src, len);
12766 : }
12767 :
12768 :
12769 : /* Tells whether the expression is to be treated as a variable reference. */
12770 :
12771 : bool
12772 317887 : gfc_expr_is_variable (gfc_expr *expr)
12773 : {
12774 318165 : gfc_expr *arg;
12775 318165 : gfc_component *comp;
12776 318165 : gfc_symbol *func_ifc;
12777 :
12778 318165 : if (expr->expr_type == EXPR_VARIABLE)
12779 : return true;
12780 :
12781 282370 : arg = gfc_get_noncopying_intrinsic_argument (expr);
12782 282370 : if (arg)
12783 : {
12784 278 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
12785 : return gfc_expr_is_variable (arg);
12786 : }
12787 :
12788 : /* A data-pointer-returning function should be considered as a variable
12789 : too. */
12790 282092 : if (expr->expr_type == EXPR_FUNCTION
12791 37506 : && expr->ref == NULL)
12792 : {
12793 37117 : if (expr->value.function.isym != NULL)
12794 : return false;
12795 :
12796 9672 : if (expr->value.function.esym != NULL)
12797 : {
12798 9663 : func_ifc = expr->value.function.esym;
12799 9663 : goto found_ifc;
12800 : }
12801 9 : gcc_assert (expr->symtree);
12802 9 : func_ifc = expr->symtree->n.sym;
12803 9 : goto found_ifc;
12804 : }
12805 :
12806 244975 : comp = gfc_get_proc_ptr_comp (expr);
12807 244975 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
12808 389 : && comp)
12809 : {
12810 275 : func_ifc = comp->ts.interface;
12811 275 : goto found_ifc;
12812 : }
12813 :
12814 244700 : if (expr->expr_type == EXPR_COMPCALL)
12815 : {
12816 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
12817 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
12818 0 : goto found_ifc;
12819 : }
12820 :
12821 : return false;
12822 :
12823 9947 : found_ifc:
12824 9947 : gcc_assert (func_ifc->attr.function
12825 : && func_ifc->result != NULL);
12826 9947 : return func_ifc->result->attr.pointer;
12827 : }
12828 :
12829 :
12830 : /* Is the lhs OK for automatic reallocation? */
12831 :
12832 : static bool
12833 268874 : is_scalar_reallocatable_lhs (gfc_expr *expr)
12834 : {
12835 268874 : gfc_ref * ref;
12836 :
12837 : /* An allocatable variable with no reference. */
12838 268874 : if (expr->symtree->n.sym->attr.allocatable
12839 6830 : && !expr->ref)
12840 : return true;
12841 :
12842 : /* All that can be left are allocatable components. However, we do
12843 : not check for allocatable components here because the expression
12844 : could be an allocatable component of a pointer component. */
12845 266065 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
12846 243084 : && expr->symtree->n.sym->ts.type != BT_CLASS)
12847 : return false;
12848 :
12849 : /* Find an allocatable component ref last. */
12850 40922 : for (ref = expr->ref; ref; ref = ref->next)
12851 16883 : if (ref->type == REF_COMPONENT
12852 12461 : && !ref->next
12853 9575 : && ref->u.c.component->attr.allocatable)
12854 : return true;
12855 :
12856 : return false;
12857 : }
12858 :
12859 :
12860 : /* Allocate or reallocate scalar lhs, as necessary. */
12861 :
12862 : static void
12863 3673 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
12864 : tree string_length,
12865 : gfc_expr *expr1,
12866 : gfc_expr *expr2)
12867 :
12868 : {
12869 3673 : tree cond;
12870 3673 : tree tmp;
12871 3673 : tree size;
12872 3673 : tree size_in_bytes;
12873 3673 : tree jump_label1;
12874 3673 : tree jump_label2;
12875 3673 : gfc_se lse;
12876 3673 : gfc_ref *ref;
12877 :
12878 3673 : if (!expr1 || expr1->rank)
12879 0 : return;
12880 :
12881 3673 : if (!expr2 || expr2->rank)
12882 : return;
12883 :
12884 5145 : for (ref = expr1->ref; ref; ref = ref->next)
12885 1472 : if (ref->type == REF_SUBSTRING)
12886 : return;
12887 :
12888 3673 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
12889 :
12890 : /* Since this is a scalar lhs, we can afford to do this. That is,
12891 : there is no risk of side effects being repeated. */
12892 3673 : gfc_init_se (&lse, NULL);
12893 3673 : lse.want_pointer = 1;
12894 3673 : gfc_conv_expr (&lse, expr1);
12895 :
12896 3673 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12897 3673 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12898 :
12899 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
12900 3673 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
12901 3673 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
12902 : lse.expr, tmp);
12903 3673 : tmp = build3_v (COND_EXPR, cond,
12904 : build1_v (GOTO_EXPR, jump_label1),
12905 : build_empty_stmt (input_location));
12906 3673 : gfc_add_expr_to_block (block, tmp);
12907 :
12908 3673 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12909 : {
12910 : /* Use the rhs string length and the lhs element size. Note that 'size' is
12911 : used below for the string-length comparison, only. */
12912 1524 : size = string_length;
12913 1524 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12914 3048 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
12915 1524 : TREE_TYPE (tmp), tmp,
12916 1524 : fold_convert (TREE_TYPE (tmp), size));
12917 : }
12918 : else
12919 : {
12920 : /* Otherwise use the length in bytes of the rhs. */
12921 2149 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
12922 2149 : size_in_bytes = size;
12923 : }
12924 :
12925 3673 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12926 : size_in_bytes, size_one_node);
12927 :
12928 3673 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
12929 : {
12930 32 : tree caf_decl, token;
12931 32 : gfc_se caf_se;
12932 32 : symbol_attribute attr;
12933 :
12934 32 : gfc_clear_attr (&attr);
12935 32 : gfc_init_se (&caf_se, NULL);
12936 :
12937 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
12938 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
12939 : NULL);
12940 32 : gfc_add_block_to_block (block, &caf_se.pre);
12941 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
12942 : gfc_build_addr_expr (NULL_TREE, token),
12943 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
12944 : expr1, 1);
12945 : }
12946 3641 : else if (expr1->ts.type == BT_DERIVED
12947 3641 : && (expr1->ts.u.derived->attr.alloc_comp
12948 220 : || has_parameterized_comps (expr1->ts.u.derived)))
12949 : {
12950 128 : tmp = build_call_expr_loc (input_location,
12951 : builtin_decl_explicit (BUILT_IN_CALLOC),
12952 : 2, build_one_cst (size_type_node),
12953 : size_in_bytes);
12954 128 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12955 128 : gfc_add_modify (block, lse.expr, tmp);
12956 : }
12957 : else
12958 : {
12959 3513 : tmp = build_call_expr_loc (input_location,
12960 : builtin_decl_explicit (BUILT_IN_MALLOC),
12961 : 1, size_in_bytes);
12962 3513 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12963 3513 : gfc_add_modify (block, lse.expr, tmp);
12964 : }
12965 :
12966 3673 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12967 : {
12968 : /* Deferred characters need checking for lhs and rhs string
12969 : length. Other deferred parameter variables will have to
12970 : come here too. */
12971 1524 : tmp = build1_v (GOTO_EXPR, jump_label2);
12972 1524 : gfc_add_expr_to_block (block, tmp);
12973 : }
12974 3673 : tmp = build1_v (LABEL_EXPR, jump_label1);
12975 3673 : gfc_add_expr_to_block (block, tmp);
12976 :
12977 : /* For a deferred length character, reallocate if lengths of lhs and
12978 : rhs are different. */
12979 3673 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12980 : {
12981 1524 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12982 : lse.string_length,
12983 1524 : fold_convert (TREE_TYPE (lse.string_length),
12984 : size));
12985 : /* Jump past the realloc if the lengths are the same. */
12986 1524 : tmp = build3_v (COND_EXPR, cond,
12987 : build1_v (GOTO_EXPR, jump_label2),
12988 : build_empty_stmt (input_location));
12989 1524 : gfc_add_expr_to_block (block, tmp);
12990 1524 : tmp = build_call_expr_loc (input_location,
12991 : builtin_decl_explicit (BUILT_IN_REALLOC),
12992 : 2, fold_convert (pvoid_type_node, lse.expr),
12993 : size_in_bytes);
12994 1524 : tree omp_cond = NULL_TREE;
12995 1524 : if (flag_openmp_allocators)
12996 : {
12997 1 : tree omp_tmp;
12998 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
12999 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
13000 :
13001 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
13002 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
13003 : fold_convert (pvoid_type_node,
13004 : lse.expr), size_in_bytes,
13005 : build_zero_cst (ptr_type_node),
13006 : build_zero_cst (ptr_type_node));
13007 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
13008 : omp_cond, omp_tmp, tmp);
13009 : }
13010 1524 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
13011 1524 : gfc_add_modify (block, lse.expr, tmp);
13012 1524 : if (omp_cond)
13013 1 : gfc_add_expr_to_block (block,
13014 : build3_loc (input_location, COND_EXPR,
13015 : void_type_node, omp_cond,
13016 : gfc_omp_call_add_alloc (lse.expr),
13017 : build_empty_stmt (input_location)));
13018 1524 : tmp = build1_v (LABEL_EXPR, jump_label2);
13019 1524 : gfc_add_expr_to_block (block, tmp);
13020 :
13021 : /* Update the lhs character length. */
13022 1524 : size = string_length;
13023 1524 : gfc_add_modify (block, lse.string_length,
13024 1524 : fold_convert (TREE_TYPE (lse.string_length), size));
13025 : }
13026 : }
13027 :
13028 : /* Check for assignments of the type
13029 :
13030 : a = a + 4
13031 :
13032 : to make sure we do not check for reallocation unnecessarily. */
13033 :
13034 :
13035 : /* Strip parentheses from an expression to get the underlying variable.
13036 : This is needed for self-assignment detection since (a) creates a
13037 : parentheses operator node. */
13038 :
13039 : static gfc_expr *
13040 8033 : strip_parentheses (gfc_expr *expr)
13041 : {
13042 0 : while (expr->expr_type == EXPR_OP
13043 319406 : && expr->value.op.op == INTRINSIC_PARENTHESES)
13044 596 : expr = expr->value.op.op1;
13045 318139 : return expr;
13046 : }
13047 :
13048 :
13049 : static bool
13050 7556 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
13051 : {
13052 8033 : gfc_actual_arglist *a;
13053 8033 : gfc_expr *e1, *e2;
13054 :
13055 : /* Strip parentheses to handle cases like a = (a). */
13056 16117 : expr1 = strip_parentheses (expr1);
13057 8033 : expr2 = strip_parentheses (expr2);
13058 :
13059 8033 : switch (expr2->expr_type)
13060 : {
13061 2206 : case EXPR_VARIABLE:
13062 2206 : return gfc_dep_compare_expr (expr1, expr2) == 0;
13063 :
13064 2839 : case EXPR_FUNCTION:
13065 2839 : if (expr2->value.function.esym
13066 305 : && expr2->value.function.esym->attr.elemental)
13067 : {
13068 75 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
13069 : {
13070 74 : e1 = a->expr;
13071 74 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
13072 : return false;
13073 : }
13074 : return true;
13075 : }
13076 2777 : else if (expr2->value.function.isym
13077 2520 : && expr2->value.function.isym->elemental)
13078 : {
13079 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
13080 : {
13081 322 : e1 = a->expr;
13082 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
13083 : return false;
13084 : }
13085 : return true;
13086 : }
13087 :
13088 : break;
13089 :
13090 671 : case EXPR_OP:
13091 671 : switch (expr2->value.op.op)
13092 : {
13093 19 : case INTRINSIC_NOT:
13094 19 : case INTRINSIC_UPLUS:
13095 19 : case INTRINSIC_UMINUS:
13096 19 : case INTRINSIC_PARENTHESES:
13097 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
13098 :
13099 627 : case INTRINSIC_PLUS:
13100 627 : case INTRINSIC_MINUS:
13101 627 : case INTRINSIC_TIMES:
13102 627 : case INTRINSIC_DIVIDE:
13103 627 : case INTRINSIC_POWER:
13104 627 : case INTRINSIC_AND:
13105 627 : case INTRINSIC_OR:
13106 627 : case INTRINSIC_EQV:
13107 627 : case INTRINSIC_NEQV:
13108 627 : case INTRINSIC_EQ:
13109 627 : case INTRINSIC_NE:
13110 627 : case INTRINSIC_GT:
13111 627 : case INTRINSIC_GE:
13112 627 : case INTRINSIC_LT:
13113 627 : case INTRINSIC_LE:
13114 627 : case INTRINSIC_EQ_OS:
13115 627 : case INTRINSIC_NE_OS:
13116 627 : case INTRINSIC_GT_OS:
13117 627 : case INTRINSIC_GE_OS:
13118 627 : case INTRINSIC_LT_OS:
13119 627 : case INTRINSIC_LE_OS:
13120 :
13121 627 : e1 = expr2->value.op.op1;
13122 627 : e2 = expr2->value.op.op2;
13123 :
13124 627 : if (e1->rank == 0 && e2->rank > 0)
13125 : return is_runtime_conformable (expr1, e2);
13126 569 : else if (e1->rank > 0 && e2->rank == 0)
13127 : return is_runtime_conformable (expr1, e1);
13128 169 : else if (e1->rank > 0 && e2->rank > 0)
13129 169 : return is_runtime_conformable (expr1, e1)
13130 169 : && is_runtime_conformable (expr1, e2);
13131 : break;
13132 :
13133 : default:
13134 : break;
13135 :
13136 : }
13137 :
13138 : break;
13139 :
13140 : default:
13141 : break;
13142 : }
13143 : return false;
13144 : }
13145 :
13146 :
13147 : static tree
13148 3421 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
13149 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
13150 : bool class_realloc)
13151 : {
13152 3421 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
13153 3421 : vec<tree, va_gc> *args = NULL;
13154 3421 : bool final_expr;
13155 :
13156 3421 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
13157 3421 : if (final_expr)
13158 : {
13159 515 : if (rse->loop)
13160 244 : gfc_prepend_expr_to_block (&rse->loop->pre,
13161 : gfc_finish_block (&lse->finalblock));
13162 : else
13163 271 : gfc_add_block_to_block (block, &lse->finalblock);
13164 : }
13165 :
13166 : /* Store the old vptr so that dynamic types can be compared for
13167 : reallocation to occur or not. */
13168 3421 : if (class_realloc)
13169 : {
13170 307 : tmp = lse->expr;
13171 307 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13172 0 : tmp = gfc_get_class_from_expr (tmp);
13173 : }
13174 :
13175 3421 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
13176 : &from_len, &rhs_vptr);
13177 3421 : if (rhs_vptr == NULL_TREE)
13178 43 : rhs_vptr = vptr;
13179 :
13180 : /* Generate (re)allocation of the lhs. */
13181 3421 : if (class_realloc)
13182 : {
13183 307 : stmtblock_t alloc, re_alloc;
13184 307 : tree class_han, re, size;
13185 :
13186 307 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13187 307 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
13188 : else
13189 0 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
13190 :
13191 307 : size = gfc_vptr_size_get (rhs_vptr);
13192 :
13193 : /* Take into account _len of unlimited polymorphic entities.
13194 : TODO: handle class(*) allocatable function results on rhs. */
13195 307 : if (UNLIMITED_POLY (rhs))
13196 : {
13197 18 : tree len;
13198 18 : if (rhs->expr_type == EXPR_VARIABLE)
13199 12 : len = trans_get_upoly_len (block, rhs);
13200 : else
13201 6 : len = gfc_class_len_get (tmp);
13202 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13203 : fold_convert (size_type_node, len),
13204 : size_one_node);
13205 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
13206 18 : size, fold_convert (TREE_TYPE (size), len));
13207 18 : }
13208 289 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
13209 27 : size = fold_build2_loc (input_location, MULT_EXPR,
13210 : gfc_charlen_type_node, size,
13211 : rse->string_length);
13212 :
13213 :
13214 307 : tmp = lse->expr;
13215 307 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
13216 307 : ? gfc_class_data_get (tmp) : tmp;
13217 :
13218 307 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
13219 0 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
13220 :
13221 : /* Allocate block. */
13222 307 : gfc_init_block (&alloc);
13223 307 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
13224 :
13225 : /* Reallocate if dynamic types are different. */
13226 307 : gfc_init_block (&re_alloc);
13227 307 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
13228 : {
13229 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
13230 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
13231 : }
13232 : else
13233 : {
13234 280 : tmp = fold_convert (pvoid_type_node, class_han);
13235 280 : re = build_call_expr_loc (input_location,
13236 : builtin_decl_explicit (BUILT_IN_REALLOC),
13237 : 2, tmp, size);
13238 280 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
13239 : tmp, re);
13240 280 : tmp = fold_build2_loc (input_location, NE_EXPR,
13241 : logical_type_node, rhs_vptr, old_vptr);
13242 280 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13243 : tmp, re, build_empty_stmt (input_location));
13244 280 : gfc_add_expr_to_block (&re_alloc, re);
13245 : }
13246 307 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
13247 307 : gfc_finish_block (&re_alloc) :
13248 0 : build_empty_stmt (input_location);
13249 :
13250 : /* Allocate if _data is NULL, reallocate otherwise. */
13251 307 : tmp = fold_build2_loc (input_location, EQ_EXPR,
13252 : logical_type_node, class_han,
13253 : build_int_cst (prvoid_type_node, 0));
13254 307 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13255 : gfc_unlikely (tmp,
13256 : PRED_FORTRAN_FAIL_ALLOC),
13257 : gfc_finish_block (&alloc),
13258 : realloc_expr);
13259 307 : gfc_add_expr_to_block (&lse->pre, tmp);
13260 : }
13261 :
13262 3421 : fcn = gfc_vptr_copy_get (vptr);
13263 :
13264 3421 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
13265 3421 : ? gfc_class_data_get (rse->expr) : rse->expr;
13266 3421 : if (use_vptr_copy)
13267 : {
13268 5728 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13269 584 : || INDIRECT_REF_P (tmp)
13270 427 : || (rhs->ts.type == BT_DERIVED
13271 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13272 0 : && !rhs->ts.u.derived->attr.pointer
13273 0 : && !rhs->ts.u.derived->attr.allocatable)
13274 3580 : || (UNLIMITED_POLY (rhs)
13275 134 : && !CLASS_DATA (rhs)->attr.pointer
13276 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13277 2726 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13278 : else
13279 427 : vec_safe_push (args, tmp);
13280 3153 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13281 3153 : ? gfc_class_data_get (lse->expr) : lse->expr;
13282 5466 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13283 840 : || INDIRECT_REF_P (tmp)
13284 307 : || (lhs->ts.type == BT_DERIVED
13285 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13286 0 : && !lhs->ts.u.derived->attr.pointer
13287 0 : && !lhs->ts.u.derived->attr.allocatable)
13288 3460 : || (UNLIMITED_POLY (lhs)
13289 119 : && !CLASS_DATA (lhs)->attr.pointer
13290 119 : && !CLASS_DATA (lhs)->attr.allocatable))
13291 2846 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13292 : else
13293 307 : vec_safe_push (args, tmp);
13294 :
13295 3153 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13296 :
13297 3153 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13298 : {
13299 442 : tree extcopy;
13300 442 : vec_safe_push (args, from_len);
13301 442 : vec_safe_push (args, to_len);
13302 442 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13303 :
13304 442 : tmp = fold_build2_loc (input_location, GT_EXPR,
13305 : logical_type_node, from_len,
13306 442 : build_zero_cst (TREE_TYPE (from_len)));
13307 442 : return fold_build3_loc (input_location, COND_EXPR,
13308 : void_type_node, tmp,
13309 442 : extcopy, stdcopy);
13310 : }
13311 : else
13312 : return stdcopy;
13313 : }
13314 : else
13315 : {
13316 268 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13317 268 : ? gfc_class_data_get (lse->expr) : lse->expr;
13318 268 : stmtblock_t tblock;
13319 268 : gfc_init_block (&tblock);
13320 268 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13321 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13322 268 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13323 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13324 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13325 268 : gfc_add_modify_loc (input_location, &tblock, rhst,
13326 268 : fold_convert (TREE_TYPE (rhst), tmp));
13327 268 : return gfc_finish_block (&tblock);
13328 : }
13329 : }
13330 :
13331 : bool
13332 312110 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13333 : {
13334 312110 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13335 : return false;
13336 :
13337 32278 : return lhs->symtree->n.sym->assoc
13338 32278 : && lhs->symtree->n.sym->assoc->target == rhs;
13339 : }
13340 :
13341 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13342 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13343 : init_flag indicates initialization expressions and dealloc that no
13344 : deallocate prior assignment is needed (if in doubt, set true).
13345 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13346 : routine instead of a pointer assignment. Alias resolution is only done,
13347 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13348 : where it is known, that newly allocated memory on the lhs can never be
13349 : an alias of the rhs. */
13350 :
13351 : static tree
13352 312110 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13353 : bool dealloc, bool use_vptr_copy, bool may_alias)
13354 : {
13355 312110 : gfc_se lse;
13356 312110 : gfc_se rse;
13357 312110 : gfc_ss *lss;
13358 312110 : gfc_ss *lss_section;
13359 312110 : gfc_ss *rss;
13360 312110 : gfc_loopinfo loop;
13361 312110 : tree tmp;
13362 312110 : stmtblock_t block;
13363 312110 : stmtblock_t body;
13364 312110 : bool final_expr;
13365 312110 : bool l_is_temp;
13366 312110 : bool scalar_to_array;
13367 312110 : tree string_length;
13368 312110 : int n;
13369 312110 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13370 312110 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr, rhs_attr;
13371 312110 : bool is_poly_assign;
13372 312110 : bool realloc_flag;
13373 312110 : bool assoc_assign = false;
13374 312110 : bool dummy_class_array_copy;
13375 :
13376 : /* Assignment of the form lhs = rhs. */
13377 312110 : gfc_start_block (&block);
13378 :
13379 312110 : gfc_init_se (&lse, NULL);
13380 312110 : gfc_init_se (&rse, NULL);
13381 :
13382 312110 : gfc_fix_class_refs (expr1);
13383 :
13384 624220 : realloc_flag = flag_realloc_lhs
13385 305914 : && gfc_is_reallocatable_lhs (expr1)
13386 8367 : && expr2->rank
13387 319006 : && !is_runtime_conformable (expr1, expr2);
13388 :
13389 : /* Walk the lhs. */
13390 312110 : lss = gfc_walk_expr (expr1);
13391 312110 : if (realloc_flag)
13392 : {
13393 6513 : lss->no_bounds_check = 1;
13394 6513 : lss->is_alloc_lhs = 1;
13395 : }
13396 : else
13397 305597 : lss->no_bounds_check = expr1->no_bounds_check;
13398 :
13399 312110 : rss = NULL;
13400 :
13401 312110 : if (expr2->expr_type != EXPR_VARIABLE
13402 312110 : && expr2->expr_type != EXPR_CONSTANT
13403 312110 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13404 : {
13405 906 : expr2->must_finalize = 1;
13406 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13407 : function, the result is finalized after execution of the innermost
13408 : executable construct containing the reference. */
13409 906 : if (expr2->expr_type == EXPR_FUNCTION
13410 906 : && (gfc_expr_attr (expr2).pointer
13411 310 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13412 147 : expr2->must_finalize = 0;
13413 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13414 : structure constructor or array constructor, the entity created by
13415 : the constructor is finalized after execution of the innermost
13416 : executable construct containing the reference.
13417 : These finalizations were later deleted by the Combined Technical
13418 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13419 759 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13420 759 : && (expr2->expr_type == EXPR_STRUCTURE
13421 716 : || expr2->expr_type == EXPR_ARRAY))
13422 387 : expr2->must_finalize = 0;
13423 : }
13424 :
13425 :
13426 : /* Checking whether a class assignment is desired is quite complicated and
13427 : needed at two locations, so do it once only before the information is
13428 : needed. */
13429 312110 : lhs_attr = gfc_expr_attr (expr1);
13430 312110 : rhs_attr = gfc_expr_attr (expr2);
13431 312110 : dummy_class_array_copy
13432 624220 : = (expr2->expr_type == EXPR_VARIABLE
13433 32278 : && expr2->rank > 0
13434 8438 : && expr2->symtree != NULL
13435 8438 : && expr2->symtree->n.sym->attr.dummy
13436 1507 : && expr2->ts.type == BT_CLASS
13437 163 : && !rhs_attr.pointer
13438 163 : && !rhs_attr.allocatable
13439 150 : && !CLASS_DATA (expr2)->attr.class_pointer
13440 312260 : && !CLASS_DATA (expr2)->attr.allocatable);
13441 :
13442 : /* What can be sent to trans_class_assignment includes all the obvious
13443 : candidates but scalar assignment of a class expression to a derived type
13444 : must be done using gfc_trans_scalar_assign; partly because it is simpler
13445 : and partly because some cases fail, eg. class assignment to derived_type
13446 : select type temporaries. */
13447 312110 : is_poly_assign
13448 312110 : = (use_vptr_copy
13449 294815 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13450 23272 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13451 21137 : || gfc_is_class_scalar_expr (expr1)
13452 19784 : || gfc_is_class_array_ref (expr2, NULL)
13453 19784 : || (gfc_is_class_scalar_expr (expr2)
13454 42 : && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
13455 315598 : && lhs_attr.flavor != FL_PROCEDURE;
13456 :
13457 312110 : assoc_assign = is_assoc_assign (expr1, expr2);
13458 :
13459 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13460 : mode. Avoid false-positive uninitialized diagnostics with initializing
13461 : the codimension flag unconditionally. */
13462 312110 : lhs_caf_attr.codimension = false;
13463 312110 : rhs_caf_attr.codimension = false;
13464 312110 : if (flag_coarray == GFC_FCOARRAY_LIB)
13465 : {
13466 6793 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13467 6793 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13468 : }
13469 :
13470 312110 : tree reallocation = NULL_TREE;
13471 312110 : if (lss != gfc_ss_terminator)
13472 : {
13473 : /* The assignment needs scalarization. */
13474 : lss_section = lss;
13475 :
13476 : /* Find a non-scalar SS from the lhs. */
13477 : while (lss_section != gfc_ss_terminator
13478 40401 : && lss_section->info->type != GFC_SS_SECTION)
13479 0 : lss_section = lss_section->next;
13480 :
13481 40401 : gcc_assert (lss_section != gfc_ss_terminator);
13482 :
13483 : /* Initialize the scalarizer. */
13484 40401 : gfc_init_loopinfo (&loop);
13485 :
13486 : /* Walk the rhs. */
13487 40401 : rss = gfc_walk_expr (expr2);
13488 40401 : if (rss == gfc_ss_terminator)
13489 : {
13490 : /* The rhs is scalar. Add a ss for the expression. */
13491 15102 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13492 15102 : lss->is_alloc_lhs = 0;
13493 : }
13494 :
13495 : /* When doing a class assign, then the handle to the rhs needs to be a
13496 : pointer to allow for polymorphism. */
13497 40401 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13498 509 : rss->info->type = GFC_SS_REFERENCE;
13499 :
13500 40401 : rss->no_bounds_check = expr2->no_bounds_check;
13501 : /* Associate the SS with the loop. */
13502 40401 : gfc_add_ss_to_loop (&loop, lss);
13503 40401 : gfc_add_ss_to_loop (&loop, rss);
13504 :
13505 : /* Calculate the bounds of the scalarization. */
13506 40401 : gfc_conv_ss_startstride (&loop);
13507 : /* Enable loop reversal. */
13508 686817 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13509 606015 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13510 : /* Resolve any data dependencies in the statement. */
13511 40401 : if (may_alias)
13512 38098 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13513 : /* Setup the scalarizing loops. */
13514 40401 : gfc_conv_loop_setup (&loop, &expr2->where);
13515 :
13516 : /* Setup the gfc_se structures. */
13517 40401 : gfc_copy_loopinfo_to_se (&lse, &loop);
13518 40401 : gfc_copy_loopinfo_to_se (&rse, &loop);
13519 :
13520 40401 : rse.ss = rss;
13521 40401 : gfc_mark_ss_chain_used (rss, 1);
13522 40401 : if (loop.temp_ss == NULL)
13523 : {
13524 39287 : lse.ss = lss;
13525 39287 : gfc_mark_ss_chain_used (lss, 1);
13526 : }
13527 : else
13528 : {
13529 1114 : lse.ss = loop.temp_ss;
13530 1114 : gfc_mark_ss_chain_used (lss, 3);
13531 1114 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13532 : }
13533 :
13534 : /* Allow the scalarizer to workshare array assignments. */
13535 40401 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13536 : == OMPWS_WORKSHARE_FLAG
13537 85 : && loop.temp_ss == NULL)
13538 : {
13539 73 : maybe_workshare = true;
13540 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13541 : }
13542 :
13543 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13544 40401 : if (realloc_flag)
13545 : {
13546 6513 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13547 6513 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13548 6513 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13549 : expr2);
13550 : }
13551 :
13552 : /* Start the scalarized loop body. */
13553 40401 : gfc_start_scalarized_body (&loop, &body);
13554 : }
13555 : else
13556 271709 : gfc_init_block (&body);
13557 :
13558 312110 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13559 :
13560 : /* Translate the expression. */
13561 624220 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13562 312110 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13563 312110 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13564 312110 : gfc_conv_expr (&rse, expr2);
13565 :
13566 : /* Deal with the case of a scalar class function assigned to a derived type.
13567 : */
13568 312110 : if (gfc_is_alloc_class_scalar_function (expr2)
13569 312110 : && expr1->ts.type == BT_DERIVED)
13570 : {
13571 60 : rse.expr = gfc_class_data_get (rse.expr);
13572 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13573 : }
13574 :
13575 : /* Stabilize a string length for temporaries. */
13576 312110 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13577 24778 : && !(VAR_P (rse.string_length)
13578 : || TREE_CODE (rse.string_length) == PARM_DECL
13579 : || INDIRECT_REF_P (rse.string_length)))
13580 23902 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13581 288208 : else if (expr2->ts.type == BT_CHARACTER)
13582 : {
13583 4394 : if (expr1->ts.deferred
13584 6821 : && gfc_expr_attr (expr1).allocatable
13585 6941 : && gfc_check_dependency (expr1, expr2, true))
13586 120 : rse.string_length =
13587 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13588 4394 : string_length = rse.string_length;
13589 : }
13590 : else
13591 : string_length = NULL_TREE;
13592 :
13593 312110 : if (l_is_temp)
13594 : {
13595 1114 : gfc_conv_tmp_array_ref (&lse);
13596 1114 : if (expr2->ts.type == BT_CHARACTER)
13597 123 : lse.string_length = string_length;
13598 : }
13599 : else
13600 : {
13601 310996 : gfc_conv_expr (&lse, expr1);
13602 : /* For some expression (e.g. complex numbers) fold_convert uses a
13603 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13604 : not updated when assigned to. */
13605 310996 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13606 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13607 :
13608 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13609 317149 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13610 : {
13611 36 : tree cond;
13612 36 : const char* msg;
13613 :
13614 36 : tmp = INDIRECT_REF_P (lse.expr)
13615 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13616 36 : STRIP_NOPS (tmp);
13617 :
13618 : /* We should only get array references here. */
13619 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13620 : || TREE_CODE (tmp) == ARRAY_REF);
13621 :
13622 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13623 : or the array itself(ARRAY_REF). */
13624 36 : tmp = TREE_OPERAND (tmp, 0);
13625 :
13626 : /* Provide the address of the array. */
13627 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13628 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13629 :
13630 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13631 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13632 36 : msg = _("Assignment of scalar to unallocated array");
13633 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13634 : &expr1->where, msg);
13635 : }
13636 :
13637 : /* Deallocate the lhs parameterized components if required. */
13638 310996 : if (dealloc
13639 292136 : && !expr1->symtree->n.sym->attr.associate_var
13640 290154 : && expr2->expr_type != EXPR_ARRAY
13641 284040 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
13642 : {
13643 361 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
13644 :
13645 361 : tmp = lse.expr;
13646 361 : if (pdt_dep)
13647 : {
13648 : /* Create a temporary for deallocation after assignment. */
13649 168 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
13650 168 : gfc_add_modify (&lse.pre, tmp, lse.expr);
13651 : }
13652 :
13653 361 : if (expr1->ts.type == BT_DERIVED)
13654 361 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
13655 : expr1->rank);
13656 0 : else if (expr1->ts.type == BT_CLASS)
13657 : {
13658 0 : tmp = gfc_class_data_get (tmp);
13659 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
13660 : tmp, expr1->rank);
13661 : }
13662 :
13663 361 : if (tmp && pdt_dep)
13664 92 : gfc_add_expr_to_block (&rse.post, tmp);
13665 269 : else if (tmp)
13666 67 : gfc_add_expr_to_block (&lse.pre, tmp);
13667 : }
13668 : }
13669 :
13670 : /* Assignments of scalar derived types with allocatable components
13671 : to arrays must be done with a deep copy and the rhs temporary
13672 : must have its components deallocated afterwards. */
13673 624220 : scalar_to_array = (expr2->ts.type == BT_DERIVED
13674 19876 : && expr2->ts.u.derived->attr.alloc_comp
13675 6928 : && !gfc_expr_is_variable (expr2)
13676 315861 : && expr1->rank && !expr2->rank);
13677 624220 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
13678 20171 : && expr1->rank
13679 3891 : && expr1->ts.u.derived->attr.alloc_comp
13680 313539 : && gfc_is_alloc_class_scalar_function (expr2));
13681 312110 : if (scalar_to_array && dealloc)
13682 : {
13683 59 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
13684 59 : gfc_prepend_expr_to_block (&loop.post, tmp);
13685 : }
13686 :
13687 : /* When assigning a character function result to a deferred-length variable,
13688 : the function call must happen before the (re)allocation of the lhs -
13689 : otherwise the character length of the result is not known.
13690 : NOTE 1: This relies on having the exact dependence of the length type
13691 : parameter available to the caller; gfortran saves it in the .mod files.
13692 : NOTE 2: Vector array references generate an index temporary that must
13693 : not go outside the loop. Otherwise, variables should not generate
13694 : a pre block.
13695 : NOTE 3: The concatenation operation generates a temporary pointer,
13696 : whose allocation must go to the innermost loop.
13697 : NOTE 4: Elemental functions may generate a temporary, too. */
13698 312110 : if (flag_realloc_lhs
13699 305914 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
13700 2990 : && !(lss != gfc_ss_terminator
13701 928 : && rss != gfc_ss_terminator
13702 928 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
13703 741 : || (expr2->expr_type == EXPR_FUNCTION
13704 160 : && expr2->value.function.esym != NULL
13705 26 : && expr2->value.function.esym->attr.elemental)
13706 728 : || (expr2->expr_type == EXPR_FUNCTION
13707 147 : && expr2->value.function.isym != NULL
13708 134 : && expr2->value.function.isym->elemental)
13709 672 : || (expr2->expr_type == EXPR_OP
13710 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
13711 2709 : gfc_add_block_to_block (&block, &rse.pre);
13712 :
13713 : /* Nullify the allocatable components corresponding to those of the lhs
13714 : derived type, so that the finalization of the function result does not
13715 : affect the lhs of the assignment. Prepend is used to ensure that the
13716 : nullification occurs before the call to the finalizer. In the case of
13717 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
13718 : as part of the deep copy. */
13719 311282 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
13720 331453 : && (gfc_is_class_array_function (expr2)
13721 19319 : || gfc_is_alloc_class_scalar_function (expr2)))
13722 : {
13723 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
13724 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
13725 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
13726 0 : gfc_add_block_to_block (&loop.post, &rse.post);
13727 : }
13728 :
13729 312110 : tmp = NULL_TREE;
13730 :
13731 312110 : if (is_poly_assign)
13732 : {
13733 10263 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
13734 575 : use_vptr_copy || (lhs_attr.allocatable
13735 307 : && !lhs_attr.dimension),
13736 3147 : !realloc_flag && flag_realloc_lhs
13737 575 : && !lhs_attr.pointer);
13738 3421 : if (expr2->expr_type == EXPR_FUNCTION
13739 232 : && expr2->ts.type == BT_DERIVED
13740 18 : && expr2->ts.u.derived->attr.alloc_comp)
13741 : {
13742 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
13743 : rse.expr, expr2->rank);
13744 18 : if (lss == gfc_ss_terminator)
13745 18 : gfc_add_expr_to_block (&rse.post, tmp2);
13746 : else
13747 0 : gfc_add_expr_to_block (&loop.post, tmp2);
13748 : }
13749 :
13750 3421 : expr1->must_finalize = 0;
13751 : }
13752 308689 : else if (!is_poly_assign
13753 308689 : && expr1->ts.type == BT_CLASS
13754 448 : && expr2->ts.type == BT_CLASS
13755 255 : && (expr2->must_finalize || dummy_class_array_copy))
13756 : {
13757 : /* This case comes about when the scalarizer provides array element
13758 : references to class temporaries or nonpointer dummy arrays. Use the
13759 : vptr copy function, since this does a deep copy of allocatable
13760 : components. */
13761 132 : tmp = gfc_get_vptr_from_expr (rse.expr);
13762 132 : if (tmp == NULL_TREE && dummy_class_array_copy)
13763 12 : tmp = gfc_get_vptr_from_expr (gfc_get_class_from_gfc_expr (expr2));
13764 132 : if (tmp != NULL_TREE)
13765 : {
13766 132 : tree fcn = gfc_vptr_copy_get (tmp);
13767 132 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
13768 132 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
13769 132 : tmp = build_call_expr_loc (input_location,
13770 : fcn, 2,
13771 : gfc_build_addr_expr (NULL, rse.expr),
13772 : gfc_build_addr_expr (NULL, lse.expr));
13773 : }
13774 : }
13775 :
13776 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
13777 : after evaluation of the rhs and before reallocation.
13778 : Skip finalization for self-assignment to avoid use-after-free.
13779 : Strip parentheses from both sides to handle cases like a = (a). */
13780 312110 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
13781 312110 : if (final_expr
13782 684 : && gfc_dep_compare_expr (strip_parentheses (expr1),
13783 : strip_parentheses (expr2)) != 0
13784 312770 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
13785 229 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
13786 : {
13787 660 : if (lss == gfc_ss_terminator)
13788 : {
13789 189 : gfc_add_block_to_block (&block, &rse.pre);
13790 189 : gfc_add_block_to_block (&block, &lse.finalblock);
13791 : }
13792 : else
13793 : {
13794 471 : gfc_add_block_to_block (&body, &rse.pre);
13795 471 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
13796 : &lse.finalblock);
13797 : }
13798 : }
13799 : else
13800 311450 : gfc_add_block_to_block (&body, &rse.pre);
13801 :
13802 312110 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
13803 2994 : && assoc_assign)
13804 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
13805 :
13806 : /* The finalization above is all that is wanted: the structure copy is done
13807 : component by component in generate_component_assignments. */
13808 312110 : if (expr1->finalize_only)
13809 24 : tmp = build_empty_stmt (input_location);
13810 :
13811 : /* If nothing else works, do it the old fashioned way! */
13812 312110 : if (tmp == NULL_TREE)
13813 : {
13814 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
13815 308533 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
13816 308533 : tmp
13817 617066 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13818 308533 : gfc_expr_is_variable (expr2_stripped)
13819 278068 : || scalar_to_array
13820 277330 : || expr2->expr_type == EXPR_ARRAY,
13821 : !(l_is_temp || init_flag) && dealloc,
13822 308533 : expr1->symtree->n.sym->attr.codimension,
13823 : assoc_assign);
13824 : }
13825 :
13826 : /* Add the lse pre block to the body */
13827 312110 : gfc_add_block_to_block (&body, &lse.pre);
13828 312110 : gfc_add_expr_to_block (&body, tmp);
13829 :
13830 : /* Add the post blocks to the body. Scalar finalization must appear before
13831 : the post block in case any dellocations are done. */
13832 312110 : if (rse.finalblock.head
13833 312110 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
13834 154 : && gfc_expr_attr (expr2).elemental)))
13835 : {
13836 154 : gfc_add_block_to_block (&body, &rse.finalblock);
13837 154 : gfc_add_block_to_block (&body, &rse.post);
13838 : }
13839 : else
13840 311956 : gfc_add_block_to_block (&body, &rse.post);
13841 :
13842 312110 : gfc_add_block_to_block (&body, &lse.post);
13843 :
13844 312110 : if (lss == gfc_ss_terminator)
13845 : {
13846 : /* F2003: Add the code for reallocation on assignment. */
13847 268874 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
13848 275382 : && !is_poly_assign)
13849 3673 : alloc_scalar_allocatable_for_assignment (&block, string_length,
13850 : expr1, expr2);
13851 :
13852 : /* Use the scalar assignment as is. */
13853 271709 : gfc_add_block_to_block (&block, &body);
13854 : }
13855 : else
13856 : {
13857 40401 : gcc_assert (lse.ss == gfc_ss_terminator
13858 : && rse.ss == gfc_ss_terminator);
13859 :
13860 40401 : if (l_is_temp)
13861 : {
13862 1114 : gfc_trans_scalarized_loop_boundary (&loop, &body);
13863 :
13864 : /* We need to copy the temporary to the actual lhs. */
13865 1114 : gfc_init_se (&lse, NULL);
13866 1114 : gfc_init_se (&rse, NULL);
13867 1114 : gfc_copy_loopinfo_to_se (&lse, &loop);
13868 1114 : gfc_copy_loopinfo_to_se (&rse, &loop);
13869 :
13870 1114 : rse.ss = loop.temp_ss;
13871 1114 : lse.ss = lss;
13872 :
13873 1114 : gfc_conv_tmp_array_ref (&rse);
13874 1114 : gfc_conv_expr (&lse, expr1);
13875 :
13876 1114 : gcc_assert (lse.ss == gfc_ss_terminator
13877 : && rse.ss == gfc_ss_terminator);
13878 :
13879 1114 : if (expr2->ts.type == BT_CHARACTER)
13880 123 : rse.string_length = string_length;
13881 :
13882 1114 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13883 : false, dealloc);
13884 1114 : gfc_add_expr_to_block (&body, tmp);
13885 : }
13886 :
13887 40401 : if (reallocation != NULL_TREE)
13888 6513 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
13889 :
13890 40401 : if (maybe_workshare)
13891 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
13892 :
13893 : /* Generate the copying loops. */
13894 40401 : gfc_trans_scalarizing_loops (&loop, &body);
13895 :
13896 : /* Wrap the whole thing up. */
13897 40401 : gfc_add_block_to_block (&block, &loop.pre);
13898 40401 : gfc_add_block_to_block (&block, &loop.post);
13899 :
13900 40401 : gfc_cleanup_loop (&loop);
13901 : }
13902 :
13903 : /* Since parameterized components cannot have default initializers,
13904 : the default PDT constructor leaves them unallocated. Do the
13905 : allocation now. */
13906 312110 : if (init_flag && IS_PDT (expr1)
13907 359 : && !expr1->symtree->n.sym->attr.allocatable
13908 359 : && !expr1->symtree->n.sym->attr.dummy)
13909 : {
13910 73 : gfc_symbol *sym = expr1->symtree->n.sym;
13911 73 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
13912 : sym->backend_decl,
13913 73 : sym->as ? sym->as->rank : 0,
13914 73 : sym->param_list);
13915 73 : gfc_add_expr_to_block (&block, tmp);
13916 : }
13917 :
13918 312110 : return gfc_finish_block (&block);
13919 : }
13920 :
13921 :
13922 : /* Check whether EXPR is a copyable array. */
13923 :
13924 : static bool
13925 989055 : copyable_array_p (gfc_expr * expr)
13926 : {
13927 989055 : if (expr->expr_type != EXPR_VARIABLE)
13928 : return false;
13929 :
13930 : /* First check it's an array. */
13931 965093 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
13932 : return false;
13933 :
13934 149248 : if (!gfc_full_array_ref_p (expr->ref, NULL))
13935 : return false;
13936 :
13937 : /* Next check that it's of a simple enough type. */
13938 117020 : switch (expr->ts.type)
13939 : {
13940 : case BT_INTEGER:
13941 : case BT_REAL:
13942 : case BT_COMPLEX:
13943 : case BT_LOGICAL:
13944 : return true;
13945 :
13946 : case BT_CHARACTER:
13947 : return false;
13948 :
13949 6803 : case_bt_struct:
13950 6803 : return (!expr->ts.u.derived->attr.alloc_comp
13951 6803 : && !expr->ts.u.derived->attr.pdt_type);
13952 :
13953 : default:
13954 : break;
13955 : }
13956 :
13957 : return false;
13958 : }
13959 :
13960 : /* Translate an assignment. */
13961 :
13962 : tree
13963 330077 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13964 : bool dealloc, bool use_vptr_copy, bool may_alias)
13965 : {
13966 330077 : tree tmp;
13967 :
13968 : /* Special case a single function returning an array. */
13969 330077 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
13970 : {
13971 14512 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
13972 14512 : if (tmp)
13973 : return tmp;
13974 : }
13975 :
13976 : /* Special case assigning an array to zero. */
13977 323210 : if (copyable_array_p (expr1)
13978 323210 : && is_zero_initializer_p (expr2))
13979 : {
13980 3988 : tmp = gfc_trans_zero_assign (expr1);
13981 3988 : if (tmp)
13982 : return tmp;
13983 : }
13984 :
13985 : /* Special case copying one array to another. */
13986 319507 : if (copyable_array_p (expr1)
13987 28317 : && copyable_array_p (expr2)
13988 2699 : && gfc_compare_types (&expr1->ts, &expr2->ts)
13989 322206 : && !gfc_check_dependency (expr1, expr2, 0))
13990 : {
13991 2603 : tmp = gfc_trans_array_copy (expr1, expr2);
13992 2603 : if (tmp)
13993 : return tmp;
13994 : }
13995 :
13996 : /* Special case initializing an array from a constant array constructor. */
13997 318021 : if (copyable_array_p (expr1)
13998 26831 : && expr2->expr_type == EXPR_ARRAY
13999 326310 : && gfc_compare_types (&expr1->ts, &expr2->ts))
14000 : {
14001 8289 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
14002 8289 : if (tmp)
14003 : return tmp;
14004 : }
14005 :
14006 312110 : if (UNLIMITED_POLY (expr1) && expr1->rank)
14007 312110 : use_vptr_copy = true;
14008 :
14009 : /* Fallback to the scalarizer to generate explicit loops. */
14010 312110 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
14011 312110 : use_vptr_copy, may_alias);
14012 : }
14013 :
14014 : tree
14015 13394 : gfc_trans_init_assign (gfc_code * code)
14016 : {
14017 13394 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
14018 : }
14019 :
14020 : tree
14021 308222 : gfc_trans_assign (gfc_code * code)
14022 : {
14023 308222 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
14024 : }
14025 :
14026 : /* Generate a simple loop for internal use of the form
14027 : for (var = begin; var <cond> end; var += step)
14028 : body; */
14029 : void
14030 12171 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
14031 : enum tree_code cond, tree step, tree body)
14032 : {
14033 12171 : tree tmp;
14034 :
14035 : /* var = begin. */
14036 12171 : gfc_add_modify (block, var, begin);
14037 :
14038 : /* Loop: for (var = begin; var <cond> end; var += step). */
14039 12171 : tree label_loop = gfc_build_label_decl (NULL_TREE);
14040 12171 : tree label_cond = gfc_build_label_decl (NULL_TREE);
14041 12171 : TREE_USED (label_loop) = 1;
14042 12171 : TREE_USED (label_cond) = 1;
14043 :
14044 12171 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
14045 12171 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
14046 :
14047 : /* Loop body. */
14048 12171 : gfc_add_expr_to_block (block, body);
14049 :
14050 : /* End of loop body. */
14051 12171 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
14052 12171 : gfc_add_modify (block, var, tmp);
14053 12171 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
14054 12171 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
14055 12171 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
14056 : build_empty_stmt (input_location));
14057 12171 : gfc_add_expr_to_block (block, tmp);
14058 12171 : }
|
