Line data Source code
1 : /* Expression translation
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Paul Brook <paul@nowt.org>
4 : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 :
6 : This file is part of GCC.
7 :
8 : GCC is free software; you can redistribute it and/or modify it under
9 : the terms of the GNU General Public License as published by the Free
10 : Software Foundation; either version 3, or (at your option) any later
11 : version.
12 :
13 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : for more details.
17 :
18 : You should have received a copy of the GNU General Public License
19 : along with GCC; see the file COPYING3. If not see
20 : <http://www.gnu.org/licenses/>. */
21 :
22 : /* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
23 :
24 : #define INCLUDE_MEMORY
25 : #include "config.h"
26 : #include "system.h"
27 : #include "coretypes.h"
28 : #include "options.h"
29 : #include "tree.h"
30 : #include "gfortran.h"
31 : #include "trans.h"
32 : #include "stringpool.h"
33 : #include "diagnostic-core.h" /* For fatal_error. */
34 : #include "fold-const.h"
35 : #include "langhooks.h"
36 : #include "arith.h"
37 : #include "constructor.h"
38 : #include "trans-const.h"
39 : #include "trans-types.h"
40 : #include "trans-array.h"
41 : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 : #include "trans-stmt.h"
43 : #include "dependency.h"
44 : #include "gimplify.h"
45 : #include "tm.h" /* For CHAR_TYPE_SIZE. */
46 :
47 :
48 : /* Calculate the number of characters in a string. */
49 :
50 : static tree
51 36136 : gfc_get_character_len (tree type)
52 : {
53 36136 : tree len;
54 :
55 36136 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
56 : && TYPE_STRING_FLAG (type));
57 :
58 36136 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
59 36136 : len = (len) ? (len) : (integer_zero_node);
60 36136 : return fold_convert (gfc_charlen_type_node, len);
61 : }
62 :
63 :
64 :
65 : /* Calculate the number of bytes in a string. */
66 :
67 : tree
68 36136 : gfc_get_character_len_in_bytes (tree type)
69 : {
70 36136 : tree tmp, len;
71 :
72 36136 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
73 : && TYPE_STRING_FLAG (type));
74 :
75 36136 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
76 72272 : tmp = (tmp && !integer_zerop (tmp))
77 72272 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
78 36136 : len = gfc_get_character_len (type);
79 36136 : if (tmp && len && !integer_zerop (len))
80 35364 : len = fold_build2_loc (input_location, MULT_EXPR,
81 : gfc_charlen_type_node, len, tmp);
82 36136 : return len;
83 : }
84 :
85 :
86 : /* Convert a scalar to an array descriptor. To be used for assumed-rank
87 : arrays. */
88 :
89 : static tree
90 6276 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
91 : {
92 6276 : enum gfc_array_kind akind;
93 6276 : tree *lbound = NULL, *ubound = NULL;
94 6276 : int codim = 0;
95 :
96 6276 : if (attr.pointer)
97 : akind = GFC_ARRAY_POINTER_CONT;
98 5924 : else if (attr.allocatable)
99 : akind = GFC_ARRAY_ALLOCATABLE;
100 : else
101 5155 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
102 :
103 6276 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
104 5329 : scalar = TREE_TYPE (scalar);
105 6276 : if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
106 : {
107 4734 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
108 4734 : codim = lang_specific->corank;
109 4734 : lbound = lang_specific->lbound;
110 4734 : ubound = lang_specific->ubound;
111 : }
112 6276 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
113 : ubound, 1, akind,
114 6276 : !(attr.pointer || attr.target));
115 : }
116 :
117 : tree
118 5598 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
119 : {
120 5598 : tree desc, type, etype;
121 :
122 5598 : type = get_scalar_to_descriptor_type (scalar, attr);
123 5598 : etype = TREE_TYPE (scalar);
124 5598 : desc = gfc_create_var (type, "desc");
125 5598 : DECL_ARTIFICIAL (desc) = 1;
126 :
127 5598 : if (CONSTANT_CLASS_P (scalar))
128 : {
129 54 : tree tmp;
130 54 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
131 54 : gfc_add_modify (&se->pre, tmp, scalar);
132 54 : scalar = tmp;
133 : }
134 5598 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
135 947 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
136 4651 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
137 158 : etype = TREE_TYPE (etype);
138 5598 : gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
139 : gfc_get_dtype_rank_type (0, etype));
140 5598 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
141 5598 : gfc_conv_descriptor_span_set (&se->pre, desc,
142 : gfc_conv_descriptor_elem_len (desc));
143 :
144 : /* Copy pointer address back - but only if it could have changed and
145 : if the actual argument is a pointer and not, e.g., NULL(). */
146 5598 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
147 846 : gfc_add_modify (&se->post, scalar,
148 423 : fold_convert (TREE_TYPE (scalar),
149 : gfc_conv_descriptor_data_get (desc)));
150 5598 : return desc;
151 : }
152 :
153 :
154 : /* Get the coarray token from the ultimate array or component ref.
155 : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
156 :
157 : tree
158 512 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
159 : {
160 512 : gfc_symbol *sym = expr->symtree->n.sym;
161 1024 : bool is_coarray = sym->ts.type == BT_CLASS
162 512 : ? CLASS_DATA (sym)->attr.codimension
163 467 : : sym->attr.codimension;
164 512 : gfc_expr *caf_expr = gfc_copy_expr (expr);
165 512 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
166 :
167 1622 : while (ref)
168 : {
169 1110 : if (ref->type == REF_COMPONENT
170 417 : && (ref->u.c.component->attr.allocatable
171 104 : || ref->u.c.component->attr.pointer)
172 415 : && (is_coarray || ref->u.c.component->attr.codimension))
173 1110 : last_caf_ref = ref;
174 1110 : ref = ref->next;
175 : }
176 :
177 512 : if (last_caf_ref == NULL)
178 : {
179 180 : gfc_free_expr (caf_expr);
180 180 : return NULL_TREE;
181 : }
182 :
183 143 : tree comp = last_caf_ref->u.c.component->caf_token
184 332 : ? gfc_comp_caf_token (last_caf_ref->u.c.component)
185 : : NULL_TREE,
186 : caf;
187 332 : gfc_se se;
188 332 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
189 332 : if (comp == NULL_TREE && comp_ref)
190 : {
191 46 : gfc_free_expr (caf_expr);
192 46 : return NULL_TREE;
193 : }
194 286 : gfc_init_se (&se, outerse);
195 286 : gfc_free_ref_list (last_caf_ref->next);
196 286 : last_caf_ref->next = NULL;
197 286 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
198 572 : caf_expr->corank = last_caf_ref->u.c.component->as
199 286 : ? last_caf_ref->u.c.component->as->corank
200 : : expr->corank;
201 286 : se.want_pointer = comp_ref;
202 286 : gfc_conv_expr (&se, caf_expr);
203 286 : gfc_add_block_to_block (&outerse->pre, &se.pre);
204 :
205 286 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
206 143 : se.expr = TREE_OPERAND (se.expr, 0);
207 286 : gfc_free_expr (caf_expr);
208 :
209 286 : if (comp_ref)
210 143 : caf = fold_build3_loc (input_location, COMPONENT_REF,
211 143 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
212 : else
213 143 : caf = gfc_conv_descriptor_token (se.expr);
214 286 : return gfc_build_addr_expr (NULL_TREE, caf);
215 : }
216 :
217 :
218 : /* This is the seed for an eventual trans-class.c
219 :
220 : The following parameters should not be used directly since they might
221 : in future implementations. Use the corresponding APIs. */
222 : #define CLASS_DATA_FIELD 0
223 : #define CLASS_VPTR_FIELD 1
224 : #define CLASS_LEN_FIELD 2
225 : #define VTABLE_HASH_FIELD 0
226 : #define VTABLE_SIZE_FIELD 1
227 : #define VTABLE_EXTENDS_FIELD 2
228 : #define VTABLE_DEF_INIT_FIELD 3
229 : #define VTABLE_COPY_FIELD 4
230 : #define VTABLE_FINAL_FIELD 5
231 : #define VTABLE_DEALLOCATE_FIELD 6
232 :
233 :
234 : tree
235 40 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
236 : {
237 40 : tree tmp;
238 40 : tree field;
239 40 : vec<constructor_elt, va_gc> *init = NULL;
240 :
241 40 : field = TYPE_FIELDS (TREE_TYPE (decl));
242 40 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
243 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
244 :
245 40 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
246 40 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
247 :
248 40 : return build_constructor (TREE_TYPE (decl), init);
249 : }
250 :
251 :
252 : tree
253 32217 : gfc_class_data_get (tree decl)
254 : {
255 32217 : tree data;
256 32217 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
257 5418 : decl = build_fold_indirect_ref_loc (input_location, decl);
258 32217 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
259 : CLASS_DATA_FIELD);
260 32217 : return fold_build3_loc (input_location, COMPONENT_REF,
261 32217 : TREE_TYPE (data), decl, data,
262 32217 : NULL_TREE);
263 : }
264 :
265 :
266 : tree
267 45645 : gfc_class_vptr_get (tree decl)
268 : {
269 45645 : tree vptr;
270 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
271 : then available through the saved descriptor. */
272 28270 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
273 47445 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
274 1297 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
275 45645 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
276 2362 : decl = build_fold_indirect_ref_loc (input_location, decl);
277 45645 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
278 : CLASS_VPTR_FIELD);
279 45645 : return fold_build3_loc (input_location, COMPONENT_REF,
280 45645 : TREE_TYPE (vptr), decl, vptr,
281 45645 : NULL_TREE);
282 : }
283 :
284 :
285 : tree
286 6662 : gfc_class_len_get (tree decl)
287 : {
288 6662 : tree len;
289 : /* For class arrays decl may be a temporary descriptor handle, the len is
290 : then available through the saved descriptor. */
291 4791 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
292 6911 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
293 85 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
294 6662 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
295 662 : decl = build_fold_indirect_ref_loc (input_location, decl);
296 6662 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
297 : CLASS_LEN_FIELD);
298 6662 : return fold_build3_loc (input_location, COMPONENT_REF,
299 6662 : TREE_TYPE (len), decl, len,
300 6662 : NULL_TREE);
301 : }
302 :
303 :
304 : /* Try to get the _len component of a class. When the class is not unlimited
305 : poly, i.e. no _len field exists, then return a zero node. */
306 :
307 : static tree
308 4991 : gfc_class_len_or_zero_get (tree decl)
309 : {
310 4991 : tree len;
311 : /* For class arrays decl may be a temporary descriptor handle, the vptr is
312 : then available through the saved descriptor. */
313 2975 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
314 5039 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
315 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
316 4991 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
317 12 : decl = build_fold_indirect_ref_loc (input_location, decl);
318 4991 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
319 : CLASS_LEN_FIELD);
320 6850 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
321 1859 : TREE_TYPE (len), decl, len,
322 : NULL_TREE)
323 3132 : : build_zero_cst (gfc_charlen_type_node);
324 : }
325 :
326 :
327 : tree
328 4831 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
329 : {
330 4831 : tree tmp;
331 4831 : tree tmp2;
332 4831 : tree type;
333 :
334 4831 : tmp = gfc_class_len_or_zero_get (class_expr);
335 :
336 : /* Include the len value in the element size if present. */
337 4831 : if (!integer_zerop (tmp))
338 : {
339 1699 : type = TREE_TYPE (size);
340 1699 : if (block)
341 : {
342 986 : size = gfc_evaluate_now (size, block);
343 986 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
344 : }
345 : else
346 713 : tmp = fold_convert (type , tmp);
347 1699 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
348 : type, size, tmp);
349 1699 : tmp = fold_build2_loc (input_location, GT_EXPR,
350 : logical_type_node, tmp,
351 : build_zero_cst (type));
352 1699 : size = fold_build3_loc (input_location, COND_EXPR,
353 : type, tmp, tmp2, size);
354 : }
355 : else
356 : return size;
357 :
358 1699 : if (block)
359 986 : size = gfc_evaluate_now (size, block);
360 :
361 : return size;
362 : }
363 :
364 :
365 : /* Get the specified FIELD from the VPTR. */
366 :
367 : static tree
368 21249 : vptr_field_get (tree vptr, int fieldno)
369 : {
370 21249 : tree field;
371 21249 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
372 21249 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
373 : fieldno);
374 21249 : field = fold_build3_loc (input_location, COMPONENT_REF,
375 21249 : TREE_TYPE (field), vptr, field,
376 : NULL_TREE);
377 21249 : gcc_assert (field);
378 21249 : return field;
379 : }
380 :
381 :
382 : /* Get the field from the class' vptr. */
383 :
384 : static tree
385 9872 : class_vtab_field_get (tree decl, int fieldno)
386 : {
387 9872 : tree vptr;
388 9872 : vptr = gfc_class_vptr_get (decl);
389 9872 : return vptr_field_get (vptr, fieldno);
390 : }
391 :
392 :
393 : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
394 : unison. */
395 : #define VTAB_GET_FIELD_GEN(name, field) tree \
396 : gfc_class_vtab_## name ##_get (tree cl) \
397 : { \
398 : return class_vtab_field_get (cl, field); \
399 : } \
400 : \
401 : tree \
402 : gfc_vptr_## name ##_get (tree vptr) \
403 : { \
404 : return vptr_field_get (vptr, field); \
405 : }
406 :
407 183 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
408 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
409 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
410 4354 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
411 1812 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
412 1023 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
413 : #undef VTAB_GET_FIELD_GEN
414 :
415 : /* The size field is returned as an array index type. Therefore treat
416 : it and only it specially. */
417 :
418 : tree
419 7898 : gfc_class_vtab_size_get (tree cl)
420 : {
421 7898 : tree size;
422 7898 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
423 : /* Always return size as an array index type. */
424 7898 : size = fold_convert (gfc_array_index_type, size);
425 7898 : gcc_assert (size);
426 7898 : return size;
427 : }
428 :
429 : tree
430 5979 : gfc_vptr_size_get (tree vptr)
431 : {
432 5979 : tree size;
433 5979 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
434 : /* Always return size as an array index type. */
435 5979 : size = fold_convert (gfc_array_index_type, size);
436 5979 : gcc_assert (size);
437 5979 : return size;
438 : }
439 :
440 :
441 : #undef CLASS_DATA_FIELD
442 : #undef CLASS_VPTR_FIELD
443 : #undef CLASS_LEN_FIELD
444 : #undef VTABLE_HASH_FIELD
445 : #undef VTABLE_SIZE_FIELD
446 : #undef VTABLE_EXTENDS_FIELD
447 : #undef VTABLE_DEF_INIT_FIELD
448 : #undef VTABLE_COPY_FIELD
449 : #undef VTABLE_FINAL_FIELD
450 :
451 :
452 : /* IF ts is null (default), search for the last _class ref in the chain
453 : of references of the expression and cut the chain there. Although
454 : this routine is similiar to class.cc:gfc_add_component_ref (), there
455 : is a significant difference: gfc_add_component_ref () concentrates
456 : on an array ref that is the last ref in the chain and is oblivious
457 : to the kind of refs following.
458 : ELSE IF ts is non-null the cut is at the class entity or component
459 : that is followed by an array reference, which is not an element.
460 : These calls come from trans-array.cc:build_class_array_ref, which
461 : handles scalarized class array references.*/
462 :
463 : gfc_expr *
464 9444 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
465 : gfc_typespec **ts)
466 : {
467 9444 : gfc_expr *base_expr;
468 9444 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
469 :
470 : /* Find the last class reference. */
471 9444 : class_ref = NULL;
472 9444 : array_ref = NULL;
473 :
474 9444 : if (ts)
475 : {
476 435 : if (e->symtree
477 410 : && e->symtree->n.sym->ts.type == BT_CLASS)
478 410 : *ts = &e->symtree->n.sym->ts;
479 : else
480 25 : *ts = NULL;
481 : }
482 :
483 23745 : for (ref = e->ref; ref; ref = ref->next)
484 : {
485 14721 : if (ts)
486 : {
487 1038 : if (ref->type == REF_COMPONENT
488 490 : && ref->u.c.component->ts.type == BT_CLASS
489 0 : && ref->next && ref->next->type == REF_COMPONENT
490 0 : && !strcmp (ref->next->u.c.component->name, "_data")
491 0 : && ref->next->next
492 0 : && ref->next->next->type == REF_ARRAY
493 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
494 : {
495 0 : *ts = &ref->u.c.component->ts;
496 0 : class_ref = ref;
497 0 : break;
498 : }
499 :
500 1038 : if (ref->next == NULL)
501 : break;
502 : }
503 : else
504 : {
505 13683 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
506 13683 : array_ref = ref;
507 :
508 13683 : if (ref->type == REF_COMPONENT
509 8235 : && ref->u.c.component->ts.type == BT_CLASS)
510 : {
511 : /* Component to the right of a part reference with nonzero
512 : rank must not have the ALLOCATABLE attribute. If attempts
513 : are made to reference such a component reference, an error
514 : results followed by an ICE. */
515 1609 : if (array_ref
516 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
517 : return NULL;
518 : class_ref = ref;
519 : }
520 : }
521 : }
522 :
523 9434 : if (ts && *ts == NULL)
524 : return NULL;
525 :
526 : /* Remove and store all subsequent references after the
527 : CLASS reference. */
528 9409 : if (class_ref)
529 : {
530 1407 : tail = class_ref->next;
531 1407 : class_ref->next = NULL;
532 : }
533 8002 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
534 : {
535 8002 : tail = e->ref;
536 8002 : e->ref = NULL;
537 : }
538 :
539 9409 : if (is_mold)
540 61 : base_expr = gfc_expr_to_initialize (e);
541 : else
542 9348 : base_expr = gfc_copy_expr (e);
543 :
544 : /* Restore the original tail expression. */
545 9409 : if (class_ref)
546 : {
547 1407 : gfc_free_ref_list (class_ref->next);
548 1407 : class_ref->next = tail;
549 : }
550 8002 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
551 : {
552 8002 : gfc_free_ref_list (e->ref);
553 8002 : e->ref = tail;
554 : }
555 : return base_expr;
556 : }
557 :
558 : /* Reset the vptr to the declared type, e.g. after deallocation.
559 : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
560 : one with e or class_type. At least one of the two has to be set. The
561 : generated assignment code is added at the end of BLOCK. */
562 :
563 : void
564 11167 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container,
565 : gfc_symbol *class_type)
566 : {
567 11167 : tree vptr = NULL_TREE;
568 :
569 11167 : if (class_container != NULL_TREE)
570 6675 : vptr = gfc_get_vptr_from_expr (class_container);
571 :
572 6675 : if (vptr == NULL_TREE)
573 : {
574 4499 : gfc_se se;
575 4499 : gcc_assert (e);
576 :
577 : /* Evaluate the expression and obtain the vptr from it. */
578 4499 : gfc_init_se (&se, NULL);
579 4499 : if (e->rank)
580 2245 : gfc_conv_expr_descriptor (&se, e);
581 : else
582 2254 : gfc_conv_expr (&se, e);
583 4499 : gfc_add_block_to_block (block, &se.pre);
584 :
585 4499 : vptr = gfc_get_vptr_from_expr (se.expr);
586 : }
587 :
588 : /* If a vptr is not found, we can do nothing more. */
589 4499 : if (vptr == NULL_TREE)
590 : return;
591 :
592 11157 : if (UNLIMITED_POLY (e)
593 10131 : || UNLIMITED_POLY (class_type)
594 : /* When the class_type's source is not a symbol (e.g. a component's ts),
595 : then look at the _data-components type. */
596 1515 : || (class_type != NULL && class_type->ts.type == BT_UNKNOWN
597 1515 : && class_type->components && class_type->components->ts.u.derived
598 1509 : && class_type->components->ts.u.derived->attr.unlimited_polymorphic))
599 1194 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
600 : else
601 : {
602 9963 : gfc_symbol *vtab, *type = nullptr;
603 9963 : tree vtable;
604 :
605 9963 : if (e)
606 8616 : type = e->ts.u.derived;
607 1347 : else if (class_type)
608 : {
609 1347 : if (class_type->ts.type == BT_CLASS)
610 0 : type = CLASS_DATA (class_type)->ts.u.derived;
611 : else
612 : type = class_type;
613 : }
614 8616 : gcc_assert (type);
615 : /* Return the vptr to the address of the declared type. */
616 9963 : vtab = gfc_find_derived_vtab (type);
617 9963 : vtable = vtab->backend_decl;
618 9963 : if (vtable == NULL_TREE)
619 76 : vtable = gfc_get_symbol_decl (vtab);
620 9963 : vtable = gfc_build_addr_expr (NULL, vtable);
621 9963 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
622 9963 : gfc_add_modify (block, vptr, vtable);
623 : }
624 : }
625 :
626 : /* Set the vptr of a class in to from the type given in from. If from is NULL,
627 : then reset the vptr to the default or to. */
628 :
629 : void
630 228 : gfc_class_set_vptr (stmtblock_t *block, tree to, tree from)
631 : {
632 228 : tree tmp, vptr_ref;
633 228 : gfc_symbol *type;
634 :
635 228 : vptr_ref = gfc_get_vptr_from_expr (to);
636 264 : if (POINTER_TYPE_P (TREE_TYPE (from))
637 228 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from))))
638 : {
639 44 : gfc_add_modify (block, vptr_ref,
640 22 : fold_convert (TREE_TYPE (vptr_ref),
641 : gfc_get_vptr_from_expr (from)));
642 250 : return;
643 : }
644 206 : tmp = gfc_get_vptr_from_expr (from);
645 206 : if (tmp)
646 : {
647 170 : gfc_add_modify (block, vptr_ref,
648 170 : fold_convert (TREE_TYPE (vptr_ref), tmp));
649 170 : return;
650 : }
651 36 : if (VAR_P (from)
652 36 : && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0)
653 : {
654 36 : gfc_add_modify (block, vptr_ref,
655 36 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), from));
656 36 : return;
657 : }
658 0 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from)))
659 0 : && GFC_CLASS_TYPE_P (
660 : TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0))))
661 : {
662 0 : gfc_add_modify (block, vptr_ref,
663 0 : fold_convert (TREE_TYPE (vptr_ref),
664 : gfc_get_vptr_from_expr (TREE_OPERAND (
665 : TREE_OPERAND (from, 0), 0))));
666 0 : return;
667 : }
668 :
669 : /* If nothing of the above matches, set the vtype according to the type. */
670 0 : tmp = TREE_TYPE (from);
671 0 : if (POINTER_TYPE_P (tmp))
672 0 : tmp = TREE_TYPE (tmp);
673 0 : gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1,
674 : &type);
675 0 : tmp = gfc_find_derived_vtab (type)->backend_decl;
676 0 : gcc_assert (tmp);
677 0 : gfc_add_modify (block, vptr_ref,
678 0 : gfc_build_addr_expr (TREE_TYPE (vptr_ref), tmp));
679 : }
680 :
681 : /* Reset the len for unlimited polymorphic objects. */
682 :
683 : void
684 630 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
685 : {
686 630 : gfc_expr *e;
687 630 : gfc_se se_len;
688 630 : e = gfc_find_and_cut_at_last_class_ref (expr);
689 630 : if (e == NULL)
690 0 : return;
691 630 : gfc_add_len_component (e);
692 630 : gfc_init_se (&se_len, NULL);
693 630 : gfc_conv_expr (&se_len, e);
694 630 : gfc_add_modify (block, se_len.expr,
695 630 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
696 630 : gfc_free_expr (e);
697 : }
698 :
699 :
700 : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
701 : reference is found. Note that it is up to the caller to avoid using this
702 : for expressions other than variables. */
703 :
704 : tree
705 1451 : gfc_get_class_from_gfc_expr (gfc_expr *e)
706 : {
707 1451 : gfc_expr *class_expr;
708 1451 : gfc_se cse;
709 1451 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
710 1451 : if (class_expr == NULL)
711 : return NULL_TREE;
712 1451 : gfc_init_se (&cse, NULL);
713 1451 : gfc_conv_expr (&cse, class_expr);
714 1451 : gfc_free_expr (class_expr);
715 1451 : return cse.expr;
716 : }
717 :
718 :
719 : /* Obtain the last class reference in an expression.
720 : Return NULL_TREE if no class reference is found. */
721 :
722 : tree
723 107703 : gfc_get_class_from_expr (tree expr)
724 : {
725 107703 : tree tmp;
726 107703 : tree type;
727 107703 : bool array_descr_found = false;
728 107703 : bool comp_after_descr_found = false;
729 :
730 277656 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
731 : {
732 277656 : if (CONSTANT_CLASS_P (tmp))
733 : return NULL_TREE;
734 :
735 277619 : type = TREE_TYPE (tmp);
736 321929 : while (type)
737 : {
738 314051 : if (GFC_CLASS_TYPE_P (type))
739 : return tmp;
740 294146 : if (GFC_DESCRIPTOR_TYPE_P (type))
741 35173 : array_descr_found = true;
742 294146 : if (type != TYPE_CANONICAL (type))
743 44310 : type = TYPE_CANONICAL (type);
744 : else
745 : type = NULL_TREE;
746 : }
747 257714 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
748 : break;
749 :
750 : /* Avoid walking up the reference chain too far. For class arrays, the
751 : array descriptor is a direct component (through a pointer) of the class
752 : container. So there is exactly one COMPONENT_REF between a class
753 : container and its child array descriptor. After seeing an array
754 : descriptor, we can give up on the second COMPONENT_REF we see, if no
755 : class container was found until that point. */
756 169953 : if (array_descr_found)
757 : {
758 7451 : if (comp_after_descr_found)
759 : {
760 12 : if (TREE_CODE (tmp) == COMPONENT_REF)
761 : return NULL_TREE;
762 : }
763 7439 : else if (TREE_CODE (tmp) == COMPONENT_REF)
764 7451 : comp_after_descr_found = true;
765 : }
766 : }
767 :
768 87761 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
769 58902 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
770 :
771 87761 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
772 : return tmp;
773 :
774 : return NULL_TREE;
775 : }
776 :
777 :
778 : /* Obtain the vptr of the last class reference in an expression.
779 : Return NULL_TREE if no class reference is found. */
780 :
781 : tree
782 11822 : gfc_get_vptr_from_expr (tree expr)
783 : {
784 11822 : tree tmp;
785 :
786 11822 : tmp = gfc_get_class_from_expr (expr);
787 :
788 11822 : if (tmp != NULL_TREE)
789 11757 : return gfc_class_vptr_get (tmp);
790 :
791 : return NULL_TREE;
792 : }
793 :
794 : static void
795 2347 : copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
796 : {
797 2347 : tree src_type = TREE_TYPE (src);
798 2347 : if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
799 : {
800 135 : struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
801 270 : for (int c = 0; c < lang_specific->corank; ++c)
802 : {
803 135 : int dim = lang_specific->rank + c;
804 135 : tree codim = gfc_rank_cst[dim];
805 :
806 135 : if (lang_specific->lbound[dim])
807 54 : gfc_conv_descriptor_lbound_set (block, dest, codim,
808 : lang_specific->lbound[dim]);
809 : else
810 81 : gfc_conv_descriptor_lbound_set (
811 : block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
812 135 : if (dim + 1 < lang_specific->corank)
813 : {
814 0 : if (lang_specific->ubound[dim])
815 0 : gfc_conv_descriptor_ubound_set (block, dest, codim,
816 : lang_specific->ubound[dim]);
817 : else
818 0 : gfc_conv_descriptor_ubound_set (
819 : block, dest, codim,
820 : gfc_conv_descriptor_ubound_get (src, codim));
821 : }
822 : }
823 : }
824 2347 : }
825 :
826 : void
827 2025 : gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
828 : bool lhs_type)
829 : {
830 2025 : tree lhs_dim, rhs_dim, type;
831 :
832 2025 : gfc_conv_descriptor_data_set (block, lhs_desc,
833 : gfc_conv_descriptor_data_get (rhs_desc));
834 2025 : gfc_conv_descriptor_offset_set (block, lhs_desc,
835 : gfc_conv_descriptor_offset_get (rhs_desc));
836 :
837 2025 : gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
838 : gfc_conv_descriptor_dtype (rhs_desc));
839 :
840 : /* Assign the dimension as range-ref. */
841 2025 : lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
842 2025 : rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
843 :
844 2025 : type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
845 2025 : lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
846 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
847 2025 : rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
848 : gfc_index_zero_node, NULL_TREE, NULL_TREE);
849 2025 : gfc_add_modify (block, lhs_dim, rhs_dim);
850 :
851 : /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
852 2025 : copy_coarray_desc_part (block, lhs_desc, rhs_desc);
853 2025 : }
854 :
855 : /* Takes a derived type expression and returns the address of a temporary
856 : class object of the 'declared' type. If opt_vptr_src is not NULL, this is
857 : used for the temporary class object.
858 : optional_alloc_ptr is false when the dummy is neither allocatable
859 : nor a pointer; that's only relevant for the optional handling.
860 : The optional argument 'derived_array' is used to preserve the parmse
861 : expression for deallocation of allocatable components. Assumed rank
862 : formal arguments made this necessary. */
863 : void
864 5178 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
865 : tree opt_vptr_src, bool optional,
866 : bool optional_alloc_ptr, const char *proc_name,
867 : tree *derived_array)
868 : {
869 5178 : tree cond_optional = NULL_TREE;
870 5178 : gfc_ss *ss;
871 5178 : tree ctree;
872 5178 : tree var;
873 5178 : tree tmp;
874 5178 : tree packed = NULL_TREE;
875 :
876 : /* The derived type needs to be converted to a temporary CLASS object. */
877 5178 : tmp = gfc_typenode_for_spec (&fsym->ts);
878 5178 : var = gfc_create_var (tmp, "class");
879 :
880 : /* Set the vptr. */
881 5178 : if (opt_vptr_src)
882 128 : gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
883 : else
884 5050 : gfc_reset_vptr (&parmse->pre, e, var);
885 :
886 : /* Now set the data field. */
887 5178 : ctree = gfc_class_data_get (var);
888 :
889 5178 : if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
890 : {
891 4 : tree token;
892 4 : tmp = gfc_get_tree_for_caf_expr (e);
893 4 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
894 2 : tmp = build_fold_indirect_ref (tmp);
895 4 : gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
896 4 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), token);
897 : }
898 :
899 5178 : if (optional)
900 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
901 :
902 : /* Set the _len as early as possible. */
903 5178 : if (fsym->ts.u.derived->components->ts.type == BT_DERIVED
904 5178 : && fsym->ts.u.derived->components->ts.u.derived->attr
905 5178 : .unlimited_polymorphic)
906 : {
907 : /* Take care about initializing the _len component correctly. */
908 386 : tree len_tree = gfc_class_len_get (var);
909 386 : if (UNLIMITED_POLY (e))
910 : {
911 12 : gfc_expr *len;
912 12 : gfc_se se;
913 :
914 12 : len = gfc_find_and_cut_at_last_class_ref (e);
915 12 : gfc_add_len_component (len);
916 12 : gfc_init_se (&se, NULL);
917 12 : gfc_conv_expr (&se, len);
918 12 : if (optional)
919 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
920 : cond_optional, se.expr,
921 0 : fold_convert (TREE_TYPE (se.expr),
922 : integer_zero_node));
923 : else
924 12 : tmp = se.expr;
925 12 : gfc_free_expr (len);
926 12 : }
927 : else
928 374 : tmp = integer_zero_node;
929 386 : gfc_add_modify (&parmse->pre, len_tree,
930 386 : fold_convert (TREE_TYPE (len_tree), tmp));
931 : }
932 :
933 5178 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
934 : {
935 : /* If there is a ready made pointer to a derived type, use it
936 : rather than evaluating the expression again. */
937 535 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
938 535 : gfc_add_modify (&parmse->pre, ctree, tmp);
939 : }
940 4643 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
941 : {
942 : /* For an array reference in an elemental procedure call we need
943 : to retain the ss to provide the scalarized array reference. */
944 445 : gfc_conv_expr_reference (parmse, e);
945 445 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
946 445 : if (optional)
947 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
948 : cond_optional, tmp,
949 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
950 445 : gfc_add_modify (&parmse->pre, ctree, tmp);
951 : }
952 : else
953 : {
954 4198 : ss = gfc_walk_expr (e);
955 4198 : if (ss == gfc_ss_terminator)
956 : {
957 2950 : parmse->ss = NULL;
958 2950 : gfc_conv_expr_reference (parmse, e);
959 :
960 : /* Scalar to an assumed-rank array. */
961 2950 : if (fsym->ts.u.derived->components->as)
962 : {
963 322 : tree type;
964 322 : type = get_scalar_to_descriptor_type (parmse->expr,
965 : gfc_expr_attr (e));
966 322 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
967 : gfc_get_dtype (type));
968 322 : copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
969 322 : if (optional)
970 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
971 96 : TREE_TYPE (parmse->expr),
972 : cond_optional, parmse->expr,
973 96 : fold_convert (TREE_TYPE (parmse->expr),
974 : null_pointer_node));
975 322 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
976 : }
977 : else
978 : {
979 2628 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
980 2628 : if (optional)
981 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
982 : cond_optional, tmp,
983 132 : fold_convert (TREE_TYPE (tmp),
984 : null_pointer_node));
985 2628 : gfc_add_modify (&parmse->pre, ctree, tmp);
986 : }
987 : }
988 : else
989 : {
990 1248 : stmtblock_t block;
991 1248 : gfc_init_block (&block);
992 1248 : gfc_ref *ref;
993 1248 : int dim;
994 1248 : tree lbshift = NULL_TREE;
995 :
996 : /* Array refs with sections indicate, that a for a formal argument
997 : expecting contiguous repacking needs to be done. */
998 2345 : for (ref = e->ref; ref; ref = ref->next)
999 1247 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1000 : break;
1001 1248 : if (IS_CLASS_ARRAY (fsym)
1002 1140 : && (CLASS_DATA (fsym)->as->type == AS_EXPLICIT
1003 882 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_SIZE)
1004 354 : && (ref || e->rank != fsym->ts.u.derived->components->as->rank))
1005 144 : fsym->attr.contiguous = 1;
1006 :
1007 : /* Detect any array references with vector subscripts. */
1008 2489 : for (ref = e->ref; ref; ref = ref->next)
1009 1247 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
1010 1205 : && ref->u.ar.type != AR_FULL)
1011 : {
1012 336 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
1013 192 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
1014 : break;
1015 150 : if (dim < ref->u.ar.dimen)
1016 : break;
1017 : }
1018 : /* Array references with vector subscripts and non-variable
1019 : expressions need be converted to a one-based descriptor. */
1020 1248 : if (ref || e->expr_type != EXPR_VARIABLE)
1021 49 : lbshift = gfc_index_one_node;
1022 :
1023 1248 : parmse->expr = var;
1024 1248 : gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
1025 : &lbshift, &packed);
1026 :
1027 1248 : if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
1028 : {
1029 1152 : *derived_array
1030 1152 : = gfc_create_var (TREE_TYPE (parmse->expr), "array");
1031 1152 : gfc_add_modify (&block, *derived_array, parmse->expr);
1032 : }
1033 :
1034 1248 : if (optional)
1035 : {
1036 348 : tmp = gfc_finish_block (&block);
1037 :
1038 348 : gfc_init_block (&block);
1039 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
1040 348 : if (derived_array && *derived_array != NULL_TREE)
1041 348 : gfc_conv_descriptor_data_set (&block, *derived_array,
1042 : null_pointer_node);
1043 :
1044 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
1045 : gfc_finish_block (&block));
1046 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
1047 : }
1048 : else
1049 900 : gfc_add_block_to_block (&parmse->pre, &block);
1050 : }
1051 : }
1052 :
1053 : /* Pass the address of the class object. */
1054 5178 : if (packed)
1055 96 : parmse->expr = packed;
1056 : else
1057 5082 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1058 :
1059 5178 : if (optional && optional_alloc_ptr)
1060 84 : parmse->expr
1061 84 : = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr),
1062 : cond_optional, parmse->expr,
1063 84 : fold_convert (TREE_TYPE (parmse->expr), null_pointer_node));
1064 5178 : }
1065 :
1066 : /* Create a new class container, which is required as scalar coarrays
1067 : have an array descriptor while normal scalars haven't. Optionally,
1068 : NULL pointer checks are added if the argument is OPTIONAL. */
1069 :
1070 : static void
1071 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
1072 : gfc_typespec class_ts, bool optional)
1073 : {
1074 48 : tree var, ctree, tmp;
1075 48 : stmtblock_t block;
1076 48 : gfc_ref *ref;
1077 48 : gfc_ref *class_ref;
1078 :
1079 48 : gfc_init_block (&block);
1080 :
1081 48 : class_ref = NULL;
1082 144 : for (ref = e->ref; ref; ref = ref->next)
1083 : {
1084 96 : if (ref->type == REF_COMPONENT
1085 48 : && ref->u.c.component->ts.type == BT_CLASS)
1086 96 : class_ref = ref;
1087 : }
1088 :
1089 48 : if (class_ref == NULL
1090 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1091 48 : tmp = e->symtree->n.sym->backend_decl;
1092 : else
1093 : {
1094 : /* Remove everything after the last class reference, convert the
1095 : expression and then recover its tailend once more. */
1096 0 : gfc_se tmpse;
1097 0 : ref = class_ref->next;
1098 0 : class_ref->next = NULL;
1099 0 : gfc_init_se (&tmpse, NULL);
1100 0 : gfc_conv_expr (&tmpse, e);
1101 0 : class_ref->next = ref;
1102 0 : tmp = tmpse.expr;
1103 : }
1104 :
1105 48 : var = gfc_typenode_for_spec (&class_ts);
1106 48 : var = gfc_create_var (var, "class");
1107 :
1108 48 : ctree = gfc_class_vptr_get (var);
1109 96 : gfc_add_modify (&block, ctree,
1110 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
1111 :
1112 48 : ctree = gfc_class_data_get (var);
1113 48 : tmp = gfc_conv_descriptor_data_get (
1114 48 : gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
1115 : ? tmp
1116 24 : : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
1117 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1118 :
1119 : /* Pass the address of the class object. */
1120 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1121 :
1122 48 : if (optional)
1123 : {
1124 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
1125 48 : tree tmp2;
1126 :
1127 48 : tmp = gfc_finish_block (&block);
1128 :
1129 48 : gfc_init_block (&block);
1130 48 : tmp2 = gfc_class_data_get (var);
1131 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1132 : null_pointer_node));
1133 48 : tmp2 = gfc_finish_block (&block);
1134 :
1135 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1136 : cond, tmp, tmp2);
1137 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
1138 : }
1139 : else
1140 0 : gfc_add_block_to_block (&parmse->pre, &block);
1141 48 : }
1142 :
1143 :
1144 : /* Takes an intrinsic type expression and returns the address of a temporary
1145 : class object of the 'declared' type. */
1146 : void
1147 882 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1148 : gfc_typespec class_ts)
1149 : {
1150 882 : gfc_symbol *vtab;
1151 882 : gfc_ss *ss;
1152 882 : tree ctree;
1153 882 : tree var;
1154 882 : tree tmp;
1155 882 : int dim;
1156 882 : bool unlimited_poly;
1157 :
1158 1764 : unlimited_poly = class_ts.type == BT_CLASS
1159 882 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1160 882 : && class_ts.u.derived->components->ts.u.derived
1161 882 : ->attr.unlimited_polymorphic;
1162 :
1163 : /* The intrinsic type needs to be converted to a temporary
1164 : CLASS object. */
1165 882 : tmp = gfc_typenode_for_spec (&class_ts);
1166 882 : var = gfc_create_var (tmp, "class");
1167 :
1168 : /* Force a temporary for component or substring references. */
1169 882 : if (unlimited_poly
1170 882 : && class_ts.u.derived->components->attr.dimension
1171 623 : && !class_ts.u.derived->components->attr.allocatable
1172 623 : && !class_ts.u.derived->components->attr.class_pointer
1173 1505 : && is_subref_array (e))
1174 17 : parmse->force_tmp = 1;
1175 :
1176 : /* Set the vptr. */
1177 882 : ctree = gfc_class_vptr_get (var);
1178 :
1179 882 : vtab = gfc_find_vtab (&e->ts);
1180 882 : gcc_assert (vtab);
1181 882 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1182 882 : gfc_add_modify (&parmse->pre, ctree,
1183 882 : fold_convert (TREE_TYPE (ctree), tmp));
1184 :
1185 : /* Now set the data field. */
1186 882 : ctree = gfc_class_data_get (var);
1187 882 : if (parmse->ss && parmse->ss->info->useflags)
1188 : {
1189 : /* For an array reference in an elemental procedure call we need
1190 : to retain the ss to provide the scalarized array reference. */
1191 36 : gfc_conv_expr_reference (parmse, e);
1192 36 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1193 36 : gfc_add_modify (&parmse->pre, ctree, tmp);
1194 : }
1195 : else
1196 : {
1197 846 : ss = gfc_walk_expr (e);
1198 846 : if (ss == gfc_ss_terminator)
1199 : {
1200 247 : parmse->ss = NULL;
1201 247 : gfc_conv_expr_reference (parmse, e);
1202 247 : if (class_ts.u.derived->components->as
1203 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1204 : {
1205 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1206 : gfc_expr_attr (e));
1207 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1208 24 : TREE_TYPE (ctree), tmp);
1209 : }
1210 : else
1211 223 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1212 247 : gfc_add_modify (&parmse->pre, ctree, tmp);
1213 : }
1214 : else
1215 : {
1216 599 : parmse->ss = ss;
1217 599 : gfc_conv_expr_descriptor (parmse, e);
1218 :
1219 : /* Array references with vector subscripts and non-variable expressions
1220 : need be converted to a one-based descriptor. */
1221 599 : if (e->expr_type != EXPR_VARIABLE)
1222 : {
1223 368 : for (dim = 0; dim < e->rank; ++dim)
1224 193 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1225 : dim, gfc_index_one_node);
1226 : }
1227 :
1228 599 : if (class_ts.u.derived->components->as->rank != e->rank)
1229 : {
1230 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1231 49 : TREE_TYPE (ctree), parmse->expr);
1232 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1233 : }
1234 : else
1235 550 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1236 : }
1237 : }
1238 :
1239 882 : gcc_assert (class_ts.type == BT_CLASS);
1240 882 : if (unlimited_poly)
1241 : {
1242 882 : ctree = gfc_class_len_get (var);
1243 : /* When the actual arg is a char array, then set the _len component of the
1244 : unlimited polymorphic entity to the length of the string. */
1245 882 : if (e->ts.type == BT_CHARACTER)
1246 : {
1247 : /* Start with parmse->string_length because this seems to be set to a
1248 : correct value more often. */
1249 175 : if (parmse->string_length)
1250 : tmp = parmse->string_length;
1251 : /* When the string_length is not yet set, then try the backend_decl of
1252 : the cl. */
1253 0 : else if (e->ts.u.cl->backend_decl)
1254 : tmp = e->ts.u.cl->backend_decl;
1255 : /* If both of the above approaches fail, then try to generate an
1256 : expression from the input, which is only feasible currently, when the
1257 : expression can be evaluated to a constant one. */
1258 : else
1259 : {
1260 : /* Try to simplify the expression. */
1261 0 : gfc_simplify_expr (e, 0);
1262 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1263 : {
1264 : /* Amazingly all data is present to compute the length of a
1265 : constant string, but the expression is not yet there. */
1266 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1267 : gfc_charlen_int_kind,
1268 : &e->where);
1269 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1270 0 : e->value.character.length);
1271 0 : gfc_conv_const_charlen (e->ts.u.cl);
1272 0 : e->ts.u.cl->resolved = 1;
1273 0 : tmp = e->ts.u.cl->backend_decl;
1274 : }
1275 : else
1276 : {
1277 0 : gfc_error ("Cannot compute the length of the char array "
1278 : "at %L.", &e->where);
1279 : }
1280 : }
1281 : }
1282 : else
1283 707 : tmp = integer_zero_node;
1284 :
1285 882 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1286 : }
1287 :
1288 : /* Pass the address of the class object. */
1289 882 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1290 882 : }
1291 :
1292 :
1293 : /* Takes a scalarized class array expression and returns the
1294 : address of a temporary scalar class object of the 'declared'
1295 : type.
1296 : OOP-TODO: This could be improved by adding code that branched on
1297 : the dynamic type being the same as the declared type. In this case
1298 : the original class expression can be passed directly.
1299 : optional_alloc_ptr is false when the dummy is neither allocatable
1300 : nor a pointer; that's relevant for the optional handling.
1301 : Set copyback to true if class container's _data and _vtab pointers
1302 : might get modified. */
1303 :
1304 : void
1305 3615 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1306 : bool elemental, bool copyback, bool optional,
1307 : bool optional_alloc_ptr)
1308 : {
1309 3615 : tree ctree;
1310 3615 : tree var;
1311 3615 : tree tmp;
1312 3615 : tree vptr;
1313 3615 : tree cond = NULL_TREE;
1314 3615 : tree slen = NULL_TREE;
1315 3615 : gfc_ref *ref;
1316 3615 : gfc_ref *class_ref;
1317 3615 : stmtblock_t block;
1318 3615 : bool full_array = false;
1319 :
1320 : /* If this is the data field of a class temporary, the class expression
1321 : can be obtained and returned directly. */
1322 3615 : if (e->expr_type != EXPR_VARIABLE
1323 180 : && TREE_CODE (parmse->expr) == COMPONENT_REF
1324 36 : && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))
1325 3651 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse->expr, 0))))
1326 : {
1327 36 : parmse->expr = TREE_OPERAND (parmse->expr, 0);
1328 36 : if (!VAR_P (parmse->expr))
1329 0 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
1330 36 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
1331 174 : return;
1332 : }
1333 :
1334 3579 : gfc_init_block (&block);
1335 :
1336 3579 : class_ref = NULL;
1337 7174 : for (ref = e->ref; ref; ref = ref->next)
1338 : {
1339 6798 : if (ref->type == REF_COMPONENT
1340 3629 : && ref->u.c.component->ts.type == BT_CLASS)
1341 6798 : class_ref = ref;
1342 :
1343 6798 : if (ref->next == NULL)
1344 : break;
1345 : }
1346 :
1347 3579 : if ((ref == NULL || class_ref == ref)
1348 488 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1349 4049 : && (!class_ts.u.derived->components->as
1350 379 : || class_ts.u.derived->components->as->rank != -1))
1351 : return;
1352 :
1353 : /* Test for FULL_ARRAY. */
1354 3441 : if (e->rank == 0
1355 3441 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1356 494 : || (class_ts.u.derived->components->as
1357 366 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1358 411 : full_array = true;
1359 : else
1360 3030 : gfc_is_class_array_ref (e, &full_array);
1361 :
1362 : /* The derived type needs to be converted to a temporary
1363 : CLASS object. */
1364 3441 : tmp = gfc_typenode_for_spec (&class_ts);
1365 3441 : var = gfc_create_var (tmp, "class");
1366 :
1367 : /* Set the data. */
1368 3441 : ctree = gfc_class_data_get (var);
1369 3441 : if (class_ts.u.derived->components->as
1370 3157 : && e->rank != class_ts.u.derived->components->as->rank)
1371 : {
1372 965 : if (e->rank == 0)
1373 : {
1374 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1375 : gfc_expr_attr (e));
1376 356 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1377 : gfc_get_dtype (type));
1378 :
1379 356 : tmp = gfc_class_data_get (parmse->expr);
1380 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1381 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1382 :
1383 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1384 : }
1385 : else
1386 609 : gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
1387 : }
1388 : else
1389 : {
1390 2476 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1391 1424 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1392 1424 : TREE_TYPE (ctree), parmse->expr);
1393 2476 : gfc_add_modify (&block, ctree, parmse->expr);
1394 : }
1395 :
1396 : /* Return the data component, except in the case of scalarized array
1397 : references, where nullification of the cannot occur and so there
1398 : is no need. */
1399 3441 : if (!elemental && full_array && copyback)
1400 : {
1401 1155 : if (class_ts.u.derived->components->as
1402 1155 : && e->rank != class_ts.u.derived->components->as->rank)
1403 : {
1404 270 : if (e->rank == 0)
1405 : {
1406 102 : tmp = gfc_class_data_get (parmse->expr);
1407 204 : gfc_add_modify (&parmse->post, tmp,
1408 102 : fold_convert (TREE_TYPE (tmp),
1409 : gfc_conv_descriptor_data_get (ctree)));
1410 : }
1411 : else
1412 168 : gfc_class_array_data_assign (&parmse->post, parmse->expr, ctree,
1413 : true);
1414 : }
1415 : else
1416 885 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1417 : }
1418 :
1419 : /* Set the vptr. */
1420 3441 : ctree = gfc_class_vptr_get (var);
1421 :
1422 : /* The vptr is the second field of the actual argument.
1423 : First we have to find the corresponding class reference. */
1424 :
1425 3441 : tmp = NULL_TREE;
1426 3441 : if (gfc_is_class_array_function (e)
1427 3441 : && parmse->class_vptr != NULL_TREE)
1428 : tmp = parmse->class_vptr;
1429 3423 : else if (class_ref == NULL
1430 2979 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1431 : {
1432 2979 : tmp = e->symtree->n.sym->backend_decl;
1433 :
1434 2979 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1435 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1436 :
1437 2979 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1438 397 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1439 :
1440 2979 : slen = build_zero_cst (size_type_node);
1441 : }
1442 444 : else if (parmse->class_container != NULL_TREE)
1443 : /* Don't redundantly evaluate the expression if the required information
1444 : is already available. */
1445 : tmp = parmse->class_container;
1446 : else
1447 : {
1448 : /* Remove everything after the last class reference, convert the
1449 : expression and then recover its tailend once more. */
1450 18 : gfc_se tmpse;
1451 18 : ref = class_ref->next;
1452 18 : class_ref->next = NULL;
1453 18 : gfc_init_se (&tmpse, NULL);
1454 18 : gfc_conv_expr (&tmpse, e);
1455 18 : class_ref->next = ref;
1456 18 : tmp = tmpse.expr;
1457 18 : slen = tmpse.string_length;
1458 : }
1459 :
1460 3441 : gcc_assert (tmp != NULL_TREE);
1461 :
1462 : /* Dereference if needs be. */
1463 3441 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1464 345 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1465 :
1466 3441 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1467 3423 : vptr = gfc_class_vptr_get (tmp);
1468 : else
1469 : vptr = tmp;
1470 :
1471 3441 : gfc_add_modify (&block, ctree,
1472 3441 : fold_convert (TREE_TYPE (ctree), vptr));
1473 :
1474 : /* Return the vptr component, except in the case of scalarized array
1475 : references, where the dynamic type cannot change. */
1476 3441 : if (!elemental && full_array && copyback)
1477 1155 : gfc_add_modify (&parmse->post, vptr,
1478 1155 : fold_convert (TREE_TYPE (vptr), ctree));
1479 :
1480 : /* For unlimited polymorphic objects also set the _len component. */
1481 3441 : if (class_ts.type == BT_CLASS
1482 3441 : && class_ts.u.derived->components
1483 3441 : && class_ts.u.derived->components->ts.u
1484 3441 : .derived->attr.unlimited_polymorphic)
1485 : {
1486 1109 : ctree = gfc_class_len_get (var);
1487 1109 : if (UNLIMITED_POLY (e))
1488 913 : tmp = gfc_class_len_get (tmp);
1489 196 : else if (e->ts.type == BT_CHARACTER)
1490 : {
1491 0 : gcc_assert (slen != NULL_TREE);
1492 : tmp = slen;
1493 : }
1494 : else
1495 196 : tmp = build_zero_cst (size_type_node);
1496 1109 : gfc_add_modify (&parmse->pre, ctree,
1497 1109 : fold_convert (TREE_TYPE (ctree), tmp));
1498 :
1499 : /* Return the len component, except in the case of scalarized array
1500 : references, where the dynamic type cannot change. */
1501 1109 : if (!elemental && full_array && copyback
1502 440 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1503 428 : gfc_add_modify (&parmse->post, tmp,
1504 428 : fold_convert (TREE_TYPE (tmp), ctree));
1505 : }
1506 :
1507 3441 : if (optional)
1508 : {
1509 510 : tree tmp2;
1510 :
1511 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1512 : /* parmse->pre may contain some preparatory instructions for the
1513 : temporary array descriptor. Those may only be executed when the
1514 : optional argument is set, therefore add parmse->pre's instructions
1515 : to block, which is later guarded by an if (optional_arg_given). */
1516 510 : gfc_add_block_to_block (&parmse->pre, &block);
1517 510 : block.head = parmse->pre.head;
1518 510 : parmse->pre.head = NULL_TREE;
1519 510 : tmp = gfc_finish_block (&block);
1520 :
1521 510 : if (optional_alloc_ptr)
1522 102 : tmp2 = build_empty_stmt (input_location);
1523 : else
1524 : {
1525 408 : gfc_init_block (&block);
1526 :
1527 408 : tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1528 408 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1529 : null_pointer_node));
1530 408 : tmp2 = gfc_finish_block (&block);
1531 : }
1532 :
1533 510 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1534 : cond, tmp, tmp2);
1535 510 : gfc_add_expr_to_block (&parmse->pre, tmp);
1536 :
1537 510 : if (!elemental && full_array && copyback)
1538 : {
1539 30 : tmp2 = build_empty_stmt (input_location);
1540 30 : tmp = gfc_finish_block (&parmse->post);
1541 30 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1542 : cond, tmp, tmp2);
1543 30 : gfc_add_expr_to_block (&parmse->post, tmp);
1544 : }
1545 : }
1546 : else
1547 2931 : gfc_add_block_to_block (&parmse->pre, &block);
1548 :
1549 : /* Pass the address of the class object. */
1550 3441 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1551 :
1552 3441 : if (optional && optional_alloc_ptr)
1553 204 : parmse->expr = build3_loc (input_location, COND_EXPR,
1554 102 : TREE_TYPE (parmse->expr),
1555 : cond, parmse->expr,
1556 102 : fold_convert (TREE_TYPE (parmse->expr),
1557 : null_pointer_node));
1558 : }
1559 :
1560 :
1561 : /* Given a class array declaration and an index, returns the address
1562 : of the referenced element. */
1563 :
1564 : static tree
1565 712 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1566 : bool unlimited)
1567 : {
1568 712 : tree data, size, tmp, ctmp, offset, ptr;
1569 :
1570 712 : data = data_comp != NULL_TREE ? data_comp :
1571 0 : gfc_class_data_get (class_decl);
1572 712 : size = gfc_class_vtab_size_get (class_decl);
1573 :
1574 712 : if (unlimited)
1575 : {
1576 200 : tmp = fold_convert (gfc_array_index_type,
1577 : gfc_class_len_get (class_decl));
1578 200 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1579 : gfc_array_index_type, size, tmp);
1580 200 : tmp = fold_build2_loc (input_location, GT_EXPR,
1581 : logical_type_node, tmp,
1582 200 : build_zero_cst (TREE_TYPE (tmp)));
1583 200 : size = fold_build3_loc (input_location, COND_EXPR,
1584 : gfc_array_index_type, tmp, ctmp, size);
1585 : }
1586 :
1587 712 : offset = fold_build2_loc (input_location, MULT_EXPR,
1588 : gfc_array_index_type,
1589 : index, size);
1590 :
1591 712 : data = gfc_conv_descriptor_data_get (data);
1592 712 : ptr = fold_convert (pvoid_type_node, data);
1593 712 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1594 712 : return fold_convert (TREE_TYPE (data), ptr);
1595 : }
1596 :
1597 :
1598 : /* Copies one class expression to another, assuming that if either
1599 : 'to' or 'from' are arrays they are packed. Should 'from' be
1600 : NULL_TREE, the initialization expression for 'to' is used, assuming
1601 : that the _vptr is set. */
1602 :
1603 : tree
1604 758 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1605 : {
1606 758 : tree fcn;
1607 758 : tree fcn_type;
1608 758 : tree from_data;
1609 758 : tree from_len;
1610 758 : tree to_data;
1611 758 : tree to_len;
1612 758 : tree to_ref;
1613 758 : tree from_ref;
1614 758 : vec<tree, va_gc> *args;
1615 758 : tree tmp;
1616 758 : tree stdcopy;
1617 758 : tree extcopy;
1618 758 : tree index;
1619 758 : bool is_from_desc = false, is_to_class = false;
1620 :
1621 758 : args = NULL;
1622 : /* To prevent warnings on uninitialized variables. */
1623 758 : from_len = to_len = NULL_TREE;
1624 :
1625 758 : if (from != NULL_TREE)
1626 758 : fcn = gfc_class_vtab_copy_get (from);
1627 : else
1628 0 : fcn = gfc_class_vtab_copy_get (to);
1629 :
1630 758 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1631 :
1632 758 : if (from != NULL_TREE)
1633 : {
1634 758 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1635 758 : if (is_from_desc)
1636 : {
1637 0 : from_data = from;
1638 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1639 : }
1640 : else
1641 : {
1642 : /* Check that from is a class. When the class is part of a coarray,
1643 : then from is a common pointer and is to be used as is. */
1644 1516 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1645 758 : ? build_fold_indirect_ref (from) : from;
1646 1516 : from_data =
1647 758 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1648 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1649 758 : ? gfc_class_data_get (from) : from;
1650 758 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1651 : }
1652 : }
1653 : else
1654 0 : from_data = gfc_class_vtab_def_init_get (to);
1655 :
1656 758 : if (unlimited)
1657 : {
1658 160 : if (from != NULL_TREE && unlimited)
1659 160 : from_len = gfc_class_len_or_zero_get (from);
1660 : else
1661 0 : from_len = build_zero_cst (size_type_node);
1662 : }
1663 :
1664 758 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1665 : {
1666 758 : is_to_class = true;
1667 758 : to_data = gfc_class_data_get (to);
1668 758 : if (unlimited)
1669 160 : to_len = gfc_class_len_get (to);
1670 : }
1671 : else
1672 : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1673 0 : to_data = to;
1674 :
1675 758 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1676 : {
1677 356 : stmtblock_t loopbody;
1678 356 : stmtblock_t body;
1679 356 : stmtblock_t ifbody;
1680 356 : gfc_loopinfo loop;
1681 :
1682 356 : gfc_init_block (&body);
1683 356 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1684 : gfc_array_index_type, nelems,
1685 : gfc_index_one_node);
1686 356 : nelems = gfc_evaluate_now (tmp, &body);
1687 356 : index = gfc_create_var (gfc_array_index_type, "S");
1688 :
1689 356 : if (is_from_desc)
1690 : {
1691 356 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1692 : unlimited);
1693 356 : vec_safe_push (args, from_ref);
1694 : }
1695 : else
1696 0 : vec_safe_push (args, from_data);
1697 :
1698 356 : if (is_to_class)
1699 356 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1700 : else
1701 : {
1702 0 : tmp = gfc_conv_array_data (to);
1703 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1704 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1705 : gfc_build_array_ref (tmp, index, to));
1706 : }
1707 356 : vec_safe_push (args, to_ref);
1708 :
1709 : /* Add bounds check. */
1710 356 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1711 : {
1712 25 : const char *name = "<<unknown>>";
1713 25 : int dim, rank;
1714 :
1715 25 : if (DECL_P (to))
1716 0 : name = IDENTIFIER_POINTER (DECL_NAME (to));
1717 :
1718 25 : rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
1719 55 : for (dim = 1; dim <= rank; dim++)
1720 : {
1721 30 : tree from_len, to_len, cond;
1722 30 : char *msg;
1723 :
1724 30 : from_len = gfc_conv_descriptor_size (from_data, dim);
1725 30 : from_len = fold_convert (long_integer_type_node, from_len);
1726 30 : to_len = gfc_conv_descriptor_size (to_data, dim);
1727 30 : to_len = fold_convert (long_integer_type_node, to_len);
1728 30 : msg = xasprintf ("Array bound mismatch for dimension %d "
1729 : "of array '%s' (%%ld/%%ld)",
1730 : dim, name);
1731 30 : cond = fold_build2_loc (input_location, NE_EXPR,
1732 : logical_type_node, from_len, to_len);
1733 30 : gfc_trans_runtime_check (true, false, cond, &body,
1734 : NULL, msg, to_len, from_len);
1735 30 : free (msg);
1736 : }
1737 : }
1738 :
1739 356 : tmp = build_call_vec (fcn_type, fcn, args);
1740 :
1741 : /* Build the body of the loop. */
1742 356 : gfc_init_block (&loopbody);
1743 356 : gfc_add_expr_to_block (&loopbody, tmp);
1744 :
1745 : /* Build the loop and return. */
1746 356 : gfc_init_loopinfo (&loop);
1747 356 : loop.dimen = 1;
1748 356 : loop.from[0] = gfc_index_zero_node;
1749 356 : loop.loopvar[0] = index;
1750 356 : loop.to[0] = nelems;
1751 356 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1752 356 : gfc_init_block (&ifbody);
1753 356 : gfc_add_block_to_block (&ifbody, &loop.pre);
1754 356 : stdcopy = gfc_finish_block (&ifbody);
1755 : /* In initialization mode from_len is a constant zero. */
1756 356 : if (unlimited && !integer_zerop (from_len))
1757 : {
1758 100 : vec_safe_push (args, from_len);
1759 100 : vec_safe_push (args, to_len);
1760 100 : tmp = build_call_vec (fcn_type, fcn, args);
1761 : /* Build the body of the loop. */
1762 100 : gfc_init_block (&loopbody);
1763 100 : gfc_add_expr_to_block (&loopbody, tmp);
1764 :
1765 : /* Build the loop and return. */
1766 100 : gfc_init_loopinfo (&loop);
1767 100 : loop.dimen = 1;
1768 100 : loop.from[0] = gfc_index_zero_node;
1769 100 : loop.loopvar[0] = index;
1770 100 : loop.to[0] = nelems;
1771 100 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1772 100 : gfc_init_block (&ifbody);
1773 100 : gfc_add_block_to_block (&ifbody, &loop.pre);
1774 100 : extcopy = gfc_finish_block (&ifbody);
1775 :
1776 100 : tmp = fold_build2_loc (input_location, GT_EXPR,
1777 : logical_type_node, from_len,
1778 100 : build_zero_cst (TREE_TYPE (from_len)));
1779 100 : tmp = fold_build3_loc (input_location, COND_EXPR,
1780 : void_type_node, tmp, extcopy, stdcopy);
1781 100 : gfc_add_expr_to_block (&body, tmp);
1782 100 : tmp = gfc_finish_block (&body);
1783 : }
1784 : else
1785 : {
1786 256 : gfc_add_expr_to_block (&body, stdcopy);
1787 256 : tmp = gfc_finish_block (&body);
1788 : }
1789 356 : gfc_cleanup_loop (&loop);
1790 : }
1791 : else
1792 : {
1793 402 : gcc_assert (!is_from_desc);
1794 402 : vec_safe_push (args, from_data);
1795 402 : vec_safe_push (args, to_data);
1796 402 : stdcopy = build_call_vec (fcn_type, fcn, args);
1797 :
1798 : /* In initialization mode from_len is a constant zero. */
1799 402 : if (unlimited && !integer_zerop (from_len))
1800 : {
1801 60 : vec_safe_push (args, from_len);
1802 60 : vec_safe_push (args, to_len);
1803 60 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1804 60 : tmp = fold_build2_loc (input_location, GT_EXPR,
1805 : logical_type_node, from_len,
1806 60 : build_zero_cst (TREE_TYPE (from_len)));
1807 60 : tmp = fold_build3_loc (input_location, COND_EXPR,
1808 : void_type_node, tmp, extcopy, stdcopy);
1809 : }
1810 : else
1811 : tmp = stdcopy;
1812 : }
1813 :
1814 : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1815 758 : if (from == NULL_TREE)
1816 : {
1817 0 : tree cond;
1818 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1819 : logical_type_node,
1820 : from_data, null_pointer_node);
1821 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1822 : void_type_node, cond,
1823 : tmp, build_empty_stmt (input_location));
1824 : }
1825 :
1826 758 : return tmp;
1827 : }
1828 :
1829 :
1830 : static tree
1831 106 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1832 : {
1833 106 : gfc_actual_arglist *actual;
1834 106 : gfc_expr *ppc;
1835 106 : gfc_code *ppc_code;
1836 106 : tree res;
1837 :
1838 106 : actual = gfc_get_actual_arglist ();
1839 106 : actual->expr = gfc_copy_expr (rhs);
1840 106 : actual->next = gfc_get_actual_arglist ();
1841 106 : actual->next->expr = gfc_copy_expr (lhs);
1842 106 : ppc = gfc_copy_expr (obj);
1843 106 : gfc_add_vptr_component (ppc);
1844 106 : gfc_add_component_ref (ppc, "_copy");
1845 106 : ppc_code = gfc_get_code (EXEC_CALL);
1846 106 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1847 : /* Although '_copy' is set to be elemental in class.cc, it is
1848 : not staying that way. Find out why, sometime.... */
1849 106 : ppc_code->resolved_sym->attr.elemental = 1;
1850 106 : ppc_code->ext.actual = actual;
1851 106 : ppc_code->expr1 = ppc;
1852 : /* Since '_copy' is elemental, the scalarizer will take care
1853 : of arrays in gfc_trans_call. */
1854 106 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1855 106 : gfc_free_statements (ppc_code);
1856 :
1857 106 : if (UNLIMITED_POLY(obj))
1858 : {
1859 : /* Check if rhs is non-NULL. */
1860 24 : gfc_se src;
1861 24 : gfc_init_se (&src, NULL);
1862 24 : gfc_conv_expr (&src, rhs);
1863 24 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1864 24 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1865 24 : src.expr, fold_convert (TREE_TYPE (src.expr),
1866 : null_pointer_node));
1867 24 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1868 : build_empty_stmt (input_location));
1869 : }
1870 :
1871 106 : return res;
1872 : }
1873 :
1874 : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1875 : A MEMCPY is needed to copy the full data from the default initializer
1876 : of the dynamic type. */
1877 :
1878 : tree
1879 461 : gfc_trans_class_init_assign (gfc_code *code)
1880 : {
1881 461 : stmtblock_t block;
1882 461 : tree tmp;
1883 461 : bool cmp_flag = true;
1884 461 : gfc_se dst,src,memsz;
1885 461 : gfc_expr *lhs, *rhs, *sz;
1886 461 : gfc_component *cmp;
1887 461 : gfc_symbol *sym;
1888 461 : gfc_ref *ref;
1889 :
1890 461 : gfc_start_block (&block);
1891 :
1892 461 : lhs = gfc_copy_expr (code->expr1);
1893 :
1894 461 : rhs = gfc_copy_expr (code->expr1);
1895 461 : gfc_add_vptr_component (rhs);
1896 :
1897 : /* Make sure that the component backend_decls have been built, which
1898 : will not have happened if the derived types concerned have not
1899 : been referenced. */
1900 461 : gfc_get_derived_type (rhs->ts.u.derived);
1901 461 : gfc_add_def_init_component (rhs);
1902 : /* The _def_init is always scalar. */
1903 461 : rhs->rank = 0;
1904 :
1905 : /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
1906 : default initializer components NULL, use the passed value even though
1907 : F2018(8.5.10) asserts that it should considered to be undefined. This is
1908 : needed for consistency with other brands. */
1909 461 : sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
1910 : : NULL;
1911 461 : if (code->op != EXEC_ALLOCATE
1912 400 : && sym && sym->attr.dummy
1913 400 : && sym->attr.intent == INTENT_OUT)
1914 : {
1915 400 : ref = rhs->ref;
1916 800 : while (ref && ref->next)
1917 : ref = ref->next;
1918 400 : cmp = ref->u.c.component->ts.u.derived->components;
1919 611 : for (; cmp; cmp = cmp->next)
1920 : {
1921 428 : if (cmp->initializer)
1922 : break;
1923 211 : else if (!cmp->next)
1924 146 : cmp_flag = false;
1925 : }
1926 : }
1927 :
1928 461 : if (code->expr1->ts.type == BT_CLASS
1929 438 : && CLASS_DATA (code->expr1)->attr.dimension)
1930 : {
1931 106 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1932 106 : *tmparr = *CLASS_DATA (code->expr1)->as;
1933 : /* Adding the array ref to the class expression results in correct
1934 : indexing to the dynamic type. */
1935 106 : gfc_add_full_array_ref (lhs, tmparr);
1936 106 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1937 106 : }
1938 355 : else if (cmp_flag)
1939 : {
1940 : /* Scalar initialization needs the _data component. */
1941 222 : gfc_add_data_component (lhs);
1942 222 : sz = gfc_copy_expr (code->expr1);
1943 222 : gfc_add_vptr_component (sz);
1944 222 : gfc_add_size_component (sz);
1945 :
1946 222 : gfc_init_se (&dst, NULL);
1947 222 : gfc_init_se (&src, NULL);
1948 222 : gfc_init_se (&memsz, NULL);
1949 222 : gfc_conv_expr (&dst, lhs);
1950 222 : gfc_conv_expr (&src, rhs);
1951 222 : gfc_conv_expr (&memsz, sz);
1952 222 : gfc_add_block_to_block (&block, &src.pre);
1953 222 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1954 :
1955 222 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1956 :
1957 222 : if (UNLIMITED_POLY(code->expr1))
1958 : {
1959 : /* Check if _def_init is non-NULL. */
1960 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1961 : logical_type_node, src.expr,
1962 7 : fold_convert (TREE_TYPE (src.expr),
1963 : null_pointer_node));
1964 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1965 : tmp, build_empty_stmt (input_location));
1966 : }
1967 : }
1968 : else
1969 133 : tmp = build_empty_stmt (input_location);
1970 :
1971 461 : if (code->expr1->symtree->n.sym->attr.dummy
1972 410 : && (code->expr1->symtree->n.sym->attr.optional
1973 404 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1974 : {
1975 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1976 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1977 : present, tmp,
1978 : build_empty_stmt (input_location));
1979 : }
1980 :
1981 461 : gfc_add_expr_to_block (&block, tmp);
1982 461 : gfc_free_expr (lhs);
1983 461 : gfc_free_expr (rhs);
1984 :
1985 461 : return gfc_finish_block (&block);
1986 : }
1987 :
1988 :
1989 : /* Class valued elemental function calls or class array elements arriving
1990 : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1991 : is used to ensure that the rhs dynamic type is assigned to the lhs. */
1992 :
1993 : static bool
1994 788 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1995 : {
1996 788 : tree fcn;
1997 788 : tree rse_expr;
1998 788 : tree class_data;
1999 788 : tree tmp;
2000 788 : tree zero;
2001 788 : tree cond;
2002 788 : tree final_cond;
2003 788 : stmtblock_t inner_block;
2004 788 : bool is_descriptor;
2005 788 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
2006 788 : bool not_lhs_array_type;
2007 :
2008 : /* Temporaries arising from dependencies in assignment get cast as a
2009 : character type of the dynamic size of the rhs. Use the vptr copy
2010 : for this case. */
2011 788 : tmp = TREE_TYPE (lse->expr);
2012 788 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
2013 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
2014 :
2015 : /* Use ordinary assignment if the rhs is not a call expression or
2016 : the lhs is not a class entity or an array(ie. character) type. */
2017 740 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
2018 1061 : && not_lhs_array_type)
2019 : return false;
2020 :
2021 : /* Ordinary assignment can be used if both sides are class expressions
2022 : since the dynamic type is preserved by copying the vptr. This
2023 : should only occur, where temporaries are involved. */
2024 515 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
2025 515 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
2026 : return false;
2027 :
2028 : /* Fix the class expression and the class data of the rhs. */
2029 454 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
2030 454 : || not_call_expr)
2031 : {
2032 454 : tmp = gfc_get_class_from_expr (rse->expr);
2033 454 : if (tmp == NULL_TREE)
2034 : return false;
2035 146 : rse_expr = gfc_evaluate_now (tmp, block);
2036 : }
2037 : else
2038 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
2039 :
2040 146 : class_data = gfc_class_data_get (rse_expr);
2041 :
2042 : /* Check that the rhs data is not null. */
2043 146 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
2044 146 : if (is_descriptor)
2045 146 : class_data = gfc_conv_descriptor_data_get (class_data);
2046 146 : class_data = gfc_evaluate_now (class_data, block);
2047 :
2048 146 : zero = build_int_cst (TREE_TYPE (class_data), 0);
2049 146 : cond = fold_build2_loc (input_location, NE_EXPR,
2050 : logical_type_node,
2051 : class_data, zero);
2052 :
2053 : /* Copy the rhs to the lhs. */
2054 146 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
2055 146 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2056 146 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
2057 146 : tmp = is_descriptor ? tmp : class_data;
2058 146 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
2059 : gfc_build_addr_expr (NULL, lse->expr));
2060 146 : gfc_add_expr_to_block (block, tmp);
2061 :
2062 : /* Only elemental function results need to be finalised and freed. */
2063 146 : if (not_call_expr)
2064 : return true;
2065 :
2066 : /* Finalize the class data if needed. */
2067 0 : gfc_init_block (&inner_block);
2068 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
2069 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
2070 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
2071 : logical_type_node, fcn, zero);
2072 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
2073 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
2074 0 : tmp = build3_v (COND_EXPR, final_cond,
2075 : tmp, build_empty_stmt (input_location));
2076 0 : gfc_add_expr_to_block (&inner_block, tmp);
2077 :
2078 : /* Free the class data. */
2079 0 : tmp = gfc_call_free (class_data);
2080 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2081 : build_empty_stmt (input_location));
2082 0 : gfc_add_expr_to_block (&inner_block, tmp);
2083 :
2084 : /* Finish the inner block and subject it to the condition on the
2085 : class data being non-zero. */
2086 0 : tmp = gfc_finish_block (&inner_block);
2087 0 : tmp = build3_v (COND_EXPR, cond, tmp,
2088 : build_empty_stmt (input_location));
2089 0 : gfc_add_expr_to_block (block, tmp);
2090 :
2091 0 : return true;
2092 : }
2093 :
2094 : /* End of prototype trans-class.c */
2095 :
2096 :
2097 : static void
2098 12743 : realloc_lhs_warning (bt type, bool array, locus *where)
2099 : {
2100 12743 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
2101 25 : gfc_warning (OPT_Wrealloc_lhs,
2102 : "Code for reallocating the allocatable array at %L will "
2103 : "be added", where);
2104 12718 : else if (warn_realloc_lhs_all)
2105 4 : gfc_warning (OPT_Wrealloc_lhs_all,
2106 : "Code for reallocating the allocatable variable at %L "
2107 : "will be added", where);
2108 12743 : }
2109 :
2110 :
2111 : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
2112 : gfc_expr *);
2113 :
2114 : /* Copy the scalarization loop variables. */
2115 :
2116 : static void
2117 1277774 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
2118 : {
2119 1277774 : dest->ss = src->ss;
2120 1277774 : dest->loop = src->loop;
2121 1277774 : }
2122 :
2123 :
2124 : /* Initialize a simple expression holder.
2125 :
2126 : Care must be taken when multiple se are created with the same parent.
2127 : The child se must be kept in sync. The easiest way is to delay creation
2128 : of a child se until after the previous se has been translated. */
2129 :
2130 : void
2131 4638467 : gfc_init_se (gfc_se * se, gfc_se * parent)
2132 : {
2133 4638467 : memset (se, 0, sizeof (gfc_se));
2134 4638467 : gfc_init_block (&se->pre);
2135 4638467 : gfc_init_block (&se->finalblock);
2136 4638467 : gfc_init_block (&se->post);
2137 :
2138 4638467 : se->parent = parent;
2139 :
2140 4638467 : if (parent)
2141 1277774 : gfc_copy_se_loopvars (se, parent);
2142 4638467 : }
2143 :
2144 :
2145 : /* Advances to the next SS in the chain. Use this rather than setting
2146 : se->ss = se->ss->next because all the parents needs to be kept in sync.
2147 : See gfc_init_se. */
2148 :
2149 : void
2150 242427 : gfc_advance_se_ss_chain (gfc_se * se)
2151 : {
2152 242427 : gfc_se *p;
2153 :
2154 242427 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
2155 :
2156 : p = se;
2157 : /* Walk down the parent chain. */
2158 636574 : while (p != NULL)
2159 : {
2160 : /* Simple consistency check. */
2161 394147 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
2162 : || p->parent->ss->nested_ss == p->ss);
2163 :
2164 394147 : p->ss = p->ss->next;
2165 :
2166 394147 : p = p->parent;
2167 : }
2168 242427 : }
2169 :
2170 :
2171 : /* Ensures the result of the expression as either a temporary variable
2172 : or a constant so that it can be used repeatedly. */
2173 :
2174 : void
2175 8110 : gfc_make_safe_expr (gfc_se * se)
2176 : {
2177 8110 : tree var;
2178 :
2179 8110 : if (CONSTANT_CLASS_P (se->expr))
2180 : return;
2181 :
2182 : /* We need a temporary for this result. */
2183 272 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2184 272 : gfc_add_modify (&se->pre, var, se->expr);
2185 272 : se->expr = var;
2186 : }
2187 :
2188 :
2189 : /* Return an expression which determines if a dummy parameter is present.
2190 : Also used for arguments to procedures with multiple entry points. */
2191 :
2192 : tree
2193 11604 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2194 : {
2195 11604 : tree decl, orig_decl, cond;
2196 :
2197 11604 : gcc_assert (sym->attr.dummy);
2198 11604 : orig_decl = decl = gfc_get_symbol_decl (sym);
2199 :
2200 : /* Intrinsic scalars and derived types with VALUE attribute which are passed
2201 : by value use a hidden argument to denote the presence status. */
2202 11604 : if (sym->attr.value && !sym->attr.dimension && sym->ts.type != BT_CLASS)
2203 : {
2204 1052 : char name[GFC_MAX_SYMBOL_LEN + 2];
2205 1052 : tree tree_name;
2206 :
2207 1052 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2208 1052 : name[0] = '.';
2209 1052 : strcpy (&name[1], sym->name);
2210 1052 : tree_name = get_identifier (name);
2211 :
2212 : /* Walk function argument list to find hidden arg. */
2213 1052 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2214 5320 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2215 5320 : if (DECL_NAME (cond) == tree_name
2216 5320 : && DECL_ARTIFICIAL (cond))
2217 : break;
2218 :
2219 1052 : gcc_assert (cond);
2220 1052 : return cond;
2221 : }
2222 :
2223 : /* Assumed-shape arrays use a local variable for the array data;
2224 : the actual PARAM_DECL is in a saved decl. As the local variable
2225 : is NULL, it can be checked instead, unless use_saved_desc is
2226 : requested. */
2227 :
2228 10552 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2229 : {
2230 822 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2231 : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2232 822 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2233 : }
2234 :
2235 10552 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2236 10552 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2237 :
2238 : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2239 : as actual argument to denote absent dummies. For array descriptors,
2240 : we thus also need to check the array descriptor. For BT_CLASS, it
2241 : can also occur for scalars and F2003 due to type->class wrapping and
2242 : class->class wrapping. Note further that BT_CLASS always uses an
2243 : array descriptor for arrays, also for explicit-shape/assumed-size.
2244 : For assumed-rank arrays, no local variable is generated, hence,
2245 : the following also applies with !use_saved_desc. */
2246 :
2247 10552 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2248 7511 : && !sym->attr.allocatable
2249 6299 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2250 2296 : || (sym->ts.type == BT_CLASS
2251 1041 : && !CLASS_DATA (sym)->attr.allocatable
2252 567 : && !CLASS_DATA (sym)->attr.class_pointer))
2253 4210 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2254 6 : || sym->ts.type == BT_CLASS))
2255 : {
2256 4204 : tree tmp;
2257 :
2258 4204 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2259 1495 : || sym->as->type == AS_ASSUMED_RANK
2260 1407 : || sym->attr.codimension))
2261 3336 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2262 : {
2263 1039 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2264 1039 : if (sym->ts.type == BT_CLASS)
2265 171 : tmp = gfc_class_data_get (tmp);
2266 1039 : tmp = gfc_conv_array_data (tmp);
2267 : }
2268 3165 : else if (sym->ts.type == BT_CLASS)
2269 36 : tmp = gfc_class_data_get (decl);
2270 : else
2271 : tmp = NULL_TREE;
2272 :
2273 1075 : if (tmp != NULL_TREE)
2274 : {
2275 1075 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2276 1075 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2277 1075 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2278 : logical_type_node, cond, tmp);
2279 : }
2280 : }
2281 :
2282 : return cond;
2283 : }
2284 :
2285 :
2286 : /* Converts a missing, dummy argument into a null or zero. */
2287 :
2288 : void
2289 844 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2290 : {
2291 844 : tree present;
2292 844 : tree tmp;
2293 :
2294 844 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2295 :
2296 844 : if (kind > 0)
2297 : {
2298 : /* Create a temporary and convert it to the correct type. */
2299 54 : tmp = gfc_get_int_type (kind);
2300 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2301 : se->expr));
2302 :
2303 : /* Test for a NULL value. */
2304 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2305 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2306 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2307 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2308 : }
2309 : else
2310 : {
2311 790 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2312 : present, se->expr,
2313 790 : build_zero_cst (TREE_TYPE (se->expr)));
2314 790 : tmp = gfc_evaluate_now (tmp, &se->pre);
2315 790 : se->expr = tmp;
2316 : }
2317 :
2318 844 : if (ts.type == BT_CHARACTER)
2319 : {
2320 : /* Handle deferred-length dummies that pass the character length by
2321 : reference so that the value can be returned. */
2322 244 : if (ts.deferred && INDIRECT_REF_P (se->string_length))
2323 : {
2324 18 : tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
2325 18 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2326 : present, tmp, null_pointer_node);
2327 18 : tmp = gfc_evaluate_now (tmp, &se->pre);
2328 18 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2329 : }
2330 : else
2331 : {
2332 226 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2333 226 : tmp = fold_build3_loc (input_location, COND_EXPR,
2334 : gfc_charlen_type_node,
2335 : present, se->string_length, tmp);
2336 226 : tmp = gfc_evaluate_now (tmp, &se->pre);
2337 : }
2338 244 : se->string_length = tmp;
2339 : }
2340 844 : return;
2341 : }
2342 :
2343 :
2344 : /* Get the character length of an expression, looking through gfc_refs
2345 : if necessary. */
2346 :
2347 : tree
2348 20153 : gfc_get_expr_charlen (gfc_expr *e)
2349 : {
2350 20153 : gfc_ref *r;
2351 20153 : tree length;
2352 20153 : tree previous = NULL_TREE;
2353 20153 : gfc_se se;
2354 :
2355 20153 : gcc_assert (e->expr_type == EXPR_VARIABLE
2356 : && e->ts.type == BT_CHARACTER);
2357 :
2358 20153 : length = NULL; /* To silence compiler warning. */
2359 :
2360 20153 : if (is_subref_array (e) && e->ts.u.cl->length)
2361 : {
2362 767 : gfc_se tmpse;
2363 767 : gfc_init_se (&tmpse, NULL);
2364 767 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2365 767 : e->ts.u.cl->backend_decl = tmpse.expr;
2366 767 : return tmpse.expr;
2367 : }
2368 :
2369 : /* First candidate: if the variable is of type CHARACTER, the
2370 : expression's length could be the length of the character
2371 : variable. */
2372 19386 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2373 19086 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2374 :
2375 : /* Look through the reference chain for component references. */
2376 38915 : for (r = e->ref; r; r = r->next)
2377 : {
2378 19529 : previous = length;
2379 19529 : switch (r->type)
2380 : {
2381 300 : case REF_COMPONENT:
2382 300 : if (r->u.c.component->ts.type == BT_CHARACTER)
2383 300 : length = r->u.c.component->ts.u.cl->backend_decl;
2384 : break;
2385 :
2386 : case REF_ARRAY:
2387 : /* Do nothing. */
2388 : break;
2389 :
2390 20 : case REF_SUBSTRING:
2391 20 : gfc_init_se (&se, NULL);
2392 20 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2393 20 : length = se.expr;
2394 20 : if (r->u.ss.end)
2395 0 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2396 : else
2397 20 : se.expr = previous;
2398 20 : length = fold_build2_loc (input_location, MINUS_EXPR,
2399 : gfc_charlen_type_node,
2400 : se.expr, length);
2401 20 : length = fold_build2_loc (input_location, PLUS_EXPR,
2402 : gfc_charlen_type_node, length,
2403 : gfc_index_one_node);
2404 20 : break;
2405 :
2406 0 : default:
2407 0 : gcc_unreachable ();
2408 19529 : break;
2409 : }
2410 : }
2411 :
2412 19386 : gcc_assert (length != NULL);
2413 : return length;
2414 : }
2415 :
2416 :
2417 : /* Return for an expression the backend decl of the coarray. */
2418 :
2419 : tree
2420 2052 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2421 : {
2422 2052 : tree caf_decl;
2423 2052 : bool found = false;
2424 2052 : gfc_ref *ref;
2425 :
2426 2052 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2427 :
2428 : /* Not-implemented diagnostic. */
2429 2052 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2430 39 : && UNLIMITED_POLY (expr->symtree->n.sym)
2431 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2432 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2433 : "%L is not supported", &expr->where);
2434 :
2435 4335 : for (ref = expr->ref; ref; ref = ref->next)
2436 2283 : if (ref->type == REF_COMPONENT)
2437 : {
2438 195 : if (ref->u.c.component->ts.type == BT_CLASS
2439 0 : && UNLIMITED_POLY (ref->u.c.component)
2440 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2441 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2442 : "component at %L is not supported", &expr->where);
2443 : }
2444 :
2445 : /* Make sure the backend_decl is present before accessing it. */
2446 2052 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2447 2052 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2448 : : expr->symtree->n.sym->backend_decl;
2449 :
2450 2052 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2451 : {
2452 39 : if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2453 45 : && GFC_DECL_SAVED_DESCRIPTOR (caf_decl))
2454 6 : caf_decl = GFC_DECL_SAVED_DESCRIPTOR (caf_decl);
2455 :
2456 39 : if (expr->ref && expr->ref->type == REF_ARRAY)
2457 : {
2458 28 : caf_decl = gfc_class_data_get (caf_decl);
2459 28 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2460 : return caf_decl;
2461 : }
2462 11 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2463 2 : && GFC_DECL_TOKEN (caf_decl)
2464 13 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2465 : return caf_decl;
2466 :
2467 23 : for (ref = expr->ref; ref; ref = ref->next)
2468 : {
2469 18 : if (ref->type == REF_COMPONENT
2470 9 : && strcmp (ref->u.c.component->name, "_data") != 0)
2471 : {
2472 0 : caf_decl = gfc_class_data_get (caf_decl);
2473 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2474 : return caf_decl;
2475 : break;
2476 : }
2477 18 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2478 : break;
2479 : }
2480 : }
2481 2022 : if (expr->symtree->n.sym->attr.codimension)
2482 : return caf_decl;
2483 :
2484 : /* The following code assumes that the coarray is a component reachable via
2485 : only scalar components/variables; the Fortran standard guarantees this. */
2486 :
2487 46 : for (ref = expr->ref; ref; ref = ref->next)
2488 46 : if (ref->type == REF_COMPONENT)
2489 : {
2490 46 : gfc_component *comp = ref->u.c.component;
2491 :
2492 46 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2493 0 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2494 46 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2495 46 : TREE_TYPE (comp->backend_decl), caf_decl,
2496 : comp->backend_decl, NULL_TREE);
2497 46 : if (comp->ts.type == BT_CLASS)
2498 : {
2499 0 : caf_decl = gfc_class_data_get (caf_decl);
2500 0 : if (CLASS_DATA (comp)->attr.codimension)
2501 : {
2502 : found = true;
2503 : break;
2504 : }
2505 : }
2506 46 : if (comp->attr.codimension)
2507 : {
2508 : found = true;
2509 : break;
2510 : }
2511 : }
2512 46 : gcc_assert (found && caf_decl);
2513 : return caf_decl;
2514 : }
2515 :
2516 :
2517 : /* Obtain the Coarray token - and optionally also the offset. */
2518 :
2519 : void
2520 1923 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2521 : tree se_expr, gfc_expr *expr)
2522 : {
2523 1923 : tree tmp;
2524 :
2525 1923 : gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
2526 :
2527 : /* Coarray token. */
2528 1923 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2529 548 : *token = gfc_conv_descriptor_token (caf_decl);
2530 1373 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2531 1574 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2532 6 : *token = GFC_DECL_TOKEN (caf_decl);
2533 : else
2534 : {
2535 1369 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2536 : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2537 1369 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2538 : }
2539 :
2540 1923 : if (offset == NULL)
2541 : return;
2542 :
2543 : /* Offset between the coarray base address and the address wanted. */
2544 179 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2545 179 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2546 0 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2547 0 : *offset = build_int_cst (gfc_array_index_type, 0);
2548 179 : else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
2549 179 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2550 0 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2551 179 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2552 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2553 : else
2554 179 : *offset = build_int_cst (gfc_array_index_type, 0);
2555 :
2556 179 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2557 179 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2558 : {
2559 0 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2560 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2561 : }
2562 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2563 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2564 : else
2565 : {
2566 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2567 : tmp = se_expr;
2568 : }
2569 :
2570 179 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2571 : *offset, fold_convert (gfc_array_index_type, tmp));
2572 :
2573 179 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2574 0 : && expr->symtree->n.sym->attr.codimension
2575 0 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2576 : {
2577 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2578 0 : gfc_ref *ref = base_expr->ref;
2579 0 : gfc_se base_se;
2580 :
2581 : // Iterate through the refs until the last one.
2582 0 : while (ref->next)
2583 : ref = ref->next;
2584 :
2585 0 : if (ref->type == REF_ARRAY
2586 0 : && ref->u.ar.type != AR_FULL)
2587 : {
2588 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2589 0 : int i;
2590 0 : for (i = 0; i < ranksum; ++i)
2591 : {
2592 0 : ref->u.ar.start[i] = NULL;
2593 0 : ref->u.ar.end[i] = NULL;
2594 : }
2595 0 : ref->u.ar.type = AR_FULL;
2596 : }
2597 0 : gfc_init_se (&base_se, NULL);
2598 0 : if (gfc_caf_attr (base_expr).dimension)
2599 : {
2600 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2601 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2602 : }
2603 : else
2604 : {
2605 0 : gfc_conv_expr (&base_se, base_expr);
2606 0 : tmp = base_se.expr;
2607 : }
2608 :
2609 0 : gfc_free_expr (base_expr);
2610 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2611 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2612 0 : }
2613 179 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2614 0 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2615 179 : else if (INDIRECT_REF_P (caf_decl))
2616 0 : tmp = TREE_OPERAND (caf_decl, 0);
2617 : else
2618 : {
2619 179 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2620 : tmp = caf_decl;
2621 : }
2622 :
2623 179 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2624 : fold_convert (gfc_array_index_type, *offset),
2625 : fold_convert (gfc_array_index_type, tmp));
2626 : }
2627 :
2628 :
2629 : /* Convert the coindex of a coarray into an image index; the result is
2630 : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2631 : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2632 :
2633 : tree
2634 1634 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2635 : {
2636 1634 : gfc_ref *ref;
2637 1634 : tree lbound, ubound, extent, tmp, img_idx;
2638 1634 : gfc_se se;
2639 1634 : int i;
2640 :
2641 1665 : for (ref = e->ref; ref; ref = ref->next)
2642 1665 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2643 : break;
2644 1634 : gcc_assert (ref != NULL);
2645 :
2646 1634 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2647 95 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2648 95 : null_pointer_node);
2649 :
2650 1539 : img_idx = build_zero_cst (gfc_array_index_type);
2651 1539 : extent = build_one_cst (gfc_array_index_type);
2652 1539 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2653 630 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2654 : {
2655 321 : gfc_init_se (&se, NULL);
2656 321 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2657 321 : gfc_add_block_to_block (block, &se.pre);
2658 321 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2659 321 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2660 321 : TREE_TYPE (lbound), se.expr, lbound);
2661 321 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2662 : extent, tmp);
2663 321 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2664 321 : TREE_TYPE (tmp), img_idx, tmp);
2665 321 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2666 : {
2667 12 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2668 12 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2669 12 : extent = fold_build2_loc (input_location, MULT_EXPR,
2670 12 : TREE_TYPE (tmp), extent, tmp);
2671 : }
2672 : }
2673 : else
2674 2476 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2675 : {
2676 1246 : gfc_init_se (&se, NULL);
2677 1246 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2678 1246 : gfc_add_block_to_block (block, &se.pre);
2679 1246 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2680 1246 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2681 1246 : TREE_TYPE (lbound), se.expr, lbound);
2682 1246 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2683 : extent, tmp);
2684 1246 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2685 : img_idx, tmp);
2686 1246 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2687 : {
2688 16 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2689 16 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2690 16 : TREE_TYPE (ubound), ubound, lbound);
2691 16 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2692 16 : tmp, build_one_cst (TREE_TYPE (tmp)));
2693 16 : extent = fold_build2_loc (input_location, MULT_EXPR,
2694 16 : TREE_TYPE (tmp), extent, tmp);
2695 : }
2696 : }
2697 1539 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2698 1539 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2699 1539 : return fold_convert (integer_type_node, img_idx);
2700 : }
2701 :
2702 :
2703 : /* For each character array constructor subexpression without a ts.u.cl->length,
2704 : replace it by its first element (if there aren't any elements, the length
2705 : should already be set to zero). */
2706 :
2707 : static void
2708 110 : flatten_array_ctors_without_strlen (gfc_expr* e)
2709 : {
2710 110 : gfc_actual_arglist* arg;
2711 110 : gfc_constructor* c;
2712 :
2713 110 : if (!e)
2714 : return;
2715 :
2716 110 : switch (e->expr_type)
2717 : {
2718 :
2719 0 : case EXPR_OP:
2720 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2721 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2722 0 : break;
2723 :
2724 0 : case EXPR_COMPCALL:
2725 : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2726 0 : gcc_unreachable ();
2727 :
2728 13 : case EXPR_FUNCTION:
2729 40 : for (arg = e->value.function.actual; arg; arg = arg->next)
2730 27 : flatten_array_ctors_without_strlen (arg->expr);
2731 : break;
2732 :
2733 0 : case EXPR_ARRAY:
2734 :
2735 : /* We've found what we're looking for. */
2736 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2737 : {
2738 0 : gfc_constructor *c;
2739 0 : gfc_expr* new_expr;
2740 :
2741 0 : gcc_assert (e->value.constructor);
2742 :
2743 0 : c = gfc_constructor_first (e->value.constructor);
2744 0 : new_expr = c->expr;
2745 0 : c->expr = NULL;
2746 :
2747 0 : flatten_array_ctors_without_strlen (new_expr);
2748 0 : gfc_replace_expr (e, new_expr);
2749 0 : break;
2750 : }
2751 :
2752 : /* Otherwise, fall through to handle constructor elements. */
2753 0 : gcc_fallthrough ();
2754 0 : case EXPR_STRUCTURE:
2755 0 : for (c = gfc_constructor_first (e->value.constructor);
2756 0 : c; c = gfc_constructor_next (c))
2757 0 : flatten_array_ctors_without_strlen (c->expr);
2758 : break;
2759 :
2760 : default:
2761 : break;
2762 :
2763 : }
2764 : }
2765 :
2766 :
2767 : /* Generate code to initialize a string length variable. Returns the
2768 : value. For array constructors, cl->length might be NULL and in this case,
2769 : the first element of the constructor is needed. expr is the original
2770 : expression so we can access it but can be NULL if this is not needed. */
2771 :
2772 : void
2773 3843 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2774 : {
2775 3843 : gfc_se se;
2776 :
2777 3843 : gfc_init_se (&se, NULL);
2778 :
2779 3843 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2780 1361 : return;
2781 :
2782 : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2783 : "flatten" array constructors by taking their first element; all elements
2784 : should be the same length or a cl->length should be present. */
2785 2575 : if (!cl->length)
2786 : {
2787 176 : gfc_expr* expr_flat;
2788 176 : if (!expr)
2789 : return;
2790 83 : expr_flat = gfc_copy_expr (expr);
2791 83 : flatten_array_ctors_without_strlen (expr_flat);
2792 83 : gfc_resolve_expr (expr_flat);
2793 83 : if (expr_flat->rank)
2794 13 : gfc_conv_expr_descriptor (&se, expr_flat);
2795 : else
2796 70 : gfc_conv_expr (&se, expr_flat);
2797 83 : if (expr_flat->expr_type != EXPR_VARIABLE)
2798 77 : gfc_add_block_to_block (pblock, &se.pre);
2799 83 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2800 83 : gfc_add_block_to_block (pblock, &se.post);
2801 83 : gfc_free_expr (expr_flat);
2802 : }
2803 : else
2804 : {
2805 : /* Convert cl->length. */
2806 2399 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2807 2399 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2808 : gfc_charlen_type_node, se.expr,
2809 2399 : build_zero_cst (TREE_TYPE (se.expr)));
2810 2399 : gfc_add_block_to_block (pblock, &se.pre);
2811 : }
2812 :
2813 2482 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2814 1564 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2815 : else
2816 918 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2817 : }
2818 :
2819 :
2820 : static void
2821 7258 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2822 : const char *name, locus *where)
2823 : {
2824 7258 : tree tmp;
2825 7258 : tree type;
2826 7258 : tree fault;
2827 7258 : gfc_se start;
2828 7258 : gfc_se end;
2829 7258 : char *msg;
2830 7258 : mpz_t length;
2831 :
2832 7258 : type = gfc_get_character_type (kind, ref->u.ss.length);
2833 7258 : type = build_pointer_type (type);
2834 :
2835 7258 : gfc_init_se (&start, se);
2836 7258 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2837 7258 : gfc_add_block_to_block (&se->pre, &start.pre);
2838 :
2839 7258 : if (integer_onep (start.expr))
2840 2732 : gfc_conv_string_parameter (se);
2841 : else
2842 : {
2843 4526 : tmp = start.expr;
2844 4526 : STRIP_NOPS (tmp);
2845 : /* Avoid multiple evaluation of substring start. */
2846 4526 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2847 1697 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2848 :
2849 : /* Change the start of the string. */
2850 4526 : if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2851 1194 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2852 3452 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2853 5600 : || (POINTER_TYPE_P (TREE_TYPE (se->expr))
2854 1074 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE))
2855 : tmp = se->expr;
2856 : else
2857 1066 : tmp = build_fold_indirect_ref_loc (input_location,
2858 : se->expr);
2859 : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2860 4526 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2861 : {
2862 4398 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2863 4398 : se->expr = gfc_build_addr_expr (type, tmp);
2864 : }
2865 128 : else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
2866 : {
2867 8 : tree diff;
2868 8 : diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr,
2869 : build_one_cst (gfc_charlen_type_node));
2870 8 : diff = fold_convert (size_type_node, diff);
2871 8 : se->expr
2872 8 : = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff);
2873 : }
2874 : }
2875 :
2876 : /* Length = end + 1 - start. */
2877 7258 : gfc_init_se (&end, se);
2878 7258 : if (ref->u.ss.end == NULL)
2879 202 : end.expr = se->string_length;
2880 : else
2881 : {
2882 7056 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2883 7056 : gfc_add_block_to_block (&se->pre, &end.pre);
2884 : }
2885 7258 : tmp = end.expr;
2886 7258 : STRIP_NOPS (tmp);
2887 7258 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2888 2301 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2889 :
2890 7258 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2891 474 : && !gfc_contains_implied_index_p (ref->u.ss.start)
2892 7713 : && !gfc_contains_implied_index_p (ref->u.ss.end))
2893 : {
2894 455 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2895 : logical_type_node, start.expr,
2896 : end.expr);
2897 :
2898 : /* Check lower bound. */
2899 455 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2900 : start.expr,
2901 455 : build_one_cst (TREE_TYPE (start.expr)));
2902 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2903 : logical_type_node, nonempty, fault);
2904 455 : if (name)
2905 454 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2906 : "is less than one", name);
2907 : else
2908 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2909 : "is less than one");
2910 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2911 : fold_convert (long_integer_type_node,
2912 : start.expr));
2913 455 : free (msg);
2914 :
2915 : /* Check upper bound. */
2916 455 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2917 : end.expr, se->string_length);
2918 455 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2919 : logical_type_node, nonempty, fault);
2920 455 : if (name)
2921 454 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2922 : "exceeds string length (%%ld)", name);
2923 : else
2924 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2925 : "exceeds string length (%%ld)");
2926 455 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2927 : fold_convert (long_integer_type_node, end.expr),
2928 : fold_convert (long_integer_type_node,
2929 : se->string_length));
2930 455 : free (msg);
2931 : }
2932 :
2933 : /* Try to calculate the length from the start and end expressions. */
2934 7258 : if (ref->u.ss.end
2935 7258 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2936 : {
2937 6039 : HOST_WIDE_INT i_len;
2938 :
2939 6039 : i_len = gfc_mpz_get_hwi (length) + 1;
2940 6039 : if (i_len < 0)
2941 : i_len = 0;
2942 :
2943 6039 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2944 6039 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2945 : }
2946 : else
2947 : {
2948 1219 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2949 : fold_convert (gfc_charlen_type_node, end.expr),
2950 : fold_convert (gfc_charlen_type_node, start.expr));
2951 1219 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2952 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2953 1219 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2954 : tmp, build_int_cst (gfc_charlen_type_node, 0));
2955 : }
2956 :
2957 7258 : se->string_length = tmp;
2958 7258 : }
2959 :
2960 :
2961 : /* Convert a derived type component reference. */
2962 :
2963 : void
2964 176191 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2965 : {
2966 176191 : gfc_component *c;
2967 176191 : tree tmp;
2968 176191 : tree decl;
2969 176191 : tree field;
2970 176191 : tree context;
2971 :
2972 176191 : c = ref->u.c.component;
2973 :
2974 176191 : if (c->backend_decl == NULL_TREE
2975 6 : && ref->u.c.sym != NULL)
2976 6 : gfc_get_derived_type (ref->u.c.sym);
2977 :
2978 176191 : field = c->backend_decl;
2979 176191 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2980 176191 : decl = se->expr;
2981 176191 : context = DECL_FIELD_CONTEXT (field);
2982 :
2983 : /* Components can correspond to fields of different containing
2984 : types, as components are created without context, whereas
2985 : a concrete use of a component has the type of decl as context.
2986 : So, if the type doesn't match, we search the corresponding
2987 : FIELD_DECL in the parent type. To not waste too much time
2988 : we cache this result in norestrict_decl.
2989 : On the other hand, if the context is a UNION or a MAP (a
2990 : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2991 :
2992 176191 : if (context != TREE_TYPE (decl)
2993 176191 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2994 12159 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2995 : {
2996 12159 : tree f2 = c->norestrict_decl;
2997 20633 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2998 7304 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2999 7304 : if (TREE_CODE (f2) == FIELD_DECL
3000 7304 : && DECL_NAME (f2) == DECL_NAME (field))
3001 : break;
3002 12159 : gcc_assert (f2);
3003 12159 : c->norestrict_decl = f2;
3004 12159 : field = f2;
3005 : }
3006 :
3007 176191 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
3008 0 : && strcmp ("_data", c->name) == 0)
3009 : {
3010 : /* Found a ref to the _data component. Store the associated ref to
3011 : the vptr in se->class_vptr. */
3012 0 : se->class_vptr = gfc_class_vptr_get (decl);
3013 : }
3014 : else
3015 176191 : se->class_vptr = NULL_TREE;
3016 :
3017 176191 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
3018 : decl, field, NULL_TREE);
3019 :
3020 176191 : se->expr = tmp;
3021 :
3022 : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
3023 : strlen () conditional below. */
3024 176191 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
3025 8772 : && !c->ts.deferred
3026 5632 : && !c->attr.pdt_string)
3027 : {
3028 5458 : tmp = c->ts.u.cl->backend_decl;
3029 : /* Components must always be constant length. */
3030 5458 : gcc_assert (tmp && INTEGER_CST_P (tmp));
3031 5458 : se->string_length = tmp;
3032 : }
3033 :
3034 176191 : if (gfc_deferred_strlen (c, &field))
3035 : {
3036 3314 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
3037 3314 : TREE_TYPE (field),
3038 : decl, field, NULL_TREE);
3039 3314 : se->string_length = tmp;
3040 : }
3041 :
3042 176191 : if (((c->attr.pointer || c->attr.allocatable)
3043 103206 : && (!c->attr.dimension && !c->attr.codimension)
3044 55569 : && c->ts.type != BT_CHARACTER)
3045 122827 : || c->attr.proc_pointer)
3046 59644 : se->expr = build_fold_indirect_ref_loc (input_location,
3047 : se->expr);
3048 176191 : }
3049 :
3050 :
3051 : /* This function deals with component references to components of the
3052 : parent type for derived type extensions. */
3053 : void
3054 63971 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
3055 : {
3056 63971 : gfc_component *c;
3057 63971 : gfc_component *cmp;
3058 63971 : gfc_symbol *dt;
3059 63971 : gfc_ref parent;
3060 :
3061 63971 : dt = ref->u.c.sym;
3062 63971 : c = ref->u.c.component;
3063 :
3064 : /* Return if the component is in this type, i.e. not in the parent type. */
3065 110168 : for (cmp = dt->components; cmp; cmp = cmp->next)
3066 99718 : if (c == cmp)
3067 53521 : return;
3068 :
3069 : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
3070 10450 : parent.type = REF_COMPONENT;
3071 10450 : parent.next = NULL;
3072 10450 : parent.u.c.sym = dt;
3073 10450 : parent.u.c.component = dt->components;
3074 :
3075 10450 : if (dt->backend_decl == NULL)
3076 0 : gfc_get_derived_type (dt);
3077 :
3078 : /* Build the reference and call self. */
3079 10450 : gfc_conv_component_ref (se, &parent);
3080 10450 : parent.u.c.sym = dt->components->ts.u.derived;
3081 10450 : parent.u.c.component = c;
3082 10450 : conv_parent_component_references (se, &parent);
3083 : }
3084 :
3085 :
3086 : static void
3087 549 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
3088 : {
3089 549 : tree res = se->expr;
3090 :
3091 549 : switch (ref->u.i)
3092 : {
3093 265 : case INQUIRY_RE:
3094 530 : res = fold_build1_loc (input_location, REALPART_EXPR,
3095 265 : TREE_TYPE (TREE_TYPE (res)), res);
3096 265 : break;
3097 :
3098 239 : case INQUIRY_IM:
3099 478 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
3100 239 : TREE_TYPE (TREE_TYPE (res)), res);
3101 239 : break;
3102 :
3103 7 : case INQUIRY_KIND:
3104 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
3105 7 : ts->kind);
3106 7 : se->string_length = NULL_TREE;
3107 7 : break;
3108 :
3109 38 : case INQUIRY_LEN:
3110 38 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
3111 : se->string_length);
3112 38 : se->string_length = NULL_TREE;
3113 38 : break;
3114 :
3115 0 : default:
3116 0 : gcc_unreachable ();
3117 : }
3118 549 : se->expr = res;
3119 549 : }
3120 :
3121 : /* Dereference VAR where needed if it is a pointer, reference, etc.
3122 : according to Fortran semantics. */
3123 :
3124 : tree
3125 1446647 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
3126 : bool is_classarray)
3127 : {
3128 1446647 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
3129 : return var;
3130 291730 : if (is_CFI_desc (sym, NULL))
3131 11892 : return build_fold_indirect_ref_loc (input_location, var);
3132 :
3133 : /* Characters are entirely different from other types, they are treated
3134 : separately. */
3135 279838 : if (sym->ts.type == BT_CHARACTER)
3136 : {
3137 : /* Dereference character pointer dummy arguments
3138 : or results. */
3139 32765 : if ((sym->attr.pointer || sym->attr.allocatable
3140 18899 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3141 14202 : && (sym->attr.dummy
3142 10886 : || sym->attr.function
3143 10512 : || sym->attr.result))
3144 4357 : var = build_fold_indirect_ref_loc (input_location, var);
3145 : }
3146 247073 : else if (!sym->attr.value)
3147 : {
3148 : /* Dereference temporaries for class array dummy arguments. */
3149 170448 : if (sym->attr.dummy && is_classarray
3150 253884 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
3151 : {
3152 5313 : if (!descriptor_only_p)
3153 2704 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
3154 :
3155 5313 : var = build_fold_indirect_ref_loc (input_location, var);
3156 : }
3157 :
3158 : /* Dereference non-character scalar dummy arguments. */
3159 246269 : if (sym->attr.dummy && !sym->attr.dimension
3160 103855 : && !(sym->attr.codimension && sym->attr.allocatable)
3161 103789 : && (sym->ts.type != BT_CLASS
3162 19429 : || (!CLASS_DATA (sym)->attr.dimension
3163 11344 : && !(CLASS_DATA (sym)->attr.codimension
3164 283 : && CLASS_DATA (sym)->attr.allocatable))))
3165 95563 : var = build_fold_indirect_ref_loc (input_location, var);
3166 :
3167 : /* Dereference scalar hidden result. */
3168 246269 : if (flag_f2c && sym->ts.type == BT_COMPLEX
3169 286 : && (sym->attr.function || sym->attr.result)
3170 108 : && !sym->attr.dimension && !sym->attr.pointer
3171 60 : && !sym->attr.always_explicit)
3172 36 : var = build_fold_indirect_ref_loc (input_location, var);
3173 :
3174 : /* Dereference non-character, non-class pointer variables.
3175 : These must be dummies, results, or scalars. */
3176 246269 : if (!is_classarray
3177 238211 : && (sym->attr.pointer || sym->attr.allocatable
3178 189581 : || gfc_is_associate_pointer (sym)
3179 184898 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
3180 321736 : && (sym->attr.dummy
3181 35471 : || sym->attr.function
3182 34541 : || sym->attr.result
3183 33447 : || (!sym->attr.dimension
3184 33442 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3185 75462 : var = build_fold_indirect_ref_loc (input_location, var);
3186 : /* Now treat the class array pointer variables accordingly. */
3187 170807 : else if (sym->ts.type == BT_CLASS
3188 19872 : && sym->attr.dummy
3189 19429 : && (CLASS_DATA (sym)->attr.dimension
3190 11344 : || CLASS_DATA (sym)->attr.codimension)
3191 8368 : && ((CLASS_DATA (sym)->as
3192 8368 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3193 7371 : || CLASS_DATA (sym)->attr.allocatable
3194 6046 : || CLASS_DATA (sym)->attr.class_pointer))
3195 2913 : var = build_fold_indirect_ref_loc (input_location, var);
3196 : /* And the case where a non-dummy, non-result, non-function,
3197 : non-allocable and non-pointer classarray is present. This case was
3198 : previously covered by the first if, but with introducing the
3199 : condition !is_classarray there, that case has to be covered
3200 : explicitly. */
3201 167894 : else if (sym->ts.type == BT_CLASS
3202 16959 : && !sym->attr.dummy
3203 443 : && !sym->attr.function
3204 443 : && !sym->attr.result
3205 443 : && (CLASS_DATA (sym)->attr.dimension
3206 4 : || CLASS_DATA (sym)->attr.codimension)
3207 443 : && (sym->assoc
3208 0 : || !CLASS_DATA (sym)->attr.allocatable)
3209 443 : && !CLASS_DATA (sym)->attr.class_pointer)
3210 443 : var = build_fold_indirect_ref_loc (input_location, var);
3211 : }
3212 :
3213 : return var;
3214 : }
3215 :
3216 : /* Return the contents of a variable. Also handles reference/pointer
3217 : variables (all Fortran pointer references are implicit). */
3218 :
3219 : static void
3220 1599945 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3221 : {
3222 1599945 : gfc_ss *ss;
3223 1599945 : gfc_ref *ref;
3224 1599945 : gfc_symbol *sym;
3225 1599945 : tree parent_decl = NULL_TREE;
3226 1599945 : int parent_flag;
3227 1599945 : bool return_value;
3228 1599945 : bool alternate_entry;
3229 1599945 : bool entry_master;
3230 1599945 : bool is_classarray;
3231 1599945 : bool first_time = true;
3232 :
3233 1599945 : sym = expr->symtree->n.sym;
3234 1599945 : is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
3235 1599945 : ss = se->ss;
3236 1599945 : if (ss != NULL)
3237 : {
3238 132731 : gfc_ss_info *ss_info = ss->info;
3239 :
3240 : /* Check that something hasn't gone horribly wrong. */
3241 132731 : gcc_assert (ss != gfc_ss_terminator);
3242 132731 : gcc_assert (ss_info->expr == expr);
3243 :
3244 : /* A scalarized term. We already know the descriptor. */
3245 132731 : se->expr = ss_info->data.array.descriptor;
3246 132731 : se->string_length = ss_info->string_length;
3247 132731 : ref = ss_info->data.array.ref;
3248 132731 : if (ref)
3249 132377 : gcc_assert (ref->type == REF_ARRAY
3250 : && ref->u.ar.type != AR_ELEMENT);
3251 : else
3252 354 : gfc_conv_tmp_array_ref (se);
3253 : }
3254 : else
3255 : {
3256 1467214 : tree se_expr = NULL_TREE;
3257 :
3258 1467214 : se->expr = gfc_get_symbol_decl (sym);
3259 :
3260 : /* Deal with references to a parent results or entries by storing
3261 : the current_function_decl and moving to the parent_decl. */
3262 1467214 : return_value = sym->attr.function && sym->result == sym;
3263 18955 : alternate_entry = sym->attr.function && sym->attr.entry
3264 1468353 : && sym->result == sym;
3265 2934428 : entry_master = sym->attr.result
3266 14326 : && sym->ns->proc_name->attr.entry_master
3267 1467595 : && !gfc_return_by_reference (sym->ns->proc_name);
3268 1467214 : if (current_function_decl)
3269 1446879 : parent_decl = DECL_CONTEXT (current_function_decl);
3270 :
3271 1467214 : if ((se->expr == parent_decl && return_value)
3272 1467103 : || (sym->ns && sym->ns->proc_name
3273 1462175 : && parent_decl
3274 1441840 : && sym->ns->proc_name->backend_decl == parent_decl
3275 37759 : && (alternate_entry || entry_master)))
3276 : parent_flag = 1;
3277 : else
3278 1467070 : parent_flag = 0;
3279 :
3280 : /* Special case for assigning the return value of a function.
3281 : Self recursive functions must have an explicit return value. */
3282 1467214 : if (return_value && (se->expr == current_function_decl || parent_flag))
3283 10252 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3284 :
3285 : /* Similarly for alternate entry points. */
3286 1456962 : else if (alternate_entry
3287 1106 : && (sym->ns->proc_name->backend_decl == current_function_decl
3288 0 : || parent_flag))
3289 : {
3290 1106 : gfc_entry_list *el = NULL;
3291 :
3292 1705 : for (el = sym->ns->entries; el; el = el->next)
3293 1705 : if (sym == el->sym)
3294 : {
3295 1106 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3296 1106 : break;
3297 : }
3298 : }
3299 :
3300 1455856 : else if (entry_master
3301 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3302 0 : || parent_flag))
3303 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3304 :
3305 11653 : if (se_expr)
3306 11653 : se->expr = se_expr;
3307 :
3308 : /* Procedure actual arguments. Look out for temporary variables
3309 : with the same attributes as function values. */
3310 1455561 : else if (!sym->attr.temporary
3311 1455493 : && sym->attr.flavor == FL_PROCEDURE
3312 22678 : && se->expr != current_function_decl)
3313 : {
3314 22611 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3315 : {
3316 20911 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3317 20911 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3318 : }
3319 22611 : return;
3320 : }
3321 :
3322 1444603 : if (sym->ts.type == BT_CLASS
3323 72228 : && sym->attr.class_ok
3324 71986 : && sym->ts.u.derived->attr.is_class)
3325 : {
3326 27979 : if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
3327 79454 : && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
3328 5455 : se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
3329 : else
3330 66531 : se->class_container = se->expr;
3331 : }
3332 :
3333 : /* Dereference the expression, where needed. */
3334 1444603 : if (se->class_container && CLASS_DATA (sym)->attr.codimension
3335 2042 : && !CLASS_DATA (sym)->attr.dimension)
3336 877 : se->expr
3337 877 : = gfc_maybe_dereference_var (sym, se->class_container,
3338 877 : se->descriptor_only, is_classarray);
3339 : else
3340 1443726 : se->expr
3341 1443726 : = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3342 : is_classarray);
3343 :
3344 1444603 : ref = expr->ref;
3345 : }
3346 :
3347 : /* For character variables, also get the length. */
3348 1577334 : if (sym->ts.type == BT_CHARACTER)
3349 : {
3350 : /* If the character length of an entry isn't set, get the length from
3351 : the master function instead. */
3352 165865 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3353 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3354 : else
3355 165865 : se->string_length = sym->ts.u.cl->backend_decl;
3356 165865 : gcc_assert (se->string_length);
3357 :
3358 : /* For coarray strings return the pointer to the data and not the
3359 : descriptor. */
3360 5143 : if (sym->attr.codimension && sym->attr.associate_var
3361 6 : && !se->descriptor_only
3362 165871 : && TREE_CODE (TREE_TYPE (se->expr)) != ARRAY_TYPE)
3363 6 : se->expr = gfc_conv_descriptor_data_get (se->expr);
3364 : }
3365 :
3366 : /* F202Y: Runtime warning that an assumed rank object is associated
3367 : with an assumed size object. */
3368 1577334 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3369 90726 : && (gfc_option.allow_std & GFC_STD_F202Y)
3370 1577568 : && expr->rank == -1 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
3371 : {
3372 60 : tree dim, lower, upper, cond;
3373 60 : char *msg;
3374 :
3375 60 : dim = fold_convert (signed_char_type_node,
3376 : gfc_conv_descriptor_rank (se->expr));
3377 60 : dim = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
3378 : dim, build_int_cst (signed_char_type_node, 1));
3379 60 : lower = gfc_conv_descriptor_lbound_get (se->expr, dim);
3380 60 : upper = gfc_conv_descriptor_ubound_get (se->expr, dim);
3381 :
3382 60 : msg = xasprintf ("Assumed rank object %s is associated with an "
3383 : "assumed size object", sym->name);
3384 60 : cond = fold_build2_loc (input_location, LT_EXPR,
3385 : logical_type_node, upper, lower);
3386 60 : gfc_trans_runtime_check (false, true, cond, &se->pre,
3387 : &gfc_current_locus, msg);
3388 60 : free (msg);
3389 : }
3390 :
3391 : /* Some expressions leak through that haven't been fixed up. */
3392 1577334 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3393 416 : gfc_fixup_inferred_type_refs (expr);
3394 :
3395 1577334 : gfc_typespec *ts = &sym->ts;
3396 2010389 : while (ref)
3397 : {
3398 781401 : switch (ref->type)
3399 : {
3400 608287 : case REF_ARRAY:
3401 : /* Return the descriptor if that's what we want and this is an array
3402 : section reference. */
3403 608287 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3404 : return;
3405 : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3406 : /* Return the descriptor for array pointers and allocations. */
3407 269266 : if (se->want_pointer
3408 23934 : && ref->next == NULL && (se->descriptor_only))
3409 : return;
3410 :
3411 259941 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3412 : /* Return a pointer to an element. */
3413 259941 : break;
3414 :
3415 165565 : case REF_COMPONENT:
3416 165565 : ts = &ref->u.c.component->ts;
3417 165565 : if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
3418 5757 : && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
3419 3076 : && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
3420 3076 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3421 2609 : && strcmp ("_data", ref->u.c.component->name) == 0)
3422 : /* Skip the first ref of a _data component, because for class
3423 : arrays that one is already done by introducing a temporary
3424 : array descriptor. */
3425 : break;
3426 :
3427 162956 : if (ref->u.c.sym->attr.extension)
3428 53430 : conv_parent_component_references (se, ref);
3429 :
3430 162956 : gfc_conv_component_ref (se, ref);
3431 :
3432 162956 : if (ref->u.c.component->ts.type == BT_CLASS
3433 11801 : && ref->u.c.component->attr.class_ok
3434 11801 : && ref->u.c.component->ts.u.derived->attr.is_class)
3435 11801 : se->class_container = se->expr;
3436 151155 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3437 148661 : && ref->u.c.sym->attr.is_class))
3438 83528 : se->class_container = NULL_TREE;
3439 :
3440 162956 : if (!ref->next && ref->u.c.sym->attr.codimension
3441 0 : && se->want_pointer && se->descriptor_only)
3442 : return;
3443 :
3444 : break;
3445 :
3446 7000 : case REF_SUBSTRING:
3447 7000 : gfc_conv_substring (se, ref, expr->ts.kind,
3448 7000 : expr->symtree->name, &expr->where);
3449 7000 : break;
3450 :
3451 549 : case REF_INQUIRY:
3452 549 : conv_inquiry (se, ref, expr, ts);
3453 549 : break;
3454 :
3455 0 : default:
3456 0 : gcc_unreachable ();
3457 433055 : break;
3458 : }
3459 433055 : first_time = false;
3460 433055 : ref = ref->next;
3461 : }
3462 : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3463 : separately. */
3464 1228988 : if (se->want_pointer)
3465 : {
3466 133796 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3467 8020 : gfc_conv_string_parameter (se);
3468 : else
3469 125776 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3470 : }
3471 : }
3472 :
3473 :
3474 : /* Unary ops are easy... Or they would be if ! was a valid op. */
3475 :
3476 : static void
3477 28840 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3478 : {
3479 28840 : gfc_se operand;
3480 28840 : tree type;
3481 :
3482 28840 : gcc_assert (expr->ts.type != BT_CHARACTER);
3483 : /* Initialize the operand. */
3484 28840 : gfc_init_se (&operand, se);
3485 28840 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3486 28840 : gfc_add_block_to_block (&se->pre, &operand.pre);
3487 :
3488 28840 : type = gfc_typenode_for_spec (&expr->ts);
3489 :
3490 : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3491 : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3492 : All other unary operators have an equivalent GIMPLE unary operator. */
3493 28840 : if (code == TRUTH_NOT_EXPR)
3494 20237 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3495 : build_int_cst (type, 0));
3496 : else
3497 8603 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3498 :
3499 28840 : }
3500 :
3501 : /* Expand power operator to optimal multiplications when a value is raised
3502 : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3503 : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3504 : Programming", 3rd Edition, 1998. */
3505 :
3506 : /* This code is mostly duplicated from expand_powi in the backend.
3507 : We establish the "optimal power tree" lookup table with the defined size.
3508 : The items in the table are the exponents used to calculate the index
3509 : exponents. Any integer n less than the value can get an "addition chain",
3510 : with the first node being one. */
3511 : #define POWI_TABLE_SIZE 256
3512 :
3513 : /* The table is from builtins.cc. */
3514 : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3515 : {
3516 : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3517 : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3518 : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3519 : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3520 : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3521 : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3522 : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3523 : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3524 : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3525 : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3526 : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3527 : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3528 : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3529 : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3530 : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3531 : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3532 : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3533 : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3534 : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3535 : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3536 : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3537 : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3538 : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3539 : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3540 : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3541 : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3542 : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3543 : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3544 : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3545 : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3546 : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3547 : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3548 : };
3549 :
3550 : /* If n is larger than lookup table's max index, we use the "window
3551 : method". */
3552 : #define POWI_WINDOW_SIZE 3
3553 :
3554 : /* Recursive function to expand the power operator. The temporary
3555 : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3556 : static tree
3557 178323 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3558 : {
3559 178323 : tree op0;
3560 178323 : tree op1;
3561 178323 : tree tmp;
3562 178323 : int digit;
3563 :
3564 178323 : if (n < POWI_TABLE_SIZE)
3565 : {
3566 137336 : if (tmpvar[n])
3567 : return tmpvar[n];
3568 :
3569 56612 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3570 56612 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3571 : }
3572 40987 : else if (n & 1)
3573 : {
3574 10015 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3575 10015 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3576 10015 : op1 = gfc_conv_powi (se, digit, tmpvar);
3577 : }
3578 : else
3579 : {
3580 30972 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3581 30972 : op1 = op0;
3582 : }
3583 :
3584 97599 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3585 97599 : tmp = gfc_evaluate_now (tmp, &se->pre);
3586 :
3587 97599 : if (n < POWI_TABLE_SIZE)
3588 56612 : tmpvar[n] = tmp;
3589 :
3590 : return tmp;
3591 : }
3592 :
3593 :
3594 : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3595 : return 1. Else return 0 and a call to runtime library functions
3596 : will have to be built. */
3597 : static int
3598 3305 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3599 : {
3600 3305 : tree cond;
3601 3305 : tree tmp;
3602 3305 : tree type;
3603 3305 : tree vartmp[POWI_TABLE_SIZE];
3604 3305 : HOST_WIDE_INT m;
3605 3305 : unsigned HOST_WIDE_INT n;
3606 3305 : int sgn;
3607 3305 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3608 :
3609 : /* If exponent is too large, we won't expand it anyway, so don't bother
3610 : with large integer values. */
3611 3305 : if (!wi::fits_shwi_p (wrhs))
3612 : return 0;
3613 :
3614 2945 : m = wrhs.to_shwi ();
3615 : /* Use the wide_int's routine to reliably get the absolute value on all
3616 : platforms. Then convert it to a HOST_WIDE_INT like above. */
3617 2945 : n = wi::abs (wrhs).to_shwi ();
3618 :
3619 2945 : type = TREE_TYPE (lhs);
3620 2945 : sgn = tree_int_cst_sgn (rhs);
3621 :
3622 2945 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3623 5890 : || optimize_size) && (m > 2 || m < -1))
3624 : return 0;
3625 :
3626 : /* rhs == 0 */
3627 1639 : if (sgn == 0)
3628 : {
3629 282 : se->expr = gfc_build_const (type, integer_one_node);
3630 282 : return 1;
3631 : }
3632 :
3633 : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3634 1357 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3635 : {
3636 220 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3637 220 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3638 220 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3639 220 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3640 :
3641 : /* If rhs is even,
3642 : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3643 220 : if ((n & 1) == 0)
3644 : {
3645 104 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3646 : logical_type_node, tmp, cond);
3647 104 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3648 : tmp, build_int_cst (type, 1),
3649 : build_int_cst (type, 0));
3650 104 : return 1;
3651 : }
3652 : /* If rhs is odd,
3653 : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3654 116 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3655 : build_int_cst (type, -1),
3656 : build_int_cst (type, 0));
3657 116 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3658 : cond, build_int_cst (type, 1), tmp);
3659 116 : return 1;
3660 : }
3661 :
3662 1137 : memset (vartmp, 0, sizeof (vartmp));
3663 1137 : vartmp[1] = lhs;
3664 1137 : if (sgn == -1)
3665 : {
3666 141 : tmp = gfc_build_const (type, integer_one_node);
3667 141 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3668 : vartmp[1]);
3669 : }
3670 :
3671 1137 : se->expr = gfc_conv_powi (se, n, vartmp);
3672 :
3673 1137 : return 1;
3674 : }
3675 :
3676 : /* Convert lhs**rhs, for constant rhs, when both are unsigned.
3677 : Method:
3678 : if (rhs == 0) ! Checked here.
3679 : return 1;
3680 : if (lhs & 1 == 1) ! odd_cnd
3681 : {
3682 : if (bit_size(rhs) < bit_size(lhs)) ! Checked here.
3683 : return lhs ** rhs;
3684 :
3685 : mask = 1 << (bit_size(a) - 1) / 2;
3686 : return lhs ** (n & rhs);
3687 : }
3688 : if (rhs > bit_size(lhs)) ! Checked here.
3689 : return 0;
3690 :
3691 : return lhs ** rhs;
3692 : */
3693 :
3694 : static int
3695 15120 : gfc_conv_cst_uint_power (gfc_se * se, tree lhs, tree rhs)
3696 : {
3697 15120 : tree type = TREE_TYPE (lhs);
3698 15120 : tree tmp, is_odd, odd_branch, even_branch;
3699 15120 : unsigned HOST_WIDE_INT lhs_prec, rhs_prec;
3700 15120 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3701 15120 : unsigned HOST_WIDE_INT n, n_odd;
3702 15120 : tree vartmp_odd[POWI_TABLE_SIZE], vartmp_even[POWI_TABLE_SIZE];
3703 :
3704 : /* Anything ** 0 is one. */
3705 15120 : if (integer_zerop (rhs))
3706 : {
3707 1800 : se->expr = build_int_cst (type, 1);
3708 1800 : return 1;
3709 : }
3710 :
3711 13320 : if (!wi::fits_uhwi_p (wrhs))
3712 : return 0;
3713 :
3714 12960 : n = wrhs.to_uhwi ();
3715 :
3716 : /* tmp = a & 1; . */
3717 12960 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3718 : lhs, build_int_cst (type, 1));
3719 12960 : is_odd = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3720 : tmp, build_int_cst (type, 1));
3721 :
3722 12960 : lhs_prec = TYPE_PRECISION (type);
3723 12960 : rhs_prec = TYPE_PRECISION (TREE_TYPE (rhs));
3724 :
3725 12960 : if (rhs_prec >= lhs_prec && lhs_prec <= HOST_BITS_PER_WIDE_INT)
3726 : {
3727 7044 : unsigned HOST_WIDE_INT mask = (HOST_WIDE_INT_1U << (lhs_prec - 1)) - 1;
3728 7044 : n_odd = n & mask;
3729 : }
3730 : else
3731 : n_odd = n;
3732 :
3733 12960 : memset (vartmp_odd, 0, sizeof (vartmp_odd));
3734 12960 : vartmp_odd[0] = build_int_cst (type, 1);
3735 12960 : vartmp_odd[1] = lhs;
3736 12960 : odd_branch = gfc_conv_powi (se, n_odd, vartmp_odd);
3737 12960 : even_branch = NULL_TREE;
3738 :
3739 12960 : if (n > lhs_prec)
3740 4260 : even_branch = build_int_cst (type, 0);
3741 : else
3742 : {
3743 8700 : if (n_odd != n)
3744 : {
3745 0 : memset (vartmp_even, 0, sizeof (vartmp_even));
3746 0 : vartmp_even[0] = build_int_cst (type, 1);
3747 0 : vartmp_even[1] = lhs;
3748 0 : even_branch = gfc_conv_powi (se, n, vartmp_even);
3749 : }
3750 : }
3751 4260 : if (even_branch != NULL_TREE)
3752 4260 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, is_odd,
3753 : odd_branch, even_branch);
3754 : else
3755 8700 : se->expr = odd_branch;
3756 :
3757 : return 1;
3758 : }
3759 :
3760 : /* Power op (**). Constant integer exponent and powers of 2 have special
3761 : handling. */
3762 :
3763 : static void
3764 49129 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3765 : {
3766 49129 : tree gfc_int4_type_node;
3767 49129 : int kind;
3768 49129 : int ikind;
3769 49129 : int res_ikind_1, res_ikind_2;
3770 49129 : gfc_se lse;
3771 49129 : gfc_se rse;
3772 49129 : tree fndecl = NULL;
3773 :
3774 49129 : gfc_init_se (&lse, se);
3775 49129 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3776 49129 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3777 49129 : gfc_add_block_to_block (&se->pre, &lse.pre);
3778 :
3779 49129 : gfc_init_se (&rse, se);
3780 49129 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3781 49129 : gfc_add_block_to_block (&se->pre, &rse.pre);
3782 :
3783 49129 : if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
3784 : {
3785 17563 : if (expr->value.op.op2->ts.type == BT_INTEGER)
3786 : {
3787 2292 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3788 20418 : return;
3789 : }
3790 15271 : else if (expr->value.op.op2->ts.type == BT_UNSIGNED)
3791 : {
3792 15120 : if (gfc_conv_cst_uint_power (se, lse.expr, rse.expr))
3793 : return;
3794 : }
3795 : }
3796 :
3797 32730 : if ((expr->value.op.op2->ts.type == BT_INTEGER
3798 31468 : || expr->value.op.op2->ts.type == BT_UNSIGNED)
3799 31862 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3800 1013 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3801 : return;
3802 :
3803 32730 : if (INTEGER_CST_P (lse.expr)
3804 15371 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE
3805 48101 : && expr->value.op.op2->ts.type == BT_INTEGER)
3806 : {
3807 251 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3808 251 : HOST_WIDE_INT v;
3809 251 : unsigned HOST_WIDE_INT w;
3810 251 : int kind, ikind, bit_size;
3811 :
3812 251 : v = wlhs.to_shwi ();
3813 251 : w = absu_hwi (v);
3814 :
3815 251 : kind = expr->value.op.op1->ts.kind;
3816 251 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3817 251 : bit_size = gfc_integer_kinds[ikind].bit_size;
3818 :
3819 251 : if (v == 1)
3820 : {
3821 : /* 1**something is always 1. */
3822 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3823 239 : return;
3824 : }
3825 216 : else if (v == -1)
3826 : {
3827 : /* (-1)**n is 1 - ((n & 1) << 1) */
3828 34 : tree type;
3829 34 : tree tmp;
3830 :
3831 34 : type = TREE_TYPE (lse.expr);
3832 34 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3833 : rse.expr, build_int_cst (type, 1));
3834 34 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3835 : tmp, build_int_cst (type, 1));
3836 34 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3837 : build_int_cst (type, 1), tmp);
3838 34 : se->expr = tmp;
3839 34 : return;
3840 : }
3841 182 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3842 : {
3843 : /* Here v is +/- 2**e. The further simplification uses
3844 : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3845 : 1<<(4*n), etc., but we have to make sure to return zero
3846 : if the number of bits is too large. */
3847 170 : tree lshift;
3848 170 : tree type;
3849 170 : tree shift;
3850 170 : tree ge;
3851 170 : tree cond;
3852 170 : tree num_bits;
3853 170 : tree cond2;
3854 170 : tree tmp1;
3855 :
3856 170 : type = TREE_TYPE (lse.expr);
3857 :
3858 170 : if (w == 2)
3859 110 : shift = rse.expr;
3860 60 : else if (w == 4)
3861 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3862 12 : TREE_TYPE (rse.expr),
3863 : rse.expr, rse.expr);
3864 : else
3865 : {
3866 : /* use popcount for fast log2(w) */
3867 48 : int e = wi::popcount (w-1);
3868 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3869 48 : TREE_TYPE (rse.expr),
3870 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3871 : rse.expr);
3872 : }
3873 :
3874 170 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3875 : build_int_cst (type, 1), shift);
3876 170 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3877 : rse.expr, build_int_cst (type, 0));
3878 170 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3879 : build_int_cst (type, 0));
3880 170 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3881 170 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3882 : rse.expr, num_bits);
3883 170 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3884 : build_int_cst (type, 0), cond);
3885 170 : if (v > 0)
3886 : {
3887 128 : se->expr = tmp1;
3888 : }
3889 : else
3890 : {
3891 : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3892 42 : tree tmp2;
3893 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3894 : rse.expr, build_int_cst (type, 1));
3895 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3896 : tmp2, build_int_cst (type, 1));
3897 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3898 : build_int_cst (type, 1), tmp2);
3899 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3900 : tmp1, tmp2);
3901 : }
3902 170 : return;
3903 : }
3904 : }
3905 : /* Handle unsigned separate from signed above, things would be too
3906 : complicated otherwise. */
3907 :
3908 32491 : if (INTEGER_CST_P (lse.expr) && expr->value.op.op1->ts.type == BT_UNSIGNED)
3909 : {
3910 15120 : gfc_expr * op1 = expr->value.op.op1;
3911 15120 : tree type;
3912 :
3913 15120 : type = TREE_TYPE (lse.expr);
3914 :
3915 15120 : if (mpz_cmp_ui (op1->value.integer, 1) == 0)
3916 : {
3917 : /* 1**something is always 1. */
3918 1260 : se->expr = build_int_cst (type, 1);
3919 1260 : return;
3920 : }
3921 :
3922 : /* Simplify 2u**x to a shift, with the value set to zero if it falls
3923 : outside the range. */
3924 26460 : if (mpz_popcount (op1->value.integer) == 1)
3925 : {
3926 2520 : tree prec_m1, lim, shift, lshift, cond, tmp;
3927 2520 : tree rtype = TREE_TYPE (rse.expr);
3928 2520 : int e = mpz_scan1 (op1->value.integer, 0);
3929 :
3930 2520 : shift = fold_build2_loc (input_location, MULT_EXPR,
3931 2520 : rtype, build_int_cst (rtype, e),
3932 : rse.expr);
3933 2520 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3934 : build_int_cst (type, 1), shift);
3935 5040 : prec_m1 = fold_build2_loc (input_location, MINUS_EXPR, rtype,
3936 2520 : build_int_cst (rtype, TYPE_PRECISION (type)),
3937 : build_int_cst (rtype, 1));
3938 2520 : lim = fold_build2_loc (input_location, TRUNC_DIV_EXPR, rtype,
3939 2520 : prec_m1, build_int_cst (rtype, e));
3940 2520 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
3941 : rse.expr, lim);
3942 2520 : tmp = fold_build3_loc (input_location, COND_EXPR, type, cond,
3943 : build_int_cst (type, 0), lshift);
3944 2520 : se->expr = tmp;
3945 2520 : return;
3946 : }
3947 : }
3948 :
3949 28711 : gfc_int4_type_node = gfc_get_int_type (4);
3950 :
3951 : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3952 : library routine. But in the end, we have to convert the result back
3953 : if this case applies -- with res_ikind_K, we keep track whether operand K
3954 : falls into this case. */
3955 28711 : res_ikind_1 = -1;
3956 28711 : res_ikind_2 = -1;
3957 :
3958 28711 : kind = expr->value.op.op1->ts.kind;
3959 28711 : switch (expr->value.op.op2->ts.type)
3960 : {
3961 1023 : case BT_INTEGER:
3962 1023 : ikind = expr->value.op.op2->ts.kind;
3963 1023 : switch (ikind)
3964 : {
3965 144 : case 1:
3966 144 : case 2:
3967 144 : rse.expr = convert (gfc_int4_type_node, rse.expr);
3968 144 : res_ikind_2 = ikind;
3969 : /* Fall through. */
3970 :
3971 : case 4:
3972 : ikind = 0;
3973 : break;
3974 :
3975 : case 8:
3976 : ikind = 1;
3977 : break;
3978 :
3979 6 : case 16:
3980 6 : ikind = 2;
3981 6 : break;
3982 :
3983 0 : default:
3984 0 : gcc_unreachable ();
3985 : }
3986 1023 : switch (kind)
3987 : {
3988 0 : case 1:
3989 0 : case 2:
3990 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
3991 : {
3992 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
3993 0 : res_ikind_1 = kind;
3994 : }
3995 : else
3996 0 : gcc_unreachable ();
3997 : /* Fall through. */
3998 :
3999 : case 4:
4000 : kind = 0;
4001 : break;
4002 :
4003 : case 8:
4004 : kind = 1;
4005 : break;
4006 :
4007 6 : case 10:
4008 6 : kind = 2;
4009 6 : break;
4010 :
4011 18 : case 16:
4012 18 : kind = 3;
4013 18 : break;
4014 :
4015 0 : default:
4016 0 : gcc_unreachable ();
4017 : }
4018 :
4019 1023 : switch (expr->value.op.op1->ts.type)
4020 : {
4021 129 : case BT_INTEGER:
4022 129 : if (kind == 3) /* Case 16 was not handled properly above. */
4023 : kind = 2;
4024 129 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
4025 129 : break;
4026 :
4027 662 : case BT_REAL:
4028 : /* Use builtins for real ** int4. */
4029 662 : if (ikind == 0)
4030 : {
4031 565 : switch (kind)
4032 : {
4033 392 : case 0:
4034 392 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
4035 392 : break;
4036 :
4037 155 : case 1:
4038 155 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
4039 155 : break;
4040 :
4041 6 : case 2:
4042 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4043 6 : break;
4044 :
4045 12 : case 3:
4046 : /* Use the __builtin_powil() only if real(kind=16) is
4047 : actually the C long double type. */
4048 12 : if (!gfc_real16_is_float128)
4049 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
4050 : break;
4051 :
4052 : default:
4053 : gcc_unreachable ();
4054 : }
4055 : }
4056 :
4057 : /* If we don't have a good builtin for this, go for the
4058 : library function. */
4059 553 : if (!fndecl)
4060 109 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
4061 : break;
4062 :
4063 232 : case BT_COMPLEX:
4064 232 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
4065 232 : break;
4066 :
4067 0 : default:
4068 0 : gcc_unreachable ();
4069 : }
4070 : break;
4071 :
4072 139 : case BT_REAL:
4073 139 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
4074 139 : break;
4075 :
4076 729 : case BT_COMPLEX:
4077 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
4078 729 : break;
4079 :
4080 26820 : case BT_UNSIGNED:
4081 26820 : {
4082 : /* Valid kinds for unsigned are 1, 2, 4, 8, 16. Instead of using a
4083 : large switch statement, let's just use __builtin_ctz. */
4084 26820 : int base = __builtin_ctz (expr->value.op.op1->ts.kind);
4085 26820 : int expon = __builtin_ctz (expr->value.op.op2->ts.kind);
4086 26820 : fndecl = gfor_fndecl_unsigned_pow_list[base][expon];
4087 : }
4088 26820 : break;
4089 :
4090 0 : default:
4091 0 : gcc_unreachable ();
4092 28711 : break;
4093 : }
4094 :
4095 28711 : se->expr = build_call_expr_loc (input_location,
4096 : fndecl, 2, lse.expr, rse.expr);
4097 :
4098 : /* Convert the result back if it is of wrong integer kind. */
4099 28711 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
4100 : {
4101 : /* We want the maximum of both operand kinds as result. */
4102 0 : if (res_ikind_1 < res_ikind_2)
4103 0 : res_ikind_1 = res_ikind_2;
4104 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
4105 : }
4106 : }
4107 :
4108 :
4109 : /* Generate code to allocate a string temporary. */
4110 :
4111 : tree
4112 4867 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
4113 : {
4114 4867 : tree var;
4115 4867 : tree tmp;
4116 :
4117 4867 : if (gfc_can_put_var_on_stack (len))
4118 : {
4119 : /* Create a temporary variable to hold the result. */
4120 4572 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4121 2286 : TREE_TYPE (len), len,
4122 2286 : build_int_cst (TREE_TYPE (len), 1));
4123 2286 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
4124 :
4125 2286 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
4126 2286 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
4127 : else
4128 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
4129 :
4130 2286 : var = gfc_create_var (tmp, "str");
4131 2286 : var = gfc_build_addr_expr (type, var);
4132 : }
4133 : else
4134 : {
4135 : /* Allocate a temporary to hold the result. */
4136 2581 : var = gfc_create_var (type, "pstr");
4137 2581 : gcc_assert (POINTER_TYPE_P (type));
4138 2581 : tmp = TREE_TYPE (type);
4139 2581 : if (TREE_CODE (tmp) == ARRAY_TYPE)
4140 2581 : tmp = TREE_TYPE (tmp);
4141 2581 : tmp = TYPE_SIZE_UNIT (tmp);
4142 2581 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4143 : fold_convert (size_type_node, len),
4144 : fold_convert (size_type_node, tmp));
4145 2581 : tmp = gfc_call_malloc (&se->pre, type, tmp);
4146 2581 : gfc_add_modify (&se->pre, var, tmp);
4147 :
4148 : /* Free the temporary afterwards. */
4149 2581 : tmp = gfc_call_free (var);
4150 2581 : gfc_add_expr_to_block (&se->post, tmp);
4151 : }
4152 :
4153 4867 : return var;
4154 : }
4155 :
4156 :
4157 : /* Handle a string concatenation operation. A temporary will be allocated to
4158 : hold the result. */
4159 :
4160 : static void
4161 1282 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
4162 : {
4163 1282 : gfc_se lse, rse;
4164 1282 : tree len, type, var, tmp, fndecl;
4165 :
4166 1282 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
4167 : && expr->value.op.op2->ts.type == BT_CHARACTER);
4168 1282 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
4169 :
4170 1282 : gfc_init_se (&lse, se);
4171 1282 : gfc_conv_expr (&lse, expr->value.op.op1);
4172 1282 : gfc_conv_string_parameter (&lse);
4173 1282 : gfc_init_se (&rse, se);
4174 1282 : gfc_conv_expr (&rse, expr->value.op.op2);
4175 1282 : gfc_conv_string_parameter (&rse);
4176 :
4177 1282 : gfc_add_block_to_block (&se->pre, &lse.pre);
4178 1282 : gfc_add_block_to_block (&se->pre, &rse.pre);
4179 :
4180 1282 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4181 1282 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
4182 1282 : if (len == NULL_TREE)
4183 : {
4184 1063 : len = fold_build2_loc (input_location, PLUS_EXPR,
4185 : gfc_charlen_type_node,
4186 : fold_convert (gfc_charlen_type_node,
4187 : lse.string_length),
4188 : fold_convert (gfc_charlen_type_node,
4189 : rse.string_length));
4190 : }
4191 :
4192 1282 : type = build_pointer_type (type);
4193 :
4194 1282 : var = gfc_conv_string_tmp (se, type, len);
4195 :
4196 : /* Do the actual concatenation. */
4197 1282 : if (expr->ts.kind == 1)
4198 1191 : fndecl = gfor_fndecl_concat_string;
4199 91 : else if (expr->ts.kind == 4)
4200 91 : fndecl = gfor_fndecl_concat_string_char4;
4201 : else
4202 0 : gcc_unreachable ();
4203 :
4204 1282 : tmp = build_call_expr_loc (input_location,
4205 : fndecl, 6, len, var, lse.string_length, lse.expr,
4206 : rse.string_length, rse.expr);
4207 1282 : gfc_add_expr_to_block (&se->pre, tmp);
4208 :
4209 : /* Add the cleanup for the operands. */
4210 1282 : gfc_add_block_to_block (&se->pre, &rse.post);
4211 1282 : gfc_add_block_to_block (&se->pre, &lse.post);
4212 :
4213 1282 : se->expr = var;
4214 1282 : se->string_length = len;
4215 1282 : }
4216 :
4217 : /* Translates an op expression. Common (binary) cases are handled by this
4218 : function, others are passed on. Recursion is used in either case.
4219 : We use the fact that (op1.ts == op2.ts) (except for the power
4220 : operator **).
4221 : Operators need no special handling for scalarized expressions as long as
4222 : they call gfc_conv_simple_val to get their operands.
4223 : Character strings get special handling. */
4224 :
4225 : static void
4226 505778 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
4227 : {
4228 505778 : enum tree_code code;
4229 505778 : gfc_se lse;
4230 505778 : gfc_se rse;
4231 505778 : tree tmp, type;
4232 505778 : int lop;
4233 505778 : int checkstring;
4234 :
4235 505778 : checkstring = 0;
4236 505778 : lop = 0;
4237 505778 : switch (expr->value.op.op)
4238 : {
4239 15513 : case INTRINSIC_PARENTHESES:
4240 15513 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
4241 3801 : && flag_protect_parens)
4242 : {
4243 3668 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
4244 3668 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
4245 91102 : return;
4246 : }
4247 :
4248 : /* Fallthrough. */
4249 11851 : case INTRINSIC_UPLUS:
4250 11851 : gfc_conv_expr (se, expr->value.op.op1);
4251 11851 : return;
4252 :
4253 4935 : case INTRINSIC_UMINUS:
4254 4935 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
4255 4935 : return;
4256 :
4257 20237 : case INTRINSIC_NOT:
4258 20237 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
4259 20237 : return;
4260 :
4261 : case INTRINSIC_PLUS:
4262 : code = PLUS_EXPR;
4263 : break;
4264 :
4265 28872 : case INTRINSIC_MINUS:
4266 28872 : code = MINUS_EXPR;
4267 28872 : break;
4268 :
4269 32451 : case INTRINSIC_TIMES:
4270 32451 : code = MULT_EXPR;
4271 32451 : break;
4272 :
4273 6886 : case INTRINSIC_DIVIDE:
4274 : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
4275 : an integer or unsigned, we must round towards zero, so we use a
4276 : TRUNC_DIV_EXPR. */
4277 6886 : if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED)
4278 : code = TRUNC_DIV_EXPR;
4279 : else
4280 414676 : code = RDIV_EXPR;
4281 : break;
4282 :
4283 49129 : case INTRINSIC_POWER:
4284 49129 : gfc_conv_power_op (se, expr);
4285 49129 : return;
4286 :
4287 1282 : case INTRINSIC_CONCAT:
4288 1282 : gfc_conv_concat_op (se, expr);
4289 1282 : return;
4290 :
4291 4786 : case INTRINSIC_AND:
4292 4786 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
4293 : lop = 1;
4294 : break;
4295 :
4296 55978 : case INTRINSIC_OR:
4297 55978 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
4298 : lop = 1;
4299 : break;
4300 :
4301 : /* EQV and NEQV only work on logicals, but since we represent them
4302 : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
4303 12634 : case INTRINSIC_EQ:
4304 12634 : case INTRINSIC_EQ_OS:
4305 12634 : case INTRINSIC_EQV:
4306 12634 : code = EQ_EXPR;
4307 12634 : checkstring = 1;
4308 12634 : lop = 1;
4309 12634 : break;
4310 :
4311 206582 : case INTRINSIC_NE:
4312 206582 : case INTRINSIC_NE_OS:
4313 206582 : case INTRINSIC_NEQV:
4314 206582 : code = NE_EXPR;
4315 206582 : checkstring = 1;
4316 206582 : lop = 1;
4317 206582 : break;
4318 :
4319 11916 : case INTRINSIC_GT:
4320 11916 : case INTRINSIC_GT_OS:
4321 11916 : code = GT_EXPR;
4322 11916 : checkstring = 1;
4323 11916 : lop = 1;
4324 11916 : break;
4325 :
4326 1661 : case INTRINSIC_GE:
4327 1661 : case INTRINSIC_GE_OS:
4328 1661 : code = GE_EXPR;
4329 1661 : checkstring = 1;
4330 1661 : lop = 1;
4331 1661 : break;
4332 :
4333 4340 : case INTRINSIC_LT:
4334 4340 : case INTRINSIC_LT_OS:
4335 4340 : code = LT_EXPR;
4336 4340 : checkstring = 1;
4337 4340 : lop = 1;
4338 4340 : break;
4339 :
4340 2596 : case INTRINSIC_LE:
4341 2596 : case INTRINSIC_LE_OS:
4342 2596 : code = LE_EXPR;
4343 2596 : checkstring = 1;
4344 2596 : lop = 1;
4345 2596 : break;
4346 :
4347 0 : case INTRINSIC_USER:
4348 0 : case INTRINSIC_ASSIGN:
4349 : /* These should be converted into function calls by the frontend. */
4350 0 : gcc_unreachable ();
4351 :
4352 0 : default:
4353 0 : fatal_error (input_location, "Unknown intrinsic op");
4354 414676 : return;
4355 : }
4356 :
4357 : /* The only exception to this is **, which is handled separately anyway. */
4358 414676 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
4359 :
4360 414676 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
4361 380721 : checkstring = 0;
4362 :
4363 : /* lhs */
4364 414676 : gfc_init_se (&lse, se);
4365 414676 : gfc_conv_expr (&lse, expr->value.op.op1);
4366 414676 : gfc_add_block_to_block (&se->pre, &lse.pre);
4367 :
4368 : /* rhs */
4369 414676 : gfc_init_se (&rse, se);
4370 414676 : gfc_conv_expr (&rse, expr->value.op.op2);
4371 414676 : gfc_add_block_to_block (&se->pre, &rse.pre);
4372 :
4373 414676 : if (checkstring)
4374 : {
4375 33955 : gfc_conv_string_parameter (&lse);
4376 33955 : gfc_conv_string_parameter (&rse);
4377 :
4378 67910 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
4379 : rse.string_length, rse.expr,
4380 33955 : expr->value.op.op1->ts.kind,
4381 : code);
4382 33955 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4383 33955 : gfc_add_block_to_block (&lse.post, &rse.post);
4384 : }
4385 :
4386 414676 : type = gfc_typenode_for_spec (&expr->ts);
4387 :
4388 414676 : if (lop)
4389 : {
4390 : // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
4391 300493 : if (expr->value.op.op1->expr_type == EXPR_VARIABLE
4392 169635 : && expr->value.op.op1->ts.type == BT_INTEGER
4393 73125 : && expr->value.op.op1->symtree
4394 73125 : && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
4395 12 : TREE_THIS_VOLATILE (lse.expr) = 1;
4396 :
4397 300493 : if (expr->value.op.op2->expr_type == EXPR_VARIABLE
4398 72180 : && expr->value.op.op2->ts.type == BT_INTEGER
4399 12849 : && expr->value.op.op2->symtree
4400 12849 : && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
4401 12 : TREE_THIS_VOLATILE (rse.expr) = 1;
4402 :
4403 : /* The result of logical ops is always logical_type_node. */
4404 300493 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4405 : lse.expr, rse.expr);
4406 300493 : se->expr = convert (type, tmp);
4407 : }
4408 : else
4409 114183 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4410 :
4411 : /* Add the post blocks. */
4412 414676 : gfc_add_block_to_block (&se->post, &rse.post);
4413 414676 : gfc_add_block_to_block (&se->post, &lse.post);
4414 : }
4415 :
4416 : static void
4417 151 : gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr)
4418 : {
4419 151 : gfc_se cond_se, true_se, false_se;
4420 151 : tree condition, true_val, false_val;
4421 151 : tree type;
4422 :
4423 151 : gfc_init_se (&cond_se, se);
4424 151 : gfc_init_se (&true_se, se);
4425 151 : gfc_init_se (&false_se, se);
4426 :
4427 151 : gfc_conv_expr (&cond_se, expr->value.conditional.condition);
4428 151 : gfc_add_block_to_block (&se->pre, &cond_se.pre);
4429 151 : condition = gfc_evaluate_now (cond_se.expr, &se->pre);
4430 :
4431 151 : true_se.want_pointer = se->want_pointer;
4432 151 : gfc_conv_expr (&true_se, expr->value.conditional.true_expr);
4433 151 : true_val = true_se.expr;
4434 151 : false_se.want_pointer = se->want_pointer;
4435 151 : gfc_conv_expr (&false_se, expr->value.conditional.false_expr);
4436 151 : false_val = false_se.expr;
4437 :
4438 151 : if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE)
4439 24 : gfc_add_expr_to_block (
4440 : &se->pre,
4441 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4442 24 : true_se.pre.head != NULL_TREE
4443 6 : ? gfc_finish_block (&true_se.pre)
4444 18 : : build_empty_stmt (input_location),
4445 24 : false_se.pre.head != NULL_TREE
4446 24 : ? gfc_finish_block (&false_se.pre)
4447 0 : : build_empty_stmt (input_location)));
4448 :
4449 151 : if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE)
4450 6 : gfc_add_expr_to_block (
4451 : &se->post,
4452 : fold_build3_loc (input_location, COND_EXPR, void_type_node, condition,
4453 6 : true_se.post.head != NULL_TREE
4454 0 : ? gfc_finish_block (&true_se.post)
4455 6 : : build_empty_stmt (input_location),
4456 6 : false_se.post.head != NULL_TREE
4457 6 : ? gfc_finish_block (&false_se.post)
4458 0 : : build_empty_stmt (input_location)));
4459 :
4460 151 : type = gfc_typenode_for_spec (&expr->ts);
4461 151 : if (se->want_pointer)
4462 18 : type = build_pointer_type (type);
4463 :
4464 151 : se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition,
4465 : true_val, false_val);
4466 151 : if (expr->ts.type == BT_CHARACTER)
4467 66 : se->string_length
4468 66 : = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
4469 : condition, true_se.string_length,
4470 : false_se.string_length);
4471 151 : }
4472 :
4473 : /* If a string's length is one, we convert it to a single character. */
4474 :
4475 : tree
4476 139796 : gfc_string_to_single_character (tree len, tree str, int kind)
4477 : {
4478 :
4479 139796 : if (len == NULL
4480 139796 : || !tree_fits_uhwi_p (len)
4481 256882 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4482 : return NULL_TREE;
4483 :
4484 117034 : if (TREE_INT_CST_LOW (len) == 1)
4485 : {
4486 22541 : str = fold_convert (gfc_get_pchar_type (kind), str);
4487 22541 : return build_fold_indirect_ref_loc (input_location, str);
4488 : }
4489 :
4490 94493 : if (kind == 1
4491 77123 : && TREE_CODE (str) == ADDR_EXPR
4492 66483 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4493 47563 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4494 29185 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4495 29185 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4496 29185 : && TREE_INT_CST_LOW (len) > 1
4497 121922 : && TREE_INT_CST_LOW (len)
4498 : == (unsigned HOST_WIDE_INT)
4499 27429 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4500 : {
4501 27429 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4502 27429 : ret = build_fold_indirect_ref_loc (input_location, ret);
4503 27429 : if (TREE_CODE (ret) == INTEGER_CST)
4504 : {
4505 27429 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4506 27429 : int i, length = TREE_STRING_LENGTH (string_cst);
4507 27429 : const char *ptr = TREE_STRING_POINTER (string_cst);
4508 :
4509 41134 : for (i = 1; i < length; i++)
4510 40461 : if (ptr[i] != ' ')
4511 : return NULL_TREE;
4512 :
4513 : return ret;
4514 : }
4515 : }
4516 :
4517 : return NULL_TREE;
4518 : }
4519 :
4520 :
4521 : static void
4522 172 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4523 : {
4524 172 : gcc_assert (expr);
4525 :
4526 : /* We used to modify the tree here. Now it is done earlier in
4527 : the front-end, so we only check it here to avoid regressions. */
4528 172 : if (sym->backend_decl)
4529 : {
4530 67 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4531 67 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4532 67 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4533 67 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4534 : }
4535 :
4536 : /* If we have a constant character expression, make it into an
4537 : integer of type C char. */
4538 172 : if ((*expr)->expr_type == EXPR_CONSTANT)
4539 : {
4540 166 : gfc_typespec ts;
4541 166 : gfc_clear_ts (&ts);
4542 :
4543 332 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4544 166 : (*expr)->value.character.string[0]);
4545 166 : gfc_replace_expr (*expr, tmp);
4546 : }
4547 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4548 : {
4549 6 : if ((*expr)->ref == NULL)
4550 : {
4551 6 : se->expr = gfc_string_to_single_character
4552 6 : (integer_one_node,
4553 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4554 : gfc_get_symbol_decl
4555 6 : ((*expr)->symtree->n.sym)),
4556 : (*expr)->ts.kind);
4557 : }
4558 : else
4559 : {
4560 0 : gfc_conv_variable (se, *expr);
4561 0 : se->expr = gfc_string_to_single_character
4562 0 : (integer_one_node,
4563 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4564 : se->expr),
4565 0 : (*expr)->ts.kind);
4566 : }
4567 : }
4568 172 : }
4569 :
4570 : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4571 : if STR is a string literal, otherwise return -1. */
4572 :
4573 : static int
4574 32236 : gfc_optimize_len_trim (tree len, tree str, int kind)
4575 : {
4576 32236 : if (kind == 1
4577 27194 : && TREE_CODE (str) == ADDR_EXPR
4578 23861 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4579 15210 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4580 9784 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4581 9784 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4582 9784 : && tree_fits_uhwi_p (len)
4583 9784 : && tree_to_uhwi (len) >= 1
4584 32236 : && tree_to_uhwi (len)
4585 9740 : == (unsigned HOST_WIDE_INT)
4586 9740 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4587 : {
4588 9740 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4589 9740 : folded = build_fold_indirect_ref_loc (input_location, folded);
4590 9740 : if (TREE_CODE (folded) == INTEGER_CST)
4591 : {
4592 9740 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4593 9740 : int length = TREE_STRING_LENGTH (string_cst);
4594 9740 : const char *ptr = TREE_STRING_POINTER (string_cst);
4595 :
4596 14649 : for (; length > 0; length--)
4597 14649 : if (ptr[length - 1] != ' ')
4598 : break;
4599 :
4600 : return length;
4601 : }
4602 : }
4603 : return -1;
4604 : }
4605 :
4606 : /* Helper to build a call to memcmp. */
4607 :
4608 : static tree
4609 13081 : build_memcmp_call (tree s1, tree s2, tree n)
4610 : {
4611 13081 : tree tmp;
4612 :
4613 13081 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4614 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4615 : else
4616 13081 : s1 = fold_convert (pvoid_type_node, s1);
4617 :
4618 13081 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4619 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4620 : else
4621 13081 : s2 = fold_convert (pvoid_type_node, s2);
4622 :
4623 13081 : n = fold_convert (size_type_node, n);
4624 :
4625 13081 : tmp = build_call_expr_loc (input_location,
4626 : builtin_decl_explicit (BUILT_IN_MEMCMP),
4627 : 3, s1, s2, n);
4628 :
4629 13081 : return fold_convert (integer_type_node, tmp);
4630 : }
4631 :
4632 : /* Compare two strings. If they are all single characters, the result is the
4633 : subtraction of them. Otherwise, we build a library call. */
4634 :
4635 : tree
4636 34054 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4637 : enum tree_code code)
4638 : {
4639 34054 : tree sc1;
4640 34054 : tree sc2;
4641 34054 : tree fndecl;
4642 :
4643 34054 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4644 34054 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4645 :
4646 34054 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4647 34054 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4648 :
4649 34054 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4650 : {
4651 : /* Deal with single character specially. */
4652 4839 : sc1 = fold_convert (integer_type_node, sc1);
4653 4839 : sc2 = fold_convert (integer_type_node, sc2);
4654 4839 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4655 4839 : sc1, sc2);
4656 : }
4657 :
4658 29215 : if ((code == EQ_EXPR || code == NE_EXPR)
4659 28653 : && optimize
4660 24002 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4661 : {
4662 : /* If one string is a string literal with LEN_TRIM longer
4663 : than the length of the second string, the strings
4664 : compare unequal. */
4665 16118 : int len = gfc_optimize_len_trim (len1, str1, kind);
4666 16118 : if (len > 0 && compare_tree_int (len2, len) < 0)
4667 0 : return integer_one_node;
4668 16118 : len = gfc_optimize_len_trim (len2, str2, kind);
4669 16118 : if (len > 0 && compare_tree_int (len1, len) < 0)
4670 0 : return integer_one_node;
4671 : }
4672 :
4673 : /* We can compare via memcpy if the strings are known to be equal
4674 : in length and they are
4675 : - kind=1
4676 : - kind=4 and the comparison is for (in)equality. */
4677 :
4678 19647 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4679 19309 : && tree_int_cst_equal (len1, len2)
4680 42356 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4681 : {
4682 13081 : tree tmp;
4683 13081 : tree chartype;
4684 :
4685 13081 : chartype = gfc_get_char_type (kind);
4686 13081 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4687 13081 : fold_convert (TREE_TYPE(len1),
4688 : TYPE_SIZE_UNIT(chartype)),
4689 : len1);
4690 13081 : return build_memcmp_call (str1, str2, tmp);
4691 : }
4692 :
4693 : /* Build a call for the comparison. */
4694 16134 : if (kind == 1)
4695 13291 : fndecl = gfor_fndecl_compare_string;
4696 2843 : else if (kind == 4)
4697 2843 : fndecl = gfor_fndecl_compare_string_char4;
4698 : else
4699 0 : gcc_unreachable ();
4700 :
4701 16134 : return build_call_expr_loc (input_location, fndecl, 4,
4702 16134 : len1, str1, len2, str2);
4703 : }
4704 :
4705 :
4706 : /* Return the backend_decl for a procedure pointer component. */
4707 :
4708 : static tree
4709 1900 : get_proc_ptr_comp (gfc_expr *e)
4710 : {
4711 1900 : gfc_se comp_se;
4712 1900 : gfc_expr *e2;
4713 1900 : expr_t old_type;
4714 :
4715 1900 : gfc_init_se (&comp_se, NULL);
4716 1900 : e2 = gfc_copy_expr (e);
4717 : /* We have to restore the expr type later so that gfc_free_expr frees
4718 : the exact same thing that was allocated.
4719 : TODO: This is ugly. */
4720 1900 : old_type = e2->expr_type;
4721 1900 : e2->expr_type = EXPR_VARIABLE;
4722 1900 : gfc_conv_expr (&comp_se, e2);
4723 1900 : e2->expr_type = old_type;
4724 1900 : gfc_free_expr (e2);
4725 1900 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4726 : }
4727 :
4728 :
4729 : /* Convert a typebound function reference from a class object. */
4730 : static void
4731 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4732 : {
4733 80 : gfc_ref *ref;
4734 80 : tree var;
4735 :
4736 80 : if (!VAR_P (base_object))
4737 : {
4738 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4739 0 : gfc_add_modify (&se->pre, var, base_object);
4740 : }
4741 80 : se->expr = gfc_class_vptr_get (base_object);
4742 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4743 80 : ref = expr->ref;
4744 308 : while (ref && ref->next)
4745 : ref = ref->next;
4746 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4747 80 : if (ref->u.c.sym->attr.extension)
4748 0 : conv_parent_component_references (se, ref);
4749 80 : gfc_conv_component_ref (se, ref);
4750 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4751 80 : }
4752 :
4753 : static tree
4754 127470 : get_builtin_fn (gfc_symbol * sym)
4755 : {
4756 127470 : if (!gfc_option.disable_omp_is_initial_device
4757 127466 : && flag_openmp && sym->attr.function && sym->ts.type == BT_LOGICAL
4758 631 : && !strcmp (sym->name, "omp_is_initial_device"))
4759 41 : return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE);
4760 :
4761 127429 : if (!gfc_option.disable_omp_get_initial_device
4762 127422 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4763 4162 : && !strcmp (sym->name, "omp_get_initial_device"))
4764 29 : return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE);
4765 :
4766 127400 : if (!gfc_option.disable_omp_get_num_devices
4767 127393 : && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER
4768 4133 : && !strcmp (sym->name, "omp_get_num_devices"))
4769 92 : return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES);
4770 :
4771 127308 : if (!gfc_option.disable_acc_on_device
4772 127128 : && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL
4773 1163 : && !strcmp (sym->name, "acc_on_device_h"))
4774 390 : return builtin_decl_explicit (BUILT_IN_ACC_ON_DEVICE);
4775 :
4776 : return NULL_TREE;
4777 : }
4778 :
4779 : static tree
4780 552 : update_builtin_function (tree fn_call, gfc_symbol *sym)
4781 : {
4782 552 : tree fn = TREE_OPERAND (CALL_EXPR_FN (fn_call), 0);
4783 :
4784 552 : if (DECL_FUNCTION_CODE (fn) == BUILT_IN_OMP_IS_INITIAL_DEVICE)
4785 : /* In Fortran omp_is_initial_device returns logical(4)
4786 : but the builtin uses 'int'. */
4787 41 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4788 :
4789 511 : else if (DECL_FUNCTION_CODE (fn) == BUILT_IN_ACC_ON_DEVICE)
4790 : {
4791 : /* Likewise for the return type; additionally, the argument it a
4792 : call-by-value int, Fortran has a by-reference 'integer(4)'. */
4793 390 : tree arg = build_fold_indirect_ref_loc (input_location,
4794 390 : CALL_EXPR_ARG (fn_call, 0));
4795 390 : CALL_EXPR_ARG (fn_call, 0) = fold_convert (integer_type_node, arg);
4796 390 : return fold_convert (TREE_TYPE (TREE_TYPE (sym->backend_decl)), fn_call);
4797 : }
4798 : return fn_call;
4799 : }
4800 :
4801 : static void
4802 130174 : conv_function_val (gfc_se * se, bool *is_builtin, gfc_symbol * sym,
4803 : gfc_expr * expr, gfc_actual_arglist *actual_args)
4804 : {
4805 130174 : tree tmp;
4806 :
4807 130174 : if (gfc_is_proc_ptr_comp (expr))
4808 1900 : tmp = get_proc_ptr_comp (expr);
4809 128274 : else if (sym->attr.dummy)
4810 : {
4811 804 : tmp = gfc_get_symbol_decl (sym);
4812 804 : if (sym->attr.proc_pointer)
4813 83 : tmp = build_fold_indirect_ref_loc (input_location,
4814 : tmp);
4815 804 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4816 : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4817 : }
4818 : else
4819 : {
4820 127470 : if (!sym->backend_decl)
4821 31892 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4822 :
4823 127470 : if ((tmp = get_builtin_fn (sym)) != NULL_TREE)
4824 552 : *is_builtin = true;
4825 : else
4826 : {
4827 126918 : TREE_USED (sym->backend_decl) = 1;
4828 126918 : tmp = sym->backend_decl;
4829 : }
4830 :
4831 127470 : if (sym->attr.cray_pointee)
4832 : {
4833 : /* TODO - make the cray pointee a pointer to a procedure,
4834 : assign the pointer to it and use it for the call. This
4835 : will do for now! */
4836 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4837 19 : gfc_get_symbol_decl (sym->cp_pointer));
4838 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4839 : }
4840 :
4841 127470 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4842 : {
4843 126848 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4844 126848 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4845 : }
4846 : }
4847 130174 : se->expr = tmp;
4848 130174 : }
4849 :
4850 :
4851 : /* Initialize MAPPING. */
4852 :
4853 : void
4854 130291 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4855 : {
4856 130291 : mapping->syms = NULL;
4857 130291 : mapping->charlens = NULL;
4858 130291 : }
4859 :
4860 :
4861 : /* Free all memory held by MAPPING (but not MAPPING itself). */
4862 :
4863 : void
4864 130291 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4865 : {
4866 130291 : gfc_interface_sym_mapping *sym;
4867 130291 : gfc_interface_sym_mapping *nextsym;
4868 130291 : gfc_charlen *cl;
4869 130291 : gfc_charlen *nextcl;
4870 :
4871 170837 : for (sym = mapping->syms; sym; sym = nextsym)
4872 : {
4873 40546 : nextsym = sym->next;
4874 40546 : sym->new_sym->n.sym->formal = NULL;
4875 40546 : gfc_free_symbol (sym->new_sym->n.sym);
4876 40546 : gfc_free_expr (sym->expr);
4877 40546 : free (sym->new_sym);
4878 40546 : free (sym);
4879 : }
4880 134931 : for (cl = mapping->charlens; cl; cl = nextcl)
4881 : {
4882 4640 : nextcl = cl->next;
4883 4640 : gfc_free_expr (cl->length);
4884 4640 : free (cl);
4885 : }
4886 130291 : }
4887 :
4888 :
4889 : /* Return a copy of gfc_charlen CL. Add the returned structure to
4890 : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4891 :
4892 : static gfc_charlen *
4893 4640 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4894 : gfc_charlen * cl)
4895 : {
4896 4640 : gfc_charlen *new_charlen;
4897 :
4898 4640 : new_charlen = gfc_get_charlen ();
4899 4640 : new_charlen->next = mapping->charlens;
4900 4640 : new_charlen->length = gfc_copy_expr (cl->length);
4901 :
4902 4640 : mapping->charlens = new_charlen;
4903 4640 : return new_charlen;
4904 : }
4905 :
4906 :
4907 : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4908 : array variable that can be used as the actual argument for dummy
4909 : argument SYM, except in the case of assumed rank dummies of
4910 : non-intrinsic functions where the descriptor must be passed. Add any
4911 : initialization code to BLOCK. PACKED is as for gfc_get_nodesc_array_type
4912 : and DATA points to the first element in the passed array. */
4913 :
4914 : static tree
4915 8382 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4916 : gfc_packed packed, tree data, tree len,
4917 : bool assumed_rank_formal)
4918 : {
4919 8382 : tree type;
4920 8382 : tree var;
4921 :
4922 8382 : if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
4923 58 : type = gfc_get_character_type_len (sym->ts.kind, len);
4924 : else
4925 8324 : type = gfc_typenode_for_spec (&sym->ts);
4926 :
4927 8382 : if (assumed_rank_formal)
4928 13 : type = TREE_TYPE (data);
4929 : else
4930 8369 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4931 8345 : !sym->attr.target && !sym->attr.pointer
4932 16714 : && !sym->attr.proc_pointer);
4933 :
4934 8382 : var = gfc_create_var (type, "ifm");
4935 8382 : gfc_add_modify (block, var, fold_convert (type, data));
4936 :
4937 8382 : return var;
4938 : }
4939 :
4940 :
4941 : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4942 : and offset of descriptorless array type TYPE given that it has the same
4943 : size as DESC. Add any set-up code to BLOCK. */
4944 :
4945 : static void
4946 8112 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4947 : {
4948 8112 : int n;
4949 8112 : tree dim;
4950 8112 : tree offset;
4951 8112 : tree tmp;
4952 :
4953 8112 : offset = gfc_index_zero_node;
4954 9214 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4955 : {
4956 1102 : dim = gfc_rank_cst[n];
4957 1102 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4958 1102 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4959 : {
4960 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
4961 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
4962 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
4963 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
4964 : }
4965 1101 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4966 : {
4967 1075 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4968 : gfc_array_index_type,
4969 : gfc_conv_descriptor_ubound_get (desc, dim),
4970 : gfc_conv_descriptor_lbound_get (desc, dim));
4971 3225 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4972 : gfc_array_index_type,
4973 1075 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4974 1075 : tmp = gfc_evaluate_now (tmp, block);
4975 1075 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4976 : }
4977 4408 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4978 1102 : GFC_TYPE_ARRAY_LBOUND (type, n),
4979 1102 : GFC_TYPE_ARRAY_STRIDE (type, n));
4980 1102 : offset = fold_build2_loc (input_location, MINUS_EXPR,
4981 : gfc_array_index_type, offset, tmp);
4982 : }
4983 8112 : offset = gfc_evaluate_now (offset, block);
4984 8112 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
4985 8112 : }
4986 :
4987 :
4988 : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4989 : in SE. The caller may still use se->expr and se->string_length after
4990 : calling this function. */
4991 :
4992 : void
4993 40546 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4994 : gfc_symbol * sym, gfc_se * se,
4995 : gfc_expr *expr)
4996 : {
4997 40546 : gfc_interface_sym_mapping *sm;
4998 40546 : tree desc;
4999 40546 : tree tmp;
5000 40546 : tree value;
5001 40546 : gfc_symbol *new_sym;
5002 40546 : gfc_symtree *root;
5003 40546 : gfc_symtree *new_symtree;
5004 :
5005 : /* Create a new symbol to represent the actual argument. */
5006 40546 : new_sym = gfc_new_symbol (sym->name, NULL);
5007 40546 : new_sym->ts = sym->ts;
5008 40546 : new_sym->as = gfc_copy_array_spec (sym->as);
5009 40546 : new_sym->attr.referenced = 1;
5010 40546 : new_sym->attr.dimension = sym->attr.dimension;
5011 40546 : new_sym->attr.contiguous = sym->attr.contiguous;
5012 40546 : new_sym->attr.codimension = sym->attr.codimension;
5013 40546 : new_sym->attr.pointer = sym->attr.pointer;
5014 40546 : new_sym->attr.allocatable = sym->attr.allocatable;
5015 40546 : new_sym->attr.flavor = sym->attr.flavor;
5016 40546 : new_sym->attr.function = sym->attr.function;
5017 40546 : new_sym->attr.dummy = 0;
5018 :
5019 : /* Ensure that the interface is available and that
5020 : descriptors are passed for array actual arguments. */
5021 40546 : if (sym->attr.flavor == FL_PROCEDURE)
5022 : {
5023 36 : new_sym->formal = expr->symtree->n.sym->formal;
5024 36 : new_sym->attr.always_explicit
5025 36 : = expr->symtree->n.sym->attr.always_explicit;
5026 : }
5027 :
5028 : /* Create a fake symtree for it. */
5029 40546 : root = NULL;
5030 40546 : new_symtree = gfc_new_symtree (&root, sym->name);
5031 40546 : new_symtree->n.sym = new_sym;
5032 40546 : gcc_assert (new_symtree == root);
5033 :
5034 : /* Create a dummy->actual mapping. */
5035 40546 : sm = XCNEW (gfc_interface_sym_mapping);
5036 40546 : sm->next = mapping->syms;
5037 40546 : sm->old = sym;
5038 40546 : sm->new_sym = new_symtree;
5039 40546 : sm->expr = gfc_copy_expr (expr);
5040 40546 : mapping->syms = sm;
5041 :
5042 : /* Stabilize the argument's value. */
5043 40546 : if (!sym->attr.function && se)
5044 40448 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5045 :
5046 40546 : if (sym->ts.type == BT_CHARACTER)
5047 : {
5048 : /* Create a copy of the dummy argument's length. */
5049 2856 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
5050 2856 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
5051 :
5052 : /* If the length is specified as "*", record the length that
5053 : the caller is passing. We should use the callee's length
5054 : in all other cases. */
5055 2856 : if (!new_sym->ts.u.cl->length && se)
5056 : {
5057 2628 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5058 2628 : new_sym->ts.u.cl->backend_decl = se->string_length;
5059 : }
5060 : }
5061 :
5062 40532 : if (!se)
5063 62 : return;
5064 :
5065 : /* Use the passed value as-is if the argument is a function. */
5066 40484 : if (sym->attr.flavor == FL_PROCEDURE)
5067 36 : value = se->expr;
5068 :
5069 : /* If the argument is a pass-by-value scalar, use the value as is. */
5070 40448 : else if (!sym->attr.dimension && sym->attr.value)
5071 78 : value = se->expr;
5072 :
5073 : /* If the argument is either a string or a pointer to a string,
5074 : convert it to a boundless character type. */
5075 40370 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
5076 : {
5077 1287 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
5078 1287 : tmp = gfc_get_character_type_len (sym->ts.kind, se->string_length);
5079 1287 : tmp = build_pointer_type (tmp);
5080 1287 : if (sym->attr.pointer)
5081 126 : value = build_fold_indirect_ref_loc (input_location,
5082 : se->expr);
5083 : else
5084 1161 : value = se->expr;
5085 1287 : value = fold_convert (tmp, value);
5086 : }
5087 :
5088 : /* If the argument is a scalar, a pointer to an array or an allocatable,
5089 : dereference it. */
5090 39083 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
5091 29204 : value = build_fold_indirect_ref_loc (input_location,
5092 : se->expr);
5093 :
5094 : /* For character(*), use the actual argument's descriptor. */
5095 9879 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
5096 1497 : value = build_fold_indirect_ref_loc (input_location,
5097 : se->expr);
5098 :
5099 : /* If the argument is an array descriptor, use it to determine
5100 : information about the actual argument's shape. */
5101 8382 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
5102 8382 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
5103 : {
5104 8112 : bool assumed_rank_formal = false;
5105 :
5106 : /* Get the actual argument's descriptor. */
5107 8112 : desc = build_fold_indirect_ref_loc (input_location,
5108 : se->expr);
5109 :
5110 : /* Create the replacement variable. */
5111 8112 : if (sym->as && sym->as->type == AS_ASSUMED_RANK
5112 7334 : && !(sym->ns && sym->ns->proc_name
5113 7334 : && sym->ns->proc_name->attr.proc == PROC_INTRINSIC))
5114 : {
5115 : assumed_rank_formal = true;
5116 : tmp = desc;
5117 : }
5118 : else
5119 8099 : tmp = gfc_conv_descriptor_data_get (desc);
5120 :
5121 8112 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5122 : PACKED_NO, tmp,
5123 : se->string_length,
5124 : assumed_rank_formal);
5125 :
5126 : /* Use DESC to work out the upper bounds, strides and offset. */
5127 8112 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
5128 : }
5129 : else
5130 : /* Otherwise we have a packed array. */
5131 270 : value = gfc_get_interface_mapping_array (&se->pre, sym,
5132 : PACKED_FULL, se->expr,
5133 : se->string_length,
5134 : false);
5135 :
5136 40484 : new_sym->backend_decl = value;
5137 : }
5138 :
5139 :
5140 : /* Called once all dummy argument mappings have been added to MAPPING,
5141 : but before the mapping is used to evaluate expressions. Pre-evaluate
5142 : the length of each argument, adding any initialization code to PRE and
5143 : any finalization code to POST. */
5144 :
5145 : static void
5146 130254 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
5147 : stmtblock_t * pre, stmtblock_t * post)
5148 : {
5149 130254 : gfc_interface_sym_mapping *sym;
5150 130254 : gfc_expr *expr;
5151 130254 : gfc_se se;
5152 :
5153 170738 : for (sym = mapping->syms; sym; sym = sym->next)
5154 40484 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
5155 2842 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
5156 : {
5157 214 : expr = sym->new_sym->n.sym->ts.u.cl->length;
5158 214 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5159 214 : gfc_init_se (&se, NULL);
5160 214 : gfc_conv_expr (&se, expr);
5161 214 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
5162 214 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
5163 214 : gfc_add_block_to_block (pre, &se.pre);
5164 214 : gfc_add_block_to_block (post, &se.post);
5165 :
5166 214 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
5167 : }
5168 130254 : }
5169 :
5170 :
5171 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5172 : constructor C. */
5173 :
5174 : static void
5175 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
5176 : gfc_constructor_base base)
5177 : {
5178 47 : gfc_constructor *c;
5179 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
5180 : {
5181 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
5182 381 : if (c->iterator)
5183 : {
5184 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
5185 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
5186 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
5187 : }
5188 : }
5189 47 : }
5190 :
5191 :
5192 : /* Like gfc_apply_interface_mapping_to_expr, but applied to
5193 : reference REF. */
5194 :
5195 : static void
5196 12585 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
5197 : gfc_ref * ref)
5198 : {
5199 12585 : int n;
5200 :
5201 14070 : for (; ref; ref = ref->next)
5202 1485 : switch (ref->type)
5203 : {
5204 : case REF_ARRAY:
5205 2915 : for (n = 0; n < ref->u.ar.dimen; n++)
5206 : {
5207 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
5208 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
5209 1650 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
5210 : }
5211 : break;
5212 :
5213 : case REF_COMPONENT:
5214 : case REF_INQUIRY:
5215 : break;
5216 :
5217 43 : case REF_SUBSTRING:
5218 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
5219 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
5220 43 : break;
5221 : }
5222 12585 : }
5223 :
5224 :
5225 : /* Convert intrinsic function calls into result expressions. */
5226 :
5227 : static bool
5228 2214 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
5229 : {
5230 2214 : gfc_symbol *sym;
5231 2214 : gfc_expr *new_expr;
5232 2214 : gfc_expr *arg1;
5233 2214 : gfc_expr *arg2;
5234 2214 : int d, dup;
5235 :
5236 2214 : arg1 = expr->value.function.actual->expr;
5237 2214 : if (expr->value.function.actual->next)
5238 2093 : arg2 = expr->value.function.actual->next->expr;
5239 : else
5240 : arg2 = NULL;
5241 :
5242 2214 : sym = arg1->symtree->n.sym;
5243 :
5244 2214 : if (sym->attr.dummy)
5245 : return false;
5246 :
5247 2190 : new_expr = NULL;
5248 :
5249 2190 : switch (expr->value.function.isym->id)
5250 : {
5251 929 : case GFC_ISYM_LEN:
5252 : /* TODO figure out why this condition is necessary. */
5253 929 : if (sym->attr.function
5254 43 : && (arg1->ts.u.cl->length == NULL
5255 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
5256 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
5257 : return false;
5258 :
5259 886 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
5260 886 : break;
5261 :
5262 228 : case GFC_ISYM_LEN_TRIM:
5263 228 : new_expr = gfc_copy_expr (arg1);
5264 228 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5265 :
5266 228 : if (!new_expr)
5267 : return false;
5268 :
5269 228 : gfc_replace_expr (arg1, new_expr);
5270 228 : return true;
5271 :
5272 606 : case GFC_ISYM_SIZE:
5273 606 : if (!sym->as || sym->as->rank == 0)
5274 : return false;
5275 :
5276 530 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5277 : {
5278 360 : dup = mpz_get_si (arg2->value.integer);
5279 360 : d = dup - 1;
5280 : }
5281 : else
5282 : {
5283 530 : dup = sym->as->rank;
5284 530 : d = 0;
5285 : }
5286 :
5287 542 : for (; d < dup; d++)
5288 : {
5289 530 : gfc_expr *tmp;
5290 :
5291 530 : if (!sym->as->upper[d] || !sym->as->lower[d])
5292 : {
5293 518 : gfc_free_expr (new_expr);
5294 518 : return false;
5295 : }
5296 :
5297 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
5298 : gfc_get_int_expr (gfc_default_integer_kind,
5299 : NULL, 1));
5300 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
5301 12 : if (new_expr)
5302 0 : new_expr = gfc_multiply (new_expr, tmp);
5303 : else
5304 : new_expr = tmp;
5305 : }
5306 : break;
5307 :
5308 44 : case GFC_ISYM_LBOUND:
5309 44 : case GFC_ISYM_UBOUND:
5310 : /* TODO These implementations of lbound and ubound do not limit if
5311 : the size < 0, according to F95's 13.14.53 and 13.14.113. */
5312 :
5313 44 : if (!sym->as || sym->as->rank == 0)
5314 : return false;
5315 :
5316 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
5317 38 : d = mpz_get_si (arg2->value.integer) - 1;
5318 : else
5319 : return false;
5320 :
5321 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
5322 : {
5323 23 : if (sym->as->lower[d])
5324 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
5325 : }
5326 : else
5327 : {
5328 15 : if (sym->as->upper[d])
5329 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
5330 : }
5331 : break;
5332 :
5333 : default:
5334 : break;
5335 : }
5336 :
5337 1319 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
5338 1319 : if (!new_expr)
5339 : return false;
5340 :
5341 113 : gfc_replace_expr (expr, new_expr);
5342 113 : return true;
5343 : }
5344 :
5345 :
5346 : static void
5347 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
5348 : gfc_interface_mapping * mapping)
5349 : {
5350 24 : gfc_formal_arglist *f;
5351 24 : gfc_actual_arglist *actual;
5352 :
5353 24 : actual = expr->value.function.actual;
5354 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
5355 :
5356 72 : for (; f && actual; f = f->next, actual = actual->next)
5357 : {
5358 24 : if (!actual->expr)
5359 0 : continue;
5360 :
5361 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
5362 : }
5363 :
5364 24 : if (map_expr->symtree->n.sym->attr.dimension)
5365 : {
5366 6 : int d;
5367 6 : gfc_array_spec *as;
5368 :
5369 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
5370 :
5371 18 : for (d = 0; d < as->rank; d++)
5372 : {
5373 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
5374 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
5375 : }
5376 :
5377 6 : expr->value.function.esym->as = as;
5378 : }
5379 :
5380 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
5381 : {
5382 0 : expr->value.function.esym->ts.u.cl->length
5383 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
5384 :
5385 0 : gfc_apply_interface_mapping_to_expr (mapping,
5386 0 : expr->value.function.esym->ts.u.cl->length);
5387 : }
5388 24 : }
5389 :
5390 :
5391 : /* EXPR is a copy of an expression that appeared in the interface
5392 : associated with MAPPING. Walk it recursively looking for references to
5393 : dummy arguments that MAPPING maps to actual arguments. Replace each such
5394 : reference with a reference to the associated actual argument. */
5395 :
5396 : static void
5397 21118 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
5398 : gfc_expr * expr)
5399 : {
5400 22683 : gfc_interface_sym_mapping *sym;
5401 22683 : gfc_actual_arglist *actual;
5402 :
5403 22683 : if (!expr)
5404 : return;
5405 :
5406 : /* Copying an expression does not copy its length, so do that here. */
5407 12585 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
5408 : {
5409 1784 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
5410 1784 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
5411 : }
5412 :
5413 : /* Apply the mapping to any references. */
5414 12585 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
5415 :
5416 : /* ...and to the expression's symbol, if it has one. */
5417 : /* TODO Find out why the condition on expr->symtree had to be moved into
5418 : the loop rather than being outside it, as originally. */
5419 29942 : for (sym = mapping->syms; sym; sym = sym->next)
5420 17357 : if (expr->symtree && !strcmp (sym->old->name, expr->symtree->n.sym->name))
5421 : {
5422 3370 : if (sym->new_sym->n.sym->backend_decl)
5423 3326 : expr->symtree = sym->new_sym;
5424 44 : else if (sym->expr)
5425 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
5426 : }
5427 :
5428 : /* ...and to subexpressions in expr->value. */
5429 12585 : switch (expr->expr_type)
5430 : {
5431 : case EXPR_VARIABLE:
5432 : case EXPR_CONSTANT:
5433 : case EXPR_NULL:
5434 : case EXPR_SUBSTRING:
5435 : break;
5436 :
5437 1565 : case EXPR_OP:
5438 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
5439 1565 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
5440 1565 : break;
5441 :
5442 0 : case EXPR_CONDITIONAL:
5443 0 : gfc_apply_interface_mapping_to_expr (mapping,
5444 0 : expr->value.conditional.true_expr);
5445 0 : gfc_apply_interface_mapping_to_expr (mapping,
5446 0 : expr->value.conditional.false_expr);
5447 0 : break;
5448 :
5449 2957 : case EXPR_FUNCTION:
5450 9502 : for (actual = expr->value.function.actual; actual; actual = actual->next)
5451 6545 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
5452 :
5453 2957 : if (expr->value.function.esym == NULL
5454 2644 : && expr->value.function.isym != NULL
5455 2632 : && expr->value.function.actual
5456 2631 : && expr->value.function.actual->expr
5457 2631 : && expr->value.function.actual->expr->symtree
5458 5171 : && gfc_map_intrinsic_function (expr, mapping))
5459 : break;
5460 :
5461 6154 : for (sym = mapping->syms; sym; sym = sym->next)
5462 3538 : if (sym->old == expr->value.function.esym)
5463 : {
5464 24 : expr->value.function.esym = sym->new_sym->n.sym;
5465 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
5466 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
5467 : }
5468 : break;
5469 :
5470 47 : case EXPR_ARRAY:
5471 47 : case EXPR_STRUCTURE:
5472 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
5473 47 : break;
5474 :
5475 0 : case EXPR_COMPCALL:
5476 0 : case EXPR_PPC:
5477 0 : case EXPR_UNKNOWN:
5478 0 : gcc_unreachable ();
5479 : break;
5480 : }
5481 :
5482 : return;
5483 : }
5484 :
5485 :
5486 : /* Evaluate interface expression EXPR using MAPPING. Store the result
5487 : in SE. */
5488 :
5489 : void
5490 4016 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
5491 : gfc_se * se, gfc_expr * expr)
5492 : {
5493 4016 : expr = gfc_copy_expr (expr);
5494 4016 : gfc_apply_interface_mapping_to_expr (mapping, expr);
5495 4016 : gfc_conv_expr (se, expr);
5496 4016 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
5497 4016 : gfc_free_expr (expr);
5498 4016 : }
5499 :
5500 :
5501 : /* Returns a reference to a temporary array into which a component of
5502 : an actual argument derived type array is copied and then returned
5503 : after the function call. */
5504 : void
5505 2616 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
5506 : sym_intent intent, bool formal_ptr,
5507 : const gfc_symbol *fsym, const char *proc_name,
5508 : gfc_symbol *sym, bool check_contiguous)
5509 : {
5510 2616 : gfc_se lse;
5511 2616 : gfc_se rse;
5512 2616 : gfc_ss *lss;
5513 2616 : gfc_ss *rss;
5514 2616 : gfc_loopinfo loop;
5515 2616 : gfc_loopinfo loop2;
5516 2616 : gfc_array_info *info;
5517 2616 : tree offset;
5518 2616 : tree tmp_index;
5519 2616 : tree tmp;
5520 2616 : tree base_type;
5521 2616 : tree size;
5522 2616 : stmtblock_t body;
5523 2616 : int n;
5524 2616 : int dimen;
5525 2616 : gfc_se work_se;
5526 2616 : gfc_se *parmse;
5527 2616 : bool pass_optional;
5528 2616 : bool readonly;
5529 :
5530 2616 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
5531 :
5532 2605 : if (pass_optional || check_contiguous)
5533 : {
5534 1363 : gfc_init_se (&work_se, NULL);
5535 1363 : parmse = &work_se;
5536 : }
5537 : else
5538 : parmse = se;
5539 :
5540 2616 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5541 : {
5542 : /* We will create a temporary array, so let us warn. */
5543 868 : char * msg;
5544 :
5545 868 : if (fsym && proc_name)
5546 868 : msg = xasprintf ("An array temporary was created for argument "
5547 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5548 : else
5549 0 : msg = xasprintf ("An array temporary was created");
5550 :
5551 868 : tmp = build_int_cst (logical_type_node, 1);
5552 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5553 : &expr->where, msg);
5554 868 : free (msg);
5555 : }
5556 :
5557 2616 : gfc_init_se (&lse, NULL);
5558 2616 : gfc_init_se (&rse, NULL);
5559 :
5560 : /* Walk the argument expression. */
5561 2616 : rss = gfc_walk_expr (expr);
5562 :
5563 2616 : gcc_assert (rss != gfc_ss_terminator);
5564 :
5565 : /* Initialize the scalarizer. */
5566 2616 : gfc_init_loopinfo (&loop);
5567 2616 : gfc_add_ss_to_loop (&loop, rss);
5568 :
5569 : /* Calculate the bounds of the scalarization. */
5570 2616 : gfc_conv_ss_startstride (&loop);
5571 :
5572 : /* Build an ss for the temporary. */
5573 2616 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5574 136 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5575 :
5576 2616 : base_type = gfc_typenode_for_spec (&expr->ts);
5577 2616 : if (GFC_ARRAY_TYPE_P (base_type)
5578 2616 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5579 0 : base_type = gfc_get_element_type (base_type);
5580 :
5581 2616 : if (expr->ts.type == BT_CLASS)
5582 121 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5583 :
5584 3780 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5585 1164 : ? expr->ts.u.cl->backend_decl
5586 : : NULL),
5587 : loop.dimen);
5588 :
5589 2616 : parmse->string_length = loop.temp_ss->info->string_length;
5590 :
5591 : /* Associate the SS with the loop. */
5592 2616 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5593 :
5594 : /* Setup the scalarizing loops. */
5595 2616 : gfc_conv_loop_setup (&loop, &expr->where);
5596 :
5597 : /* Pass the temporary descriptor back to the caller. */
5598 2616 : info = &loop.temp_ss->info->data.array;
5599 2616 : parmse->expr = info->descriptor;
5600 :
5601 : /* Setup the gfc_se structures. */
5602 2616 : gfc_copy_loopinfo_to_se (&lse, &loop);
5603 2616 : gfc_copy_loopinfo_to_se (&rse, &loop);
5604 :
5605 2616 : rse.ss = rss;
5606 2616 : lse.ss = loop.temp_ss;
5607 2616 : gfc_mark_ss_chain_used (rss, 1);
5608 2616 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5609 :
5610 : /* Start the scalarized loop body. */
5611 2616 : gfc_start_scalarized_body (&loop, &body);
5612 :
5613 : /* Translate the expression. */
5614 2616 : gfc_conv_expr (&rse, expr);
5615 :
5616 2616 : gfc_conv_tmp_array_ref (&lse);
5617 :
5618 2616 : if (intent != INTENT_OUT)
5619 : {
5620 2578 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5621 2578 : gfc_add_expr_to_block (&body, tmp);
5622 2578 : gcc_assert (rse.ss == gfc_ss_terminator);
5623 2578 : gfc_trans_scalarizing_loops (&loop, &body);
5624 : }
5625 : else
5626 : {
5627 : /* Make sure that the temporary declaration survives by merging
5628 : all the loop declarations into the current context. */
5629 85 : for (n = 0; n < loop.dimen; n++)
5630 : {
5631 47 : gfc_merge_block_scope (&body);
5632 47 : body = loop.code[loop.order[n]];
5633 : }
5634 38 : gfc_merge_block_scope (&body);
5635 : }
5636 :
5637 : /* Add the post block after the second loop, so that any
5638 : freeing of allocated memory is done at the right time. */
5639 2616 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5640 :
5641 : /**********Copy the temporary back again.*********/
5642 :
5643 2616 : gfc_init_se (&lse, NULL);
5644 2616 : gfc_init_se (&rse, NULL);
5645 :
5646 : /* Walk the argument expression. */
5647 2616 : lss = gfc_walk_expr (expr);
5648 2616 : rse.ss = loop.temp_ss;
5649 2616 : lse.ss = lss;
5650 :
5651 : /* Initialize the scalarizer. */
5652 2616 : gfc_init_loopinfo (&loop2);
5653 2616 : gfc_add_ss_to_loop (&loop2, lss);
5654 :
5655 2616 : dimen = rse.ss->dimen;
5656 :
5657 : /* Skip the write-out loop for this case. */
5658 2616 : if (gfc_is_class_array_function (expr))
5659 13 : goto class_array_fcn;
5660 :
5661 : /* Calculate the bounds of the scalarization. */
5662 2603 : gfc_conv_ss_startstride (&loop2);
5663 :
5664 : /* Setup the scalarizing loops. */
5665 2603 : gfc_conv_loop_setup (&loop2, &expr->where);
5666 :
5667 2603 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5668 2603 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5669 :
5670 2603 : gfc_mark_ss_chain_used (lss, 1);
5671 2603 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5672 :
5673 : /* Declare the variable to hold the temporary offset and start the
5674 : scalarized loop body. */
5675 2603 : offset = gfc_create_var (gfc_array_index_type, NULL);
5676 2603 : gfc_start_scalarized_body (&loop2, &body);
5677 :
5678 : /* Build the offsets for the temporary from the loop variables. The
5679 : temporary array has lbounds of zero and strides of one in all
5680 : dimensions, so this is very simple. The offset is only computed
5681 : outside the innermost loop, so the overall transfer could be
5682 : optimized further. */
5683 2603 : info = &rse.ss->info->data.array;
5684 :
5685 2603 : tmp_index = gfc_index_zero_node;
5686 3953 : for (n = dimen - 1; n > 0; n--)
5687 : {
5688 1350 : tree tmp_str;
5689 1350 : tmp = rse.loop->loopvar[n];
5690 1350 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5691 : tmp, rse.loop->from[n]);
5692 1350 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5693 : tmp, tmp_index);
5694 :
5695 2700 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5696 : gfc_array_index_type,
5697 1350 : rse.loop->to[n-1], rse.loop->from[n-1]);
5698 1350 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5699 : gfc_array_index_type,
5700 : tmp_str, gfc_index_one_node);
5701 :
5702 1350 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5703 : gfc_array_index_type, tmp, tmp_str);
5704 : }
5705 :
5706 5206 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5707 : gfc_array_index_type,
5708 2603 : tmp_index, rse.loop->from[0]);
5709 2603 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5710 :
5711 5206 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5712 : gfc_array_index_type,
5713 2603 : rse.loop->loopvar[0], offset);
5714 :
5715 : /* Now use the offset for the reference. */
5716 2603 : tmp = build_fold_indirect_ref_loc (input_location,
5717 : info->data);
5718 2603 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5719 :
5720 2603 : if (expr->ts.type == BT_CHARACTER)
5721 1164 : rse.string_length = expr->ts.u.cl->backend_decl;
5722 :
5723 2603 : gfc_conv_expr (&lse, expr);
5724 :
5725 2603 : gcc_assert (lse.ss == gfc_ss_terminator);
5726 :
5727 : /* Do not do deallocations when we are looking at a g77-style argument. */
5728 :
5729 2603 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, !g77);
5730 2603 : gfc_add_expr_to_block (&body, tmp);
5731 :
5732 : /* Generate the copying loops. */
5733 2603 : gfc_trans_scalarizing_loops (&loop2, &body);
5734 :
5735 : /* Wrap the whole thing up by adding the second loop to the post-block
5736 : and following it by the post-block of the first loop. In this way,
5737 : if the temporary needs freeing, it is done after use!
5738 : If input expr is read-only, e.g. a PARAMETER array, copying back
5739 : modified values is undefined behavior. */
5740 5206 : readonly = (expr->expr_type == EXPR_VARIABLE
5741 2549 : && expr->symtree
5742 5152 : && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
5743 :
5744 2603 : if ((intent != INTENT_IN) && !readonly)
5745 : {
5746 1170 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5747 1170 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5748 : }
5749 :
5750 1433 : class_array_fcn:
5751 :
5752 2616 : gfc_add_block_to_block (&parmse->post, &loop.post);
5753 :
5754 2616 : gfc_cleanup_loop (&loop);
5755 2616 : gfc_cleanup_loop (&loop2);
5756 :
5757 : /* Pass the string length to the argument expression. */
5758 2616 : if (expr->ts.type == BT_CHARACTER)
5759 1164 : parmse->string_length = expr->ts.u.cl->backend_decl;
5760 :
5761 : /* Determine the offset for pointer formal arguments and set the
5762 : lbounds to one. */
5763 2616 : if (formal_ptr)
5764 : {
5765 18 : size = gfc_index_one_node;
5766 18 : offset = gfc_index_zero_node;
5767 36 : for (n = 0; n < dimen; n++)
5768 : {
5769 18 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5770 : gfc_rank_cst[n]);
5771 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5772 : gfc_array_index_type, tmp,
5773 : gfc_index_one_node);
5774 18 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5775 : parmse->expr,
5776 : gfc_rank_cst[n],
5777 : tmp);
5778 18 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5779 : parmse->expr,
5780 : gfc_rank_cst[n],
5781 : gfc_index_one_node);
5782 18 : size = gfc_evaluate_now (size, &parmse->pre);
5783 18 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5784 : gfc_array_index_type,
5785 : offset, size);
5786 18 : offset = gfc_evaluate_now (offset, &parmse->pre);
5787 36 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5788 : gfc_array_index_type,
5789 18 : rse.loop->to[n], rse.loop->from[n]);
5790 18 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5791 : gfc_array_index_type,
5792 : tmp, gfc_index_one_node);
5793 18 : size = fold_build2_loc (input_location, MULT_EXPR,
5794 : gfc_array_index_type, size, tmp);
5795 : }
5796 :
5797 18 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5798 : offset);
5799 : }
5800 :
5801 : /* We want either the address for the data or the address of the descriptor,
5802 : depending on the mode of passing array arguments. */
5803 2616 : if (g77)
5804 441 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5805 : else
5806 2175 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5807 :
5808 : /* Basically make this into
5809 :
5810 : if (present)
5811 : {
5812 : if (contiguous)
5813 : {
5814 : pointer = a;
5815 : }
5816 : else
5817 : {
5818 : parmse->pre();
5819 : pointer = parmse->expr;
5820 : }
5821 : }
5822 : else
5823 : pointer = NULL;
5824 :
5825 : foo (pointer);
5826 : if (present && !contiguous)
5827 : se->post();
5828 :
5829 : */
5830 :
5831 2616 : if (pass_optional || check_contiguous)
5832 : {
5833 1363 : tree type;
5834 1363 : stmtblock_t else_block;
5835 1363 : tree pre_stmts, post_stmts;
5836 1363 : tree pointer;
5837 1363 : tree else_stmt;
5838 1363 : tree present_var = NULL_TREE;
5839 1363 : tree cont_var = NULL_TREE;
5840 1363 : tree post_cond;
5841 :
5842 1363 : type = TREE_TYPE (parmse->expr);
5843 1363 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5844 1027 : type = TREE_TYPE (type);
5845 1363 : pointer = gfc_create_var (type, "arg_ptr");
5846 :
5847 1363 : if (check_contiguous)
5848 : {
5849 1363 : gfc_se cont_se, array_se;
5850 1363 : stmtblock_t if_block, else_block;
5851 1363 : tree if_stmt, else_stmt;
5852 1363 : mpz_t size;
5853 1363 : bool size_set;
5854 :
5855 1363 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5856 :
5857 : /* If the size is known to be one at compile-time, set
5858 : cont_var to true unconditionally. This may look
5859 : inelegant, but we're only doing this during
5860 : optimization, so the statements will be optimized away,
5861 : and this saves complexity here. */
5862 :
5863 1363 : size_set = gfc_array_size (expr, &size);
5864 1363 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5865 : {
5866 6 : gfc_add_modify (&se->pre, cont_var,
5867 : build_one_cst (boolean_type_node));
5868 : }
5869 : else
5870 : {
5871 : /* cont_var = is_contiguous (expr); . */
5872 1357 : gfc_init_se (&cont_se, parmse);
5873 1357 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5874 1357 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5875 1357 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5876 1357 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5877 : }
5878 :
5879 1363 : if (size_set)
5880 1149 : mpz_clear (size);
5881 :
5882 : /* arrayse->expr = descriptor of a. */
5883 1363 : gfc_init_se (&array_se, se);
5884 1363 : gfc_conv_expr_descriptor (&array_se, expr);
5885 1363 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5886 1363 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5887 :
5888 : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5889 1363 : gfc_init_block (&if_block);
5890 1363 : if (GFC_DESCRIPTOR_TYPE_P (type))
5891 1027 : gfc_add_modify (&if_block, pointer, array_se.expr);
5892 : else
5893 : {
5894 336 : tmp = gfc_conv_array_data (array_se.expr);
5895 336 : tmp = fold_convert (type, tmp);
5896 336 : gfc_add_modify (&if_block, pointer, tmp);
5897 : }
5898 1363 : if_stmt = gfc_finish_block (&if_block);
5899 :
5900 : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5901 1363 : gfc_init_block (&else_block);
5902 1363 : gfc_add_block_to_block (&else_block, &parmse->pre);
5903 1699 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5904 1363 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5905 : : parmse->expr);
5906 1363 : gfc_add_modify (&else_block, pointer, tmp);
5907 1363 : else_stmt = gfc_finish_block (&else_block);
5908 :
5909 : /* And put the above into an if statement. */
5910 1363 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5911 : gfc_likely (cont_var,
5912 : PRED_FORTRAN_CONTIGUOUS),
5913 : if_stmt, else_stmt);
5914 : }
5915 : else
5916 : {
5917 : /* pointer = pramse->expr; . */
5918 0 : gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5919 0 : pre_stmts = gfc_finish_block (&parmse->pre);
5920 : }
5921 :
5922 1363 : if (pass_optional)
5923 : {
5924 11 : present_var = gfc_create_var (boolean_type_node, "present");
5925 :
5926 : /* present_var = present(sym); . */
5927 11 : tmp = gfc_conv_expr_present (sym);
5928 11 : tmp = fold_convert (boolean_type_node, tmp);
5929 11 : gfc_add_modify (&se->pre, present_var, tmp);
5930 :
5931 : /* else_stmt = { pointer = NULL; } . */
5932 11 : gfc_init_block (&else_block);
5933 11 : if (GFC_DESCRIPTOR_TYPE_P (type))
5934 0 : gfc_conv_descriptor_data_set (&else_block, pointer,
5935 : null_pointer_node);
5936 : else
5937 11 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5938 11 : else_stmt = gfc_finish_block (&else_block);
5939 :
5940 11 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5941 : gfc_likely (present_var,
5942 : PRED_FORTRAN_ABSENT_DUMMY),
5943 : pre_stmts, else_stmt);
5944 11 : gfc_add_expr_to_block (&se->pre, tmp);
5945 : }
5946 : else
5947 1352 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5948 :
5949 1363 : post_stmts = gfc_finish_block (&parmse->post);
5950 :
5951 : /* Put together the post stuff, plus the optional
5952 : deallocation. */
5953 1363 : if (check_contiguous)
5954 : {
5955 : /* !cont_var. */
5956 1363 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5957 : cont_var,
5958 : build_zero_cst (boolean_type_node));
5959 1363 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5960 :
5961 1363 : if (pass_optional)
5962 : {
5963 11 : tree present_likely = gfc_likely (present_var,
5964 : PRED_FORTRAN_ABSENT_DUMMY);
5965 11 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5966 : boolean_type_node, present_likely,
5967 : tmp);
5968 : }
5969 : else
5970 : post_cond = tmp;
5971 : }
5972 : else
5973 : {
5974 0 : gcc_assert (pass_optional);
5975 : post_cond = present_var;
5976 : }
5977 :
5978 1363 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5979 : post_stmts, build_empty_stmt (input_location));
5980 1363 : gfc_add_expr_to_block (&se->post, tmp);
5981 1363 : if (GFC_DESCRIPTOR_TYPE_P (type))
5982 : {
5983 1027 : type = TREE_TYPE (parmse->expr);
5984 1027 : if (POINTER_TYPE_P (type))
5985 : {
5986 1027 : pointer = gfc_build_addr_expr (type, pointer);
5987 1027 : if (pass_optional)
5988 : {
5989 0 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5990 0 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
5991 : tmp, pointer,
5992 : fold_convert (type,
5993 : null_pointer_node));
5994 : }
5995 : }
5996 : else
5997 0 : gcc_assert (!pass_optional);
5998 : }
5999 1363 : se->expr = pointer;
6000 : }
6001 :
6002 2616 : return;
6003 : }
6004 :
6005 :
6006 : /* Generate the code for argument list functions. */
6007 :
6008 : static void
6009 5826 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
6010 : {
6011 : /* Pass by value for g77 %VAL(arg), pass the address
6012 : indirectly for %LOC, else by reference. Thus %REF
6013 : is a "do-nothing" and %LOC is the same as an F95
6014 : pointer. */
6015 5826 : if (strcmp (name, "%VAL") == 0)
6016 5814 : gfc_conv_expr (se, expr);
6017 12 : else if (strcmp (name, "%LOC") == 0)
6018 : {
6019 6 : gfc_conv_expr_reference (se, expr);
6020 6 : se->expr = gfc_build_addr_expr (NULL, se->expr);
6021 : }
6022 6 : else if (strcmp (name, "%REF") == 0)
6023 6 : gfc_conv_expr_reference (se, expr);
6024 : else
6025 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
6026 5826 : }
6027 :
6028 :
6029 : /* This function tells whether the middle-end representation of the expression
6030 : E given as input may point to data otherwise accessible through a variable
6031 : (sub-)reference.
6032 : It is assumed that the only expressions that may alias are variables,
6033 : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
6034 : may alias.
6035 : This function is used to decide whether freeing an expression's allocatable
6036 : components is safe or should be avoided.
6037 :
6038 : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
6039 : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
6040 : is necessary because for array constructors, aliasing depends on how
6041 : the array is used:
6042 : - If E is an array constructor used as argument to an elemental procedure,
6043 : the array, which is generated through shallow copy by the scalarizer,
6044 : is used directly and can alias the expressions it was copied from.
6045 : - If E is an array constructor used as argument to a non-elemental
6046 : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
6047 : the array as in the previous case, but then that array is used
6048 : to initialize a new descriptor through deep copy. There is no alias
6049 : possible in that case.
6050 : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
6051 : above. */
6052 :
6053 : static bool
6054 7617 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
6055 : {
6056 7617 : gfc_constructor *c;
6057 :
6058 7617 : if (e->expr_type == EXPR_VARIABLE)
6059 : return true;
6060 550 : else if (e->expr_type == EXPR_FUNCTION)
6061 : {
6062 161 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
6063 :
6064 161 : if (proc_ifc->result != NULL
6065 161 : && ((proc_ifc->result->ts.type == BT_CLASS
6066 25 : && proc_ifc->result->ts.u.derived->attr.is_class
6067 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
6068 161 : || proc_ifc->result->attr.pointer))
6069 : return true;
6070 : else
6071 : return false;
6072 : }
6073 389 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
6074 : return false;
6075 :
6076 79 : for (c = gfc_constructor_first (e->value.constructor);
6077 233 : c; c = gfc_constructor_next (c))
6078 189 : if (c->expr
6079 189 : && expr_may_alias_variables (c->expr, array_may_alias))
6080 : return true;
6081 :
6082 : return false;
6083 : }
6084 :
6085 :
6086 : /* A helper function to set the dtype for unallocated or unassociated
6087 : entities. */
6088 :
6089 : static void
6090 891 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
6091 : {
6092 891 : tree tmp;
6093 891 : tree desc;
6094 891 : tree cond;
6095 891 : tree type;
6096 891 : stmtblock_t block;
6097 :
6098 : /* TODO Figure out how to handle optional dummies. */
6099 891 : if (e && e->expr_type == EXPR_VARIABLE
6100 807 : && e->symtree->n.sym->attr.optional)
6101 108 : return;
6102 :
6103 819 : desc = parmse->expr;
6104 819 : if (desc == NULL_TREE)
6105 : return;
6106 :
6107 819 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
6108 819 : desc = build_fold_indirect_ref_loc (input_location, desc);
6109 819 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
6110 192 : desc = gfc_class_data_get (desc);
6111 819 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
6112 : return;
6113 :
6114 783 : gfc_init_block (&block);
6115 783 : tmp = gfc_conv_descriptor_data_get (desc);
6116 783 : cond = fold_build2_loc (input_location, EQ_EXPR,
6117 : logical_type_node, tmp,
6118 783 : build_int_cst (TREE_TYPE (tmp), 0));
6119 783 : tmp = gfc_conv_descriptor_dtype (desc);
6120 783 : type = gfc_get_element_type (TREE_TYPE (desc));
6121 1566 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6122 783 : TREE_TYPE (tmp), tmp,
6123 : gfc_get_dtype_rank_type (e->rank, type));
6124 783 : gfc_add_expr_to_block (&block, tmp);
6125 783 : cond = build3_v (COND_EXPR, cond,
6126 : gfc_finish_block (&block),
6127 : build_empty_stmt (input_location));
6128 783 : gfc_add_expr_to_block (&parmse->pre, cond);
6129 : }
6130 :
6131 :
6132 :
6133 : /* Provide an interface between gfortran array descriptors and the F2018:18.4
6134 : ISO_Fortran_binding array descriptors. */
6135 :
6136 : static void
6137 6537 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
6138 : {
6139 6537 : stmtblock_t block, block2;
6140 6537 : tree cfi, gfc, tmp, tmp2;
6141 6537 : tree present = NULL;
6142 6537 : tree gfc_strlen = NULL;
6143 6537 : tree rank;
6144 6537 : gfc_se se;
6145 :
6146 6537 : if (fsym->attr.optional
6147 1094 : && e->expr_type == EXPR_VARIABLE
6148 1094 : && e->symtree->n.sym->attr.optional)
6149 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
6150 :
6151 6537 : gfc_init_block (&block);
6152 :
6153 : /* Convert original argument to a tree. */
6154 6537 : gfc_init_se (&se, NULL);
6155 6537 : if (e->rank == 0)
6156 : {
6157 687 : se.want_pointer = 1;
6158 687 : gfc_conv_expr (&se, e);
6159 687 : gfc = se.expr;
6160 : }
6161 : else
6162 : {
6163 : /* If the actual argument can be noncontiguous, copy-in/out is required,
6164 : if the dummy has either the CONTIGUOUS attribute or is an assumed-
6165 : length assumed-length/assumed-size CHARACTER array. This only
6166 : applies if the actual argument is a "variable"; if it's some
6167 : non-lvalue expression, we are going to evaluate it to a
6168 : temporary below anyway. */
6169 5850 : se.force_no_tmp = 1;
6170 5850 : if ((fsym->attr.contiguous
6171 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
6172 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
6173 937 : || fsym->as->type == AS_EXPLICIT)))
6174 2023 : && !gfc_is_simply_contiguous (e, false, true)
6175 6883 : && gfc_expr_is_variable (e))
6176 : {
6177 1027 : bool optional = fsym->attr.optional;
6178 1027 : fsym->attr.optional = 0;
6179 1027 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
6180 1027 : fsym->attr.pointer, fsym,
6181 1027 : fsym->ns->proc_name->name, NULL,
6182 : /* check_contiguous= */ true);
6183 1027 : fsym->attr.optional = optional;
6184 : }
6185 : else
6186 4823 : gfc_conv_expr_descriptor (&se, e);
6187 5850 : gfc = se.expr;
6188 : /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
6189 : elem_len = sizeof(dt) and base_addr = dt(lb) instead.
6190 : gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
6191 : While sm is fine as it uses span*stride and not elem_len. */
6192 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
6193 1027 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
6194 4823 : else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
6195 12 : gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
6196 : }
6197 6537 : if (e->ts.type == BT_CHARACTER)
6198 : {
6199 3409 : if (se.string_length)
6200 : gfc_strlen = se.string_length;
6201 883 : else if (e->ts.u.cl->backend_decl)
6202 : gfc_strlen = e->ts.u.cl->backend_decl;
6203 : else
6204 0 : gcc_unreachable ();
6205 : }
6206 6537 : gfc_add_block_to_block (&block, &se.pre);
6207 :
6208 : /* Create array descriptor and set version, rank, attribute, type. */
6209 12769 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
6210 : ? GFC_MAX_DIMENSIONS : e->rank,
6211 : false), "cfi");
6212 : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
6213 6537 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
6214 : {
6215 2516 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
6216 2338 : tmp = build_pointer_type (tmp);
6217 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
6218 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
6219 : }
6220 : else
6221 4199 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
6222 :
6223 6537 : tmp = gfc_get_cfi_desc_version (cfi);
6224 6537 : gfc_add_modify (&block, tmp,
6225 6537 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
6226 6537 : if (e->rank < 0)
6227 305 : rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
6228 : else
6229 6232 : rank = build_int_cst (signed_char_type_node, e->rank);
6230 6537 : tmp = gfc_get_cfi_desc_rank (cfi);
6231 6537 : gfc_add_modify (&block, tmp, rank);
6232 6537 : int itype = CFI_type_other;
6233 6537 : if (e->ts.f90_type == BT_VOID)
6234 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6235 96 : ? CFI_type_cfunptr : CFI_type_cptr);
6236 : else
6237 : {
6238 6441 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
6239 1 : e->ts = fsym->ts;
6240 6441 : switch (e->ts.type)
6241 : {
6242 2296 : case BT_INTEGER:
6243 2296 : case BT_LOGICAL:
6244 2296 : case BT_REAL:
6245 2296 : case BT_COMPLEX:
6246 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
6247 2296 : break;
6248 3410 : case BT_CHARACTER:
6249 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
6250 3410 : break;
6251 : case BT_DERIVED:
6252 6537 : itype = CFI_type_struct;
6253 : break;
6254 0 : case BT_VOID:
6255 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
6256 0 : ? CFI_type_cfunptr : CFI_type_cptr);
6257 : break;
6258 : case BT_ASSUMED:
6259 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6260 : break;
6261 1 : case BT_CLASS:
6262 1 : if (fsym->ts.type == BT_ASSUMED)
6263 : {
6264 : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
6265 : // type specifier is assumed-type and is an unlimited polymorphic
6266 : // entity." The actual argument _data component is passed.
6267 : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
6268 : break;
6269 : }
6270 : else
6271 0 : gcc_unreachable ();
6272 :
6273 0 : case BT_UNSIGNED:
6274 0 : gfc_internal_error ("Unsigned not yet implemented");
6275 :
6276 0 : case BT_PROCEDURE:
6277 0 : case BT_HOLLERITH:
6278 0 : case BT_UNION:
6279 0 : case BT_BOZ:
6280 0 : case BT_UNKNOWN:
6281 : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
6282 0 : gcc_unreachable ();
6283 : }
6284 : }
6285 :
6286 6537 : tmp = gfc_get_cfi_desc_type (cfi);
6287 6537 : gfc_add_modify (&block, tmp,
6288 6537 : build_int_cst (TREE_TYPE (tmp), itype));
6289 :
6290 6537 : int attr = CFI_attribute_other;
6291 6537 : if (fsym->attr.pointer)
6292 : attr = CFI_attribute_pointer;
6293 5774 : else if (fsym->attr.allocatable)
6294 433 : attr = CFI_attribute_allocatable;
6295 6537 : tmp = gfc_get_cfi_desc_attribute (cfi);
6296 6537 : gfc_add_modify (&block, tmp,
6297 6537 : build_int_cst (TREE_TYPE (tmp), attr));
6298 :
6299 : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
6300 : That is very sensible for undefined pointers, but the C code might assume
6301 : that the pointer retains the value, in particular, if it was NULL. */
6302 6537 : if (e->rank == 0)
6303 : {
6304 687 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6305 687 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
6306 : }
6307 : else
6308 : {
6309 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6310 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
6311 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
6312 : }
6313 :
6314 : /* Set elem_len if known - must be before the next if block.
6315 : Note that allocatable implies 'len=:'. */
6316 6537 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
6317 : {
6318 : /* Length is known at compile time; use 'block' for it. */
6319 3073 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
6320 3073 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6321 3073 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6322 : }
6323 :
6324 6537 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
6325 91 : goto done;
6326 :
6327 : /* When allocatable + intent out, free the cfi descriptor. */
6328 6446 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
6329 : {
6330 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6331 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
6332 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
6333 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
6334 90 : gfc_add_modify (&block, tmp,
6335 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
6336 90 : goto done;
6337 : }
6338 :
6339 : /* If not unallocated/unassociated. */
6340 6356 : gfc_init_block (&block2);
6341 :
6342 : /* Set elem_len, which may be only known at run time. */
6343 6356 : if (e->ts.type == BT_CHARACTER
6344 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
6345 : {
6346 3408 : gcc_assert (gfc_strlen);
6347 3409 : tmp = gfc_strlen;
6348 3409 : if (e->ts.kind != 1)
6349 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
6350 : gfc_charlen_type_node, tmp,
6351 : build_int_cst (gfc_charlen_type_node,
6352 1117 : e->ts.kind));
6353 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6354 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6355 : }
6356 2947 : else if (e->ts.type == BT_ASSUMED)
6357 : {
6358 54 : tmp = gfc_conv_descriptor_elem_len (gfc);
6359 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
6360 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
6361 : }
6362 :
6363 6356 : if (e->ts.type == BT_ASSUMED)
6364 : {
6365 : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
6366 : an CFI descriptor. Use the type in the descriptor as it provide
6367 : mode information. (Quality of implementation feature.) */
6368 54 : tree cond;
6369 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
6370 54 : tree type = fold_convert (TREE_TYPE (ctype),
6371 : gfc_conv_descriptor_type (gfc));
6372 54 : tree kind = fold_convert (TREE_TYPE (ctype),
6373 : gfc_conv_descriptor_elem_len (gfc));
6374 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
6375 54 : kind, build_int_cst (TREE_TYPE (type),
6376 : CFI_type_kind_shift));
6377 :
6378 : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
6379 : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
6380 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6381 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
6382 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6383 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
6384 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6385 : ctype,
6386 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
6387 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6388 : tmp, tmp2);
6389 : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
6390 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6391 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
6392 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
6393 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
6394 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6395 : tmp, tmp2);
6396 : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
6397 : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
6398 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6399 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
6400 54 : tmp = build_int_cst (TREE_TYPE (type),
6401 : CFI_type_from_type_kind (CFI_type_Character, 1));
6402 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6403 : ctype, tmp);
6404 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6405 : tmp, tmp2);
6406 : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
6407 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6408 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
6409 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
6410 54 : kind, build_int_cst (TREE_TYPE (type), 2));
6411 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
6412 54 : build_int_cst (TREE_TYPE (type),
6413 : CFI_type_Complex));
6414 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6415 : ctype, tmp);
6416 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6417 : tmp, tmp2);
6418 : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
6419 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6420 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
6421 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6422 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
6423 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6424 : cond, tmp);
6425 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
6426 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
6427 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
6428 : cond, tmp);
6429 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
6430 : type, kind);
6431 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6432 : ctype, tmp);
6433 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
6434 : tmp, tmp2);
6435 54 : gfc_add_expr_to_block (&block2, tmp2);
6436 : }
6437 :
6438 6356 : if (e->rank != 0)
6439 : {
6440 : /* Loop: for (i = 0; i < rank; ++i). */
6441 5735 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6442 : /* Loop body. */
6443 5735 : stmtblock_t loop_body;
6444 5735 : gfc_init_block (&loop_body);
6445 : /* cfi->dim[i].lower_bound = (allocatable/pointer)
6446 : ? gfc->dim[i].lbound : 0 */
6447 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
6448 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
6449 : else
6450 5087 : tmp = gfc_index_zero_node;
6451 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
6452 : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
6453 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6454 : gfc_conv_descriptor_ubound_get (gfc, idx),
6455 : gfc_conv_descriptor_lbound_get (gfc, idx));
6456 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6457 : tmp, gfc_index_one_node);
6458 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
6459 : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
6460 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6461 : gfc_conv_descriptor_stride_get (gfc, idx),
6462 : gfc_conv_descriptor_span_get (gfc));
6463 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
6464 :
6465 : /* Generate loop. */
6466 11470 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6467 5735 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6468 : gfc_finish_block (&loop_body));
6469 :
6470 5735 : if (e->expr_type == EXPR_VARIABLE
6471 5573 : && e->ref
6472 5573 : && e->ref->u.ar.type == AR_FULL
6473 2732 : && e->symtree->n.sym->attr.dummy
6474 988 : && e->symtree->n.sym->as
6475 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6476 : {
6477 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
6478 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
6479 : }
6480 : }
6481 :
6482 6356 : if (fsym->attr.allocatable || fsym->attr.pointer)
6483 : {
6484 1015 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6485 1015 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6486 : tmp, null_pointer_node);
6487 1015 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6488 : build_empty_stmt (input_location));
6489 1015 : gfc_add_expr_to_block (&block, tmp);
6490 : }
6491 : else
6492 5341 : gfc_add_block_to_block (&block, &block2);
6493 :
6494 :
6495 6537 : done:
6496 6537 : if (present)
6497 : {
6498 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
6499 103 : TREE_TYPE (parmse->expr),
6500 : present, parmse->expr, null_pointer_node);
6501 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6502 : build_empty_stmt (input_location));
6503 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
6504 : }
6505 : else
6506 6434 : gfc_add_block_to_block (&parmse->pre, &block);
6507 :
6508 6537 : gfc_init_block (&block);
6509 :
6510 6537 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
6511 1196 : || fsym->attr.intent == INTENT_IN)
6512 5550 : goto post_call;
6513 :
6514 987 : gfc_init_block (&block2);
6515 987 : if (e->rank == 0)
6516 : {
6517 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6518 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
6519 : }
6520 : else
6521 : {
6522 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
6523 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
6524 :
6525 559 : if (fsym->attr.allocatable)
6526 : {
6527 : /* gfc->span = cfi->elem_len. */
6528 252 : tmp = fold_convert (gfc_array_index_type,
6529 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
6530 : }
6531 : else
6532 : {
6533 : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
6534 : ? cfi->dim[0].sm : cfi->elem_len). */
6535 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6536 307 : tmp2 = fold_convert (gfc_array_index_type,
6537 : gfc_get_cfi_desc_elem_len (cfi));
6538 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6539 : gfc_array_index_type, tmp, tmp2);
6540 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6541 : tmp, gfc_index_zero_node);
6542 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6543 : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6544 : }
6545 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6546 :
6547 : /* Calculate offset + set lbound, ubound and stride. */
6548 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6549 : /* Loop: for (i = 0; i < rank; ++i). */
6550 559 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6551 : /* Loop body. */
6552 559 : stmtblock_t loop_body;
6553 559 : gfc_init_block (&loop_body);
6554 : /* gfc->dim[i].lbound = ... */
6555 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6556 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6557 :
6558 : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6559 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6560 : gfc_conv_descriptor_lbound_get (gfc, idx),
6561 : gfc_index_one_node);
6562 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6563 : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6564 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6565 :
6566 : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6567 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6568 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6569 : gfc_array_index_type, tmp,
6570 : fold_convert (gfc_array_index_type,
6571 : gfc_get_cfi_desc_elem_len (cfi)));
6572 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6573 :
6574 : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6575 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6576 : gfc_conv_descriptor_stride_get (gfc, idx),
6577 : gfc_conv_descriptor_lbound_get (gfc, idx));
6578 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6579 : gfc_conv_descriptor_offset_get (gfc), tmp);
6580 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6581 : /* Generate loop. */
6582 1118 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6583 559 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6584 : gfc_finish_block (&loop_body));
6585 : }
6586 :
6587 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6588 : {
6589 60 : tmp = fold_convert (gfc_charlen_type_node,
6590 : gfc_get_cfi_desc_elem_len (cfi));
6591 60 : if (e->ts.kind != 1)
6592 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6593 : gfc_charlen_type_node, tmp,
6594 : build_int_cst (gfc_charlen_type_node,
6595 24 : e->ts.kind));
6596 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6597 : }
6598 :
6599 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6600 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6601 : tmp, null_pointer_node);
6602 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6603 : build_empty_stmt (input_location));
6604 987 : gfc_add_expr_to_block (&block, tmp);
6605 :
6606 6537 : post_call:
6607 6537 : gfc_add_block_to_block (&block, &se.post);
6608 6537 : if (present && block.head)
6609 : {
6610 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6611 : build_empty_stmt (input_location));
6612 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6613 : }
6614 6531 : else if (block.head)
6615 1564 : gfc_add_block_to_block (&parmse->post, &block);
6616 6537 : }
6617 :
6618 :
6619 : /* Create "conditional temporary" to handle scalar dummy variables with the
6620 : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6621 : as fallback. Does not handle CLASS. */
6622 :
6623 : static void
6624 234 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6625 : {
6626 234 : tree temp;
6627 234 : gcc_assert (e && e->ts.type != BT_CLASS);
6628 234 : gcc_assert (e->rank == 0);
6629 234 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6630 234 : TREE_STATIC (temp) = 1;
6631 234 : TREE_CONSTANT (temp) = 1;
6632 234 : TREE_READONLY (temp) = 1;
6633 234 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6634 234 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6635 234 : TREE_TYPE (parmse->expr),
6636 : cond, parmse->expr, temp);
6637 234 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6638 234 : }
6639 :
6640 :
6641 : /* Returns true if the type specified in TS is a character type whose length
6642 : is constant. Otherwise returns false. */
6643 :
6644 : static bool
6645 22033 : gfc_const_length_character_type_p (gfc_typespec *ts)
6646 : {
6647 22033 : return (ts->type == BT_CHARACTER
6648 467 : && ts->u.cl
6649 467 : && ts->u.cl->length
6650 467 : && ts->u.cl->length->expr_type == EXPR_CONSTANT
6651 22500 : && ts->u.cl->length->ts.type == BT_INTEGER);
6652 : }
6653 :
6654 :
6655 : /* Helper function for the handling of (currently) scalar dummy variables
6656 : with the VALUE attribute. Argument parmse should already be set up. */
6657 : static void
6658 22466 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6659 : vec<tree, va_gc> *& optionalargs)
6660 : {
6661 22466 : tree tmp;
6662 :
6663 22466 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6664 :
6665 22466 : if (IS_PDT (e))
6666 : {
6667 6 : tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT");
6668 6 : gfc_add_modify (&parmse->pre, tmp, parmse->expr);
6669 6 : gfc_add_expr_to_block (&parmse->pre,
6670 6 : gfc_copy_alloc_comp (e->ts.u.derived,
6671 : parmse->expr, tmp,
6672 : e->rank, 0));
6673 6 : parmse->expr = tmp;
6674 6 : tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank);
6675 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6676 6 : return;
6677 : }
6678 :
6679 : /* Absent actual argument for optional scalar dummy. */
6680 22460 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6681 : {
6682 : /* For scalar arguments with VALUE attribute which are passed by
6683 : value, pass "0" and a hidden argument for the optional status. */
6684 427 : if (fsym->ts.type == BT_CHARACTER)
6685 : {
6686 : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6687 : zero. */
6688 90 : parmse->expr = null_pointer_node;
6689 90 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6690 : }
6691 337 : else if (gfc_bt_struct (fsym->ts.type)
6692 30 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6693 : {
6694 : /* Pass null struct. Types c_ptr and c_funptr from ISO_C_BINDING
6695 : are pointers and passed as such below. */
6696 24 : tree temp = gfc_create_var (gfc_sym_type (fsym), "absent");
6697 24 : TREE_CONSTANT (temp) = 1;
6698 24 : TREE_READONLY (temp) = 1;
6699 24 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6700 24 : parmse->expr = temp;
6701 24 : }
6702 : else
6703 313 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6704 : integer_zero_node);
6705 427 : vec_safe_push (optionalargs, boolean_false_node);
6706 :
6707 427 : return;
6708 : }
6709 :
6710 : /* Truncate a too long constant character actual argument. */
6711 22033 : if (gfc_const_length_character_type_p (&fsym->ts)
6712 467 : && e->expr_type == EXPR_CONSTANT
6713 22116 : && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
6714 : e->value.character.length) < 0)
6715 : {
6716 17 : gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
6717 :
6718 : /* Truncate actual string argument. */
6719 17 : gfc_conv_expr (parmse, e);
6720 34 : parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
6721 17 : e->value.character.string);
6722 17 : parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
6723 :
6724 17 : if (flen == 1)
6725 : {
6726 14 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6727 14 : gfc_conv_string_parameter (parmse);
6728 14 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6729 : e->ts.kind);
6730 : }
6731 :
6732 : /* Indicate value,optional scalar dummy argument as present. */
6733 17 : if (fsym->attr.optional)
6734 1 : vec_safe_push (optionalargs, boolean_true_node);
6735 17 : return;
6736 : }
6737 :
6738 : /* gfortran argument passing conventions:
6739 : actual arguments to CHARACTER(len=1),VALUE
6740 : dummy arguments are actually passed by value.
6741 : Strings are truncated to length 1. */
6742 22016 : if (gfc_length_one_character_type_p (&fsym->ts))
6743 : {
6744 378 : if (e->expr_type == EXPR_CONSTANT
6745 54 : && e->value.character.length > 1)
6746 : {
6747 0 : e->value.character.length = 1;
6748 0 : gfc_conv_expr (parmse, e);
6749 : }
6750 :
6751 378 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6752 378 : gfc_conv_string_parameter (parmse);
6753 378 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6754 : e->ts.kind);
6755 : /* Truncate resulting string to length 1. */
6756 378 : parmse->string_length = slen1;
6757 : }
6758 :
6759 22016 : if (fsym->attr.optional && fsym->ts.type != BT_CLASS)
6760 : {
6761 : /* F2018:15.5.2.12 Argument presence and
6762 : restrictions on arguments not present. */
6763 823 : if (e->expr_type == EXPR_VARIABLE
6764 650 : && e->rank == 0
6765 1419 : && (gfc_expr_attr (e).allocatable
6766 482 : || gfc_expr_attr (e).pointer))
6767 : {
6768 198 : gfc_se argse;
6769 198 : tree cond;
6770 198 : gfc_init_se (&argse, NULL);
6771 198 : argse.want_pointer = 1;
6772 198 : gfc_conv_expr (&argse, e);
6773 198 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6774 198 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6775 : argse.expr, cond);
6776 198 : if (e->symtree->n.sym->attr.dummy)
6777 24 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
6778 : logical_type_node,
6779 : gfc_conv_expr_present (e->symtree->n.sym),
6780 : cond);
6781 198 : vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond));
6782 : /* Create "conditional temporary". */
6783 198 : conv_cond_temp (parmse, e, cond);
6784 : }
6785 625 : else if (e->expr_type != EXPR_VARIABLE
6786 452 : || !e->symtree->n.sym->attr.optional
6787 260 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6788 365 : vec_safe_push (optionalargs, boolean_true_node);
6789 : else
6790 : {
6791 260 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6792 260 : if (gfc_bt_struct (fsym->ts.type)
6793 36 : && !(fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING))
6794 36 : conv_cond_temp (parmse, e, tmp);
6795 224 : else if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6796 84 : parmse->expr
6797 168 : = fold_build3_loc (input_location, COND_EXPR,
6798 84 : TREE_TYPE (parmse->expr),
6799 : tmp, parmse->expr,
6800 84 : fold_convert (TREE_TYPE (parmse->expr),
6801 : integer_zero_node));
6802 :
6803 520 : vec_safe_push (optionalargs,
6804 260 : fold_convert (boolean_type_node, tmp));
6805 : }
6806 : }
6807 : }
6808 :
6809 :
6810 : /* Helper function for the handling of NULL() actual arguments associated with
6811 : non-optional dummy variables. Argument parmse should already be set up. */
6812 : static void
6813 426 : conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
6814 : {
6815 426 : gcc_assert (fsym && e->expr_type == EXPR_NULL);
6816 :
6817 : /* Obtain the character length for a NULL() actual with a character
6818 : MOLD argument. Otherwise substitute a suitable dummy length.
6819 : Here we handle only non-optional dummies of non-bind(c) procedures. */
6820 426 : if (fsym->ts.type == BT_CHARACTER)
6821 : {
6822 216 : if (e->ts.type == BT_CHARACTER
6823 162 : && e->symtree->n.sym->ts.type == BT_CHARACTER)
6824 : {
6825 : /* MOLD is present. Substitute a temporary character NULL pointer.
6826 : For an assumed-rank dummy we need a descriptor that passes the
6827 : correct rank. */
6828 162 : if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
6829 : {
6830 54 : tree rank;
6831 54 : tree tmp = parmse->expr;
6832 54 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6833 54 : rank = gfc_conv_descriptor_rank (tmp);
6834 54 : gfc_add_modify (&parmse->pre, rank,
6835 54 : build_int_cst (TREE_TYPE (rank), e->rank));
6836 54 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6837 54 : }
6838 : else
6839 : {
6840 108 : tree tmp = gfc_create_var (TREE_TYPE (parmse->expr), "null");
6841 108 : gfc_add_modify (&parmse->pre, tmp,
6842 108 : build_zero_cst (TREE_TYPE (tmp)));
6843 108 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6844 : }
6845 :
6846 : /* Ensure that a usable length is available. */
6847 162 : if (parmse->string_length == NULL_TREE)
6848 : {
6849 162 : gfc_typespec *ts = &e->symtree->n.sym->ts;
6850 :
6851 162 : if (ts->u.cl->length != NULL
6852 108 : && ts->u.cl->length->expr_type == EXPR_CONSTANT)
6853 108 : gfc_conv_const_charlen (ts->u.cl);
6854 :
6855 162 : if (ts->u.cl->backend_decl)
6856 162 : parmse->string_length = ts->u.cl->backend_decl;
6857 : }
6858 : }
6859 54 : else if (e->ts.type == BT_UNKNOWN && parmse->string_length == NULL_TREE)
6860 : {
6861 : /* MOLD is not present. Pass length of associated dummy character
6862 : argument if constant, or zero. */
6863 54 : if (fsym->ts.u.cl->length != NULL
6864 18 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6865 : {
6866 18 : gfc_conv_const_charlen (fsym->ts.u.cl);
6867 18 : parmse->string_length = fsym->ts.u.cl->backend_decl;
6868 : }
6869 : else
6870 : {
6871 36 : parmse->string_length = gfc_create_var (gfc_charlen_type_node,
6872 : "slen");
6873 36 : gfc_add_modify (&parmse->pre, parmse->string_length,
6874 : build_zero_cst (gfc_charlen_type_node));
6875 : }
6876 : }
6877 : }
6878 210 : else if (fsym->ts.type == BT_DERIVED)
6879 : {
6880 210 : if (e->ts.type != BT_UNKNOWN)
6881 : /* MOLD is present. Pass a corresponding temporary NULL pointer.
6882 : For an assumed-rank dummy we provide a descriptor that passes
6883 : the correct rank. */
6884 : {
6885 138 : tree rank;
6886 138 : tree tmp = parmse->expr;
6887 :
6888 138 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, gfc_expr_attr (e));
6889 138 : rank = gfc_conv_descriptor_rank (tmp);
6890 138 : gfc_add_modify (&parmse->pre, rank,
6891 138 : build_int_cst (TREE_TYPE (rank), e->rank));
6892 138 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6893 138 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6894 : }
6895 : else
6896 : /* MOLD is not present. Use attributes from dummy argument, which is
6897 : not allowed to be assumed-rank. */
6898 : {
6899 72 : int dummy_rank;
6900 72 : tree tmp = parmse->expr;
6901 :
6902 72 : if ((fsym->attr.allocatable || fsym->attr.pointer)
6903 72 : && fsym->attr.intent == INTENT_UNKNOWN)
6904 36 : fsym->attr.intent = INTENT_IN;
6905 72 : tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
6906 72 : dummy_rank = fsym->as ? fsym->as->rank : 0;
6907 24 : if (dummy_rank > 0)
6908 : {
6909 24 : tree rank = gfc_conv_descriptor_rank (tmp);
6910 24 : gfc_add_modify (&parmse->pre, rank,
6911 24 : build_int_cst (TREE_TYPE (rank), dummy_rank));
6912 : }
6913 72 : gfc_conv_descriptor_data_set (&parmse->pre, tmp, null_pointer_node);
6914 72 : parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
6915 : }
6916 : }
6917 426 : }
6918 :
6919 :
6920 : /* Generate code for a procedure call. Note can return se->post != NULL.
6921 : If se->direct_byref is set then se->expr contains the return parameter.
6922 : Return nonzero, if the call has alternate specifiers.
6923 : 'expr' is only needed for procedure pointer components. */
6924 :
6925 : int
6926 136020 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6927 : gfc_actual_arglist * args, gfc_expr * expr,
6928 : vec<tree, va_gc> *append_args)
6929 : {
6930 136020 : gfc_interface_mapping mapping;
6931 136020 : vec<tree, va_gc> *arglist;
6932 136020 : vec<tree, va_gc> *retargs;
6933 136020 : tree tmp;
6934 136020 : tree fntype;
6935 136020 : gfc_se parmse;
6936 136020 : gfc_array_info *info;
6937 136020 : int byref;
6938 136020 : int parm_kind;
6939 136020 : tree type;
6940 136020 : tree var;
6941 136020 : tree len;
6942 136020 : tree base_object;
6943 136020 : vec<tree, va_gc> *stringargs;
6944 136020 : vec<tree, va_gc> *optionalargs;
6945 136020 : tree result = NULL;
6946 136020 : gfc_formal_arglist *formal;
6947 136020 : gfc_actual_arglist *arg;
6948 136020 : int has_alternate_specifier = 0;
6949 136020 : bool need_interface_mapping;
6950 136020 : bool is_builtin;
6951 136020 : bool callee_alloc;
6952 136020 : bool ulim_copy;
6953 136020 : gfc_typespec ts;
6954 136020 : gfc_charlen cl;
6955 136020 : gfc_expr *e;
6956 136020 : gfc_symbol *fsym;
6957 136020 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6958 136020 : gfc_component *comp = NULL;
6959 136020 : int arglen;
6960 136020 : unsigned int argc;
6961 136020 : tree arg1_cntnr = NULL_TREE;
6962 136020 : arglist = NULL;
6963 136020 : retargs = NULL;
6964 136020 : stringargs = NULL;
6965 136020 : optionalargs = NULL;
6966 136020 : var = NULL_TREE;
6967 136020 : len = NULL_TREE;
6968 136020 : gfc_clear_ts (&ts);
6969 136020 : gfc_intrinsic_sym *isym = expr && expr->rank ?
6970 : expr->value.function.isym : NULL;
6971 :
6972 136020 : comp = gfc_get_proc_ptr_comp (expr);
6973 :
6974 272040 : bool elemental_proc = (comp
6975 2029 : && comp->ts.interface
6976 1975 : && comp->ts.interface->attr.elemental)
6977 1830 : || (comp && comp->attr.elemental)
6978 137850 : || sym->attr.elemental;
6979 :
6980 136020 : if (se->ss != NULL)
6981 : {
6982 25010 : if (!elemental_proc)
6983 : {
6984 21457 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
6985 21457 : if (se->ss->info->useflags)
6986 : {
6987 5766 : gcc_assert ((!comp && gfc_return_by_reference (sym)
6988 : && sym->result->attr.dimension)
6989 : || (comp && comp->attr.dimension)
6990 : || gfc_is_class_array_function (expr));
6991 5766 : gcc_assert (se->loop != NULL);
6992 : /* Access the previously obtained result. */
6993 5766 : gfc_conv_tmp_array_ref (se);
6994 5766 : return 0;
6995 : }
6996 : }
6997 19244 : info = &se->ss->info->data.array;
6998 : }
6999 : else
7000 : info = NULL;
7001 :
7002 130254 : stmtblock_t post, clobbers, dealloc_blk;
7003 130254 : gfc_init_block (&post);
7004 130254 : gfc_init_block (&clobbers);
7005 130254 : gfc_init_block (&dealloc_blk);
7006 130254 : gfc_init_interface_mapping (&mapping);
7007 130254 : if (!comp)
7008 : {
7009 128274 : formal = gfc_sym_get_dummy_args (sym);
7010 128274 : need_interface_mapping = sym->attr.dimension ||
7011 112835 : (sym->ts.type == BT_CHARACTER
7012 3167 : && sym->ts.u.cl->length
7013 2427 : && sym->ts.u.cl->length->expr_type
7014 : != EXPR_CONSTANT);
7015 : }
7016 : else
7017 : {
7018 1980 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
7019 1980 : need_interface_mapping = comp->attr.dimension ||
7020 1911 : (comp->ts.type == BT_CHARACTER
7021 229 : && comp->ts.u.cl->length
7022 220 : && comp->ts.u.cl->length->expr_type
7023 : != EXPR_CONSTANT);
7024 : }
7025 :
7026 130254 : base_object = NULL_TREE;
7027 : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
7028 : is the third and fourth argument to such a function call a value
7029 : denoting the number of elements to copy (i.e., most of the time the
7030 : length of a deferred length string). */
7031 260508 : ulim_copy = (formal == NULL)
7032 31835 : && UNLIMITED_POLY (sym)
7033 130334 : && comp && (strcmp ("_copy", comp->name) == 0);
7034 :
7035 : /* Scan for allocatable actual arguments passed to allocatable dummy
7036 : arguments with INTENT(OUT). As the corresponding actual arguments are
7037 : deallocated before execution of the procedure, we evaluate actual
7038 : argument expressions to avoid problems with possible dependencies. */
7039 130254 : bool force_eval_args = false;
7040 130254 : gfc_formal_arglist *tmp_formal;
7041 400377 : for (arg = args, tmp_formal = formal; arg != NULL;
7042 236809 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
7043 : {
7044 270623 : e = arg->expr;
7045 270623 : fsym = tmp_formal ? tmp_formal->sym : NULL;
7046 257231 : if (e && fsym
7047 225344 : && e->expr_type == EXPR_VARIABLE
7048 99075 : && fsym->attr.intent == INTENT_OUT
7049 6311 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
7050 6311 : ? CLASS_DATA (fsym)->attr.allocatable
7051 4783 : : fsym->attr.allocatable)
7052 500 : && e->symtree
7053 500 : && e->symtree->n.sym
7054 527854 : && gfc_variable_attr (e, NULL).allocatable)
7055 : {
7056 : force_eval_args = true;
7057 : break;
7058 : }
7059 : }
7060 :
7061 : /* Evaluate the arguments. */
7062 401279 : for (arg = args, argc = 0; arg != NULL;
7063 271025 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
7064 : {
7065 271025 : bool finalized = false;
7066 271025 : tree derived_array = NULL_TREE;
7067 271025 : symbol_attribute *attr;
7068 :
7069 271025 : e = arg->expr;
7070 271025 : fsym = formal ? formal->sym : NULL;
7071 508736 : parm_kind = MISSING;
7072 :
7073 237711 : attr = fsym ? &(fsym->ts.type == BT_CLASS ? CLASS_DATA (fsym)->attr
7074 : : fsym->attr)
7075 : : nullptr;
7076 : /* If the procedure requires an explicit interface, the actual
7077 : argument is passed according to the corresponding formal
7078 : argument. If the corresponding formal argument is a POINTER,
7079 : ALLOCATABLE or assumed shape, we do not use g77's calling
7080 : convention, and pass the address of the array descriptor
7081 : instead. Otherwise we use g77's calling convention, in other words
7082 : pass the array data pointer without descriptor. */
7083 237658 : bool nodesc_arg = fsym != NULL
7084 237658 : && !(fsym->attr.pointer || fsym->attr.allocatable)
7085 228568 : && fsym->as
7086 40599 : && fsym->as->type != AS_ASSUMED_SHAPE
7087 24733 : && fsym->as->type != AS_ASSUMED_RANK;
7088 271025 : if (comp)
7089 2733 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
7090 : else
7091 268292 : nodesc_arg
7092 : = nodesc_arg
7093 268292 : || !(sym->attr.always_explicit || (attr && attr->codimension));
7094 :
7095 : /* Class array expressions are sometimes coming completely unadorned
7096 : with either arrayspec or _data component. Correct that here.
7097 : OOP-TODO: Move this to the frontend. */
7098 271025 : if (e && e->expr_type == EXPR_VARIABLE
7099 113176 : && !e->ref
7100 51544 : && e->ts.type == BT_CLASS
7101 2603 : && (CLASS_DATA (e)->attr.codimension
7102 2603 : || CLASS_DATA (e)->attr.dimension))
7103 : {
7104 0 : gfc_typespec temp_ts = e->ts;
7105 0 : gfc_add_class_array_ref (e);
7106 0 : e->ts = temp_ts;
7107 : }
7108 :
7109 271025 : if (e == NULL
7110 257627 : || (e->expr_type == EXPR_NULL
7111 745 : && fsym
7112 745 : && fsym->attr.value
7113 72 : && fsym->attr.optional
7114 72 : && !fsym->attr.dimension
7115 72 : && fsym->ts.type != BT_CLASS))
7116 : {
7117 13470 : if (se->ignore_optional)
7118 : {
7119 : /* Some intrinsics have already been resolved to the correct
7120 : parameters. */
7121 632 : continue;
7122 : }
7123 13272 : else if (arg->label)
7124 : {
7125 224 : has_alternate_specifier = 1;
7126 224 : continue;
7127 : }
7128 : else
7129 : {
7130 13048 : gfc_init_se (&parmse, NULL);
7131 :
7132 : /* For scalar arguments with VALUE attribute which are passed by
7133 : value, pass "0" and a hidden argument gives the optional
7134 : status. */
7135 13048 : if (fsym && fsym->attr.optional && fsym->attr.value
7136 427 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS)
7137 : {
7138 427 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7139 : }
7140 : else
7141 : {
7142 : /* Pass a NULL pointer for an absent arg. */
7143 12621 : parmse.expr = null_pointer_node;
7144 :
7145 : /* Is it an absent character dummy? */
7146 12621 : bool absent_char = false;
7147 12621 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
7148 :
7149 : /* Fall back to inferred type only if no formal. */
7150 12621 : if (fsym)
7151 11563 : absent_char = (fsym->ts.type == BT_CHARACTER);
7152 1058 : else if (dummy_arg)
7153 1058 : absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
7154 : == BT_CHARACTER);
7155 12621 : if (absent_char)
7156 1115 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
7157 : 0);
7158 : }
7159 : }
7160 : }
7161 257555 : else if (e->expr_type == EXPR_NULL
7162 673 : && (e->ts.type == BT_UNKNOWN || e->ts.type == BT_DERIVED)
7163 371 : && fsym && attr && (attr->pointer || attr->allocatable)
7164 293 : && fsym->ts.type == BT_DERIVED)
7165 : {
7166 210 : gfc_init_se (&parmse, NULL);
7167 210 : gfc_conv_expr_reference (&parmse, e);
7168 210 : conv_null_actual (&parmse, e, fsym);
7169 : }
7170 257345 : else if (arg->expr->expr_type == EXPR_NULL
7171 463 : && fsym && !fsym->attr.pointer
7172 163 : && (fsym->ts.type != BT_CLASS
7173 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
7174 : {
7175 : /* Pass a NULL pointer to denote an absent arg. */
7176 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
7177 : && (fsym->ts.type != BT_CLASS
7178 : || !CLASS_DATA (fsym)->attr.allocatable));
7179 163 : gfc_init_se (&parmse, NULL);
7180 163 : parmse.expr = null_pointer_node;
7181 163 : if (fsym->ts.type == BT_CHARACTER)
7182 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
7183 : }
7184 257182 : else if (fsym && fsym->ts.type == BT_CLASS
7185 11156 : && e->ts.type == BT_DERIVED)
7186 : {
7187 : /* The derived type needs to be converted to a temporary
7188 : CLASS object. */
7189 4643 : gfc_init_se (&parmse, se);
7190 4643 : gfc_conv_derived_to_class (&parmse, e, fsym, NULL_TREE,
7191 4643 : fsym->attr.optional
7192 1008 : && e->expr_type == EXPR_VARIABLE
7193 5651 : && e->symtree->n.sym->attr.optional,
7194 4643 : CLASS_DATA (fsym)->attr.class_pointer
7195 4643 : || CLASS_DATA (fsym)->attr.allocatable,
7196 : sym->name, &derived_array);
7197 : }
7198 220652 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
7199 906 : && e->ts.type != BT_PROCEDURE
7200 882 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
7201 12 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
7202 : {
7203 : /* The intrinsic type needs to be converted to a temporary
7204 : CLASS object for the unlimited polymorphic formal. */
7205 882 : gfc_find_vtab (&e->ts);
7206 882 : gfc_init_se (&parmse, se);
7207 882 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
7208 :
7209 : }
7210 251657 : else if (se->ss && se->ss->info->useflags)
7211 : {
7212 5831 : gfc_ss *ss;
7213 :
7214 5831 : ss = se->ss;
7215 :
7216 : /* An elemental function inside a scalarized loop. */
7217 5831 : gfc_init_se (&parmse, se);
7218 5831 : parm_kind = ELEMENTAL;
7219 :
7220 : /* When no fsym is present, ulim_copy is set and this is a third or
7221 : fourth argument, use call-by-value instead of by reference to
7222 : hand the length properties to the copy routine (i.e., most of the
7223 : time this will be a call to a __copy_character_* routine where the
7224 : third and fourth arguments are the lengths of a deferred length
7225 : char array). */
7226 5831 : if ((fsym && fsym->attr.value)
7227 5597 : || (ulim_copy && (argc == 2 || argc == 3)))
7228 234 : gfc_conv_expr (&parmse, e);
7229 5597 : else if (e->expr_type == EXPR_ARRAY)
7230 : {
7231 306 : gfc_conv_expr (&parmse, e);
7232 306 : if (e->ts.type != BT_CHARACTER)
7233 263 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7234 : }
7235 : else
7236 5291 : gfc_conv_expr_reference (&parmse, e);
7237 :
7238 5831 : if (e->ts.type == BT_CHARACTER && !e->rank
7239 174 : && e->expr_type == EXPR_FUNCTION)
7240 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
7241 : parmse.expr);
7242 :
7243 5781 : if (fsym && fsym->ts.type == BT_DERIVED
7244 7447 : && gfc_is_class_container_ref (e))
7245 : {
7246 24 : parmse.expr = gfc_class_data_get (parmse.expr);
7247 :
7248 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
7249 24 : && e->symtree->n.sym->attr.optional)
7250 : {
7251 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
7252 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
7253 0 : TREE_TYPE (parmse.expr),
7254 : cond, parmse.expr,
7255 0 : fold_convert (TREE_TYPE (parmse.expr),
7256 : null_pointer_node));
7257 : }
7258 : }
7259 :
7260 : /* Scalar dummy arguments of intrinsic type or derived type with
7261 : VALUE attribute. */
7262 5831 : if (fsym
7263 5781 : && fsym->attr.value
7264 234 : && fsym->ts.type != BT_CLASS)
7265 234 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7266 :
7267 : /* If we are passing an absent array as optional dummy to an
7268 : elemental procedure, make sure that we pass NULL when the data
7269 : pointer is NULL. We need this extra conditional because of
7270 : scalarization which passes arrays elements to the procedure,
7271 : ignoring the fact that the array can be absent/unallocated/... */
7272 5597 : else if (ss->info->can_be_null_ref
7273 415 : && ss->info->type != GFC_SS_REFERENCE)
7274 : {
7275 193 : tree descriptor_data;
7276 :
7277 193 : descriptor_data = ss->info->data.array.data;
7278 193 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7279 : descriptor_data,
7280 193 : fold_convert (TREE_TYPE (descriptor_data),
7281 : null_pointer_node));
7282 193 : parmse.expr
7283 386 : = fold_build3_loc (input_location, COND_EXPR,
7284 193 : TREE_TYPE (parmse.expr),
7285 : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
7286 193 : fold_convert (TREE_TYPE (parmse.expr),
7287 : null_pointer_node),
7288 : parmse.expr);
7289 : }
7290 :
7291 : /* The scalarizer does not repackage the reference to a class
7292 : array - instead it returns a pointer to the data element. */
7293 5831 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
7294 186 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
7295 186 : fsym->attr.intent != INTENT_IN
7296 186 : && (CLASS_DATA (fsym)->attr.class_pointer
7297 24 : || CLASS_DATA (fsym)->attr.allocatable),
7298 186 : fsym->attr.optional
7299 0 : && e->expr_type == EXPR_VARIABLE
7300 186 : && e->symtree->n.sym->attr.optional,
7301 186 : CLASS_DATA (fsym)->attr.class_pointer
7302 186 : || CLASS_DATA (fsym)->attr.allocatable);
7303 : }
7304 : else
7305 : {
7306 245826 : bool scalar;
7307 245826 : gfc_ss *argss;
7308 :
7309 245826 : gfc_init_se (&parmse, NULL);
7310 :
7311 : /* Check whether the expression is a scalar or not; we cannot use
7312 : e->rank as it can be nonzero for functions arguments. */
7313 245826 : argss = gfc_walk_expr (e);
7314 245826 : scalar = argss == gfc_ss_terminator;
7315 245826 : if (!scalar)
7316 60340 : gfc_free_ss_chain (argss);
7317 :
7318 : /* Special handling for passing scalar polymorphic coarrays;
7319 : otherwise one passes "class->_data.data" instead of "&class". */
7320 245826 : if (e->rank == 0 && e->ts.type == BT_CLASS
7321 3551 : && fsym && fsym->ts.type == BT_CLASS
7322 3129 : && CLASS_DATA (fsym)->attr.codimension
7323 55 : && !CLASS_DATA (fsym)->attr.dimension)
7324 : {
7325 55 : gfc_add_class_array_ref (e);
7326 55 : parmse.want_coarray = 1;
7327 55 : scalar = false;
7328 : }
7329 :
7330 : /* A scalar or transformational function. */
7331 245826 : if (scalar)
7332 : {
7333 185431 : if (e->expr_type == EXPR_VARIABLE
7334 54965 : && e->symtree->n.sym->attr.cray_pointee
7335 390 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
7336 : {
7337 : /* The Cray pointer needs to be converted to a pointer to
7338 : a type given by the expression. */
7339 6 : gfc_conv_expr (&parmse, e);
7340 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
7341 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
7342 6 : parmse.expr = convert (type, tmp);
7343 : }
7344 :
7345 185425 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7346 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7347 687 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7348 :
7349 184738 : else if (fsym && fsym->attr.value)
7350 : {
7351 21977 : if (fsym->ts.type == BT_CHARACTER
7352 543 : && fsym->ts.is_c_interop
7353 181 : && fsym->ns->proc_name != NULL
7354 181 : && fsym->ns->proc_name->attr.is_bind_c)
7355 : {
7356 172 : parmse.expr = NULL;
7357 172 : conv_scalar_char_value (fsym, &parmse, &e);
7358 172 : if (parmse.expr == NULL)
7359 166 : gfc_conv_expr (&parmse, e);
7360 : }
7361 : else
7362 : {
7363 21805 : gfc_conv_expr (&parmse, e);
7364 21805 : conv_dummy_value (&parmse, e, fsym, optionalargs);
7365 : }
7366 : }
7367 :
7368 162761 : else if (arg->name && arg->name[0] == '%')
7369 : /* Argument list functions %VAL, %LOC and %REF are signalled
7370 : through arg->name. */
7371 5826 : conv_arglist_function (&parmse, arg->expr, arg->name);
7372 156935 : else if ((e->expr_type == EXPR_FUNCTION)
7373 8305 : && ((e->value.function.esym
7374 2154 : && e->value.function.esym->result->attr.pointer)
7375 8210 : || (!e->value.function.esym
7376 6151 : && e->symtree->n.sym->attr.pointer))
7377 95 : && fsym && fsym->attr.target)
7378 : /* Make sure the function only gets called once. */
7379 8 : gfc_conv_expr_reference (&parmse, e);
7380 156927 : else if (e->expr_type == EXPR_FUNCTION
7381 8297 : && e->symtree->n.sym->result
7382 7262 : && e->symtree->n.sym->result != e->symtree->n.sym
7383 138 : && e->symtree->n.sym->result->attr.proc_pointer)
7384 : {
7385 : /* Functions returning procedure pointers. */
7386 18 : gfc_conv_expr (&parmse, e);
7387 18 : if (fsym && fsym->attr.proc_pointer)
7388 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7389 : }
7390 :
7391 : else
7392 : {
7393 156909 : bool defer_to_dealloc_blk = false;
7394 156909 : if (e->ts.type == BT_CLASS && fsym
7395 3484 : && fsym->ts.type == BT_CLASS
7396 3062 : && (!CLASS_DATA (fsym)->as
7397 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
7398 2706 : && CLASS_DATA (e)->attr.codimension)
7399 : {
7400 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
7401 48 : gcc_assert (!CLASS_DATA (fsym)->as);
7402 48 : gfc_add_class_array_ref (e);
7403 48 : parmse.want_coarray = 1;
7404 48 : gfc_conv_expr_reference (&parmse, e);
7405 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
7406 48 : fsym->attr.optional
7407 48 : && e->expr_type == EXPR_VARIABLE);
7408 : }
7409 156861 : else if (e->ts.type == BT_CLASS && fsym
7410 3436 : && fsym->ts.type == BT_CLASS
7411 3014 : && !CLASS_DATA (fsym)->as
7412 2658 : && !CLASS_DATA (e)->as
7413 2548 : && strcmp (fsym->ts.u.derived->name,
7414 : e->ts.u.derived->name))
7415 : {
7416 1625 : type = gfc_typenode_for_spec (&fsym->ts);
7417 1625 : var = gfc_create_var (type, fsym->name);
7418 1625 : gfc_conv_expr (&parmse, e);
7419 1625 : if (fsym->attr.optional
7420 153 : && e->expr_type == EXPR_VARIABLE
7421 153 : && e->symtree->n.sym->attr.optional)
7422 : {
7423 66 : stmtblock_t block;
7424 66 : tree cond;
7425 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7426 66 : cond = fold_build2_loc (input_location, NE_EXPR,
7427 : logical_type_node, tmp,
7428 66 : fold_convert (TREE_TYPE (tmp),
7429 : null_pointer_node));
7430 66 : gfc_start_block (&block);
7431 66 : gfc_add_modify (&block, var,
7432 : fold_build1_loc (input_location,
7433 : VIEW_CONVERT_EXPR,
7434 : type, parmse.expr));
7435 66 : gfc_add_expr_to_block (&parmse.pre,
7436 : fold_build3_loc (input_location,
7437 : COND_EXPR, void_type_node,
7438 : cond, gfc_finish_block (&block),
7439 : build_empty_stmt (input_location)));
7440 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7441 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
7442 66 : TREE_TYPE (parmse.expr),
7443 : cond, parmse.expr,
7444 66 : fold_convert (TREE_TYPE (parmse.expr),
7445 : null_pointer_node));
7446 66 : }
7447 : else
7448 : {
7449 : /* Since the internal representation of unlimited
7450 : polymorphic expressions includes an extra field
7451 : that other class objects do not, a cast to the
7452 : formal type does not work. */
7453 1559 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
7454 : {
7455 91 : tree efield;
7456 :
7457 : /* Evaluate arguments just once, when they have
7458 : side effects. */
7459 91 : if (TREE_SIDE_EFFECTS (parmse.expr))
7460 : {
7461 25 : tree cldata, zero;
7462 :
7463 25 : parmse.expr = gfc_evaluate_now (parmse.expr,
7464 : &parmse.pre);
7465 :
7466 : /* Prevent memory leak, when old component
7467 : was allocated already. */
7468 25 : cldata = gfc_class_data_get (parmse.expr);
7469 25 : zero = build_int_cst (TREE_TYPE (cldata),
7470 : 0);
7471 25 : tmp = fold_build2_loc (input_location, NE_EXPR,
7472 : logical_type_node,
7473 : cldata, zero);
7474 25 : tmp = build3_v (COND_EXPR, tmp,
7475 : gfc_call_free (cldata),
7476 : build_empty_stmt (
7477 : input_location));
7478 25 : gfc_add_expr_to_block (&parmse.finalblock,
7479 : tmp);
7480 25 : gfc_add_modify (&parmse.finalblock,
7481 : cldata, zero);
7482 : }
7483 :
7484 : /* Set the _data field. */
7485 91 : tmp = gfc_class_data_get (var);
7486 91 : efield = fold_convert (TREE_TYPE (tmp),
7487 : gfc_class_data_get (parmse.expr));
7488 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7489 :
7490 : /* Set the _vptr field. */
7491 91 : tmp = gfc_class_vptr_get (var);
7492 91 : efield = fold_convert (TREE_TYPE (tmp),
7493 : gfc_class_vptr_get (parmse.expr));
7494 91 : gfc_add_modify (&parmse.pre, tmp, efield);
7495 :
7496 : /* Set the _len field. */
7497 91 : tmp = gfc_class_len_get (var);
7498 91 : gfc_add_modify (&parmse.pre, tmp,
7499 91 : build_int_cst (TREE_TYPE (tmp), 0));
7500 91 : }
7501 : else
7502 : {
7503 1468 : tmp = fold_build1_loc (input_location,
7504 : VIEW_CONVERT_EXPR,
7505 : type, parmse.expr);
7506 1468 : gfc_add_modify (&parmse.pre, var, tmp);
7507 1559 : ;
7508 : }
7509 1559 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
7510 : }
7511 : }
7512 : else
7513 : {
7514 155236 : gfc_conv_expr_reference (&parmse, e);
7515 :
7516 155236 : gfc_symbol *dsym = fsym;
7517 155236 : gfc_dummy_arg *dummy;
7518 :
7519 : /* Use associated dummy as fallback for formal
7520 : argument if there is no explicit interface. */
7521 155236 : if (dsym == NULL
7522 27410 : && (dummy = arg->associated_dummy)
7523 24886 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
7524 178718 : && dummy->u.non_intrinsic->sym)
7525 : dsym = dummy->u.non_intrinsic->sym;
7526 :
7527 155236 : if (dsym
7528 151308 : && dsym->attr.intent == INTENT_OUT
7529 3252 : && !dsym->attr.allocatable
7530 3110 : && !dsym->attr.pointer
7531 3092 : && e->expr_type == EXPR_VARIABLE
7532 3091 : && e->ref == NULL
7533 2982 : && e->symtree
7534 2982 : && e->symtree->n.sym
7535 2982 : && !e->symtree->n.sym->attr.dimension
7536 2982 : && e->ts.type != BT_CHARACTER
7537 2880 : && e->ts.type != BT_CLASS
7538 2650 : && (e->ts.type != BT_DERIVED
7539 492 : || (dsym->ts.type == BT_DERIVED
7540 492 : && e->ts.u.derived == dsym->ts.u.derived
7541 : /* Types with allocatable components are
7542 : excluded from clobbering because we need
7543 : the unclobbered pointers to free the
7544 : allocatable components in the callee.
7545 : Same goes for finalizable types or types
7546 : with finalizable components, we need to
7547 : pass the unclobbered values to the
7548 : finalization routines.
7549 : For parameterized types, it's less clear
7550 : but they may not have a constant size
7551 : so better exclude them in any case. */
7552 477 : && !e->ts.u.derived->attr.alloc_comp
7553 351 : && !e->ts.u.derived->attr.pdt_type
7554 351 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
7555 2467 : && e->ts.type != BT_PROCEDURE
7556 157667 : && !sym->attr.elemental)
7557 : {
7558 1098 : tree var;
7559 1098 : var = build_fold_indirect_ref_loc (input_location,
7560 : parmse.expr);
7561 1098 : tree clobber = build_clobber (TREE_TYPE (var));
7562 1098 : gfc_add_modify (&clobbers, var, clobber);
7563 : }
7564 : }
7565 : /* Catch base objects that are not variables. */
7566 156909 : if (e->ts.type == BT_CLASS
7567 3484 : && e->expr_type != EXPR_VARIABLE
7568 306 : && expr && e == expr->base_expr)
7569 80 : base_object = build_fold_indirect_ref_loc (input_location,
7570 : parmse.expr);
7571 :
7572 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7573 : allocated on entry, it must be deallocated. */
7574 129499 : if (fsym && fsym->attr.intent == INTENT_OUT
7575 3181 : && (fsym->attr.allocatable
7576 3039 : || (fsym->ts.type == BT_CLASS
7577 259 : && CLASS_DATA (fsym)->attr.allocatable))
7578 157200 : && !is_CFI_desc (fsym, NULL))
7579 : {
7580 291 : stmtblock_t block;
7581 291 : tree ptr;
7582 :
7583 291 : defer_to_dealloc_blk = true;
7584 :
7585 291 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7586 : &parmse.pre);
7587 :
7588 291 : if (parmse.class_container != NULL_TREE)
7589 156 : parmse.class_container
7590 156 : = gfc_evaluate_data_ref_now (parmse.class_container,
7591 : &parmse.pre);
7592 :
7593 291 : gfc_init_block (&block);
7594 291 : ptr = parmse.expr;
7595 291 : if (e->ts.type == BT_CLASS)
7596 156 : ptr = gfc_class_data_get (ptr);
7597 :
7598 291 : tree cls = parmse.class_container;
7599 291 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
7600 : NULL_TREE, true,
7601 : e, e->ts, cls);
7602 291 : gfc_add_expr_to_block (&block, tmp);
7603 291 : gfc_add_modify (&block, ptr,
7604 291 : fold_convert (TREE_TYPE (ptr),
7605 : null_pointer_node));
7606 :
7607 291 : if (fsym->ts.type == BT_CLASS)
7608 149 : gfc_reset_vptr (&block, nullptr,
7609 : build_fold_indirect_ref (parmse.expr),
7610 149 : fsym->ts.u.derived);
7611 :
7612 291 : if (fsym->attr.optional
7613 42 : && e->expr_type == EXPR_VARIABLE
7614 42 : && e->symtree->n.sym->attr.optional)
7615 : {
7616 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
7617 : void_type_node,
7618 18 : gfc_conv_expr_present (e->symtree->n.sym),
7619 : gfc_finish_block (&block),
7620 : build_empty_stmt (input_location));
7621 : }
7622 : else
7623 273 : tmp = gfc_finish_block (&block);
7624 :
7625 291 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7626 : }
7627 :
7628 : /* A class array element needs converting back to be a
7629 : class object, if the formal argument is a class object. */
7630 156909 : if (fsym && fsym->ts.type == BT_CLASS
7631 3086 : && e->ts.type == BT_CLASS
7632 3062 : && ((CLASS_DATA (fsym)->as
7633 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7634 2706 : || CLASS_DATA (e)->attr.dimension))
7635 : {
7636 466 : gfc_se class_se = parmse;
7637 466 : gfc_init_block (&class_se.pre);
7638 466 : gfc_init_block (&class_se.post);
7639 :
7640 466 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7641 466 : fsym->attr.intent != INTENT_IN
7642 466 : && (CLASS_DATA (fsym)->attr.class_pointer
7643 267 : || CLASS_DATA (fsym)->attr.allocatable),
7644 466 : fsym->attr.optional
7645 198 : && e->expr_type == EXPR_VARIABLE
7646 664 : && e->symtree->n.sym->attr.optional,
7647 466 : CLASS_DATA (fsym)->attr.class_pointer
7648 466 : || CLASS_DATA (fsym)->attr.allocatable);
7649 :
7650 466 : parmse.expr = class_se.expr;
7651 442 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7652 466 : ? &dealloc_blk
7653 : : &parmse.pre;
7654 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7655 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7656 : }
7657 :
7658 129499 : if (fsym && (fsym->ts.type == BT_DERIVED
7659 117611 : || fsym->ts.type == BT_ASSUMED)
7660 12755 : && e->ts.type == BT_CLASS
7661 410 : && !CLASS_DATA (e)->attr.dimension
7662 374 : && !CLASS_DATA (e)->attr.codimension)
7663 : {
7664 374 : parmse.expr = gfc_class_data_get (parmse.expr);
7665 : /* The result is a class temporary, whose _data component
7666 : must be freed to avoid a memory leak. */
7667 374 : if (e->expr_type == EXPR_FUNCTION
7668 23 : && CLASS_DATA (e)->attr.allocatable)
7669 : {
7670 19 : tree zero;
7671 :
7672 : /* Finalize the expression. */
7673 19 : gfc_finalize_tree_expr (&parmse, NULL,
7674 19 : gfc_expr_attr (e), e->rank);
7675 19 : gfc_add_block_to_block (&parmse.post,
7676 : &parmse.finalblock);
7677 :
7678 : /* Then free the class _data. */
7679 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
7680 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
7681 : logical_type_node,
7682 : parmse.expr, zero);
7683 19 : tmp = build3_v (COND_EXPR, tmp,
7684 : gfc_call_free (parmse.expr),
7685 : build_empty_stmt (input_location));
7686 19 : gfc_add_expr_to_block (&parmse.post, tmp);
7687 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
7688 : }
7689 : }
7690 :
7691 : /* Wrap scalar variable in a descriptor. We need to convert
7692 : the address of a pointer back to the pointer itself before,
7693 : we can assign it to the data field. */
7694 :
7695 129499 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
7696 1314 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
7697 : {
7698 1242 : tmp = parmse.expr;
7699 1242 : if (TREE_CODE (tmp) == ADDR_EXPR)
7700 736 : tmp = TREE_OPERAND (tmp, 0);
7701 1242 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
7702 : fsym->attr);
7703 1242 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
7704 : parmse.expr);
7705 : }
7706 128257 : else if (fsym && e->expr_type != EXPR_NULL
7707 127959 : && ((fsym->attr.pointer
7708 1740 : && fsym->attr.flavor != FL_PROCEDURE)
7709 126225 : || (fsym->attr.proc_pointer
7710 193 : && !(e->expr_type == EXPR_VARIABLE
7711 193 : && e->symtree->n.sym->attr.dummy))
7712 126044 : || (fsym->attr.proc_pointer
7713 12 : && e->expr_type == EXPR_VARIABLE
7714 12 : && gfc_is_proc_ptr_comp (e))
7715 126038 : || (fsym->attr.allocatable
7716 1040 : && fsym->attr.flavor != FL_PROCEDURE)))
7717 : {
7718 : /* Scalar pointer dummy args require an extra level of
7719 : indirection. The null pointer already contains
7720 : this level of indirection. */
7721 2955 : parm_kind = SCALAR_POINTER;
7722 2955 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
7723 : }
7724 : }
7725 : }
7726 60395 : else if (e->ts.type == BT_CLASS
7727 2693 : && fsym && fsym->ts.type == BT_CLASS
7728 2347 : && (CLASS_DATA (fsym)->attr.dimension
7729 55 : || CLASS_DATA (fsym)->attr.codimension))
7730 : {
7731 : /* Pass a class array. */
7732 2347 : gfc_conv_expr_descriptor (&parmse, e);
7733 2347 : bool defer_to_dealloc_blk = false;
7734 :
7735 2347 : if (fsym->attr.optional
7736 798 : && e->expr_type == EXPR_VARIABLE
7737 798 : && e->symtree->n.sym->attr.optional)
7738 : {
7739 438 : stmtblock_t block;
7740 :
7741 438 : gfc_init_block (&block);
7742 438 : gfc_add_block_to_block (&block, &parmse.pre);
7743 :
7744 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
7745 : void_type_node,
7746 438 : gfc_conv_expr_present (e->symtree->n.sym),
7747 : gfc_finish_block (&block),
7748 : build_empty_stmt (input_location));
7749 :
7750 438 : gfc_add_expr_to_block (&parmse.pre, t);
7751 : }
7752 :
7753 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7754 : allocated on entry, it must be deallocated. */
7755 2347 : if (fsym->attr.intent == INTENT_OUT
7756 141 : && CLASS_DATA (fsym)->attr.allocatable)
7757 : {
7758 110 : stmtblock_t block;
7759 110 : tree ptr;
7760 :
7761 : /* In case the data reference to deallocate is dependent on
7762 : its own content, save the resulting pointer to a variable
7763 : and only use that variable from now on, before the
7764 : expression becomes invalid. */
7765 110 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7766 : &parmse.pre);
7767 :
7768 110 : if (parmse.class_container != NULL_TREE)
7769 110 : parmse.class_container
7770 110 : = gfc_evaluate_data_ref_now (parmse.class_container,
7771 : &parmse.pre);
7772 :
7773 110 : gfc_init_block (&block);
7774 110 : ptr = parmse.expr;
7775 110 : ptr = gfc_class_data_get (ptr);
7776 :
7777 110 : tree cls = parmse.class_container;
7778 110 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
7779 : NULL_TREE, NULL_TREE,
7780 : NULL_TREE, true, e,
7781 : GFC_CAF_COARRAY_NOCOARRAY,
7782 : cls);
7783 110 : gfc_add_expr_to_block (&block, tmp);
7784 110 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7785 : void_type_node, ptr,
7786 : null_pointer_node);
7787 110 : gfc_add_expr_to_block (&block, tmp);
7788 110 : gfc_reset_vptr (&block, e, parmse.class_container);
7789 :
7790 110 : if (fsym->attr.optional
7791 30 : && e->expr_type == EXPR_VARIABLE
7792 30 : && (!e->ref
7793 30 : || (e->ref->type == REF_ARRAY
7794 0 : && e->ref->u.ar.type != AR_FULL))
7795 0 : && e->symtree->n.sym->attr.optional)
7796 : {
7797 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7798 : void_type_node,
7799 0 : gfc_conv_expr_present (e->symtree->n.sym),
7800 : gfc_finish_block (&block),
7801 : build_empty_stmt (input_location));
7802 : }
7803 : else
7804 110 : tmp = gfc_finish_block (&block);
7805 :
7806 110 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7807 110 : defer_to_dealloc_blk = true;
7808 : }
7809 :
7810 2347 : gfc_se class_se = parmse;
7811 2347 : gfc_init_block (&class_se.pre);
7812 2347 : gfc_init_block (&class_se.post);
7813 :
7814 2347 : if (e->expr_type != EXPR_VARIABLE)
7815 : {
7816 : int n;
7817 : /* Set the bounds and offset correctly. */
7818 60 : for (n = 0; n < e->rank; n++)
7819 30 : gfc_conv_shift_descriptor_lbound (&class_se.pre,
7820 : class_se.expr,
7821 : n, gfc_index_one_node);
7822 : }
7823 :
7824 : /* The conversion does not repackage the reference to a class
7825 : array - _data descriptor. */
7826 2347 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7827 2347 : fsym->attr.intent != INTENT_IN
7828 2347 : && (CLASS_DATA (fsym)->attr.class_pointer
7829 1211 : || CLASS_DATA (fsym)->attr.allocatable),
7830 2347 : fsym->attr.optional
7831 798 : && e->expr_type == EXPR_VARIABLE
7832 3145 : && e->symtree->n.sym->attr.optional,
7833 2347 : CLASS_DATA (fsym)->attr.class_pointer
7834 2347 : || CLASS_DATA (fsym)->attr.allocatable);
7835 :
7836 2347 : parmse.expr = class_se.expr;
7837 2237 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7838 2347 : ? &dealloc_blk
7839 : : &parmse.pre;
7840 2347 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7841 2347 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7842 :
7843 2347 : if (e->expr_type == EXPR_OP
7844 12 : && POINTER_TYPE_P (TREE_TYPE (parmse.expr))
7845 2359 : && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse.expr, 0))))
7846 : {
7847 12 : tree cond;
7848 12 : tree dealloc_expr = gfc_finish_block (&parmse.post);
7849 12 : tmp = TREE_OPERAND (parmse.expr, 0);
7850 12 : gfc_init_block (&parmse.post);
7851 12 : cond = gfc_class_data_get (tmp);
7852 12 : tmp = gfc_deallocate_alloc_comp_no_caf (e->ts.u.derived,
7853 : tmp, e->rank, true);
7854 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7855 12 : cond = gfc_class_data_get (TREE_OPERAND (parmse.expr, 0));
7856 12 : cond = gfc_conv_descriptor_data_get (cond);
7857 12 : cond = fold_build2_loc (input_location, NE_EXPR,
7858 : logical_type_node, cond,
7859 12 : build_int_cst (TREE_TYPE (cond), 0));
7860 12 : tmp = build3_v (COND_EXPR, cond, dealloc_expr,
7861 : build_empty_stmt (input_location));
7862 :
7863 : /* This specific case should not be processed further and so
7864 : bundle everything up and proceed to the next argument. */
7865 12 : if (fsym && need_interface_mapping && e)
7866 12 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
7867 12 : gfc_add_expr_to_block (&parmse.post, tmp);
7868 12 : gfc_add_block_to_block (&se->pre, &parmse.pre);
7869 12 : gfc_add_block_to_block (&post, &parmse.post);
7870 12 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
7871 12 : vec_safe_push (arglist, parmse.expr);
7872 12 : continue;
7873 12 : }
7874 2335 : }
7875 : else
7876 : {
7877 : /* If the argument is a function call that may not create
7878 : a temporary for the result, we have to check that we
7879 : can do it, i.e. that there is no alias between this
7880 : argument and another one. */
7881 58048 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7882 : {
7883 358 : gfc_expr *iarg;
7884 358 : sym_intent intent;
7885 :
7886 358 : if (fsym != NULL)
7887 349 : intent = fsym->attr.intent;
7888 : else
7889 : intent = INTENT_UNKNOWN;
7890 :
7891 358 : if (gfc_check_fncall_dependency (e, intent, sym, args,
7892 : NOT_ELEMENTAL))
7893 21 : parmse.force_tmp = 1;
7894 :
7895 358 : iarg = e->value.function.actual->expr;
7896 :
7897 : /* Temporary needed if aliasing due to host association. */
7898 358 : if (sym->attr.contained
7899 114 : && !sym->attr.pure
7900 114 : && !sym->attr.implicit_pure
7901 36 : && !sym->attr.use_assoc
7902 36 : && iarg->expr_type == EXPR_VARIABLE
7903 36 : && sym->ns == iarg->symtree->n.sym->ns)
7904 36 : parmse.force_tmp = 1;
7905 :
7906 : /* Ditto within module. */
7907 358 : if (sym->attr.use_assoc
7908 6 : && !sym->attr.pure
7909 6 : && !sym->attr.implicit_pure
7910 0 : && iarg->expr_type == EXPR_VARIABLE
7911 0 : && sym->module == iarg->symtree->n.sym->module)
7912 0 : parmse.force_tmp = 1;
7913 : }
7914 :
7915 : /* Special case for assumed-rank arrays: when passing an
7916 : argument to a nonallocatable/nonpointer dummy, the bounds have
7917 : to be reset as otherwise a last-dim ubound of -1 is
7918 : indistinguishable from an assumed-size array in the callee. */
7919 58048 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
7920 35055 : && fsym->as->type == AS_ASSUMED_RANK
7921 11911 : && e->rank != -1
7922 11598 : && e->expr_type == EXPR_VARIABLE
7923 11157 : && ((fsym->ts.type == BT_CLASS
7924 0 : && !CLASS_DATA (fsym)->attr.class_pointer
7925 0 : && !CLASS_DATA (fsym)->attr.allocatable)
7926 11157 : || (fsym->ts.type != BT_CLASS
7927 11157 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
7928 : {
7929 : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7930 10614 : gfc_ref *ref;
7931 10872 : for (ref = e->ref; ref->next; ref = ref->next)
7932 : {
7933 330 : if (ref->next->type == REF_INQUIRY)
7934 : break;
7935 282 : if (ref->type == REF_ARRAY
7936 24 : && ref->u.ar.type != AR_ELEMENT)
7937 : break;
7938 10614 : };
7939 10614 : if (ref->u.ar.type == AR_FULL
7940 9864 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
7941 9744 : ref->u.ar.type = AR_SECTION;
7942 : }
7943 :
7944 58048 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7945 : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7946 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7947 :
7948 52198 : else if (e->expr_type == EXPR_VARIABLE
7949 40830 : && is_subref_array (e)
7950 53178 : && !(fsym && fsym->attr.pointer))
7951 : /* The actual argument is a component reference to an
7952 : array of derived types. In this case, the argument
7953 : is converted to a temporary, which is passed and then
7954 : written back after the procedure call. */
7955 727 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7956 685 : fsym ? fsym->attr.intent : INTENT_INOUT,
7957 727 : fsym && fsym->attr.pointer);
7958 :
7959 51471 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
7960 345 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
7961 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
7962 : /* An assumed size class actual argument being passed to
7963 : a 'no descriptor' formal argument just requires the
7964 : data pointer to be passed. For class dummy arguments
7965 : this is stored in the symbol backend decl.. */
7966 6 : parmse.expr = e->symtree->n.sym->backend_decl;
7967 :
7968 51465 : else if (gfc_is_class_array_ref (e, NULL)
7969 51465 : && fsym && fsym->ts.type == BT_DERIVED)
7970 : /* The actual argument is a component reference to an
7971 : array of derived types. In this case, the argument
7972 : is converted to a temporary, which is passed and then
7973 : written back after the procedure call.
7974 : OOP-TODO: Insert code so that if the dynamic type is
7975 : the same as the declared type, copy-in/copy-out does
7976 : not occur. */
7977 108 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7978 108 : fsym->attr.intent,
7979 108 : fsym->attr.pointer);
7980 :
7981 51357 : else if (gfc_is_class_array_function (e)
7982 51357 : && fsym && fsym->ts.type == BT_DERIVED)
7983 : /* See previous comment. For function actual argument,
7984 : the write out is not needed so the intent is set as
7985 : intent in. */
7986 : {
7987 13 : e->must_finalize = 1;
7988 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7989 13 : INTENT_IN, fsym->attr.pointer);
7990 : }
7991 47771 : else if (fsym && fsym->attr.contiguous
7992 60 : && (fsym->attr.target
7993 1707 : ? gfc_is_not_contiguous (e)
7994 1647 : : !gfc_is_simply_contiguous (e, false, true))
7995 327 : && gfc_expr_is_variable (e)
7996 53366 : && e->rank != -1)
7997 : {
7998 303 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7999 303 : fsym->attr.intent,
8000 303 : fsym->attr.pointer);
8001 : }
8002 : else
8003 : /* This is where we introduce a temporary to store the
8004 : result of a non-lvalue array expression. */
8005 51041 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
8006 : sym->name, NULL);
8007 :
8008 : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
8009 : allocated on entry, it must be deallocated.
8010 : CFI descriptors are handled elsewhere. */
8011 54433 : if (fsym && fsym->attr.allocatable
8012 1783 : && fsym->attr.intent == INTENT_OUT
8013 57823 : && !is_CFI_desc (fsym, NULL))
8014 : {
8015 157 : if (fsym->ts.type == BT_DERIVED
8016 45 : && fsym->ts.u.derived->attr.alloc_comp)
8017 : {
8018 : // deallocate the components first
8019 9 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
8020 : parmse.expr, e->rank);
8021 : /* But check whether dummy argument is optional. */
8022 9 : if (tmp != NULL_TREE
8023 9 : && fsym->attr.optional
8024 6 : && e->expr_type == EXPR_VARIABLE
8025 6 : && e->symtree->n.sym->attr.optional)
8026 : {
8027 6 : tree present;
8028 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
8029 6 : tmp = build3_v (COND_EXPR, present, tmp,
8030 : build_empty_stmt (input_location));
8031 : }
8032 9 : if (tmp != NULL_TREE)
8033 9 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8034 : }
8035 :
8036 157 : tmp = parmse.expr;
8037 : /* With bind(C), the actual argument is replaced by a bind-C
8038 : descriptor; in this case, the data component arrives here,
8039 : which shall not be dereferenced, but still freed and
8040 : nullified. */
8041 157 : if (TREE_TYPE(tmp) != pvoid_type_node)
8042 157 : tmp = build_fold_indirect_ref_loc (input_location,
8043 : parmse.expr);
8044 157 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8045 : NULL_TREE, NULL_TREE, true,
8046 : e,
8047 : GFC_CAF_COARRAY_NOCOARRAY);
8048 157 : if (fsym->attr.optional
8049 48 : && e->expr_type == EXPR_VARIABLE
8050 48 : && e->symtree->n.sym->attr.optional)
8051 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
8052 : void_type_node,
8053 24 : gfc_conv_expr_present (e->symtree->n.sym),
8054 : tmp, build_empty_stmt (input_location));
8055 157 : gfc_add_expr_to_block (&dealloc_blk, tmp);
8056 : }
8057 : }
8058 : }
8059 : /* Special case for an assumed-rank dummy argument. */
8060 270591 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
8061 56716 : && (fsym->ts.type == BT_CLASS
8062 56716 : ? (CLASS_DATA (fsym)->as
8063 4564 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
8064 52152 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
8065 : {
8066 12737 : if (fsym->ts.type == BT_CLASS
8067 12737 : ? (CLASS_DATA (fsym)->attr.class_pointer
8068 1055 : || CLASS_DATA (fsym)->attr.allocatable)
8069 11682 : : (fsym->attr.pointer || fsym->attr.allocatable))
8070 : {
8071 : /* Unallocated allocatable arrays and unassociated pointer
8072 : arrays need their dtype setting if they are argument
8073 : associated with assumed rank dummies to set the rank. */
8074 891 : set_dtype_for_unallocated (&parmse, e);
8075 : }
8076 11846 : else if (e->expr_type == EXPR_VARIABLE
8077 11367 : && e->symtree->n.sym->attr.dummy
8078 698 : && (e->ts.type == BT_CLASS
8079 891 : ? (e->ref && e->ref->next
8080 193 : && e->ref->next->type == REF_ARRAY
8081 193 : && e->ref->next->u.ar.type == AR_FULL
8082 386 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
8083 505 : : (e->ref && e->ref->type == REF_ARRAY
8084 505 : && e->ref->u.ar.type == AR_FULL
8085 733 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
8086 : {
8087 : /* Assumed-size actual to assumed-rank dummy requires
8088 : dim[rank-1].ubound = -1. */
8089 180 : tree minus_one;
8090 180 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
8091 180 : if (fsym->ts.type == BT_CLASS)
8092 60 : tmp = gfc_class_data_get (tmp);
8093 180 : minus_one = build_int_cst (gfc_array_index_type, -1);
8094 180 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
8095 180 : gfc_rank_cst[e->rank - 1],
8096 : minus_one);
8097 : }
8098 : }
8099 :
8100 : /* The case with fsym->attr.optional is that of a user subroutine
8101 : with an interface indicating an optional argument. When we call
8102 : an intrinsic subroutine, however, fsym is NULL, but we might still
8103 : have an optional argument, so we proceed to the substitution
8104 : just in case. Arguments passed to bind(c) procedures via CFI
8105 : descriptors are handled elsewhere. */
8106 257615 : if (e && (fsym == NULL || fsym->attr.optional)
8107 331003 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8108 : {
8109 : /* If an optional argument is itself an optional dummy argument,
8110 : check its presence and substitute a null if absent. This is
8111 : only needed when passing an array to an elemental procedure
8112 : as then array elements are accessed - or no NULL pointer is
8113 : allowed and a "1" or "0" should be passed if not present.
8114 : When passing a non-array-descriptor full array to a
8115 : non-array-descriptor dummy, no check is needed. For
8116 : array-descriptor actual to array-descriptor dummy, see
8117 : PR 41911 for why a check has to be inserted.
8118 : fsym == NULL is checked as intrinsics required the descriptor
8119 : but do not always set fsym.
8120 : Also, it is necessary to pass a NULL pointer to library routines
8121 : which usually ignore optional arguments, so they can handle
8122 : these themselves. */
8123 59318 : if (e->expr_type == EXPR_VARIABLE
8124 26428 : && e->symtree->n.sym->attr.optional
8125 2421 : && (((e->rank != 0 && elemental_proc)
8126 2246 : || e->representation.length || e->ts.type == BT_CHARACTER
8127 2020 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
8128 1910 : || (e->rank != 0
8129 1070 : && (fsym == NULL
8130 1034 : || (fsym->as
8131 272 : && (fsym->as->type == AS_ASSUMED_SHAPE
8132 235 : || fsym->as->type == AS_ASSUMED_RANK
8133 117 : || fsym->as->type == AS_DEFERRED)))))
8134 1685 : || se->ignore_optional))
8135 764 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
8136 764 : e->representation.length);
8137 : }
8138 :
8139 : /* Make the class container for the first argument available with class
8140 : valued transformational functions. */
8141 270591 : if (argc == 0 && e && e->ts.type == BT_CLASS
8142 4949 : && isym && isym->transformational
8143 84 : && se->ss && se->ss->info)
8144 : {
8145 84 : arg1_cntnr = parmse.expr;
8146 84 : if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
8147 84 : arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
8148 84 : arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
8149 84 : se->ss->info->class_container = arg1_cntnr;
8150 : }
8151 :
8152 : /* Obtain the character length of an assumed character length procedure
8153 : from the typespec of the actual argument. */
8154 270591 : if (e
8155 257615 : && parmse.string_length == NULL_TREE
8156 222138 : && e->ts.type == BT_PROCEDURE
8157 1923 : && e->symtree->n.sym->ts.type == BT_CHARACTER
8158 21 : && e->symtree->n.sym->ts.u.cl->length != NULL
8159 21 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
8160 : {
8161 13 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
8162 13 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
8163 : }
8164 :
8165 270591 : if (fsym && e)
8166 : {
8167 : /* Obtain the character length for a NULL() actual with a character
8168 : MOLD argument. Otherwise substitute a suitable dummy length.
8169 : Here we handle non-optional dummies of non-bind(c) procedures. */
8170 225728 : if (e->expr_type == EXPR_NULL
8171 745 : && fsym->ts.type == BT_CHARACTER
8172 296 : && !fsym->attr.optional
8173 225946 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
8174 216 : conv_null_actual (&parmse, e, fsym);
8175 : }
8176 :
8177 : /* If any actual argument of the procedure is allocatable and passed
8178 : to an allocatable dummy with INTENT(OUT), we conservatively
8179 : evaluate actual argument expressions before deallocations are
8180 : performed and the procedure is executed. May create temporaries.
8181 : This ensures we conform to F2023:15.5.3, 15.5.4. */
8182 257615 : if (e && fsym && force_eval_args
8183 1103 : && fsym->attr.intent != INTENT_OUT
8184 271000 : && !gfc_is_constant_expr (e))
8185 268 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
8186 :
8187 270591 : if (fsym && need_interface_mapping && e)
8188 40472 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
8189 :
8190 270591 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8191 270591 : gfc_add_block_to_block (&post, &parmse.post);
8192 270591 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
8193 :
8194 : /* Allocated allocatable components of derived types must be
8195 : deallocated for non-variable scalars, array arguments to elemental
8196 : procedures, and array arguments with descriptor to non-elemental
8197 : procedures. As bounds information for descriptorless arrays is no
8198 : longer available here, they are dealt with in trans-array.cc
8199 : (gfc_conv_array_parameter). */
8200 257615 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
8201 28267 : && e->ts.u.derived->attr.alloc_comp
8202 7566 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
8203 278019 : && !expr_may_alias_variables (e, elemental_proc))
8204 : {
8205 360 : int parm_rank;
8206 : /* It is known the e returns a structure type with at least one
8207 : allocatable component. When e is a function, ensure that the
8208 : function is called once only by using a temporary variable. */
8209 360 : if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
8210 140 : parmse.expr = gfc_evaluate_now_loc (input_location,
8211 : parmse.expr, &se->pre);
8212 :
8213 360 : if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
8214 140 : tmp = parmse.expr;
8215 : else
8216 220 : tmp = build_fold_indirect_ref_loc (input_location,
8217 : parmse.expr);
8218 :
8219 360 : parm_rank = e->rank;
8220 360 : switch (parm_kind)
8221 : {
8222 : case (ELEMENTAL):
8223 : case (SCALAR):
8224 360 : parm_rank = 0;
8225 : break;
8226 :
8227 0 : case (SCALAR_POINTER):
8228 0 : tmp = build_fold_indirect_ref_loc (input_location,
8229 : tmp);
8230 0 : break;
8231 : }
8232 :
8233 360 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
8234 : {
8235 : /* The derived type is passed to gfc_deallocate_alloc_comp.
8236 : Therefore, class actuals can be handled correctly but derived
8237 : types passed to class formals need the _data component. */
8238 82 : tmp = gfc_class_data_get (tmp);
8239 82 : if (!CLASS_DATA (fsym)->attr.dimension)
8240 : {
8241 56 : if (UNLIMITED_POLY (fsym))
8242 : {
8243 12 : tree type = gfc_typenode_for_spec (&e->ts);
8244 12 : type = build_pointer_type (type);
8245 12 : tmp = fold_convert (type, tmp);
8246 : }
8247 56 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8248 : }
8249 : }
8250 :
8251 360 : if (e->expr_type == EXPR_OP
8252 24 : && e->value.op.op == INTRINSIC_PARENTHESES
8253 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
8254 : {
8255 24 : tree local_tmp;
8256 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
8257 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
8258 : parm_rank, 0);
8259 24 : gfc_add_expr_to_block (&se->post, local_tmp);
8260 : }
8261 :
8262 : /* Items of array expressions passed to a polymorphic formal arguments
8263 : create their own clean up, so prevent double free. */
8264 360 : if (!finalized && !e->must_finalize
8265 359 : && !(e->expr_type == EXPR_ARRAY && fsym
8266 74 : && fsym->ts.type == BT_CLASS))
8267 : {
8268 339 : bool scalar_res_outside_loop;
8269 1005 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
8270 151 : && parm_rank == 0
8271 478 : && parmse.loop;
8272 :
8273 : /* Scalars passed to an assumed rank argument are converted to
8274 : a descriptor. Obtain the data field before deallocating any
8275 : allocatable components. */
8276 298 : if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
8277 600 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8278 19 : tmp = gfc_conv_descriptor_data_get (tmp);
8279 :
8280 339 : if (scalar_res_outside_loop)
8281 : {
8282 : /* Go through the ss chain to find the argument and use
8283 : the stored value. */
8284 30 : gfc_ss *tmp_ss = parmse.loop->ss;
8285 72 : for (; tmp_ss; tmp_ss = tmp_ss->next)
8286 60 : if (tmp_ss->info
8287 48 : && tmp_ss->info->expr == e
8288 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
8289 : {
8290 18 : tmp = tmp_ss->info->data.scalar.value;
8291 18 : break;
8292 : }
8293 : }
8294 :
8295 339 : STRIP_NOPS (tmp);
8296 :
8297 339 : if (derived_array != NULL_TREE)
8298 0 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
8299 : derived_array,
8300 : parm_rank);
8301 339 : else if ((e->ts.type == BT_CLASS
8302 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
8303 339 : || e->ts.type == BT_DERIVED)
8304 339 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
8305 : parm_rank, 0, true);
8306 0 : else if (e->ts.type == BT_CLASS)
8307 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
8308 : tmp, parm_rank);
8309 :
8310 339 : if (scalar_res_outside_loop)
8311 30 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
8312 : else
8313 309 : gfc_prepend_expr_to_block (&post, tmp);
8314 : }
8315 : }
8316 :
8317 : /* Add argument checking of passing an unallocated/NULL actual to
8318 : a nonallocatable/nonpointer dummy. */
8319 :
8320 270591 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
8321 : {
8322 6546 : symbol_attribute attr;
8323 6546 : char *msg;
8324 6546 : tree cond;
8325 6546 : tree tmp;
8326 6546 : symbol_attribute fsym_attr;
8327 :
8328 6546 : if (fsym)
8329 : {
8330 6385 : if (fsym->ts.type == BT_CLASS)
8331 : {
8332 321 : fsym_attr = CLASS_DATA (fsym)->attr;
8333 321 : fsym_attr.pointer = fsym_attr.class_pointer;
8334 : }
8335 : else
8336 6064 : fsym_attr = fsym->attr;
8337 : }
8338 :
8339 6546 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
8340 4094 : attr = gfc_expr_attr (e);
8341 : else
8342 6081 : goto end_pointer_check;
8343 :
8344 : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
8345 : allocatable to an optional dummy, cf. 12.5.2.12. */
8346 4094 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
8347 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
8348 1032 : goto end_pointer_check;
8349 :
8350 3062 : if (attr.optional)
8351 : {
8352 : /* If the actual argument is an optional pointer/allocatable and
8353 : the formal argument takes an nonpointer optional value,
8354 : it is invalid to pass a non-present argument on, even
8355 : though there is no technical reason for this in gfortran.
8356 : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
8357 60 : tree present, null_ptr, type;
8358 :
8359 60 : if (attr.allocatable
8360 0 : && (fsym == NULL || !fsym_attr.allocatable))
8361 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8362 : "allocated or not present",
8363 0 : e->symtree->n.sym->name);
8364 60 : else if (attr.pointer
8365 12 : && (fsym == NULL || !fsym_attr.pointer))
8366 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
8367 : "associated or not present",
8368 12 : e->symtree->n.sym->name);
8369 48 : else if (attr.proc_pointer && !e->value.function.actual
8370 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
8371 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8372 : "associated or not present",
8373 0 : e->symtree->n.sym->name);
8374 : else
8375 48 : goto end_pointer_check;
8376 :
8377 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
8378 12 : type = TREE_TYPE (present);
8379 12 : present = fold_build2_loc (input_location, EQ_EXPR,
8380 : logical_type_node, present,
8381 : fold_convert (type,
8382 : null_pointer_node));
8383 12 : type = TREE_TYPE (parmse.expr);
8384 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
8385 : logical_type_node, parmse.expr,
8386 : fold_convert (type,
8387 : null_pointer_node));
8388 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
8389 : logical_type_node, present, null_ptr);
8390 : }
8391 : else
8392 : {
8393 3002 : if (attr.allocatable
8394 256 : && (fsym == NULL || !fsym_attr.allocatable))
8395 190 : msg = xasprintf ("Allocatable actual argument '%s' is not "
8396 190 : "allocated", e->symtree->n.sym->name);
8397 2812 : else if (attr.pointer
8398 272 : && (fsym == NULL || !fsym_attr.pointer))
8399 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
8400 184 : "associated", e->symtree->n.sym->name);
8401 2628 : else if (attr.proc_pointer && !e->value.function.actual
8402 80 : && (fsym == NULL
8403 50 : || (!fsym_attr.proc_pointer && !fsym_attr.optional)))
8404 79 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
8405 79 : "associated", e->symtree->n.sym->name);
8406 : else
8407 2549 : goto end_pointer_check;
8408 :
8409 453 : tmp = parmse.expr;
8410 453 : if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
8411 : {
8412 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
8413 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
8414 76 : tmp = gfc_class_data_get (tmp);
8415 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
8416 3 : tmp = gfc_conv_descriptor_data_get (tmp);
8417 : }
8418 :
8419 : /* If the argument is passed by value, we need to strip the
8420 : INDIRECT_REF. */
8421 453 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
8422 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8423 :
8424 453 : cond = fold_build2_loc (input_location, EQ_EXPR,
8425 : logical_type_node, tmp,
8426 453 : fold_convert (TREE_TYPE (tmp),
8427 : null_pointer_node));
8428 : }
8429 :
8430 465 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
8431 : msg);
8432 465 : free (msg);
8433 : }
8434 264045 : end_pointer_check:
8435 :
8436 : /* Deferred length dummies pass the character length by reference
8437 : so that the value can be returned. */
8438 270591 : if (parmse.string_length && fsym && fsym->ts.deferred)
8439 : {
8440 795 : if (INDIRECT_REF_P (parmse.string_length))
8441 : {
8442 : /* In chains of functions/procedure calls the string_length already
8443 : is a pointer to the variable holding the length. Therefore
8444 : remove the deref on call. */
8445 90 : tmp = parmse.string_length;
8446 90 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
8447 : }
8448 : else
8449 : {
8450 705 : tmp = parmse.string_length;
8451 705 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
8452 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
8453 705 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
8454 : }
8455 :
8456 795 : if (e && e->expr_type == EXPR_VARIABLE
8457 638 : && fsym->attr.allocatable
8458 368 : && e->ts.u.cl->backend_decl
8459 368 : && VAR_P (e->ts.u.cl->backend_decl))
8460 : {
8461 284 : if (INDIRECT_REF_P (tmp))
8462 0 : tmp = TREE_OPERAND (tmp, 0);
8463 284 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
8464 : fold_convert (gfc_charlen_type_node, tmp));
8465 : }
8466 : }
8467 :
8468 : /* Character strings are passed as two parameters, a length and a
8469 : pointer - except for Bind(c) and c_ptrs which only pass the pointer.
8470 : An unlimited polymorphic formal argument likewise does not
8471 : need the length. */
8472 270591 : if (parmse.string_length != NULL_TREE
8473 36875 : && !sym->attr.is_bind_c
8474 36179 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
8475 6 : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8476 6 : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
8477 30295 : && !(fsym && fsym->ts.type == BT_ASSUMED)
8478 30186 : && !(fsym && UNLIMITED_POLY (fsym)))
8479 35889 : vec_safe_push (stringargs, parmse.string_length);
8480 :
8481 : /* When calling __copy for character expressions to unlimited
8482 : polymorphic entities, the dst argument needs a string length. */
8483 51840 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
8484 5325 : && startswith (sym->name, "__vtab_CHARACTER")
8485 0 : && arg->next && arg->next->expr
8486 0 : && (arg->next->expr->ts.type == BT_DERIVED
8487 0 : || arg->next->expr->ts.type == BT_CLASS)
8488 270591 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
8489 0 : vec_safe_push (stringargs, parmse.string_length);
8490 :
8491 : /* For descriptorless coarrays and assumed-shape coarray dummies, we
8492 : pass the token and the offset as additional arguments. */
8493 270591 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
8494 122 : && attr->codimension && !attr->allocatable)
8495 : {
8496 : /* Token and offset. */
8497 5 : vec_safe_push (stringargs, null_pointer_node);
8498 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
8499 5 : gcc_assert (fsym->attr.optional);
8500 : }
8501 237641 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB && attr->codimension
8502 145 : && !attr->allocatable)
8503 : {
8504 123 : tree caf_decl, caf_type, caf_desc = NULL_TREE;
8505 123 : tree offset, tmp2;
8506 :
8507 123 : caf_decl = gfc_get_tree_for_caf_expr (e);
8508 123 : caf_type = TREE_TYPE (caf_decl);
8509 123 : if (POINTER_TYPE_P (caf_type)
8510 123 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_type)))
8511 3 : caf_desc = TREE_TYPE (caf_type);
8512 120 : else if (GFC_DESCRIPTOR_TYPE_P (caf_type))
8513 : caf_desc = caf_type;
8514 :
8515 51 : if (caf_desc
8516 51 : && (GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE
8517 0 : || GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_POINTER))
8518 : {
8519 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8520 54 : ? build_fold_indirect_ref (caf_decl)
8521 : : caf_decl;
8522 51 : tmp = gfc_conv_descriptor_token (tmp);
8523 : }
8524 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8525 72 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
8526 12 : tmp = GFC_DECL_TOKEN (caf_decl);
8527 : else
8528 : {
8529 60 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
8530 : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
8531 60 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
8532 : }
8533 :
8534 123 : vec_safe_push (stringargs, tmp);
8535 :
8536 123 : if (caf_desc
8537 123 : && GFC_TYPE_ARRAY_AKIND (caf_desc) == GFC_ARRAY_ALLOCATABLE)
8538 51 : offset = build_int_cst (gfc_array_index_type, 0);
8539 72 : else if (DECL_LANG_SPECIFIC (caf_decl)
8540 72 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
8541 12 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
8542 60 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
8543 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
8544 : else
8545 60 : offset = build_int_cst (gfc_array_index_type, 0);
8546 :
8547 123 : if (caf_desc)
8548 : {
8549 102 : tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
8550 54 : ? build_fold_indirect_ref (caf_decl)
8551 : : caf_decl;
8552 51 : tmp = gfc_conv_descriptor_data_get (tmp);
8553 : }
8554 : else
8555 : {
8556 72 : gcc_assert (POINTER_TYPE_P (caf_type));
8557 72 : tmp = caf_decl;
8558 : }
8559 :
8560 108 : tmp2 = fsym->ts.type == BT_CLASS
8561 123 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
8562 123 : if ((fsym->ts.type != BT_CLASS
8563 108 : && (fsym->as->type == AS_ASSUMED_SHAPE
8564 59 : || fsym->as->type == AS_ASSUMED_RANK))
8565 74 : || (fsym->ts.type == BT_CLASS
8566 15 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
8567 10 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
8568 : {
8569 54 : if (fsym->ts.type == BT_CLASS)
8570 5 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
8571 : else
8572 : {
8573 49 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8574 49 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
8575 : }
8576 54 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
8577 54 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8578 : }
8579 69 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
8580 10 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
8581 : else
8582 : {
8583 59 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
8584 : }
8585 :
8586 123 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8587 : gfc_array_index_type,
8588 : fold_convert (gfc_array_index_type, tmp2),
8589 : fold_convert (gfc_array_index_type, tmp));
8590 123 : offset = fold_build2_loc (input_location, PLUS_EXPR,
8591 : gfc_array_index_type, offset, tmp);
8592 :
8593 123 : vec_safe_push (stringargs, offset);
8594 : }
8595 :
8596 270591 : vec_safe_push (arglist, parmse.expr);
8597 : }
8598 :
8599 130254 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
8600 130254 : gfc_add_block_to_block (&se->pre, &clobbers);
8601 130254 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
8602 :
8603 130254 : if (comp)
8604 1980 : ts = comp->ts;
8605 128274 : else if (sym->ts.type == BT_CLASS)
8606 850 : ts = CLASS_DATA (sym)->ts;
8607 : else
8608 127424 : ts = sym->ts;
8609 :
8610 130254 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
8611 210 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
8612 130044 : else if (ts.type == BT_CHARACTER)
8613 : {
8614 5009 : if (ts.u.cl->length == NULL)
8615 : {
8616 : /* Assumed character length results are not allowed by C418 of the 2003
8617 : standard and are trapped in resolve.cc; except in the case of SPREAD
8618 : (and other intrinsics?) and dummy functions. In the case of SPREAD,
8619 : we take the character length of the first argument for the result.
8620 : For dummies, we have to look through the formal argument list for
8621 : this function and use the character length found there.
8622 : Likewise, we handle the case of deferred-length character dummy
8623 : arguments to intrinsics that determine the characteristics of
8624 : the result, which cannot be deferred-length. */
8625 2303 : if (expr->value.function.isym)
8626 1703 : ts.deferred = false;
8627 2303 : if (ts.deferred)
8628 593 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
8629 1710 : else if (!sym->attr.dummy)
8630 1703 : cl.backend_decl = (*stringargs)[0];
8631 : else
8632 : {
8633 7 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
8634 26 : for (; formal; formal = formal->next)
8635 12 : if (strcmp (formal->sym->name, sym->name) == 0)
8636 7 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
8637 : }
8638 2303 : len = cl.backend_decl;
8639 : }
8640 : else
8641 : {
8642 2706 : tree tmp;
8643 :
8644 : /* Calculate the length of the returned string. */
8645 2706 : gfc_init_se (&parmse, NULL);
8646 2706 : if (need_interface_mapping)
8647 1867 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
8648 : else
8649 839 : gfc_conv_expr (&parmse, ts.u.cl->length);
8650 2706 : gfc_add_block_to_block (&se->pre, &parmse.pre);
8651 2706 : gfc_add_block_to_block (&se->post, &parmse.post);
8652 2706 : tmp = parmse.expr;
8653 : /* TODO: It would be better to have the charlens as
8654 : gfc_charlen_type_node already when the interface is
8655 : created instead of converting it here (see PR 84615). */
8656 2706 : tmp = fold_build2_loc (input_location, MAX_EXPR,
8657 : gfc_charlen_type_node,
8658 : fold_convert (gfc_charlen_type_node, tmp),
8659 : build_zero_cst (gfc_charlen_type_node));
8660 2706 : cl.backend_decl = tmp;
8661 : }
8662 :
8663 : /* Set up a charlen structure for it. */
8664 5009 : cl.next = NULL;
8665 5009 : cl.length = NULL;
8666 5009 : ts.u.cl = &cl;
8667 :
8668 5009 : len = cl.backend_decl;
8669 : }
8670 :
8671 1980 : byref = (comp && (comp->attr.dimension
8672 1911 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
8673 130254 : || (!comp && gfc_return_by_reference (sym));
8674 :
8675 18755 : if (byref)
8676 : {
8677 18755 : if (se->direct_byref)
8678 : {
8679 : /* Sometimes, too much indirection can be applied; e.g. for
8680 : function_result = array_valued_recursive_function. */
8681 6986 : if (TREE_TYPE (TREE_TYPE (se->expr))
8682 6986 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
8683 7004 : && GFC_DESCRIPTOR_TYPE_P
8684 : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
8685 18 : se->expr = build_fold_indirect_ref_loc (input_location,
8686 : se->expr);
8687 :
8688 : /* If the lhs of an assignment x = f(..) is allocatable and
8689 : f2003 is allowed, we must do the automatic reallocation.
8690 : TODO - deal with intrinsics, without using a temporary. */
8691 6986 : if (flag_realloc_lhs
8692 6911 : && se->ss && se->ss->loop_chain
8693 203 : && se->ss->loop_chain->is_alloc_lhs
8694 203 : && !expr->value.function.isym
8695 203 : && sym->result->as != NULL)
8696 : {
8697 : /* Evaluate the bounds of the result, if known. */
8698 203 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
8699 : sym->result->as);
8700 :
8701 : /* Perform the automatic reallocation. */
8702 203 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
8703 : expr, NULL);
8704 203 : gfc_add_expr_to_block (&se->pre, tmp);
8705 :
8706 : /* Pass the temporary as the first argument. */
8707 203 : result = info->descriptor;
8708 : }
8709 : else
8710 6783 : result = build_fold_indirect_ref_loc (input_location,
8711 : se->expr);
8712 6986 : vec_safe_push (retargs, se->expr);
8713 : }
8714 11769 : else if (comp && comp->attr.dimension)
8715 : {
8716 66 : gcc_assert (se->loop && info);
8717 :
8718 : /* Set the type of the array. vtable charlens are not always reliable.
8719 : Use the interface, if possible. */
8720 66 : if (comp->ts.type == BT_CHARACTER
8721 1 : && expr->symtree->n.sym->ts.type == BT_CLASS
8722 1 : && comp->ts.interface && comp->ts.interface->result)
8723 1 : tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
8724 : else
8725 65 : tmp = gfc_typenode_for_spec (&comp->ts);
8726 66 : gcc_assert (se->ss->dimen == se->loop->dimen);
8727 :
8728 : /* Evaluate the bounds of the result, if known. */
8729 66 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
8730 :
8731 : /* If the lhs of an assignment x = f(..) is allocatable and
8732 : f2003 is allowed, we must not generate the function call
8733 : here but should just send back the results of the mapping.
8734 : This is signalled by the function ss being flagged. */
8735 66 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8736 : {
8737 0 : gfc_free_interface_mapping (&mapping);
8738 0 : return has_alternate_specifier;
8739 : }
8740 :
8741 : /* Create a temporary to store the result. In case the function
8742 : returns a pointer, the temporary will be a shallow copy and
8743 : mustn't be deallocated. */
8744 66 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
8745 66 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8746 : tmp, NULL_TREE, false,
8747 : !comp->attr.pointer, callee_alloc,
8748 66 : &se->ss->info->expr->where);
8749 :
8750 : /* Pass the temporary as the first argument. */
8751 66 : result = info->descriptor;
8752 66 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8753 66 : vec_safe_push (retargs, tmp);
8754 : }
8755 11474 : else if (!comp && sym->result->attr.dimension)
8756 : {
8757 8456 : gcc_assert (se->loop && info);
8758 :
8759 : /* Set the type of the array. */
8760 8456 : tmp = gfc_typenode_for_spec (&ts);
8761 8456 : tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
8762 8456 : gcc_assert (se->ss->dimen == se->loop->dimen);
8763 :
8764 : /* Evaluate the bounds of the result, if known. */
8765 8456 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
8766 :
8767 : /* If the lhs of an assignment x = f(..) is allocatable and
8768 : f2003 is allowed, we must not generate the function call
8769 : here but should just send back the results of the mapping.
8770 : This is signalled by the function ss being flagged. */
8771 8456 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
8772 : {
8773 0 : gfc_free_interface_mapping (&mapping);
8774 0 : return has_alternate_specifier;
8775 : }
8776 :
8777 : /* Create a temporary to store the result. In case the function
8778 : returns a pointer, the temporary will be a shallow copy and
8779 : mustn't be deallocated. */
8780 8456 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
8781 8456 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
8782 : tmp, NULL_TREE, false,
8783 : !sym->attr.pointer, callee_alloc,
8784 8456 : &se->ss->info->expr->where);
8785 :
8786 : /* Pass the temporary as the first argument. */
8787 8456 : result = info->descriptor;
8788 8456 : tmp = gfc_build_addr_expr (NULL_TREE, result);
8789 8456 : vec_safe_push (retargs, tmp);
8790 : }
8791 3247 : else if (ts.type == BT_CHARACTER)
8792 : {
8793 : /* Pass the string length. */
8794 3186 : type = gfc_get_character_type (ts.kind, ts.u.cl);
8795 3186 : type = build_pointer_type (type);
8796 :
8797 : /* Emit a DECL_EXPR for the VLA type. */
8798 3186 : tmp = TREE_TYPE (type);
8799 3186 : if (TYPE_SIZE (tmp)
8800 3186 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
8801 : {
8802 1923 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
8803 1923 : DECL_ARTIFICIAL (tmp) = 1;
8804 1923 : DECL_IGNORED_P (tmp) = 1;
8805 1923 : tmp = fold_build1_loc (input_location, DECL_EXPR,
8806 1923 : TREE_TYPE (tmp), tmp);
8807 1923 : gfc_add_expr_to_block (&se->pre, tmp);
8808 : }
8809 :
8810 : /* Return an address to a char[0:len-1]* temporary for
8811 : character pointers. */
8812 3186 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8813 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8814 : {
8815 636 : var = gfc_create_var (type, "pstr");
8816 :
8817 636 : if ((!comp && sym->attr.allocatable)
8818 21 : || (comp && comp->attr.allocatable))
8819 : {
8820 349 : gfc_add_modify (&se->pre, var,
8821 349 : fold_convert (TREE_TYPE (var),
8822 : null_pointer_node));
8823 349 : tmp = gfc_call_free (var);
8824 349 : gfc_add_expr_to_block (&se->post, tmp);
8825 : }
8826 :
8827 : /* Provide an address expression for the function arguments. */
8828 636 : var = gfc_build_addr_expr (NULL_TREE, var);
8829 : }
8830 : else
8831 2550 : var = gfc_conv_string_tmp (se, type, len);
8832 :
8833 3186 : vec_safe_push (retargs, var);
8834 : }
8835 : else
8836 : {
8837 61 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
8838 :
8839 61 : type = gfc_get_complex_type (ts.kind);
8840 61 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
8841 61 : vec_safe_push (retargs, var);
8842 : }
8843 :
8844 : /* Add the string length to the argument list. */
8845 18755 : if (ts.type == BT_CHARACTER && ts.deferred)
8846 : {
8847 593 : tmp = len;
8848 593 : if (!VAR_P (tmp))
8849 0 : tmp = gfc_evaluate_now (len, &se->pre);
8850 593 : TREE_STATIC (tmp) = 1;
8851 593 : gfc_add_modify (&se->pre, tmp,
8852 593 : build_int_cst (TREE_TYPE (tmp), 0));
8853 593 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8854 593 : vec_safe_push (retargs, tmp);
8855 : }
8856 18162 : else if (ts.type == BT_CHARACTER)
8857 4416 : vec_safe_push (retargs, len);
8858 : }
8859 :
8860 130254 : gfc_free_interface_mapping (&mapping);
8861 :
8862 : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
8863 242539 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
8864 155592 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
8865 130254 : vec_safe_reserve (retargs, arglen);
8866 :
8867 : /* Add the return arguments. */
8868 130254 : vec_safe_splice (retargs, arglist);
8869 :
8870 : /* Add the hidden present status for optional+value to the arguments. */
8871 130254 : vec_safe_splice (retargs, optionalargs);
8872 :
8873 : /* Add the hidden string length parameters to the arguments. */
8874 130254 : vec_safe_splice (retargs, stringargs);
8875 :
8876 : /* We may want to append extra arguments here. This is used e.g. for
8877 : calls to libgfortran_matmul_??, which need extra information. */
8878 130254 : vec_safe_splice (retargs, append_args);
8879 :
8880 130254 : arglist = retargs;
8881 :
8882 : /* Generate the actual call. */
8883 130254 : is_builtin = false;
8884 130254 : if (base_object == NULL_TREE)
8885 130174 : conv_function_val (se, &is_builtin, sym, expr, args);
8886 : else
8887 80 : conv_base_obj_fcn_val (se, base_object, expr);
8888 :
8889 : /* If there are alternate return labels, function type should be
8890 : integer. Can't modify the type in place though, since it can be shared
8891 : with other functions. For dummy arguments, the typing is done to
8892 : this result, even if it has to be repeated for each call. */
8893 130254 : if (has_alternate_specifier
8894 130254 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
8895 : {
8896 7 : if (!sym->attr.dummy)
8897 : {
8898 0 : TREE_TYPE (sym->backend_decl)
8899 0 : = build_function_type (integer_type_node,
8900 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
8901 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
8902 : }
8903 : else
8904 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
8905 : }
8906 :
8907 130254 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
8908 130254 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
8909 :
8910 130254 : if (is_builtin)
8911 552 : se->expr = update_builtin_function (se->expr, sym);
8912 :
8913 : /* Allocatable scalar function results must be freed and nullified
8914 : after use. This necessitates the creation of a temporary to
8915 : hold the result to prevent duplicate calls. */
8916 130254 : symbol_attribute attr = comp ? comp->attr : sym->attr;
8917 130254 : bool allocatable = attr.allocatable && !attr.dimension;
8918 133483 : gfc_symbol *der = comp ?
8919 1980 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
8920 : :
8921 128274 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
8922 3229 : bool finalizable = der != NULL && der->ns->proc_name
8923 6455 : && gfc_is_finalizable (der, NULL);
8924 :
8925 130254 : if (!byref && finalizable)
8926 182 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8927 :
8928 130254 : if (!byref && sym->ts.type != BT_CHARACTER
8929 111289 : && allocatable && !finalizable)
8930 : {
8931 230 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
8932 230 : gfc_add_modify (&se->pre, tmp, se->expr);
8933 230 : se->expr = tmp;
8934 230 : tmp = gfc_call_free (tmp);
8935 230 : gfc_add_expr_to_block (&post, tmp);
8936 230 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
8937 : }
8938 :
8939 : /* If we have a pointer function, but we don't want a pointer, e.g.
8940 : something like
8941 : x = f()
8942 : where f is pointer valued, we have to dereference the result. */
8943 130254 : if (!se->want_pointer && !byref
8944 110897 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8945 1638 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
8946 456 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8947 :
8948 : /* f2c calling conventions require a scalar default real function to
8949 : return a double precision result. Convert this back to default
8950 : real. We only care about the cases that can happen in Fortran 77.
8951 : */
8952 130254 : if (flag_f2c && sym->ts.type == BT_REAL
8953 98 : && sym->ts.kind == gfc_default_real_kind
8954 74 : && !sym->attr.pointer
8955 55 : && !sym->attr.allocatable
8956 43 : && !sym->attr.always_explicit)
8957 43 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
8958 :
8959 : /* A pure function may still have side-effects - it may modify its
8960 : parameters. */
8961 130254 : TREE_SIDE_EFFECTS (se->expr) = 1;
8962 : #if 0
8963 : if (!sym->attr.pure)
8964 : TREE_SIDE_EFFECTS (se->expr) = 1;
8965 : #endif
8966 :
8967 130254 : if (byref)
8968 : {
8969 : /* Add the function call to the pre chain. There is no expression. */
8970 18755 : gfc_add_expr_to_block (&se->pre, se->expr);
8971 18755 : se->expr = NULL_TREE;
8972 :
8973 18755 : if (!se->direct_byref)
8974 : {
8975 11769 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
8976 : {
8977 8522 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
8978 : {
8979 : /* Check the data pointer hasn't been modified. This would
8980 : happen in a function returning a pointer. */
8981 251 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
8982 251 : tmp = fold_build2_loc (input_location, NE_EXPR,
8983 : logical_type_node,
8984 : tmp, info->data);
8985 251 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
8986 : gfc_msg_fault);
8987 : }
8988 8522 : se->expr = info->descriptor;
8989 : /* Bundle in the string length. */
8990 8522 : se->string_length = len;
8991 :
8992 8522 : if (finalizable)
8993 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8994 : }
8995 3247 : else if (ts.type == BT_CHARACTER)
8996 : {
8997 : /* Dereference for character pointer results. */
8998 3186 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8999 229 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
9000 636 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9001 : else
9002 2550 : se->expr = var;
9003 :
9004 3186 : se->string_length = len;
9005 : }
9006 : else
9007 : {
9008 61 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
9009 61 : se->expr = build_fold_indirect_ref_loc (input_location, var);
9010 : }
9011 : }
9012 : }
9013 :
9014 : /* Associate the rhs class object's meta-data with the result, when the
9015 : result is a temporary. */
9016 112290 : if (args && args->expr && args->expr->ts.type == BT_CLASS
9017 4961 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
9018 130286 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
9019 : {
9020 32 : gfc_se parmse;
9021 32 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
9022 :
9023 32 : gfc_init_se (&parmse, NULL);
9024 32 : parmse.data_not_needed = 1;
9025 32 : gfc_conv_expr (&parmse, class_expr);
9026 32 : if (!DECL_LANG_SPECIFIC (result))
9027 32 : gfc_allocate_lang_decl (result);
9028 32 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
9029 32 : gfc_free_expr (class_expr);
9030 : /* -fcheck= can add diagnostic code, which has to be placed before
9031 : the call. */
9032 32 : if (parmse.pre.head != NULL)
9033 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
9034 32 : gcc_assert (parmse.post.head == NULL_TREE);
9035 : }
9036 :
9037 : /* Follow the function call with the argument post block. */
9038 130254 : if (byref)
9039 : {
9040 18755 : gfc_add_block_to_block (&se->pre, &post);
9041 :
9042 : /* Transformational functions of derived types with allocatable
9043 : components must have the result allocatable components copied when the
9044 : argument is actually given. This is unnecessry for REDUCE because the
9045 : wrapper for the OPERATION function takes care of this. */
9046 18755 : arg = expr->value.function.actual;
9047 18755 : if (result && arg && expr->rank
9048 14661 : && isym && isym->transformational
9049 13092 : && isym->id != GFC_ISYM_REDUCE
9050 12966 : && arg->expr
9051 12906 : && arg->expr->ts.type == BT_DERIVED
9052 229 : && arg->expr->ts.u.derived->attr.alloc_comp)
9053 : {
9054 36 : tree tmp2;
9055 : /* Copy the allocatable components. We have to use a
9056 : temporary here to prevent source allocatable components
9057 : from being corrupted. */
9058 36 : tmp2 = gfc_evaluate_now (result, &se->pre);
9059 36 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
9060 : result, tmp2, expr->rank, 0);
9061 36 : gfc_add_expr_to_block (&se->pre, tmp);
9062 36 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
9063 : expr->rank);
9064 36 : gfc_add_expr_to_block (&se->pre, tmp);
9065 :
9066 : /* Finally free the temporary's data field. */
9067 36 : tmp = gfc_conv_descriptor_data_get (tmp2);
9068 36 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
9069 : NULL_TREE, NULL_TREE, true,
9070 : NULL, GFC_CAF_COARRAY_NOCOARRAY);
9071 36 : gfc_add_expr_to_block (&se->pre, tmp);
9072 : }
9073 : }
9074 : else
9075 : {
9076 : /* For a function with a class array result, save the result as
9077 : a temporary, set the info fields needed by the scalarizer and
9078 : call the finalization function of the temporary. Note that the
9079 : nullification of allocatable components needed by the result
9080 : is done in gfc_trans_assignment_1. */
9081 34614 : if (expr && (gfc_is_class_array_function (expr)
9082 34292 : || gfc_is_alloc_class_scalar_function (expr))
9083 841 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
9084 112328 : && expr->must_finalize)
9085 : {
9086 : /* TODO Eliminate the doubling of temporaries. This
9087 : one is necessary to ensure no memory leakage. */
9088 321 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
9089 :
9090 : /* Finalize the result, if necessary. */
9091 642 : attr = expr->value.function.esym
9092 321 : ? CLASS_DATA (expr->value.function.esym->result)->attr
9093 14 : : CLASS_DATA (expr)->attr;
9094 321 : if (!((gfc_is_class_array_function (expr)
9095 108 : || gfc_is_alloc_class_scalar_function (expr))
9096 321 : && attr.pointer))
9097 276 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
9098 : }
9099 111499 : gfc_add_block_to_block (&se->post, &post);
9100 : }
9101 :
9102 : return has_alternate_specifier;
9103 : }
9104 :
9105 :
9106 : /* Fill a character string with spaces. */
9107 :
9108 : static tree
9109 30475 : fill_with_spaces (tree start, tree type, tree size)
9110 : {
9111 30475 : stmtblock_t block, loop;
9112 30475 : tree i, el, exit_label, cond, tmp;
9113 :
9114 : /* For a simple char type, we can call memset(). */
9115 30475 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
9116 50362 : return build_call_expr_loc (input_location,
9117 : builtin_decl_explicit (BUILT_IN_MEMSET),
9118 : 3, start,
9119 : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
9120 25181 : lang_hooks.to_target_charset (' ')),
9121 : fold_convert (size_type_node, size));
9122 :
9123 : /* Otherwise, we use a loop:
9124 : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
9125 : *el = (type) ' ';
9126 : */
9127 :
9128 : /* Initialize variables. */
9129 5294 : gfc_init_block (&block);
9130 5294 : i = gfc_create_var (sizetype, "i");
9131 5294 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
9132 5294 : el = gfc_create_var (build_pointer_type (type), "el");
9133 5294 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
9134 5294 : exit_label = gfc_build_label_decl (NULL_TREE);
9135 5294 : TREE_USED (exit_label) = 1;
9136 :
9137 :
9138 : /* Loop body. */
9139 5294 : gfc_init_block (&loop);
9140 :
9141 : /* Exit condition. */
9142 5294 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
9143 : build_zero_cst (sizetype));
9144 5294 : tmp = build1_v (GOTO_EXPR, exit_label);
9145 5294 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9146 : build_empty_stmt (input_location));
9147 5294 : gfc_add_expr_to_block (&loop, tmp);
9148 :
9149 : /* Assignment. */
9150 5294 : gfc_add_modify (&loop,
9151 : fold_build1_loc (input_location, INDIRECT_REF, type, el),
9152 5294 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
9153 :
9154 : /* Increment loop variables. */
9155 5294 : gfc_add_modify (&loop, i,
9156 : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
9157 5294 : TYPE_SIZE_UNIT (type)));
9158 5294 : gfc_add_modify (&loop, el,
9159 : fold_build_pointer_plus_loc (input_location,
9160 5294 : el, TYPE_SIZE_UNIT (type)));
9161 :
9162 : /* Making the loop... actually loop! */
9163 5294 : tmp = gfc_finish_block (&loop);
9164 5294 : tmp = build1_v (LOOP_EXPR, tmp);
9165 5294 : gfc_add_expr_to_block (&block, tmp);
9166 :
9167 : /* The exit label. */
9168 5294 : tmp = build1_v (LABEL_EXPR, exit_label);
9169 5294 : gfc_add_expr_to_block (&block, tmp);
9170 :
9171 :
9172 5294 : return gfc_finish_block (&block);
9173 : }
9174 :
9175 :
9176 : /* Generate code to copy a string. */
9177 :
9178 : void
9179 35637 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
9180 : int dkind, tree slength, tree src, int skind)
9181 : {
9182 35637 : tree tmp, dlen, slen;
9183 35637 : tree dsc;
9184 35637 : tree ssc;
9185 35637 : tree cond;
9186 35637 : tree cond2;
9187 35637 : tree tmp2;
9188 35637 : tree tmp3;
9189 35637 : tree tmp4;
9190 35637 : tree chartype;
9191 35637 : stmtblock_t tempblock;
9192 :
9193 35637 : gcc_assert (dkind == skind);
9194 :
9195 35637 : if (slength != NULL_TREE)
9196 : {
9197 35637 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
9198 35637 : ssc = gfc_string_to_single_character (slen, src, skind);
9199 : }
9200 : else
9201 : {
9202 0 : slen = build_one_cst (gfc_charlen_type_node);
9203 0 : ssc = src;
9204 : }
9205 :
9206 35637 : if (dlength != NULL_TREE)
9207 : {
9208 35637 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
9209 35637 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
9210 : }
9211 : else
9212 : {
9213 0 : dlen = build_one_cst (gfc_charlen_type_node);
9214 0 : dsc = dest;
9215 : }
9216 :
9217 : /* Assign directly if the types are compatible. */
9218 35637 : if (dsc != NULL_TREE && ssc != NULL_TREE
9219 35637 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
9220 : {
9221 5162 : gfc_add_modify (block, dsc, ssc);
9222 5162 : return;
9223 : }
9224 :
9225 : /* The string copy algorithm below generates code like
9226 :
9227 : if (destlen > 0)
9228 : {
9229 : if (srclen < destlen)
9230 : {
9231 : memmove (dest, src, srclen);
9232 : // Pad with spaces.
9233 : memset (&dest[srclen], ' ', destlen - srclen);
9234 : }
9235 : else
9236 : {
9237 : // Truncate if too long.
9238 : memmove (dest, src, destlen);
9239 : }
9240 : }
9241 : */
9242 :
9243 : /* Do nothing if the destination length is zero. */
9244 30475 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
9245 30475 : build_zero_cst (TREE_TYPE (dlen)));
9246 :
9247 : /* For non-default character kinds, we have to multiply the string
9248 : length by the base type size. */
9249 30475 : chartype = gfc_get_char_type (dkind);
9250 30475 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
9251 : slen,
9252 30475 : fold_convert (TREE_TYPE (slen),
9253 : TYPE_SIZE_UNIT (chartype)));
9254 30475 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
9255 : dlen,
9256 30475 : fold_convert (TREE_TYPE (dlen),
9257 : TYPE_SIZE_UNIT (chartype)));
9258 :
9259 30475 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
9260 30427 : dest = fold_convert (pvoid_type_node, dest);
9261 : else
9262 48 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
9263 :
9264 30475 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
9265 30471 : src = fold_convert (pvoid_type_node, src);
9266 : else
9267 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
9268 :
9269 : /* Truncate string if source is too long. */
9270 30475 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
9271 : dlen);
9272 :
9273 : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
9274 30475 : if (!CONSTANT_CLASS_P (cond2))
9275 : {
9276 9379 : dest = gfc_evaluate_now (dest, block);
9277 9379 : src = gfc_evaluate_now (src, block);
9278 : }
9279 :
9280 : /* Copy and pad with spaces. */
9281 30475 : tmp3 = build_call_expr_loc (input_location,
9282 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9283 : 3, dest, src,
9284 : fold_convert (size_type_node, slen));
9285 :
9286 : /* Wstringop-overflow appears at -O3 even though this warning is not
9287 : explicitly available in fortran nor can it be switched off. If the
9288 : source length is a constant, its negative appears as a very large
9289 : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
9290 : the result of the MINUS_EXPR suppresses this spurious warning. */
9291 30475 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
9292 30475 : TREE_TYPE(dlen), dlen, slen);
9293 30475 : if (slength && TREE_CONSTANT (slength))
9294 26950 : tmp = gfc_evaluate_now (tmp, block);
9295 :
9296 30475 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
9297 30475 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
9298 :
9299 30475 : gfc_init_block (&tempblock);
9300 30475 : gfc_add_expr_to_block (&tempblock, tmp3);
9301 30475 : gfc_add_expr_to_block (&tempblock, tmp4);
9302 30475 : tmp3 = gfc_finish_block (&tempblock);
9303 :
9304 : /* The truncated memmove if the slen >= dlen. */
9305 30475 : tmp2 = build_call_expr_loc (input_location,
9306 : builtin_decl_explicit (BUILT_IN_MEMMOVE),
9307 : 3, dest, src,
9308 : fold_convert (size_type_node, dlen));
9309 :
9310 : /* The whole copy_string function is there. */
9311 30475 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
9312 : tmp3, tmp2);
9313 30475 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
9314 : build_empty_stmt (input_location));
9315 30475 : gfc_add_expr_to_block (block, tmp);
9316 : }
9317 :
9318 :
9319 : /* Translate a statement function.
9320 : The value of a statement function reference is obtained by evaluating the
9321 : expression using the values of the actual arguments for the values of the
9322 : corresponding dummy arguments. */
9323 :
9324 : static void
9325 269 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
9326 : {
9327 269 : gfc_symbol *sym;
9328 269 : gfc_symbol *fsym;
9329 269 : gfc_formal_arglist *fargs;
9330 269 : gfc_actual_arglist *args;
9331 269 : gfc_se lse;
9332 269 : gfc_se rse;
9333 269 : gfc_saved_var *saved_vars;
9334 269 : tree *temp_vars;
9335 269 : tree type;
9336 269 : tree tmp;
9337 269 : int n;
9338 :
9339 269 : sym = expr->symtree->n.sym;
9340 269 : args = expr->value.function.actual;
9341 269 : gfc_init_se (&lse, NULL);
9342 269 : gfc_init_se (&rse, NULL);
9343 :
9344 269 : n = 0;
9345 727 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
9346 458 : n++;
9347 269 : saved_vars = XCNEWVEC (gfc_saved_var, n);
9348 269 : temp_vars = XCNEWVEC (tree, n);
9349 :
9350 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9351 458 : fargs = fargs->next, n++)
9352 : {
9353 : /* Each dummy shall be specified, explicitly or implicitly, to be
9354 : scalar. */
9355 458 : gcc_assert (fargs->sym->attr.dimension == 0);
9356 458 : fsym = fargs->sym;
9357 :
9358 458 : if (fsym->ts.type == BT_CHARACTER)
9359 : {
9360 : /* Copy string arguments. */
9361 48 : tree arglen;
9362 :
9363 48 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
9364 : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
9365 :
9366 : /* Create a temporary to hold the value. */
9367 48 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
9368 1 : fsym->ts.u.cl->backend_decl
9369 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
9370 :
9371 48 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
9372 48 : temp_vars[n] = gfc_create_var (type, fsym->name);
9373 :
9374 48 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
9375 :
9376 48 : gfc_conv_expr (&rse, args->expr);
9377 48 : gfc_conv_string_parameter (&rse);
9378 48 : gfc_add_block_to_block (&se->pre, &lse.pre);
9379 48 : gfc_add_block_to_block (&se->pre, &rse.pre);
9380 :
9381 48 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
9382 : rse.string_length, rse.expr, fsym->ts.kind);
9383 48 : gfc_add_block_to_block (&se->pre, &lse.post);
9384 48 : gfc_add_block_to_block (&se->pre, &rse.post);
9385 : }
9386 : else
9387 : {
9388 : /* For everything else, just evaluate the expression. */
9389 :
9390 : /* Create a temporary to hold the value. */
9391 410 : type = gfc_typenode_for_spec (&fsym->ts);
9392 410 : temp_vars[n] = gfc_create_var (type, fsym->name);
9393 :
9394 410 : gfc_conv_expr (&lse, args->expr);
9395 :
9396 410 : gfc_add_block_to_block (&se->pre, &lse.pre);
9397 410 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
9398 410 : gfc_add_block_to_block (&se->pre, &lse.post);
9399 : }
9400 :
9401 458 : args = args->next;
9402 : }
9403 :
9404 : /* Use the temporary variables in place of the real ones. */
9405 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9406 458 : fargs = fargs->next, n++)
9407 458 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
9408 :
9409 269 : gfc_conv_expr (se, sym->value);
9410 :
9411 269 : if (sym->ts.type == BT_CHARACTER)
9412 : {
9413 55 : gfc_conv_const_charlen (sym->ts.u.cl);
9414 :
9415 : /* Force the expression to the correct length. */
9416 55 : if (!INTEGER_CST_P (se->string_length)
9417 101 : || tree_int_cst_lt (se->string_length,
9418 46 : sym->ts.u.cl->backend_decl))
9419 : {
9420 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
9421 31 : tmp = gfc_create_var (type, sym->name);
9422 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
9423 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
9424 : sym->ts.kind, se->string_length, se->expr,
9425 : sym->ts.kind);
9426 31 : se->expr = tmp;
9427 : }
9428 55 : se->string_length = sym->ts.u.cl->backend_decl;
9429 : }
9430 :
9431 : /* Restore the original variables. */
9432 727 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
9433 458 : fargs = fargs->next, n++)
9434 458 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
9435 269 : free (temp_vars);
9436 269 : free (saved_vars);
9437 269 : }
9438 :
9439 :
9440 : /* Translate a function expression. */
9441 :
9442 : static void
9443 311051 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
9444 : {
9445 311051 : gfc_symbol *sym;
9446 :
9447 311051 : if (expr->value.function.isym)
9448 : {
9449 260652 : gfc_conv_intrinsic_function (se, expr);
9450 260652 : return;
9451 : }
9452 :
9453 : /* expr.value.function.esym is the resolved (specific) function symbol for
9454 : most functions. However this isn't set for dummy procedures. */
9455 50399 : sym = expr->value.function.esym;
9456 50399 : if (!sym)
9457 1616 : sym = expr->symtree->n.sym;
9458 :
9459 : /* The IEEE_ARITHMETIC functions are caught here. */
9460 50399 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
9461 13939 : if (gfc_conv_ieee_arithmetic_function (se, expr))
9462 : return;
9463 :
9464 : /* We distinguish statement functions from general functions to improve
9465 : runtime performance. */
9466 37942 : if (sym->attr.proc == PROC_ST_FUNCTION)
9467 : {
9468 269 : gfc_conv_statement_function (se, expr);
9469 269 : return;
9470 : }
9471 :
9472 37673 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
9473 : NULL);
9474 : }
9475 :
9476 :
9477 : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
9478 :
9479 : static bool
9480 39583 : is_zero_initializer_p (gfc_expr * expr)
9481 : {
9482 39583 : if (expr->expr_type != EXPR_CONSTANT)
9483 : return false;
9484 :
9485 : /* We ignore constants with prescribed memory representations for now. */
9486 11375 : if (expr->representation.string)
9487 : return false;
9488 :
9489 11357 : switch (expr->ts.type)
9490 : {
9491 5237 : case BT_INTEGER:
9492 5237 : return mpz_cmp_si (expr->value.integer, 0) == 0;
9493 :
9494 4819 : case BT_REAL:
9495 4819 : return mpfr_zero_p (expr->value.real)
9496 4819 : && MPFR_SIGN (expr->value.real) >= 0;
9497 :
9498 925 : case BT_LOGICAL:
9499 925 : return expr->value.logical == 0;
9500 :
9501 242 : case BT_COMPLEX:
9502 242 : return mpfr_zero_p (mpc_realref (expr->value.complex))
9503 154 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
9504 154 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
9505 384 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
9506 :
9507 : default:
9508 : break;
9509 : }
9510 : return false;
9511 : }
9512 :
9513 :
9514 : static void
9515 35663 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
9516 : {
9517 35663 : gfc_ss *ss;
9518 :
9519 35663 : ss = se->ss;
9520 35663 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
9521 35663 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
9522 :
9523 35663 : gfc_conv_tmp_array_ref (se);
9524 35663 : }
9525 :
9526 :
9527 : /* Build a static initializer. EXPR is the expression for the initial value.
9528 : The other parameters describe the variable of the component being
9529 : initialized. EXPR may be null. */
9530 :
9531 : tree
9532 141934 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
9533 : bool array, bool pointer, bool procptr)
9534 : {
9535 141934 : gfc_se se;
9536 :
9537 141934 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
9538 45116 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
9539 171 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
9540 59 : return build_constructor (type, NULL);
9541 :
9542 141875 : if (!(expr || pointer || procptr))
9543 : return NULL_TREE;
9544 :
9545 : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
9546 : (these are the only two iso_c_binding derived types that can be
9547 : used as initialization expressions). If so, we need to modify
9548 : the 'expr' to be that for a (void *). */
9549 133643 : if (expr != NULL && expr->ts.type == BT_DERIVED
9550 41044 : && expr->ts.is_iso_c && expr->ts.u.derived)
9551 : {
9552 186 : if (TREE_CODE (type) == ARRAY_TYPE)
9553 4 : return build_constructor (type, NULL);
9554 182 : else if (POINTER_TYPE_P (type))
9555 182 : return build_int_cst (type, 0);
9556 : else
9557 0 : gcc_unreachable ();
9558 : }
9559 :
9560 133457 : if (array && !procptr)
9561 : {
9562 8675 : tree ctor;
9563 : /* Arrays need special handling. */
9564 8675 : if (pointer)
9565 776 : ctor = gfc_build_null_descriptor (type);
9566 : /* Special case assigning an array to zero. */
9567 7899 : else if (is_zero_initializer_p (expr))
9568 220 : ctor = build_constructor (type, NULL);
9569 : else
9570 7679 : ctor = gfc_conv_array_initializer (type, expr);
9571 8675 : TREE_STATIC (ctor) = 1;
9572 8675 : return ctor;
9573 : }
9574 124782 : else if (pointer || procptr)
9575 : {
9576 60283 : if (ts->type == BT_CLASS && !procptr)
9577 : {
9578 1762 : gfc_init_se (&se, NULL);
9579 1762 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9580 1762 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9581 1762 : TREE_STATIC (se.expr) = 1;
9582 1762 : return se.expr;
9583 : }
9584 58521 : else if (!expr || expr->expr_type == EXPR_NULL)
9585 31594 : return fold_convert (type, null_pointer_node);
9586 : else
9587 : {
9588 26927 : gfc_init_se (&se, NULL);
9589 26927 : se.want_pointer = 1;
9590 26927 : gfc_conv_expr (&se, expr);
9591 26927 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9592 : return se.expr;
9593 : }
9594 : }
9595 : else
9596 : {
9597 64499 : switch (ts->type)
9598 : {
9599 19184 : case_bt_struct:
9600 19184 : case BT_CLASS:
9601 19184 : gfc_init_se (&se, NULL);
9602 19184 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
9603 757 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
9604 : else
9605 18427 : gfc_conv_structure (&se, expr, 1);
9606 19184 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
9607 19184 : TREE_STATIC (se.expr) = 1;
9608 19184 : return se.expr;
9609 :
9610 2687 : case BT_CHARACTER:
9611 2687 : if (expr->expr_type == EXPR_CONSTANT)
9612 : {
9613 2686 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
9614 2686 : TREE_STATIC (ctor) = 1;
9615 2686 : return ctor;
9616 : }
9617 :
9618 : /* Fallthrough. */
9619 42629 : default:
9620 42629 : gfc_init_se (&se, NULL);
9621 42629 : gfc_conv_constant (&se, expr);
9622 42629 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
9623 : return se.expr;
9624 : }
9625 : }
9626 : }
9627 :
9628 : static tree
9629 956 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
9630 : {
9631 956 : gfc_se rse;
9632 956 : gfc_se lse;
9633 956 : gfc_ss *rss;
9634 956 : gfc_ss *lss;
9635 956 : gfc_array_info *lss_array;
9636 956 : stmtblock_t body;
9637 956 : stmtblock_t block;
9638 956 : gfc_loopinfo loop;
9639 956 : int n;
9640 956 : tree tmp;
9641 :
9642 956 : gfc_start_block (&block);
9643 :
9644 : /* Initialize the scalarizer. */
9645 956 : gfc_init_loopinfo (&loop);
9646 :
9647 956 : gfc_init_se (&lse, NULL);
9648 956 : gfc_init_se (&rse, NULL);
9649 :
9650 : /* Walk the rhs. */
9651 956 : rss = gfc_walk_expr (expr);
9652 956 : if (rss == gfc_ss_terminator)
9653 : /* The rhs is scalar. Add a ss for the expression. */
9654 208 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
9655 :
9656 : /* Create a SS for the destination. */
9657 956 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
9658 : GFC_SS_COMPONENT);
9659 956 : lss_array = &lss->info->data.array;
9660 956 : lss_array->shape = gfc_get_shape (cm->as->rank);
9661 956 : lss_array->descriptor = dest;
9662 956 : lss_array->data = gfc_conv_array_data (dest);
9663 956 : lss_array->offset = gfc_conv_array_offset (dest);
9664 1969 : for (n = 0; n < cm->as->rank; n++)
9665 : {
9666 1013 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
9667 1013 : lss_array->stride[n] = gfc_index_one_node;
9668 :
9669 1013 : mpz_init (lss_array->shape[n]);
9670 1013 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
9671 1013 : cm->as->lower[n]->value.integer);
9672 1013 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
9673 : }
9674 :
9675 : /* Associate the SS with the loop. */
9676 956 : gfc_add_ss_to_loop (&loop, lss);
9677 956 : gfc_add_ss_to_loop (&loop, rss);
9678 :
9679 : /* Calculate the bounds of the scalarization. */
9680 956 : gfc_conv_ss_startstride (&loop);
9681 :
9682 : /* Setup the scalarizing loops. */
9683 956 : gfc_conv_loop_setup (&loop, &expr->where);
9684 :
9685 : /* Setup the gfc_se structures. */
9686 956 : gfc_copy_loopinfo_to_se (&lse, &loop);
9687 956 : gfc_copy_loopinfo_to_se (&rse, &loop);
9688 :
9689 956 : rse.ss = rss;
9690 956 : gfc_mark_ss_chain_used (rss, 1);
9691 956 : lse.ss = lss;
9692 956 : gfc_mark_ss_chain_used (lss, 1);
9693 :
9694 : /* Start the scalarized loop body. */
9695 956 : gfc_start_scalarized_body (&loop, &body);
9696 :
9697 956 : gfc_conv_tmp_array_ref (&lse);
9698 956 : if (cm->ts.type == BT_CHARACTER)
9699 176 : lse.string_length = cm->ts.u.cl->backend_decl;
9700 :
9701 956 : gfc_conv_expr (&rse, expr);
9702 :
9703 956 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
9704 956 : gfc_add_expr_to_block (&body, tmp);
9705 :
9706 956 : gcc_assert (rse.ss == gfc_ss_terminator);
9707 :
9708 : /* Generate the copying loops. */
9709 956 : gfc_trans_scalarizing_loops (&loop, &body);
9710 :
9711 : /* Wrap the whole thing up. */
9712 956 : gfc_add_block_to_block (&block, &loop.pre);
9713 956 : gfc_add_block_to_block (&block, &loop.post);
9714 :
9715 956 : gcc_assert (lss_array->shape != NULL);
9716 956 : gfc_free_shape (&lss_array->shape, cm->as->rank);
9717 956 : gfc_cleanup_loop (&loop);
9718 :
9719 956 : return gfc_finish_block (&block);
9720 : }
9721 :
9722 :
9723 : static stmtblock_t *final_block;
9724 : static tree
9725 1292 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
9726 : gfc_expr * expr)
9727 : {
9728 1292 : gfc_se se;
9729 1292 : stmtblock_t block;
9730 1292 : tree offset;
9731 1292 : int n;
9732 1292 : tree tmp;
9733 1292 : tree tmp2;
9734 1292 : gfc_array_spec *as;
9735 1292 : gfc_expr *arg = NULL;
9736 :
9737 1292 : gfc_start_block (&block);
9738 1292 : gfc_init_se (&se, NULL);
9739 :
9740 : /* Get the descriptor for the expressions. */
9741 1292 : se.want_pointer = 0;
9742 1292 : gfc_conv_expr_descriptor (&se, expr);
9743 1292 : gfc_add_block_to_block (&block, &se.pre);
9744 1292 : gfc_add_modify (&block, dest, se.expr);
9745 1292 : if (cm->ts.type == BT_CHARACTER
9746 1292 : && gfc_deferred_strlen (cm, &tmp))
9747 : {
9748 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
9749 30 : TREE_TYPE (tmp),
9750 30 : TREE_OPERAND (dest, 0),
9751 : tmp, NULL_TREE);
9752 30 : gfc_add_modify (&block, tmp,
9753 30 : fold_convert (TREE_TYPE (tmp),
9754 : se.string_length));
9755 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
9756 : "slen");
9757 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
9758 : }
9759 :
9760 : /* Deal with arrays of derived types with allocatable components. */
9761 1292 : if (gfc_bt_struct (cm->ts.type)
9762 193 : && cm->ts.u.derived->attr.alloc_comp)
9763 : // TODO: Fix caf_mode
9764 107 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
9765 : se.expr, dest,
9766 107 : cm->as->rank, 0);
9767 1185 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
9768 36 : && CLASS_DATA(cm)->attr.allocatable)
9769 : {
9770 36 : if (cm->ts.u.derived->attr.alloc_comp)
9771 : // TODO: Fix caf_mode
9772 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
9773 : se.expr, dest,
9774 : expr->rank, 0);
9775 : else
9776 : {
9777 36 : tmp = TREE_TYPE (dest);
9778 36 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9779 : tmp, expr->rank, NULL_TREE);
9780 : }
9781 : }
9782 1149 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9783 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9784 : gfc_typenode_for_spec (&cm->ts),
9785 30 : cm->as->rank, NULL_TREE);
9786 : else
9787 1119 : tmp = gfc_duplicate_allocatable (dest, se.expr,
9788 1119 : TREE_TYPE(cm->backend_decl),
9789 1119 : cm->as->rank, NULL_TREE);
9790 :
9791 :
9792 1292 : gfc_add_expr_to_block (&block, tmp);
9793 1292 : gfc_add_block_to_block (&block, &se.post);
9794 :
9795 1292 : if (final_block && !cm->attr.allocatable
9796 96 : && expr->expr_type == EXPR_ARRAY)
9797 : {
9798 96 : tree data_ptr;
9799 96 : data_ptr = gfc_conv_descriptor_data_get (dest);
9800 96 : gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
9801 96 : }
9802 1196 : else if (final_block && cm->attr.allocatable)
9803 162 : gfc_add_block_to_block (final_block, &se.finalblock);
9804 :
9805 1292 : if (expr->expr_type != EXPR_VARIABLE)
9806 1171 : gfc_conv_descriptor_data_set (&block, se.expr,
9807 : null_pointer_node);
9808 :
9809 : /* We need to know if the argument of a conversion function is a
9810 : variable, so that the correct lower bound can be used. */
9811 1292 : if (expr->expr_type == EXPR_FUNCTION
9812 56 : && expr->value.function.isym
9813 44 : && expr->value.function.isym->conversion
9814 44 : && expr->value.function.actual->expr
9815 44 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
9816 44 : arg = expr->value.function.actual->expr;
9817 :
9818 : /* Obtain the array spec of full array references. */
9819 44 : if (arg)
9820 44 : as = gfc_get_full_arrayspec_from_expr (arg);
9821 : else
9822 1248 : as = gfc_get_full_arrayspec_from_expr (expr);
9823 :
9824 : /* Shift the lbound and ubound of temporaries to being unity,
9825 : rather than zero, based. Always calculate the offset. */
9826 1292 : gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
9827 1292 : offset = gfc_conv_descriptor_offset_get (dest);
9828 1292 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
9829 :
9830 2640 : for (n = 0; n < expr->rank; n++)
9831 : {
9832 1348 : tree span;
9833 1348 : tree lbound;
9834 :
9835 : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
9836 : TODO It looks as if gfc_conv_expr_descriptor should return
9837 : the correct bounds and that the following should not be
9838 : necessary. This would simplify gfc_conv_intrinsic_bound
9839 : as well. */
9840 1348 : if (as && as->lower[n])
9841 : {
9842 80 : gfc_se lbse;
9843 80 : gfc_init_se (&lbse, NULL);
9844 80 : gfc_conv_expr (&lbse, as->lower[n]);
9845 80 : gfc_add_block_to_block (&block, &lbse.pre);
9846 80 : lbound = gfc_evaluate_now (lbse.expr, &block);
9847 80 : }
9848 1268 : else if (as && arg)
9849 : {
9850 34 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
9851 34 : lbound = gfc_conv_descriptor_lbound_get (tmp,
9852 : gfc_rank_cst[n]);
9853 : }
9854 1234 : else if (as)
9855 64 : lbound = gfc_conv_descriptor_lbound_get (dest,
9856 : gfc_rank_cst[n]);
9857 : else
9858 1170 : lbound = gfc_index_one_node;
9859 :
9860 1348 : lbound = fold_convert (gfc_array_index_type, lbound);
9861 :
9862 : /* Shift the bounds and set the offset accordingly. */
9863 1348 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
9864 1348 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9865 : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
9866 1348 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9867 : span, lbound);
9868 1348 : gfc_conv_descriptor_ubound_set (&block, dest,
9869 : gfc_rank_cst[n], tmp);
9870 1348 : gfc_conv_descriptor_lbound_set (&block, dest,
9871 : gfc_rank_cst[n], lbound);
9872 :
9873 1348 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9874 : gfc_conv_descriptor_lbound_get (dest,
9875 : gfc_rank_cst[n]),
9876 : gfc_conv_descriptor_stride_get (dest,
9877 : gfc_rank_cst[n]));
9878 1348 : gfc_add_modify (&block, tmp2, tmp);
9879 1348 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9880 : offset, tmp2);
9881 1348 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
9882 : }
9883 :
9884 1292 : if (arg)
9885 : {
9886 : /* If a conversion expression has a null data pointer
9887 : argument, nullify the allocatable component. */
9888 44 : tree non_null_expr;
9889 44 : tree null_expr;
9890 :
9891 44 : if (arg->symtree->n.sym->attr.allocatable
9892 12 : || arg->symtree->n.sym->attr.pointer)
9893 : {
9894 32 : non_null_expr = gfc_finish_block (&block);
9895 32 : gfc_start_block (&block);
9896 32 : gfc_conv_descriptor_data_set (&block, dest,
9897 : null_pointer_node);
9898 32 : null_expr = gfc_finish_block (&block);
9899 32 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
9900 32 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
9901 32 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9902 32 : return build3_v (COND_EXPR, tmp,
9903 : null_expr, non_null_expr);
9904 : }
9905 : }
9906 :
9907 1260 : return gfc_finish_block (&block);
9908 : }
9909 :
9910 :
9911 : /* Allocate or reallocate scalar component, as necessary. */
9912 :
9913 : static void
9914 410 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
9915 : gfc_component *cm, gfc_expr *expr2,
9916 : tree slen)
9917 : {
9918 410 : tree tmp;
9919 410 : tree ptr;
9920 410 : tree size;
9921 410 : tree size_in_bytes;
9922 410 : tree lhs_cl_size = NULL_TREE;
9923 410 : gfc_se se;
9924 :
9925 410 : if (!comp)
9926 0 : return;
9927 :
9928 410 : if (!expr2 || expr2->rank)
9929 : return;
9930 :
9931 410 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9932 :
9933 410 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9934 : {
9935 139 : gcc_assert (expr2->ts.type == BT_CHARACTER);
9936 139 : size = expr2->ts.u.cl->backend_decl;
9937 139 : if (!size || !VAR_P (size))
9938 139 : size = gfc_create_var (TREE_TYPE (slen), "slen");
9939 139 : gfc_add_modify (block, size, slen);
9940 :
9941 139 : gfc_deferred_strlen (cm, &tmp);
9942 139 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
9943 : gfc_charlen_type_node,
9944 139 : TREE_OPERAND (comp, 0),
9945 : tmp, NULL_TREE);
9946 :
9947 139 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
9948 139 : tmp = TYPE_SIZE_UNIT (tmp);
9949 278 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9950 139 : TREE_TYPE (tmp), tmp,
9951 139 : fold_convert (TREE_TYPE (tmp), size));
9952 : }
9953 271 : else if (cm->ts.type == BT_CLASS)
9954 : {
9955 103 : if (expr2->ts.type != BT_CLASS)
9956 : {
9957 103 : if (expr2->ts.type == BT_CHARACTER)
9958 : {
9959 24 : gfc_init_se (&se, NULL);
9960 24 : gfc_conv_expr (&se, expr2);
9961 24 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
9962 24 : size = fold_build2_loc (input_location, MULT_EXPR,
9963 : gfc_charlen_type_node,
9964 : se.string_length, size);
9965 24 : size = fold_convert (size_type_node, size);
9966 : }
9967 : else
9968 : {
9969 79 : if (expr2->ts.type == BT_DERIVED)
9970 48 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
9971 : else
9972 31 : tmp = gfc_typenode_for_spec (&expr2->ts);
9973 79 : size = TYPE_SIZE_UNIT (tmp);
9974 : }
9975 : }
9976 : else
9977 : {
9978 0 : gfc_expr *e2vtab;
9979 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
9980 0 : gfc_add_vptr_component (e2vtab);
9981 0 : gfc_add_size_component (e2vtab);
9982 0 : gfc_init_se (&se, NULL);
9983 0 : gfc_conv_expr (&se, e2vtab);
9984 0 : gfc_add_block_to_block (block, &se.pre);
9985 0 : size = fold_convert (size_type_node, se.expr);
9986 0 : gfc_free_expr (e2vtab);
9987 : }
9988 : size_in_bytes = size;
9989 : }
9990 : else
9991 : {
9992 : /* Otherwise use the length in bytes of the rhs. */
9993 168 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
9994 168 : size_in_bytes = size;
9995 : }
9996 :
9997 410 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9998 : size_in_bytes, size_one_node);
9999 :
10000 410 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
10001 : {
10002 0 : tmp = build_call_expr_loc (input_location,
10003 : builtin_decl_explicit (BUILT_IN_CALLOC),
10004 : 2, build_one_cst (size_type_node),
10005 : size_in_bytes);
10006 0 : tmp = fold_convert (TREE_TYPE (comp), tmp);
10007 0 : gfc_add_modify (block, comp, tmp);
10008 : }
10009 : else
10010 : {
10011 410 : tmp = build_call_expr_loc (input_location,
10012 : builtin_decl_explicit (BUILT_IN_MALLOC),
10013 : 1, size_in_bytes);
10014 410 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
10015 103 : ptr = gfc_class_data_get (comp);
10016 : else
10017 : ptr = comp;
10018 410 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
10019 410 : gfc_add_modify (block, ptr, tmp);
10020 : }
10021 :
10022 410 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10023 : /* Update the lhs character length. */
10024 139 : gfc_add_modify (block, lhs_cl_size,
10025 139 : fold_convert (TREE_TYPE (lhs_cl_size), size));
10026 : }
10027 :
10028 :
10029 : /* Assign a single component of a derived type constructor. */
10030 :
10031 : static tree
10032 29215 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
10033 : gfc_expr * expr, bool init)
10034 : {
10035 29215 : gfc_se se;
10036 29215 : gfc_se lse;
10037 29215 : stmtblock_t block;
10038 29215 : tree tmp;
10039 29215 : tree vtab;
10040 :
10041 29215 : gfc_start_block (&block);
10042 :
10043 29215 : if (cm->attr.pointer || cm->attr.proc_pointer)
10044 : {
10045 : /* Only care about pointers here, not about allocatables. */
10046 2640 : gfc_init_se (&se, NULL);
10047 : /* Pointer component. */
10048 2640 : if ((cm->attr.dimension || cm->attr.codimension)
10049 676 : && !cm->attr.proc_pointer)
10050 : {
10051 : /* Array pointer. */
10052 660 : if (expr->expr_type == EXPR_NULL)
10053 654 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10054 : else
10055 : {
10056 6 : se.direct_byref = 1;
10057 6 : se.expr = dest;
10058 6 : gfc_conv_expr_descriptor (&se, expr);
10059 6 : gfc_add_block_to_block (&block, &se.pre);
10060 6 : gfc_add_block_to_block (&block, &se.post);
10061 : }
10062 : }
10063 : else
10064 : {
10065 : /* Scalar pointers. */
10066 1980 : se.want_pointer = 1;
10067 1980 : gfc_conv_expr (&se, expr);
10068 1980 : gfc_add_block_to_block (&block, &se.pre);
10069 :
10070 1980 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10071 12 : && expr->symtree->n.sym->attr.dummy)
10072 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10073 :
10074 1980 : gfc_add_modify (&block, dest,
10075 1980 : fold_convert (TREE_TYPE (dest), se.expr));
10076 1980 : gfc_add_block_to_block (&block, &se.post);
10077 : }
10078 : }
10079 26575 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
10080 : {
10081 : /* NULL initialization for CLASS components. */
10082 922 : tmp = gfc_trans_structure_assign (dest,
10083 : gfc_class_initializer (&cm->ts, expr),
10084 : false);
10085 922 : gfc_add_expr_to_block (&block, tmp);
10086 : }
10087 25653 : else if ((cm->attr.dimension || cm->attr.codimension)
10088 : && !cm->attr.proc_pointer)
10089 : {
10090 4904 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
10091 : {
10092 2692 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
10093 2692 : if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
10094 2 : gfc_add_modify (&block, gfc_conv_descriptor_token (dest),
10095 : null_pointer_node);
10096 : }
10097 2212 : else if (cm->attr.allocatable || cm->attr.pdt_array)
10098 : {
10099 1256 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
10100 1256 : gfc_add_expr_to_block (&block, tmp);
10101 : }
10102 : else
10103 : {
10104 956 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
10105 956 : gfc_add_expr_to_block (&block, tmp);
10106 : }
10107 : }
10108 20749 : else if (cm->ts.type == BT_CLASS
10109 145 : && CLASS_DATA (cm)->attr.dimension
10110 36 : && CLASS_DATA (cm)->attr.allocatable
10111 36 : && expr->ts.type == BT_DERIVED)
10112 : {
10113 36 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10114 36 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10115 36 : tmp = gfc_class_vptr_get (dest);
10116 36 : gfc_add_modify (&block, tmp,
10117 36 : fold_convert (TREE_TYPE (tmp), vtab));
10118 36 : tmp = gfc_class_data_get (dest);
10119 36 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
10120 36 : gfc_add_expr_to_block (&block, tmp);
10121 : }
10122 20713 : else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
10123 1766 : && (init
10124 1639 : || (cm->ts.type == BT_CHARACTER
10125 131 : && !(cm->ts.deferred || cm->attr.pdt_string))))
10126 : {
10127 : /* NULL initialization for allocatable components.
10128 : Deferred-length character is dealt with later. */
10129 151 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
10130 : null_pointer_node));
10131 : }
10132 20562 : else if (init && (cm->attr.allocatable
10133 13473 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
10134 109 : && expr->ts.type != BT_CLASS)))
10135 : {
10136 410 : tree size;
10137 :
10138 410 : gfc_init_se (&se, NULL);
10139 410 : gfc_conv_expr (&se, expr);
10140 :
10141 : /* The remainder of these instructions follow the if (cm->attr.pointer)
10142 : if (!cm->attr.dimension) part above. */
10143 410 : gfc_add_block_to_block (&block, &se.pre);
10144 : /* Take care about non-array allocatable components here. The alloc_*
10145 : routine below is motivated by the alloc_scalar_allocatable_for_
10146 : assignment() routine, but with the realloc portions removed and
10147 : different input. */
10148 410 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
10149 : se.string_length);
10150 :
10151 410 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
10152 0 : && expr->symtree->n.sym->attr.dummy)
10153 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
10154 :
10155 410 : if (cm->ts.type == BT_CLASS)
10156 : {
10157 103 : tmp = gfc_class_data_get (dest);
10158 103 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
10159 103 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
10160 103 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
10161 103 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
10162 103 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
10163 : }
10164 : else
10165 307 : tmp = build_fold_indirect_ref_loc (input_location, dest);
10166 :
10167 : /* For deferred strings insert a memcpy. */
10168 410 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
10169 : {
10170 139 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
10171 139 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
10172 : ? se.string_length
10173 0 : : expr->ts.u.cl->backend_decl);
10174 139 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
10175 139 : gfc_add_expr_to_block (&block, tmp);
10176 : }
10177 271 : else if (cm->ts.type == BT_CLASS)
10178 : {
10179 : /* Fix the expression for memcpy. */
10180 103 : if (expr->expr_type != EXPR_VARIABLE)
10181 73 : se.expr = gfc_evaluate_now (se.expr, &block);
10182 :
10183 103 : if (expr->ts.type == BT_CHARACTER)
10184 : {
10185 24 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
10186 24 : size = fold_build2_loc (input_location, MULT_EXPR,
10187 : gfc_charlen_type_node,
10188 : se.string_length, size);
10189 24 : size = fold_convert (size_type_node, size);
10190 : }
10191 : else
10192 79 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
10193 :
10194 : /* Now copy the expression to the constructor component _data. */
10195 103 : gfc_add_expr_to_block (&block,
10196 : gfc_build_memcpy_call (tmp, se.expr, size));
10197 :
10198 : /* Fill the unlimited polymorphic _len field. */
10199 103 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
10200 : {
10201 24 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
10202 24 : gfc_add_modify (&block, tmp,
10203 24 : fold_convert (TREE_TYPE (tmp),
10204 : se.string_length));
10205 : }
10206 : }
10207 : else
10208 168 : gfc_add_modify (&block, tmp,
10209 168 : fold_convert (TREE_TYPE (tmp), se.expr));
10210 410 : gfc_add_block_to_block (&block, &se.post);
10211 410 : }
10212 20152 : else if (expr->ts.type == BT_UNION)
10213 : {
10214 13 : tree tmp;
10215 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
10216 : /* We mark that the entire union should be initialized with a contrived
10217 : EXPR_NULL expression at the beginning. */
10218 13 : if (c != NULL && c->n.component == NULL
10219 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
10220 : {
10221 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10222 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
10223 6 : gfc_add_expr_to_block (&block, tmp);
10224 6 : c = gfc_constructor_next (c);
10225 : }
10226 : /* The following constructor expression, if any, represents a specific
10227 : map intializer, as given by the user. */
10228 13 : if (c != NULL && c->expr != NULL)
10229 : {
10230 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10231 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10232 6 : gfc_add_expr_to_block (&block, tmp);
10233 : }
10234 : }
10235 20139 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
10236 : {
10237 3123 : if (expr->expr_type != EXPR_STRUCTURE)
10238 : {
10239 452 : tree dealloc = NULL_TREE;
10240 452 : gfc_init_se (&se, NULL);
10241 452 : gfc_conv_expr (&se, expr);
10242 452 : gfc_add_block_to_block (&block, &se.pre);
10243 : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
10244 : expression in a temporary variable and deallocate the allocatable
10245 : components. Then we can the copy the expression to the result. */
10246 452 : if (cm->ts.u.derived->attr.alloc_comp
10247 330 : && expr->expr_type != EXPR_VARIABLE)
10248 : {
10249 300 : se.expr = gfc_evaluate_now (se.expr, &block);
10250 300 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
10251 : expr->rank);
10252 : }
10253 452 : gfc_add_modify (&block, dest,
10254 452 : fold_convert (TREE_TYPE (dest), se.expr));
10255 452 : if (cm->ts.u.derived->attr.alloc_comp
10256 330 : && expr->expr_type != EXPR_NULL)
10257 : {
10258 : // TODO: Fix caf_mode
10259 48 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
10260 : dest, expr->rank, 0);
10261 48 : gfc_add_expr_to_block (&block, tmp);
10262 48 : if (dealloc != NULL_TREE)
10263 18 : gfc_add_expr_to_block (&block, dealloc);
10264 : }
10265 452 : gfc_add_block_to_block (&block, &se.post);
10266 : }
10267 : else
10268 : {
10269 : /* Nested constructors. */
10270 2671 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
10271 2671 : gfc_add_expr_to_block (&block, tmp);
10272 : }
10273 : }
10274 17016 : else if (gfc_deferred_strlen (cm, &tmp))
10275 : {
10276 125 : tree strlen;
10277 125 : strlen = tmp;
10278 125 : gcc_assert (strlen);
10279 125 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
10280 125 : TREE_TYPE (strlen),
10281 125 : TREE_OPERAND (dest, 0),
10282 : strlen, NULL_TREE);
10283 :
10284 125 : if (expr->expr_type == EXPR_NULL)
10285 : {
10286 107 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
10287 107 : gfc_add_modify (&block, dest, tmp);
10288 107 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
10289 107 : gfc_add_modify (&block, strlen, tmp);
10290 : }
10291 : else
10292 : {
10293 18 : tree size;
10294 18 : gfc_init_se (&se, NULL);
10295 18 : gfc_conv_expr (&se, expr);
10296 18 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
10297 18 : size = fold_convert (size_type_node, size);
10298 18 : tmp = build_call_expr_loc (input_location,
10299 : builtin_decl_explicit (BUILT_IN_MALLOC),
10300 : 1, size);
10301 18 : gfc_add_modify (&block, dest,
10302 18 : fold_convert (TREE_TYPE (dest), tmp));
10303 18 : gfc_add_modify (&block, strlen,
10304 18 : fold_convert (TREE_TYPE (strlen), se.string_length));
10305 18 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
10306 18 : gfc_add_expr_to_block (&block, tmp);
10307 : }
10308 : }
10309 16891 : else if (!cm->attr.artificial)
10310 : {
10311 : /* Scalar component (excluding deferred parameters). */
10312 16776 : gfc_init_se (&se, NULL);
10313 16776 : gfc_init_se (&lse, NULL);
10314 :
10315 16776 : gfc_conv_expr (&se, expr);
10316 16776 : if (cm->ts.type == BT_CHARACTER)
10317 1051 : lse.string_length = cm->ts.u.cl->backend_decl;
10318 16776 : lse.expr = dest;
10319 16776 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
10320 16776 : gfc_add_expr_to_block (&block, tmp);
10321 : }
10322 29215 : return gfc_finish_block (&block);
10323 : }
10324 :
10325 : /* Assign a derived type constructor to a variable. */
10326 :
10327 : tree
10328 20393 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
10329 : {
10330 20393 : gfc_constructor *c;
10331 20393 : gfc_component *cm;
10332 20393 : stmtblock_t block;
10333 20393 : tree field;
10334 20393 : tree tmp;
10335 20393 : gfc_se se;
10336 :
10337 20393 : gfc_start_block (&block);
10338 :
10339 20393 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
10340 179 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
10341 13 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
10342 : {
10343 179 : gfc_se lse;
10344 :
10345 179 : gfc_init_se (&se, NULL);
10346 179 : gfc_init_se (&lse, NULL);
10347 179 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
10348 179 : lse.expr = dest;
10349 179 : gfc_add_modify (&block, lse.expr,
10350 179 : fold_convert (TREE_TYPE (lse.expr), se.expr));
10351 :
10352 179 : return gfc_finish_block (&block);
10353 : }
10354 :
10355 : /* Make sure that the derived type has been completely built. */
10356 20214 : if (!expr->ts.u.derived->backend_decl
10357 20214 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
10358 : {
10359 224 : tmp = gfc_typenode_for_spec (&expr->ts);
10360 224 : gcc_assert (tmp);
10361 : }
10362 :
10363 20214 : cm = expr->ts.u.derived->components;
10364 :
10365 :
10366 20214 : if (coarray)
10367 225 : gfc_init_se (&se, NULL);
10368 :
10369 20214 : for (c = gfc_constructor_first (expr->value.constructor);
10370 52561 : c; c = gfc_constructor_next (c), cm = cm->next)
10371 : {
10372 : /* Skip absent members in default initializers. */
10373 32347 : if (!c->expr && !cm->attr.allocatable)
10374 3132 : continue;
10375 :
10376 : /* Register the component with the caf-lib before it is initialized.
10377 : Register only allocatable components, that are not coarray'ed
10378 : components (%comp[*]). Only register when the constructor is the
10379 : null-expression. */
10380 29215 : if (coarray && !cm->attr.codimension
10381 515 : && (cm->attr.allocatable || cm->attr.pointer)
10382 179 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
10383 : {
10384 177 : tree token, desc, size;
10385 354 : bool is_array = cm->ts.type == BT_CLASS
10386 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
10387 :
10388 177 : field = cm->backend_decl;
10389 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
10390 177 : TREE_TYPE (field), dest, field, NULL_TREE);
10391 177 : if (cm->ts.type == BT_CLASS)
10392 0 : field = gfc_class_data_get (field);
10393 :
10394 177 : token
10395 : = is_array
10396 177 : ? gfc_conv_descriptor_token (field)
10397 52 : : fold_build3_loc (input_location, COMPONENT_REF,
10398 52 : TREE_TYPE (gfc_comp_caf_token (cm)), dest,
10399 52 : gfc_comp_caf_token (cm), NULL_TREE);
10400 :
10401 177 : if (is_array)
10402 : {
10403 : /* The _caf_register routine looks at the rank of the array
10404 : descriptor to decide whether the data registered is an array
10405 : or not. */
10406 125 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
10407 125 : : cm->as->rank;
10408 : /* When the rank is not known just set a positive rank, which
10409 : suffices to recognize the data as array. */
10410 125 : if (rank < 0)
10411 0 : rank = 1;
10412 125 : size = build_zero_cst (size_type_node);
10413 125 : desc = field;
10414 125 : gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
10415 125 : build_int_cst (signed_char_type_node, rank));
10416 : }
10417 : else
10418 : {
10419 52 : desc = gfc_conv_scalar_to_descriptor (&se, field,
10420 52 : cm->ts.type == BT_CLASS
10421 52 : ? CLASS_DATA (cm)->attr
10422 : : cm->attr);
10423 52 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
10424 : }
10425 177 : gfc_add_block_to_block (&block, &se.pre);
10426 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
10427 : 7, size, build_int_cst (
10428 : integer_type_node,
10429 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
10430 : gfc_build_addr_expr (pvoid_type_node,
10431 : token),
10432 : gfc_build_addr_expr (NULL_TREE, desc),
10433 : null_pointer_node, null_pointer_node,
10434 : integer_zero_node);
10435 177 : gfc_add_expr_to_block (&block, tmp);
10436 : }
10437 29215 : field = cm->backend_decl;
10438 29215 : gcc_assert(field);
10439 29215 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
10440 : dest, field, NULL_TREE);
10441 29215 : if (!c->expr)
10442 : {
10443 0 : gfc_expr *e = gfc_get_null_expr (NULL);
10444 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
10445 0 : gfc_free_expr (e);
10446 : }
10447 : else
10448 29215 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
10449 29215 : gfc_add_expr_to_block (&block, tmp);
10450 : }
10451 20214 : return gfc_finish_block (&block);
10452 : }
10453 :
10454 : static void
10455 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
10456 : gfc_component *un, gfc_expr *init)
10457 : {
10458 21 : gfc_constructor *ctor;
10459 :
10460 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
10461 : return;
10462 :
10463 21 : ctor = gfc_constructor_first (init->value.constructor);
10464 :
10465 21 : if (ctor == NULL || ctor->expr == NULL)
10466 : return;
10467 :
10468 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
10469 :
10470 : /* If we have an 'initialize all' constructor, do it first. */
10471 21 : if (ctor->expr->expr_type == EXPR_NULL)
10472 : {
10473 9 : tree union_type = TREE_TYPE (un->backend_decl);
10474 9 : tree val = build_constructor (union_type, NULL);
10475 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10476 9 : ctor = gfc_constructor_next (ctor);
10477 : }
10478 :
10479 : /* Add the map initializer on top. */
10480 21 : if (ctor != NULL && ctor->expr != NULL)
10481 : {
10482 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
10483 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
10484 12 : TREE_TYPE (un->backend_decl),
10485 12 : un->attr.dimension, un->attr.pointer,
10486 12 : un->attr.proc_pointer);
10487 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
10488 : }
10489 : }
10490 :
10491 : /* Build an expression for a constructor. If init is nonzero then
10492 : this is part of a static variable initializer. */
10493 :
10494 : void
10495 39198 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
10496 : {
10497 39198 : gfc_constructor *c;
10498 39198 : gfc_component *cm;
10499 39198 : tree val;
10500 39198 : tree type;
10501 39198 : tree tmp;
10502 39198 : vec<constructor_elt, va_gc> *v = NULL;
10503 :
10504 39198 : gcc_assert (se->ss == NULL);
10505 39198 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
10506 39198 : type = gfc_typenode_for_spec (&expr->ts);
10507 :
10508 39198 : if (!init)
10509 : {
10510 16036 : if (IS_PDT (expr) && expr->must_finalize)
10511 276 : final_block = &se->finalblock;
10512 :
10513 : /* Create a temporary variable and fill it in. */
10514 16036 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
10515 : /* The symtree in expr is NULL, if the code to generate is for
10516 : initializing the static members only. */
10517 32072 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
10518 16036 : se->want_coarray);
10519 16036 : gfc_add_expr_to_block (&se->pre, tmp);
10520 16036 : final_block = NULL;
10521 16036 : return;
10522 : }
10523 :
10524 23162 : cm = expr->ts.u.derived->components;
10525 :
10526 23162 : for (c = gfc_constructor_first (expr->value.constructor);
10527 121934 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
10528 : {
10529 : /* Skip absent members in default initializers and allocatable
10530 : components. Although the latter have a default initializer
10531 : of EXPR_NULL,... by default, the static nullify is not needed
10532 : since this is done every time we come into scope. */
10533 107374 : if (!c->expr
10534 96360 : || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE)
10535 189026 : || (IS_PDT (cm) && has_parameterized_comps (cm->ts.u.derived)))
10536 8602 : continue;
10537 :
10538 90170 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
10539 52246 : && strcmp (cm->name, "_extends") == 0
10540 1294 : && cm->initializer->symtree)
10541 : {
10542 1294 : tree vtab;
10543 1294 : gfc_symbol *vtabs;
10544 1294 : vtabs = cm->initializer->symtree->n.sym;
10545 1294 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
10546 1294 : vtab = unshare_expr_without_location (vtab);
10547 1294 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
10548 1294 : }
10549 88876 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
10550 : {
10551 9889 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
10552 9889 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10553 : fold_convert (TREE_TYPE (cm->backend_decl),
10554 : val));
10555 9889 : }
10556 78987 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
10557 403 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
10558 : fold_convert (TREE_TYPE (cm->backend_decl),
10559 403 : integer_zero_node));
10560 78584 : else if (cm->ts.type == BT_UNION)
10561 21 : gfc_conv_union_initializer (v, cm, c->expr);
10562 : else
10563 : {
10564 78563 : val = gfc_conv_initializer (c->expr, &cm->ts,
10565 78563 : TREE_TYPE (cm->backend_decl),
10566 78563 : cm->attr.dimension, cm->attr.pointer,
10567 78563 : cm->attr.proc_pointer);
10568 78563 : val = unshare_expr_without_location (val);
10569 :
10570 : /* Append it to the constructor list. */
10571 177335 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
10572 : }
10573 : }
10574 :
10575 23162 : se->expr = build_constructor (type, v);
10576 23162 : if (init)
10577 23162 : TREE_CONSTANT (se->expr) = 1;
10578 : }
10579 :
10580 :
10581 : /* Translate a substring expression. */
10582 :
10583 : static void
10584 258 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
10585 : {
10586 258 : gfc_ref *ref;
10587 :
10588 258 : ref = expr->ref;
10589 :
10590 258 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
10591 :
10592 516 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
10593 258 : expr->value.character.length,
10594 258 : expr->value.character.string);
10595 :
10596 258 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
10597 258 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
10598 :
10599 258 : if (ref)
10600 258 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
10601 258 : }
10602 :
10603 :
10604 : /* Entry point for expression translation. Evaluates a scalar quantity.
10605 : EXPR is the expression to be translated, and SE is the state structure if
10606 : called from within the scalarized. */
10607 :
10608 : void
10609 3642293 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
10610 : {
10611 3642293 : gfc_ss *ss;
10612 :
10613 3642293 : ss = se->ss;
10614 3642293 : if (ss && ss->info->expr == expr
10615 238158 : && (ss->info->type == GFC_SS_SCALAR
10616 : || ss->info->type == GFC_SS_REFERENCE))
10617 : {
10618 40527 : gfc_ss_info *ss_info;
10619 :
10620 40527 : ss_info = ss->info;
10621 : /* Substitute a scalar expression evaluated outside the scalarization
10622 : loop. */
10623 40527 : se->expr = ss_info->data.scalar.value;
10624 40527 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
10625 844 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
10626 :
10627 40527 : se->string_length = ss_info->string_length;
10628 40527 : gfc_advance_se_ss_chain (se);
10629 40527 : return;
10630 : }
10631 :
10632 : /* We need to convert the expressions for the iso_c_binding derived types.
10633 : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
10634 : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
10635 : typespec for the C_PTR and C_FUNPTR symbols, which has already been
10636 : updated to be an integer with a kind equal to the size of a (void *). */
10637 3601766 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
10638 16127 : && expr->ts.u.derived->attr.is_bind_c)
10639 : {
10640 15288 : if (expr->expr_type == EXPR_VARIABLE
10641 10845 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
10642 10845 : || expr->symtree->n.sym->intmod_sym_id
10643 : == ISOCBINDING_NULL_FUNPTR))
10644 : {
10645 : /* Set expr_type to EXPR_NULL, which will result in
10646 : null_pointer_node being used below. */
10647 0 : expr->expr_type = EXPR_NULL;
10648 : }
10649 : else
10650 : {
10651 : /* Update the type/kind of the expression to be what the new
10652 : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
10653 15288 : expr->ts.type = BT_INTEGER;
10654 15288 : expr->ts.f90_type = BT_VOID;
10655 15288 : expr->ts.kind = gfc_index_integer_kind;
10656 : }
10657 : }
10658 :
10659 3601766 : gfc_fix_class_refs (expr);
10660 :
10661 3601766 : switch (expr->expr_type)
10662 : {
10663 505778 : case EXPR_OP:
10664 505778 : gfc_conv_expr_op (se, expr);
10665 505778 : break;
10666 :
10667 151 : case EXPR_CONDITIONAL:
10668 151 : gfc_conv_conditional_expr (se, expr);
10669 151 : break;
10670 :
10671 304148 : case EXPR_FUNCTION:
10672 304148 : gfc_conv_function_expr (se, expr);
10673 304148 : break;
10674 :
10675 1135588 : case EXPR_CONSTANT:
10676 1135588 : gfc_conv_constant (se, expr);
10677 1135588 : break;
10678 :
10679 1599945 : case EXPR_VARIABLE:
10680 1599945 : gfc_conv_variable (se, expr);
10681 1599945 : break;
10682 :
10683 4199 : case EXPR_NULL:
10684 4199 : se->expr = null_pointer_node;
10685 4199 : break;
10686 :
10687 258 : case EXPR_SUBSTRING:
10688 258 : gfc_conv_substring_expr (se, expr);
10689 258 : break;
10690 :
10691 16036 : case EXPR_STRUCTURE:
10692 16036 : gfc_conv_structure (se, expr, 0);
10693 : /* F2008 4.5.6.3 para 5: If an executable construct references a
10694 : structure constructor or array constructor, the entity created by
10695 : the constructor is finalized after execution of the innermost
10696 : executable construct containing the reference. This, in fact,
10697 : was later deleted by the Combined Techical Corrigenda 1 TO 4 for
10698 : fortran 2008 (f08/0011). */
10699 16036 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
10700 16036 : && !(gfc_option.allow_std & GFC_STD_GNU)
10701 139 : && expr->must_finalize
10702 16048 : && gfc_may_be_finalized (expr->ts))
10703 : {
10704 12 : locus loc;
10705 12 : gfc_locus_from_location (&loc, input_location);
10706 12 : gfc_warning (0, "The structure constructor at %L has been"
10707 : " finalized. This feature was removed by f08/0011."
10708 : " Use -std=f2018 or -std=gnu to eliminate the"
10709 : " finalization.", &loc);
10710 12 : symbol_attribute attr;
10711 12 : attr.allocatable = attr.pointer = 0;
10712 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
10713 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
10714 : }
10715 : break;
10716 :
10717 35663 : case EXPR_ARRAY:
10718 35663 : gfc_conv_array_constructor_expr (se, expr);
10719 35663 : gfc_add_block_to_block (&se->post, &se->finalblock);
10720 35663 : break;
10721 :
10722 0 : default:
10723 0 : gcc_unreachable ();
10724 3642293 : break;
10725 : }
10726 : }
10727 :
10728 : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
10729 : of an assignment. */
10730 : void
10731 371711 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
10732 : {
10733 371711 : gfc_conv_expr (se, expr);
10734 : /* All numeric lvalues should have empty post chains. If not we need to
10735 : figure out a way of rewriting an lvalue so that it has no post chain. */
10736 371711 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
10737 371711 : }
10738 :
10739 : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
10740 : numeric expressions. Used for scalar values where inserting cleanup code
10741 : is inconvenient. */
10742 : void
10743 1030997 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
10744 : {
10745 1030997 : tree val;
10746 :
10747 1030997 : gcc_assert (expr->ts.type != BT_CHARACTER);
10748 1030997 : gfc_conv_expr (se, expr);
10749 1030997 : if (se->post.head)
10750 : {
10751 2561 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
10752 2561 : gfc_add_modify (&se->pre, val, se->expr);
10753 2561 : se->expr = val;
10754 2561 : gfc_add_block_to_block (&se->pre, &se->post);
10755 : }
10756 1030997 : }
10757 :
10758 : /* Helper to translate an expression and convert it to a particular type. */
10759 : void
10760 291286 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
10761 : {
10762 291286 : gfc_conv_expr_val (se, expr);
10763 291286 : se->expr = convert (type, se->expr);
10764 291286 : }
10765 :
10766 :
10767 : /* Converts an expression so that it can be passed by reference. Scalar
10768 : values only. */
10769 :
10770 : void
10771 227445 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
10772 : {
10773 227445 : gfc_ss *ss;
10774 227445 : tree var;
10775 :
10776 227445 : ss = se->ss;
10777 227445 : if (ss && ss->info->expr == expr
10778 7987 : && ss->info->type == GFC_SS_REFERENCE)
10779 : {
10780 : /* Returns a reference to the scalar evaluated outside the loop
10781 : for this case. */
10782 907 : gfc_conv_expr (se, expr);
10783 :
10784 907 : if (expr->ts.type == BT_CHARACTER
10785 114 : && expr->expr_type != EXPR_FUNCTION)
10786 102 : gfc_conv_string_parameter (se);
10787 : else
10788 805 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10789 :
10790 907 : return;
10791 : }
10792 :
10793 226538 : if (expr->ts.type == BT_CHARACTER)
10794 : {
10795 49627 : gfc_conv_expr (se, expr);
10796 49627 : gfc_conv_string_parameter (se);
10797 49627 : return;
10798 : }
10799 :
10800 176911 : if (expr->expr_type == EXPR_VARIABLE)
10801 : {
10802 70452 : se->want_pointer = 1;
10803 70452 : gfc_conv_expr (se, expr);
10804 70452 : if (se->post.head)
10805 : {
10806 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10807 0 : gfc_add_modify (&se->pre, var, se->expr);
10808 0 : gfc_add_block_to_block (&se->pre, &se->post);
10809 0 : se->expr = var;
10810 : }
10811 70452 : return;
10812 : }
10813 :
10814 106459 : if (expr->expr_type == EXPR_CONDITIONAL)
10815 : {
10816 18 : se->want_pointer = 1;
10817 18 : gfc_conv_expr (se, expr);
10818 18 : return;
10819 : }
10820 :
10821 106441 : if (expr->expr_type == EXPR_FUNCTION
10822 13668 : && ((expr->value.function.esym
10823 2095 : && expr->value.function.esym->result
10824 2094 : && expr->value.function.esym->result->attr.pointer
10825 83 : && !expr->value.function.esym->result->attr.dimension)
10826 13591 : || (!expr->value.function.esym && !expr->ref
10827 11467 : && expr->symtree->n.sym->attr.pointer
10828 0 : && !expr->symtree->n.sym->attr.dimension)))
10829 : {
10830 77 : se->want_pointer = 1;
10831 77 : gfc_conv_expr (se, expr);
10832 77 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10833 77 : gfc_add_modify (&se->pre, var, se->expr);
10834 77 : se->expr = var;
10835 77 : return;
10836 : }
10837 :
10838 106364 : gfc_conv_expr (se, expr);
10839 :
10840 : /* Create a temporary var to hold the value. */
10841 106364 : if (TREE_CONSTANT (se->expr))
10842 : {
10843 : tree tmp = se->expr;
10844 84175 : STRIP_TYPE_NOPS (tmp);
10845 84175 : var = build_decl (input_location,
10846 84175 : CONST_DECL, NULL, TREE_TYPE (tmp));
10847 84175 : DECL_INITIAL (var) = tmp;
10848 84175 : TREE_STATIC (var) = 1;
10849 84175 : pushdecl (var);
10850 : }
10851 : else
10852 : {
10853 22189 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
10854 22189 : gfc_add_modify (&se->pre, var, se->expr);
10855 : }
10856 :
10857 106364 : if (!expr->must_finalize)
10858 106268 : gfc_add_block_to_block (&se->pre, &se->post);
10859 :
10860 : /* Take the address of that value. */
10861 106364 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
10862 : }
10863 :
10864 :
10865 : /* Get the _len component for an unlimited polymorphic expression. */
10866 :
10867 : static tree
10868 1788 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
10869 : {
10870 1788 : gfc_se se;
10871 1788 : gfc_ref *ref = expr->ref;
10872 :
10873 1788 : gfc_init_se (&se, NULL);
10874 3690 : while (ref && ref->next)
10875 : ref = ref->next;
10876 1788 : gfc_add_len_component (expr);
10877 1788 : gfc_conv_expr (&se, expr);
10878 1788 : gfc_add_block_to_block (block, &se.pre);
10879 1788 : gcc_assert (se.post.head == NULL_TREE);
10880 1788 : if (ref)
10881 : {
10882 262 : gfc_free_ref_list (ref->next);
10883 262 : ref->next = NULL;
10884 : }
10885 : else
10886 : {
10887 1526 : gfc_free_ref_list (expr->ref);
10888 1526 : expr->ref = NULL;
10889 : }
10890 1788 : return se.expr;
10891 : }
10892 :
10893 :
10894 : /* Assign _vptr and _len components as appropriate. BLOCK should be a
10895 : statement-list outside of the scalarizer-loop. When code is generated, that
10896 : depends on the scalarized expression, it is added to RSE.PRE.
10897 : Returns le's _vptr tree and when set the len expressions in to_lenp and
10898 : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
10899 : expression. */
10900 :
10901 : static tree
10902 4519 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
10903 : gfc_expr * re, gfc_se *rse,
10904 : tree * to_lenp, tree * from_lenp,
10905 : tree * from_vptrp)
10906 : {
10907 4519 : gfc_se se;
10908 4519 : gfc_expr * vptr_expr;
10909 4519 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
10910 4519 : bool set_vptr = false, temp_rhs = false;
10911 4519 : stmtblock_t *pre = block;
10912 4519 : tree class_expr = NULL_TREE;
10913 4519 : tree from_vptr = NULL_TREE;
10914 :
10915 : /* Create a temporary for complicated expressions. */
10916 4519 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
10917 1262 : && rse->expr != NULL_TREE)
10918 : {
10919 1262 : if (!DECL_P (rse->expr))
10920 : {
10921 391 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10922 37 : class_expr = gfc_get_class_from_expr (rse->expr);
10923 :
10924 391 : if (rse->loop)
10925 159 : pre = &rse->loop->pre;
10926 : else
10927 232 : pre = &rse->pre;
10928 :
10929 391 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
10930 37 : tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
10931 : else
10932 354 : tmp = gfc_evaluate_now (rse->expr, &rse->pre);
10933 :
10934 391 : rse->expr = tmp;
10935 : }
10936 : else
10937 871 : pre = &rse->pre;
10938 :
10939 : temp_rhs = true;
10940 : }
10941 :
10942 : /* Get the _vptr for the left-hand side expression. */
10943 4519 : gfc_init_se (&se, NULL);
10944 4519 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
10945 4519 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
10946 : {
10947 : /* Care about _len for unlimited polymorphic entities. */
10948 4519 : if (UNLIMITED_POLY (vptr_expr)
10949 3499 : || (vptr_expr->ts.type == BT_DERIVED
10950 2479 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10951 1504 : to_len = trans_get_upoly_len (block, vptr_expr);
10952 4519 : gfc_add_vptr_component (vptr_expr);
10953 4519 : set_vptr = true;
10954 : }
10955 : else
10956 0 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10957 4519 : se.want_pointer = 1;
10958 4519 : gfc_conv_expr (&se, vptr_expr);
10959 4519 : gfc_free_expr (vptr_expr);
10960 4519 : gfc_add_block_to_block (block, &se.pre);
10961 4519 : gcc_assert (se.post.head == NULL_TREE);
10962 4519 : lhs_vptr = se.expr;
10963 4519 : STRIP_NOPS (lhs_vptr);
10964 :
10965 : /* Set the _vptr only when the left-hand side of the assignment is a
10966 : class-object. */
10967 4519 : if (set_vptr)
10968 : {
10969 : /* Get the vptr from the rhs expression only, when it is variable.
10970 : Functions are expected to be assigned to a temporary beforehand. */
10971 3130 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
10972 5300 : ? gfc_find_and_cut_at_last_class_ref (re)
10973 : : NULL;
10974 781 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
10975 : {
10976 781 : if (to_len != NULL_TREE)
10977 : {
10978 : /* Get the _len information from the rhs. */
10979 299 : if (UNLIMITED_POLY (vptr_expr)
10980 : || (vptr_expr->ts.type == BT_DERIVED
10981 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10982 272 : from_len = trans_get_upoly_len (block, vptr_expr);
10983 : }
10984 781 : gfc_add_vptr_component (vptr_expr);
10985 : }
10986 : else
10987 : {
10988 3738 : if (re->expr_type == EXPR_VARIABLE
10989 2349 : && DECL_P (re->symtree->n.sym->backend_decl)
10990 2349 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
10991 821 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
10992 3805 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
10993 : re->symtree->n.sym->backend_decl))))
10994 : {
10995 43 : vptr_expr = NULL;
10996 43 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
10997 : re->symtree->n.sym->backend_decl));
10998 43 : if (to_len && UNLIMITED_POLY (re))
10999 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
11000 : re->symtree->n.sym->backend_decl));
11001 : }
11002 3695 : else if (temp_rhs && re->ts.type == BT_CLASS)
11003 : {
11004 214 : vptr_expr = NULL;
11005 214 : if (class_expr)
11006 : tmp = class_expr;
11007 177 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11008 0 : tmp = gfc_get_class_from_expr (rse->expr);
11009 : else
11010 : tmp = rse->expr;
11011 :
11012 214 : se.expr = gfc_class_vptr_get (tmp);
11013 214 : from_vptr = se.expr;
11014 214 : if (UNLIMITED_POLY (re))
11015 74 : from_len = gfc_class_len_get (tmp);
11016 :
11017 : }
11018 3481 : else if (re->expr_type != EXPR_NULL)
11019 : /* Only when rhs is non-NULL use its declared type for vptr
11020 : initialisation. */
11021 3354 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
11022 : else
11023 : /* When the rhs is NULL use the vtab of lhs' declared type. */
11024 127 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
11025 : }
11026 :
11027 4336 : if (vptr_expr)
11028 : {
11029 4262 : gfc_init_se (&se, NULL);
11030 4262 : se.want_pointer = 1;
11031 4262 : gfc_conv_expr (&se, vptr_expr);
11032 4262 : gfc_free_expr (vptr_expr);
11033 4262 : gfc_add_block_to_block (block, &se.pre);
11034 4262 : gcc_assert (se.post.head == NULL_TREE);
11035 4262 : from_vptr = se.expr;
11036 : }
11037 4519 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
11038 : se.expr));
11039 :
11040 4519 : if (to_len != NULL_TREE)
11041 : {
11042 : /* The _len component needs to be set. Figure how to get the
11043 : value of the right-hand side. */
11044 1504 : if (from_len == NULL_TREE)
11045 : {
11046 1158 : if (rse->string_length != NULL_TREE)
11047 : from_len = rse->string_length;
11048 712 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
11049 : {
11050 0 : gfc_init_se (&se, NULL);
11051 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
11052 0 : gfc_add_block_to_block (block, &se.pre);
11053 0 : gcc_assert (se.post.head == NULL_TREE);
11054 0 : from_len = gfc_evaluate_now (se.expr, block);
11055 : }
11056 : else
11057 712 : from_len = build_zero_cst (gfc_charlen_type_node);
11058 : }
11059 1504 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
11060 : from_len));
11061 : }
11062 : }
11063 :
11064 : /* Return the _len and _vptr trees only, when requested. */
11065 4519 : if (to_lenp)
11066 3318 : *to_lenp = to_len;
11067 4519 : if (from_lenp)
11068 3318 : *from_lenp = from_len;
11069 4519 : if (from_vptrp)
11070 3318 : *from_vptrp = from_vptr;
11071 4519 : return lhs_vptr;
11072 : }
11073 :
11074 :
11075 : /* Assign tokens for pointer components. */
11076 :
11077 : static void
11078 12 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
11079 : gfc_expr *expr2)
11080 : {
11081 12 : symbol_attribute lhs_attr, rhs_attr;
11082 12 : tree tmp, lhs_tok, rhs_tok;
11083 : /* Flag to indicated component refs on the rhs. */
11084 12 : bool rhs_cr;
11085 :
11086 12 : lhs_attr = gfc_caf_attr (expr1);
11087 12 : if (expr2->expr_type != EXPR_NULL)
11088 : {
11089 8 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
11090 8 : if (lhs_attr.codimension && rhs_attr.codimension)
11091 : {
11092 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11093 4 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11094 :
11095 4 : if (rhs_cr)
11096 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
11097 : else
11098 : {
11099 4 : tree caf_decl;
11100 4 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
11101 4 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
11102 : NULL_TREE, NULL);
11103 : }
11104 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11105 : lhs_tok,
11106 4 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
11107 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11108 : }
11109 : }
11110 4 : else if (lhs_attr.codimension)
11111 : {
11112 4 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
11113 4 : if (!lhs_tok)
11114 : {
11115 2 : lhs_tok = gfc_get_tree_for_caf_expr (expr1);
11116 2 : lhs_tok = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (lhs_tok));
11117 : }
11118 : else
11119 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
11120 4 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
11121 : lhs_tok, null_pointer_node);
11122 4 : gfc_prepend_expr_to_block (&lse->post, tmp);
11123 : }
11124 12 : }
11125 :
11126 :
11127 : /* Do everything that is needed for a CLASS function expr2. */
11128 :
11129 : static tree
11130 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
11131 : gfc_expr *expr1, gfc_expr *expr2)
11132 : {
11133 18 : tree expr1_vptr = NULL_TREE;
11134 18 : tree tmp;
11135 :
11136 18 : gfc_conv_function_expr (rse, expr2);
11137 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11138 :
11139 18 : if (expr1->ts.type != BT_CLASS)
11140 12 : rse->expr = gfc_class_data_get (rse->expr);
11141 : else
11142 : {
11143 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
11144 : expr2, rse,
11145 : NULL, NULL, NULL);
11146 6 : gfc_add_block_to_block (block, &rse->pre);
11147 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
11148 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
11149 :
11150 12 : gfc_add_modify (&lse->pre, expr1_vptr,
11151 6 : fold_convert (TREE_TYPE (expr1_vptr),
11152 : gfc_class_vptr_get (tmp)));
11153 6 : rse->expr = gfc_class_data_get (tmp);
11154 : }
11155 :
11156 18 : return expr1_vptr;
11157 : }
11158 :
11159 :
11160 : tree
11161 10103 : gfc_trans_pointer_assign (gfc_code * code)
11162 : {
11163 10103 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
11164 : }
11165 :
11166 :
11167 : /* Generate code for a pointer assignment. */
11168 :
11169 : tree
11170 10158 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
11171 : {
11172 10158 : gfc_se lse;
11173 10158 : gfc_se rse;
11174 10158 : stmtblock_t block;
11175 10158 : tree desc;
11176 10158 : tree tmp;
11177 10158 : tree expr1_vptr = NULL_TREE;
11178 10158 : bool scalar, non_proc_ptr_assign;
11179 10158 : gfc_ss *ss;
11180 :
11181 10158 : gfc_start_block (&block);
11182 :
11183 10158 : gfc_init_se (&lse, NULL);
11184 :
11185 : /* Usually testing whether this is not a proc pointer assignment. */
11186 10158 : non_proc_ptr_assign
11187 10158 : = !(gfc_expr_attr (expr1).proc_pointer
11188 1187 : && ((expr2->expr_type == EXPR_VARIABLE
11189 955 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
11190 282 : || expr2->expr_type == EXPR_NULL));
11191 :
11192 : /* Check whether the expression is a scalar or not; we cannot use
11193 : expr1->rank as it can be nonzero for proc pointers. */
11194 10158 : ss = gfc_walk_expr (expr1);
11195 10158 : scalar = ss == gfc_ss_terminator;
11196 10158 : if (!scalar)
11197 4360 : gfc_free_ss_chain (ss);
11198 :
11199 10158 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
11200 90 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
11201 : {
11202 66 : gfc_add_data_component (expr2);
11203 : /* The following is required as gfc_add_data_component doesn't
11204 : update ts.type if there is a trailing REF_ARRAY. */
11205 66 : expr2->ts.type = BT_DERIVED;
11206 : }
11207 :
11208 10158 : if (scalar)
11209 : {
11210 : /* Scalar pointers. */
11211 5798 : lse.want_pointer = 1;
11212 5798 : gfc_conv_expr (&lse, expr1);
11213 5798 : gfc_init_se (&rse, NULL);
11214 5798 : rse.want_pointer = 1;
11215 5798 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11216 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
11217 : else
11218 5792 : gfc_conv_expr (&rse, expr2);
11219 :
11220 5798 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
11221 : {
11222 766 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
11223 : NULL, NULL);
11224 766 : lse.expr = gfc_class_data_get (lse.expr);
11225 : }
11226 :
11227 5798 : if (expr1->symtree->n.sym->attr.proc_pointer
11228 857 : && expr1->symtree->n.sym->attr.dummy)
11229 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
11230 : lse.expr);
11231 :
11232 5798 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
11233 47 : && expr2->symtree->n.sym->attr.dummy)
11234 20 : rse.expr = build_fold_indirect_ref_loc (input_location,
11235 : rse.expr);
11236 :
11237 5798 : gfc_add_block_to_block (&block, &lse.pre);
11238 5798 : gfc_add_block_to_block (&block, &rse.pre);
11239 :
11240 : /* Check character lengths if character expression. The test is only
11241 : really added if -fbounds-check is enabled. Exclude deferred
11242 : character length lefthand sides. */
11243 954 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
11244 780 : && !expr1->ts.deferred
11245 365 : && !expr1->symtree->n.sym->attr.proc_pointer
11246 6156 : && !gfc_is_proc_ptr_comp (expr1))
11247 : {
11248 339 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11249 339 : gcc_assert (lse.string_length && rse.string_length);
11250 339 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11251 : lse.string_length, rse.string_length,
11252 : &block);
11253 : }
11254 :
11255 : /* The assignment to an deferred character length sets the string
11256 : length to that of the rhs. */
11257 5798 : if (expr1->ts.deferred)
11258 : {
11259 530 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
11260 413 : gfc_add_modify (&block, lse.string_length,
11261 413 : fold_convert (TREE_TYPE (lse.string_length),
11262 : rse.string_length));
11263 117 : else if (lse.string_length != NULL)
11264 115 : gfc_add_modify (&block, lse.string_length,
11265 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
11266 : }
11267 :
11268 5798 : gfc_add_modify (&block, lse.expr,
11269 5798 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
11270 :
11271 5798 : if (flag_coarray == GFC_FCOARRAY_LIB)
11272 : {
11273 342 : if (expr1->ref)
11274 : /* Also set the tokens for pointer components in derived typed
11275 : coarrays. */
11276 12 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
11277 330 : else if (gfc_caf_attr (expr1).codimension)
11278 : {
11279 0 : tree lhs_caf_decl, rhs_caf_decl, lhs_tok, rhs_tok;
11280 :
11281 0 : lhs_caf_decl = gfc_get_tree_for_caf_expr (expr1);
11282 0 : rhs_caf_decl = gfc_get_tree_for_caf_expr (expr2);
11283 0 : gfc_get_caf_token_offset (&lse, &lhs_tok, nullptr, lhs_caf_decl,
11284 : NULL_TREE, expr1);
11285 0 : gfc_get_caf_token_offset (&rse, &rhs_tok, nullptr, rhs_caf_decl,
11286 : NULL_TREE, expr2);
11287 0 : gfc_add_modify (&block, lhs_tok, rhs_tok);
11288 : }
11289 : }
11290 :
11291 5798 : gfc_add_block_to_block (&block, &rse.post);
11292 5798 : gfc_add_block_to_block (&block, &lse.post);
11293 : }
11294 : else
11295 : {
11296 4360 : gfc_ref* remap;
11297 4360 : bool rank_remap;
11298 4360 : tree strlen_lhs;
11299 4360 : tree strlen_rhs = NULL_TREE;
11300 :
11301 : /* Array pointer. Find the last reference on the LHS and if it is an
11302 : array section ref, we're dealing with bounds remapping. In this case,
11303 : set it to AR_FULL so that gfc_conv_expr_descriptor does
11304 : not see it and process the bounds remapping afterwards explicitly. */
11305 14046 : for (remap = expr1->ref; remap; remap = remap->next)
11306 5705 : if (!remap->next && remap->type == REF_ARRAY
11307 4360 : && remap->u.ar.type == AR_SECTION)
11308 : break;
11309 4360 : rank_remap = (remap && remap->u.ar.end[0]);
11310 :
11311 379 : if (remap && expr2->expr_type == EXPR_NULL)
11312 : {
11313 2 : gfc_error ("If bounds remapping is specified at %L, "
11314 : "the pointer target shall not be NULL", &expr1->where);
11315 2 : return NULL_TREE;
11316 : }
11317 :
11318 4358 : gfc_init_se (&lse, NULL);
11319 4358 : if (remap)
11320 377 : lse.descriptor_only = 1;
11321 4358 : gfc_conv_expr_descriptor (&lse, expr1);
11322 4358 : strlen_lhs = lse.string_length;
11323 4358 : desc = lse.expr;
11324 :
11325 4358 : if (expr2->expr_type == EXPR_NULL)
11326 : {
11327 : /* Just set the data pointer to null. */
11328 680 : gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
11329 : }
11330 3678 : else if (rank_remap)
11331 : {
11332 : /* If we are rank-remapping, just get the RHS's descriptor and
11333 : process this later on. */
11334 254 : gfc_init_se (&rse, NULL);
11335 254 : rse.direct_byref = 1;
11336 254 : rse.byref_noassign = 1;
11337 :
11338 254 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11339 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
11340 : expr1, expr2);
11341 242 : else if (expr2->expr_type == EXPR_FUNCTION)
11342 : {
11343 : tree bound[GFC_MAX_DIMENSIONS];
11344 : int i;
11345 :
11346 26 : for (i = 0; i < expr2->rank; i++)
11347 13 : bound[i] = NULL_TREE;
11348 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
11349 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
11350 : bound, bound, 0,
11351 : GFC_ARRAY_POINTER_CONT, false);
11352 13 : tmp = gfc_create_var (tmp, "ptrtemp");
11353 13 : rse.descriptor_only = 0;
11354 13 : rse.expr = tmp;
11355 13 : rse.direct_byref = 1;
11356 13 : gfc_conv_expr_descriptor (&rse, expr2);
11357 13 : strlen_rhs = rse.string_length;
11358 13 : rse.expr = tmp;
11359 : }
11360 : else
11361 : {
11362 229 : gfc_conv_expr_descriptor (&rse, expr2);
11363 229 : strlen_rhs = rse.string_length;
11364 229 : if (expr1->ts.type == BT_CLASS)
11365 60 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11366 : expr2, &rse,
11367 : NULL, NULL,
11368 : NULL);
11369 : }
11370 : }
11371 3424 : else if (expr2->expr_type == EXPR_VARIABLE)
11372 : {
11373 : /* Assign directly to the LHS's descriptor. */
11374 3292 : lse.descriptor_only = 0;
11375 3292 : lse.direct_byref = 1;
11376 3292 : gfc_conv_expr_descriptor (&lse, expr2);
11377 3292 : strlen_rhs = lse.string_length;
11378 3292 : gfc_init_se (&rse, NULL);
11379 :
11380 3292 : if (expr1->ts.type == BT_CLASS)
11381 : {
11382 356 : rse.expr = NULL_TREE;
11383 356 : rse.string_length = strlen_rhs;
11384 356 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
11385 : NULL, NULL, NULL);
11386 : }
11387 :
11388 3292 : if (remap == NULL)
11389 : {
11390 : /* If the target is not a whole array, use the target array
11391 : reference for remap. */
11392 6757 : for (remap = expr2->ref; remap; remap = remap->next)
11393 3738 : if (remap->type == REF_ARRAY
11394 3229 : && remap->u.ar.type == AR_FULL
11395 2536 : && remap->next)
11396 : break;
11397 : }
11398 : }
11399 132 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
11400 : {
11401 25 : gfc_init_se (&rse, NULL);
11402 25 : rse.want_pointer = 1;
11403 25 : gfc_conv_function_expr (&rse, expr2);
11404 25 : if (expr1->ts.type != BT_CLASS)
11405 : {
11406 12 : rse.expr = gfc_class_data_get (rse.expr);
11407 12 : gfc_add_modify (&lse.pre, desc, rse.expr);
11408 : }
11409 : else
11410 : {
11411 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
11412 : expr2, &rse, NULL,
11413 : NULL, NULL);
11414 13 : gfc_add_block_to_block (&block, &rse.pre);
11415 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
11416 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
11417 :
11418 26 : gfc_add_modify (&lse.pre, expr1_vptr,
11419 13 : fold_convert (TREE_TYPE (expr1_vptr),
11420 : gfc_class_vptr_get (tmp)));
11421 13 : rse.expr = gfc_class_data_get (tmp);
11422 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
11423 : }
11424 : }
11425 : else
11426 : {
11427 : /* Assign to a temporary descriptor and then copy that
11428 : temporary to the pointer. */
11429 107 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
11430 107 : lse.descriptor_only = 0;
11431 107 : lse.expr = tmp;
11432 107 : lse.direct_byref = 1;
11433 107 : gfc_conv_expr_descriptor (&lse, expr2);
11434 107 : strlen_rhs = lse.string_length;
11435 107 : gfc_add_modify (&lse.pre, desc, tmp);
11436 : }
11437 :
11438 4358 : if (expr1->ts.type == BT_CHARACTER
11439 596 : && expr1->ts.deferred)
11440 : {
11441 338 : gfc_symbol *psym = expr1->symtree->n.sym;
11442 338 : tmp = NULL_TREE;
11443 338 : if (psym->ts.type == BT_CHARACTER
11444 337 : && psym->ts.u.cl->backend_decl)
11445 337 : tmp = psym->ts.u.cl->backend_decl;
11446 1 : else if (expr1->ts.u.cl->backend_decl
11447 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
11448 0 : tmp = expr1->ts.u.cl->backend_decl;
11449 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
11450 : {
11451 1 : gfc_ref *ref = expr1->ref;
11452 3 : for (;ref; ref = ref->next)
11453 : {
11454 2 : if (ref->type == REF_COMPONENT
11455 1 : && ref->u.c.component->ts.type == BT_CHARACTER
11456 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
11457 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
11458 1 : TREE_TYPE (tmp),
11459 1 : TREE_OPERAND (lse.expr, 0),
11460 : tmp, NULL_TREE);
11461 : }
11462 : }
11463 :
11464 338 : gcc_assert (tmp);
11465 :
11466 338 : if (expr2->expr_type != EXPR_NULL)
11467 326 : gfc_add_modify (&block, tmp,
11468 326 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
11469 : else
11470 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
11471 : }
11472 :
11473 4358 : gfc_add_block_to_block (&block, &lse.pre);
11474 4358 : if (rank_remap)
11475 254 : gfc_add_block_to_block (&block, &rse.pre);
11476 :
11477 : /* If we do bounds remapping, update LHS descriptor accordingly. */
11478 4358 : if (remap)
11479 : {
11480 527 : int dim;
11481 527 : gcc_assert (remap->u.ar.dimen == expr1->rank);
11482 :
11483 : /* Always set dtype. */
11484 527 : tree dtype = gfc_conv_descriptor_dtype (desc);
11485 527 : tmp = gfc_get_dtype (TREE_TYPE (desc));
11486 527 : gfc_add_modify (&block, dtype, tmp);
11487 :
11488 : /* For unlimited polymorphic LHS use elem_len from RHS. */
11489 527 : if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
11490 : {
11491 60 : tree elem_len;
11492 60 : tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
11493 60 : elem_len = fold_convert (gfc_array_index_type, tmp);
11494 60 : elem_len = gfc_evaluate_now (elem_len, &block);
11495 60 : tmp = gfc_conv_descriptor_elem_len (desc);
11496 60 : gfc_add_modify (&block, tmp,
11497 60 : fold_convert (TREE_TYPE (tmp), elem_len));
11498 : }
11499 :
11500 527 : if (rank_remap)
11501 : {
11502 : /* Do rank remapping. We already have the RHS's descriptor
11503 : converted in rse and now have to build the correct LHS
11504 : descriptor for it. */
11505 :
11506 254 : tree data, span;
11507 254 : tree offs, stride;
11508 254 : tree lbound, ubound;
11509 :
11510 : /* Copy data pointer. */
11511 254 : data = gfc_conv_descriptor_data_get (rse.expr);
11512 254 : gfc_conv_descriptor_data_set (&block, desc, data);
11513 :
11514 : /* Copy the span. */
11515 254 : if (VAR_P (rse.expr)
11516 254 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
11517 12 : span = gfc_conv_descriptor_span_get (rse.expr);
11518 : else
11519 : {
11520 242 : tmp = TREE_TYPE (rse.expr);
11521 242 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
11522 242 : span = fold_convert (gfc_array_index_type, tmp);
11523 : }
11524 254 : gfc_conv_descriptor_span_set (&block, desc, span);
11525 :
11526 : /* Copy offset but adjust it such that it would correspond
11527 : to a lbound of zero. */
11528 254 : if (expr2->rank == -1)
11529 42 : gfc_conv_descriptor_offset_set (&block, desc,
11530 : gfc_index_zero_node);
11531 : else
11532 : {
11533 212 : offs = gfc_conv_descriptor_offset_get (rse.expr);
11534 654 : for (dim = 0; dim < expr2->rank; ++dim)
11535 : {
11536 230 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11537 : gfc_rank_cst[dim]);
11538 230 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
11539 : gfc_rank_cst[dim]);
11540 230 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11541 : gfc_array_index_type, stride,
11542 : lbound);
11543 230 : offs = fold_build2_loc (input_location, PLUS_EXPR,
11544 : gfc_array_index_type, offs, tmp);
11545 : }
11546 212 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11547 : }
11548 : /* Set the bounds as declared for the LHS and calculate strides as
11549 : well as another offset update accordingly. */
11550 254 : stride = gfc_conv_descriptor_stride_get (rse.expr,
11551 : gfc_rank_cst[0]);
11552 641 : for (dim = 0; dim < expr1->rank; ++dim)
11553 : {
11554 387 : gfc_se lower_se;
11555 387 : gfc_se upper_se;
11556 :
11557 387 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
11558 :
11559 387 : if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
11560 : || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
11561 387 : gfc_resolve_expr (remap->u.ar.start[dim]);
11562 387 : if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
11563 : || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
11564 387 : gfc_resolve_expr (remap->u.ar.end[dim]);
11565 :
11566 : /* Convert declared bounds. */
11567 387 : gfc_init_se (&lower_se, NULL);
11568 387 : gfc_init_se (&upper_se, NULL);
11569 387 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
11570 387 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
11571 :
11572 387 : gfc_add_block_to_block (&block, &lower_se.pre);
11573 387 : gfc_add_block_to_block (&block, &upper_se.pre);
11574 :
11575 387 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
11576 387 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
11577 :
11578 387 : lbound = gfc_evaluate_now (lbound, &block);
11579 387 : ubound = gfc_evaluate_now (ubound, &block);
11580 :
11581 387 : gfc_add_block_to_block (&block, &lower_se.post);
11582 387 : gfc_add_block_to_block (&block, &upper_se.post);
11583 :
11584 : /* Set bounds in descriptor. */
11585 387 : gfc_conv_descriptor_lbound_set (&block, desc,
11586 : gfc_rank_cst[dim], lbound);
11587 387 : gfc_conv_descriptor_ubound_set (&block, desc,
11588 : gfc_rank_cst[dim], ubound);
11589 :
11590 : /* Set stride. */
11591 387 : stride = gfc_evaluate_now (stride, &block);
11592 387 : gfc_conv_descriptor_stride_set (&block, desc,
11593 : gfc_rank_cst[dim], stride);
11594 :
11595 : /* Update offset. */
11596 387 : offs = gfc_conv_descriptor_offset_get (desc);
11597 387 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11598 : gfc_array_index_type, lbound, stride);
11599 387 : offs = fold_build2_loc (input_location, MINUS_EXPR,
11600 : gfc_array_index_type, offs, tmp);
11601 387 : offs = gfc_evaluate_now (offs, &block);
11602 387 : gfc_conv_descriptor_offset_set (&block, desc, offs);
11603 :
11604 : /* Update stride. */
11605 387 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
11606 387 : stride = fold_build2_loc (input_location, MULT_EXPR,
11607 : gfc_array_index_type, stride, tmp);
11608 : }
11609 : }
11610 : else
11611 : {
11612 : /* Bounds remapping. Just shift the lower bounds. */
11613 :
11614 273 : gcc_assert (expr1->rank == expr2->rank);
11615 :
11616 654 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
11617 : {
11618 381 : gfc_se lbound_se;
11619 :
11620 381 : gcc_assert (!remap->u.ar.end[dim]);
11621 381 : gfc_init_se (&lbound_se, NULL);
11622 381 : if (remap->u.ar.start[dim])
11623 : {
11624 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
11625 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
11626 : }
11627 : else
11628 : /* This remap arises from a target that is not a whole
11629 : array. The start expressions will be NULL but we need
11630 : the lbounds to be one. */
11631 156 : lbound_se.expr = gfc_index_one_node;
11632 381 : gfc_conv_shift_descriptor_lbound (&block, desc,
11633 : dim, lbound_se.expr);
11634 381 : gfc_add_block_to_block (&block, &lbound_se.post);
11635 : }
11636 : }
11637 : }
11638 :
11639 : /* If rank remapping was done, check with -fcheck=bounds that
11640 : the target is at least as large as the pointer. */
11641 4358 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
11642 72 : && expr2->rank != -1)
11643 : {
11644 54 : tree lsize, rsize;
11645 54 : tree fault;
11646 54 : const char* msg;
11647 :
11648 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
11649 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
11650 :
11651 54 : lsize = gfc_evaluate_now (lsize, &block);
11652 54 : rsize = gfc_evaluate_now (rsize, &block);
11653 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
11654 : rsize, lsize);
11655 :
11656 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
11657 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
11658 : msg, rsize, lsize);
11659 : }
11660 :
11661 : /* Check string lengths if applicable. The check is only really added
11662 : to the output code if -fbounds-check is enabled. */
11663 4358 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
11664 : {
11665 530 : gcc_assert (expr2->ts.type == BT_CHARACTER);
11666 530 : gcc_assert (strlen_lhs && strlen_rhs);
11667 530 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
11668 : strlen_lhs, strlen_rhs, &block);
11669 : }
11670 :
11671 4358 : gfc_add_block_to_block (&block, &lse.post);
11672 4358 : if (rank_remap)
11673 254 : gfc_add_block_to_block (&block, &rse.post);
11674 : }
11675 :
11676 10156 : return gfc_finish_block (&block);
11677 : }
11678 :
11679 :
11680 : /* Makes sure se is suitable for passing as a function string parameter. */
11681 : /* TODO: Need to check all callers of this function. It may be abused. */
11682 :
11683 : void
11684 245457 : gfc_conv_string_parameter (gfc_se * se)
11685 : {
11686 245457 : tree type;
11687 :
11688 245457 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
11689 245457 : && integer_onep (se->string_length))
11690 : {
11691 691 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
11692 691 : return;
11693 : }
11694 :
11695 244766 : if (TREE_CODE (se->expr) == STRING_CST)
11696 : {
11697 102073 : type = TREE_TYPE (TREE_TYPE (se->expr));
11698 102073 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11699 102073 : return;
11700 : }
11701 :
11702 142693 : if (TREE_CODE (se->expr) == COND_EXPR)
11703 : {
11704 478 : tree cond = TREE_OPERAND (se->expr, 0);
11705 478 : tree lhs = TREE_OPERAND (se->expr, 1);
11706 478 : tree rhs = TREE_OPERAND (se->expr, 2);
11707 :
11708 478 : gfc_se lse, rse;
11709 478 : gfc_init_se (&lse, NULL);
11710 478 : gfc_init_se (&rse, NULL);
11711 :
11712 478 : lse.expr = lhs;
11713 478 : lse.string_length = se->string_length;
11714 478 : gfc_conv_string_parameter (&lse);
11715 :
11716 478 : rse.expr = rhs;
11717 478 : rse.string_length = se->string_length;
11718 478 : gfc_conv_string_parameter (&rse);
11719 :
11720 478 : se->expr
11721 478 : = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr),
11722 : cond, lse.expr, rse.expr);
11723 : }
11724 :
11725 142693 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
11726 55818 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
11727 142789 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
11728 : {
11729 86971 : type = TREE_TYPE (se->expr);
11730 86971 : if (TREE_CODE (se->expr) != INDIRECT_REF)
11731 81920 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
11732 : else
11733 : {
11734 5051 : if (TREE_CODE (type) == ARRAY_TYPE)
11735 5051 : type = TREE_TYPE (type);
11736 5051 : type = gfc_get_character_type_len_for_eltype (type,
11737 : se->string_length);
11738 5051 : type = build_pointer_type (type);
11739 5051 : se->expr = gfc_build_addr_expr (type, se->expr);
11740 : }
11741 : }
11742 :
11743 142693 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
11744 : }
11745 :
11746 :
11747 : /* Generate code for assignment of scalar variables. Includes character
11748 : strings and derived types with allocatable components.
11749 : If you know that the LHS has no allocations, set dealloc to false.
11750 :
11751 : DEEP_COPY has no effect if the typespec TS is not a derived type with
11752 : allocatable components. Otherwise, if it is set, an explicit copy of each
11753 : allocatable component is made. This is necessary as a simple copy of the
11754 : whole object would copy array descriptors as is, so that the lhs's
11755 : allocatable components would point to the rhs's after the assignment.
11756 : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
11757 : necessary if the rhs is a non-pointer function, as the allocatable components
11758 : are not accessible by other means than the function's result after the
11759 : function has returned. It is even more subtle when temporaries are involved,
11760 : as the two following examples show:
11761 : 1. When we evaluate an array constructor, a temporary is created. Thus
11762 : there is theoretically no alias possible. However, no deep copy is
11763 : made for this temporary, so that if the constructor is made of one or
11764 : more variable with allocatable components, those components still point
11765 : to the variable's: DEEP_COPY should be set for the assignment from the
11766 : temporary to the lhs in that case.
11767 : 2. When assigning a scalar to an array, we evaluate the scalar value out
11768 : of the loop, store it into a temporary variable, and assign from that.
11769 : In that case, deep copying when assigning to the temporary would be a
11770 : waste of resources; however deep copies should happen when assigning from
11771 : the temporary to each array element: again DEEP_COPY should be set for
11772 : the assignment from the temporary to the lhs. */
11773 :
11774 : tree
11775 337245 : gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
11776 : bool deep_copy, bool dealloc, bool in_coarray,
11777 : bool assoc_assign)
11778 : {
11779 337245 : stmtblock_t block;
11780 337245 : tree tmp;
11781 337245 : tree cond;
11782 337245 : int caf_mode;
11783 :
11784 337245 : gfc_init_block (&block);
11785 :
11786 337245 : if (ts.type == BT_CHARACTER)
11787 : {
11788 33229 : tree rlen = NULL;
11789 33229 : tree llen = NULL;
11790 :
11791 33229 : if (lse->string_length != NULL_TREE)
11792 : {
11793 33229 : gfc_conv_string_parameter (lse);
11794 33229 : gfc_add_block_to_block (&block, &lse->pre);
11795 33229 : llen = lse->string_length;
11796 : }
11797 :
11798 33229 : if (rse->string_length != NULL_TREE)
11799 : {
11800 33229 : gfc_conv_string_parameter (rse);
11801 33229 : gfc_add_block_to_block (&block, &rse->pre);
11802 33229 : rlen = rse->string_length;
11803 : }
11804 :
11805 33229 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
11806 : rse->expr, ts.kind);
11807 : }
11808 285063 : else if (gfc_bt_struct (ts.type)
11809 304016 : && (ts.u.derived->attr.alloc_comp
11810 12437 : || (deep_copy && has_parameterized_comps (ts.u.derived))))
11811 : {
11812 6660 : tree tmp_var = NULL_TREE;
11813 6660 : cond = NULL_TREE;
11814 :
11815 : /* Are the rhs and the lhs the same? */
11816 6660 : if (deep_copy)
11817 : {
11818 3990 : if (!TREE_CONSTANT (rse->expr) && !VAR_P (rse->expr))
11819 2868 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
11820 3990 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11821 : gfc_build_addr_expr (NULL_TREE, lse->expr),
11822 : gfc_build_addr_expr (NULL_TREE, rse->expr));
11823 3990 : cond = gfc_evaluate_now (cond, &lse->pre);
11824 : }
11825 :
11826 : /* Deallocate the lhs allocated components as long as it is not
11827 : the same as the rhs. This must be done following the assignment
11828 : to prevent deallocating data that could be used in the rhs
11829 : expression. */
11830 6660 : if (dealloc)
11831 : {
11832 1885 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
11833 1885 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
11834 1885 : 0, gfc_may_be_finalized (ts));
11835 1885 : if (deep_copy)
11836 797 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11837 : tmp);
11838 1885 : gfc_add_expr_to_block (&lse->post, tmp);
11839 : }
11840 :
11841 6660 : gfc_add_block_to_block (&block, &rse->pre);
11842 :
11843 : /* Skip finalization for self-assignment. */
11844 6660 : if (deep_copy && lse->finalblock.head)
11845 : {
11846 24 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11847 : gfc_finish_block (&lse->finalblock));
11848 24 : gfc_add_expr_to_block (&block, tmp);
11849 : }
11850 : else
11851 6636 : gfc_add_block_to_block (&block, &lse->finalblock);
11852 :
11853 6660 : gfc_add_block_to_block (&block, &lse->pre);
11854 :
11855 6660 : if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
11856 6660 : == TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)))
11857 6354 : gfc_add_modify (&block, lse->expr,
11858 6354 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11859 : else
11860 : {
11861 306 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11862 306 : TREE_TYPE (lse->expr), rse->expr);
11863 306 : gfc_add_modify (&block, lse->expr, tmp);
11864 : }
11865 :
11866 : /* Restore pointer address of coarray components. */
11867 6660 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
11868 : {
11869 5 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
11870 5 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11871 : tmp);
11872 5 : gfc_add_expr_to_block (&block, tmp);
11873 : }
11874 :
11875 : /* Do a deep copy if the rhs is a variable, if it is not the
11876 : same as the lhs. */
11877 6660 : if (deep_copy)
11878 : {
11879 3990 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11880 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
11881 3990 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
11882 : caf_mode);
11883 3990 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
11884 : tmp);
11885 3990 : gfc_add_expr_to_block (&block, tmp);
11886 : }
11887 : }
11888 297356 : else if (gfc_bt_struct (ts.type))
11889 : {
11890 12293 : gfc_add_block_to_block (&block, &rse->pre);
11891 12293 : gfc_add_block_to_block (&block, &lse->finalblock);
11892 12293 : gfc_add_block_to_block (&block, &lse->pre);
11893 12293 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11894 12293 : TREE_TYPE (lse->expr), rse->expr);
11895 12293 : gfc_add_modify (&block, lse->expr, tmp);
11896 : }
11897 : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
11898 285063 : else if (ts.type == BT_CLASS)
11899 : {
11900 788 : gfc_add_block_to_block (&block, &lse->pre);
11901 788 : gfc_add_block_to_block (&block, &rse->pre);
11902 788 : gfc_add_block_to_block (&block, &lse->finalblock);
11903 :
11904 788 : if (!trans_scalar_class_assign (&block, lse, rse))
11905 : {
11906 : /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
11907 : for the lhs which ensures that class data rhs cast as a string
11908 : assigns correctly. */
11909 642 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
11910 642 : TREE_TYPE (rse->expr), lse->expr);
11911 642 : gfc_add_modify (&block, tmp, rse->expr);
11912 :
11913 : /* Copy allocatable components but guard against class pointer
11914 : assign, which arrives here. */
11915 : #define DATA_DT ts.u.derived->components->ts.u.derived
11916 642 : if (deep_copy
11917 195 : && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11918 43 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
11919 152 : && ts.u.derived->components
11920 794 : && DATA_DT && DATA_DT->attr.alloc_comp)
11921 : {
11922 6 : caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
11923 : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
11924 : : 0;
11925 6 : tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0,
11926 : caf_mode);
11927 6 : gfc_add_expr_to_block (&block, tmp);
11928 : }
11929 : #undef DATA_DT
11930 : }
11931 : }
11932 284275 : else if (ts.type != BT_CLASS)
11933 : {
11934 284275 : gfc_add_block_to_block (&block, &lse->pre);
11935 284275 : gfc_add_block_to_block (&block, &rse->pre);
11936 :
11937 284275 : if (in_coarray)
11938 : {
11939 847 : if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
11940 : {
11941 0 : gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr),
11942 0 : TYPE_LANG_SPECIFIC (
11943 : TREE_TYPE (TREE_TYPE (rse->expr)))
11944 : ->caf_token);
11945 : }
11946 847 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
11947 0 : lse->expr = gfc_conv_array_data (lse->expr);
11948 276 : if (flag_coarray == GFC_FCOARRAY_SINGLE && assoc_assign
11949 847 : && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
11950 0 : rse->expr = gfc_build_addr_expr (NULL_TREE, rse->expr);
11951 : }
11952 284275 : gfc_add_modify (&block, lse->expr,
11953 284275 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
11954 : }
11955 :
11956 337245 : gfc_add_block_to_block (&block, &lse->post);
11957 337245 : gfc_add_block_to_block (&block, &rse->post);
11958 :
11959 337245 : return gfc_finish_block (&block);
11960 : }
11961 :
11962 :
11963 : /* There are quite a lot of restrictions on the optimisation in using an
11964 : array function assign without a temporary. */
11965 :
11966 : static bool
11967 14423 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
11968 : {
11969 14423 : gfc_ref * ref;
11970 14423 : bool seen_array_ref;
11971 14423 : bool c = false;
11972 14423 : gfc_symbol *sym = expr1->symtree->n.sym;
11973 :
11974 : /* Play it safe with class functions assigned to a derived type. */
11975 14423 : if (gfc_is_class_array_function (expr2)
11976 14423 : && expr1->ts.type == BT_DERIVED)
11977 : return true;
11978 :
11979 : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
11980 14399 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
11981 : return true;
11982 :
11983 : /* Elemental functions are scalarized so that they don't need a
11984 : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
11985 : they would need special treatment in gfc_trans_arrayfunc_assign. */
11986 8506 : if (expr2->value.function.esym != NULL
11987 1577 : && expr2->value.function.esym->attr.elemental)
11988 : return true;
11989 :
11990 : /* Need a temporary if rhs is not FULL or a contiguous section. */
11991 8147 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
11992 : return true;
11993 :
11994 : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
11995 7903 : if (gfc_ref_needs_temporary_p (expr1->ref))
11996 : return true;
11997 :
11998 : /* Functions returning pointers or allocatables need temporaries. */
11999 7891 : if (gfc_expr_attr (expr2).pointer
12000 7891 : || gfc_expr_attr (expr2).allocatable)
12001 370 : return true;
12002 :
12003 : /* Character array functions need temporaries unless the
12004 : character lengths are the same. */
12005 7521 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
12006 : {
12007 562 : if (UNLIMITED_POLY (expr1))
12008 : return true;
12009 :
12010 556 : if (expr1->ts.u.cl->length == NULL
12011 507 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12012 : return true;
12013 :
12014 493 : if (expr2->ts.u.cl->length == NULL
12015 487 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
12016 : return true;
12017 :
12018 475 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
12019 475 : expr2->ts.u.cl->length->value.integer) != 0)
12020 : return true;
12021 : }
12022 :
12023 : /* Check that no LHS component references appear during an array
12024 : reference. This is needed because we do not have the means to
12025 : span any arbitrary stride with an array descriptor. This check
12026 : is not needed for the rhs because the function result has to be
12027 : a complete type. */
12028 7428 : seen_array_ref = false;
12029 14856 : for (ref = expr1->ref; ref; ref = ref->next)
12030 : {
12031 7441 : if (ref->type == REF_ARRAY)
12032 : seen_array_ref= true;
12033 13 : else if (ref->type == REF_COMPONENT && seen_array_ref)
12034 : return true;
12035 : }
12036 :
12037 : /* Check for a dependency. */
12038 7415 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
12039 : expr2->value.function.esym,
12040 : expr2->value.function.actual,
12041 : NOT_ELEMENTAL))
12042 : return true;
12043 :
12044 : /* If we have reached here with an intrinsic function, we do not
12045 : need a temporary except in the particular case that reallocation
12046 : on assignment is active and the lhs is allocatable and a target,
12047 : or a pointer which may be a subref pointer. FIXME: The last
12048 : condition can go away when we use span in the intrinsics
12049 : directly.*/
12050 6978 : if (expr2->value.function.isym)
12051 6100 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
12052 12287 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
12053 :
12054 : /* If the LHS is a dummy, we need a temporary if it is not
12055 : INTENT(OUT). */
12056 803 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
12057 : return true;
12058 :
12059 : /* If the lhs has been host_associated, is in common, a pointer or is
12060 : a target and the function is not using a RESULT variable, aliasing
12061 : can occur and a temporary is needed. */
12062 797 : if ((sym->attr.host_assoc
12063 743 : || sym->attr.in_common
12064 737 : || sym->attr.pointer
12065 731 : || sym->attr.cray_pointee
12066 731 : || sym->attr.target)
12067 66 : && expr2->symtree != NULL
12068 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
12069 : return true;
12070 :
12071 : /* A PURE function can unconditionally be called without a temporary. */
12072 755 : if (expr2->value.function.esym != NULL
12073 730 : && expr2->value.function.esym->attr.pure)
12074 : return false;
12075 :
12076 : /* Implicit_pure functions are those which could legally be declared
12077 : to be PURE. */
12078 727 : if (expr2->value.function.esym != NULL
12079 702 : && expr2->value.function.esym->attr.implicit_pure)
12080 : return false;
12081 :
12082 444 : if (!sym->attr.use_assoc
12083 444 : && !sym->attr.in_common
12084 444 : && !sym->attr.pointer
12085 438 : && !sym->attr.target
12086 438 : && !sym->attr.cray_pointee
12087 438 : && expr2->value.function.esym)
12088 : {
12089 : /* A temporary is not needed if the function is not contained and
12090 : the variable is local or host associated and not a pointer or
12091 : a target. */
12092 413 : if (!expr2->value.function.esym->attr.contained)
12093 : return false;
12094 :
12095 : /* A temporary is not needed if the lhs has never been host
12096 : associated and the procedure is contained. */
12097 164 : else if (!sym->attr.host_assoc)
12098 : return false;
12099 :
12100 : /* A temporary is not needed if the variable is local and not
12101 : a pointer, a target or a result. */
12102 6 : if (sym->ns->parent
12103 0 : && expr2->value.function.esym->ns == sym->ns->parent)
12104 : return false;
12105 : }
12106 :
12107 : /* Default to temporary use. */
12108 : return true;
12109 : }
12110 :
12111 :
12112 : /* Provide the loop info so that the lhs descriptor can be built for
12113 : reallocatable assignments from extrinsic function calls. */
12114 :
12115 : static void
12116 203 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
12117 : gfc_loopinfo *loop)
12118 : {
12119 : /* Signal that the function call should not be made by
12120 : gfc_conv_loop_setup. */
12121 203 : se->ss->is_alloc_lhs = 1;
12122 203 : gfc_init_loopinfo (loop);
12123 203 : gfc_add_ss_to_loop (loop, *ss);
12124 203 : gfc_add_ss_to_loop (loop, se->ss);
12125 203 : gfc_conv_ss_startstride (loop);
12126 203 : gfc_conv_loop_setup (loop, where);
12127 203 : gfc_copy_loopinfo_to_se (se, loop);
12128 203 : gfc_add_block_to_block (&se->pre, &loop->pre);
12129 203 : gfc_add_block_to_block (&se->pre, &loop->post);
12130 203 : se->ss->is_alloc_lhs = 0;
12131 203 : }
12132 :
12133 :
12134 : /* For assignment to a reallocatable lhs from intrinsic functions,
12135 : replace the se.expr (ie. the result) with a temporary descriptor.
12136 : Null the data field so that the library allocates space for the
12137 : result. Free the data of the original descriptor after the function,
12138 : in case it appears in an argument expression and transfer the
12139 : result to the original descriptor. */
12140 :
12141 : static void
12142 2126 : fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
12143 : {
12144 2126 : tree desc;
12145 2126 : tree res_desc;
12146 2126 : tree tmp;
12147 2126 : tree offset;
12148 2126 : tree zero_cond;
12149 2126 : tree not_same_shape;
12150 2126 : stmtblock_t shape_block;
12151 2126 : int n;
12152 :
12153 : /* Use the allocation done by the library. Substitute the lhs
12154 : descriptor with a copy, whose data field is nulled.*/
12155 2126 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
12156 2126 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
12157 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
12158 :
12159 : /* Unallocated, the descriptor does not have a dtype. */
12160 2126 : tmp = gfc_conv_descriptor_dtype (desc);
12161 2126 : if (dtype != NULL_TREE)
12162 13 : gfc_add_modify (&se->pre, tmp, dtype);
12163 : else
12164 2113 : gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
12165 :
12166 2126 : res_desc = gfc_evaluate_now (desc, &se->pre);
12167 2126 : gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
12168 2126 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
12169 :
12170 : /* Free the lhs after the function call and copy the result data to
12171 : the lhs descriptor. */
12172 2126 : tmp = gfc_conv_descriptor_data_get (desc);
12173 2126 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
12174 : logical_type_node, tmp,
12175 2126 : build_int_cst (TREE_TYPE (tmp), 0));
12176 2126 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
12177 2126 : tmp = gfc_call_free (tmp);
12178 2126 : gfc_add_expr_to_block (&se->post, tmp);
12179 :
12180 2126 : tmp = gfc_conv_descriptor_data_get (res_desc);
12181 2126 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
12182 :
12183 : /* Check that the shapes are the same between lhs and expression.
12184 : The evaluation of the shape is done in 'shape_block' to avoid
12185 : unitialized warnings from the lhs bounds. */
12186 2126 : not_same_shape = boolean_false_node;
12187 2126 : gfc_start_block (&shape_block);
12188 6844 : for (n = 0 ; n < rank; n++)
12189 : {
12190 4718 : tree tmp1;
12191 4718 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12192 4718 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
12193 4718 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12194 : gfc_array_index_type, tmp, tmp1);
12195 4718 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
12196 4718 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
12197 : gfc_array_index_type, tmp, tmp1);
12198 4718 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12199 4718 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12200 : gfc_array_index_type, tmp, tmp1);
12201 4718 : tmp = fold_build2_loc (input_location, NE_EXPR,
12202 : logical_type_node, tmp,
12203 : gfc_index_zero_node);
12204 4718 : tmp = gfc_evaluate_now (tmp, &shape_block);
12205 4718 : if (n == 0)
12206 : not_same_shape = tmp;
12207 : else
12208 2592 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
12209 : logical_type_node, tmp,
12210 : not_same_shape);
12211 : }
12212 :
12213 : /* 'zero_cond' being true is equal to lhs not being allocated or the
12214 : shapes being different. */
12215 2126 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
12216 : zero_cond, not_same_shape);
12217 2126 : gfc_add_modify (&shape_block, zero_cond, tmp);
12218 2126 : tmp = gfc_finish_block (&shape_block);
12219 2126 : tmp = build3_v (COND_EXPR, zero_cond,
12220 : build_empty_stmt (input_location), tmp);
12221 2126 : gfc_add_expr_to_block (&se->post, tmp);
12222 :
12223 : /* Now reset the bounds returned from the function call to bounds based
12224 : on the lhs lbounds, except where the lhs is not allocated or the shapes
12225 : of 'variable and 'expr' are different. Set the offset accordingly. */
12226 2126 : offset = gfc_index_zero_node;
12227 6844 : for (n = 0 ; n < rank; n++)
12228 : {
12229 4718 : tree lbound;
12230 :
12231 4718 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
12232 4718 : lbound = fold_build3_loc (input_location, COND_EXPR,
12233 : gfc_array_index_type, zero_cond,
12234 : gfc_index_one_node, lbound);
12235 4718 : lbound = gfc_evaluate_now (lbound, &se->post);
12236 :
12237 4718 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
12238 4718 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
12239 : gfc_array_index_type, tmp, lbound);
12240 4718 : gfc_conv_descriptor_lbound_set (&se->post, desc,
12241 : gfc_rank_cst[n], lbound);
12242 4718 : gfc_conv_descriptor_ubound_set (&se->post, desc,
12243 : gfc_rank_cst[n], tmp);
12244 :
12245 : /* Set stride and accumulate the offset. */
12246 4718 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
12247 4718 : gfc_conv_descriptor_stride_set (&se->post, desc,
12248 : gfc_rank_cst[n], tmp);
12249 4718 : tmp = fold_build2_loc (input_location, MULT_EXPR,
12250 : gfc_array_index_type, lbound, tmp);
12251 4718 : offset = fold_build2_loc (input_location, MINUS_EXPR,
12252 : gfc_array_index_type, offset, tmp);
12253 4718 : offset = gfc_evaluate_now (offset, &se->post);
12254 : }
12255 :
12256 2126 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
12257 2126 : }
12258 :
12259 :
12260 :
12261 : /* Try to translate array(:) = func (...), where func is a transformational
12262 : array function, without using a temporary. Returns NULL if this isn't the
12263 : case. */
12264 :
12265 : static tree
12266 14463 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
12267 : {
12268 14463 : gfc_se se;
12269 14463 : gfc_ss *ss = NULL;
12270 14463 : gfc_component *comp = NULL;
12271 14463 : gfc_loopinfo loop;
12272 14463 : tree tmp;
12273 14463 : tree lhs;
12274 14463 : gfc_se final_se;
12275 14463 : gfc_symbol *sym = expr1->symtree->n.sym;
12276 14463 : bool finalizable = gfc_may_be_finalized (expr1->ts);
12277 :
12278 : /* If the symbol is host associated and has not been referenced in its name
12279 : space, it might be lacking a backend_decl and vtable. */
12280 14463 : if (sym->backend_decl == NULL_TREE)
12281 : return NULL_TREE;
12282 :
12283 14423 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
12284 : return NULL_TREE;
12285 :
12286 : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
12287 : functions. */
12288 6860 : comp = gfc_get_proc_ptr_comp (expr2);
12289 :
12290 6860 : if (!(expr2->value.function.isym
12291 718 : || (comp && comp->attr.dimension)
12292 718 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
12293 718 : && expr2->value.function.esym->result->attr.dimension)))
12294 0 : return NULL_TREE;
12295 :
12296 6860 : gfc_init_se (&se, NULL);
12297 6860 : gfc_start_block (&se.pre);
12298 6860 : se.want_pointer = 1;
12299 :
12300 : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
12301 : backend decl, stash the original away for the finalization so that the
12302 : value used is that before the assignment. This is necessary because
12303 : evaluation of the rhs expression using direct by reference can change
12304 : the value. However, the standard mandates that the finalization must occur
12305 : after evaluation of the rhs. */
12306 6860 : gfc_init_se (&final_se, NULL);
12307 :
12308 6860 : if (finalizable)
12309 : {
12310 45 : tmp = sym->backend_decl;
12311 45 : lhs = sym->backend_decl;
12312 45 : if (INDIRECT_REF_P (tmp))
12313 0 : tmp = TREE_OPERAND (tmp, 0);
12314 45 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
12315 45 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
12316 45 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
12317 : {
12318 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
12319 : expr1->rank, 0);
12320 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
12321 : }
12322 : }
12323 :
12324 45 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
12325 : {
12326 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12327 45 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
12328 : }
12329 :
12330 6860 : if (finalizable)
12331 45 : sym->backend_decl = lhs;
12332 :
12333 6860 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
12334 :
12335 6860 : if (expr1->ts.type == BT_DERIVED
12336 252 : && expr1->ts.u.derived->attr.alloc_comp)
12337 : {
12338 98 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
12339 98 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
12340 : expr1->rank);
12341 98 : gfc_add_expr_to_block (&se.pre, tmp);
12342 : }
12343 :
12344 6860 : se.direct_byref = 1;
12345 6860 : se.ss = gfc_walk_expr (expr2);
12346 6860 : gcc_assert (se.ss != gfc_ss_terminator);
12347 :
12348 : /* Since this is a direct by reference call, references to the lhs can be
12349 : used for finalization of the function result just as long as the blocks
12350 : from final_se are added at the right time. */
12351 6860 : gfc_init_se (&final_se, NULL);
12352 6860 : if (finalizable && expr2->value.function.esym)
12353 : {
12354 32 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
12355 32 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
12356 32 : expr2->value.function.esym->attr,
12357 : expr2->rank);
12358 : }
12359 :
12360 : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
12361 : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
12362 : Clearly, this cannot be done for an allocatable function result, since
12363 : the shape of the result is unknown and, in any case, the function must
12364 : correctly take care of the reallocation internally. For intrinsic
12365 : calls, the array data is freed and the library takes care of allocation.
12366 : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
12367 : to the library. */
12368 6860 : if (flag_realloc_lhs
12369 6785 : && gfc_is_reallocatable_lhs (expr1)
12370 9189 : && !gfc_expr_attr (expr1).codimension
12371 2329 : && !gfc_is_coindexed (expr1)
12372 9189 : && !(expr2->value.function.esym
12373 203 : && expr2->value.function.esym->result->attr.allocatable))
12374 : {
12375 2329 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12376 :
12377 2329 : if (!expr2->value.function.isym)
12378 : {
12379 203 : ss = gfc_walk_expr (expr1);
12380 203 : gcc_assert (ss != gfc_ss_terminator);
12381 :
12382 203 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
12383 203 : ss->is_alloc_lhs = 1;
12384 : }
12385 : else
12386 : {
12387 2126 : tree dtype = NULL_TREE;
12388 2126 : tree type = gfc_typenode_for_spec (&expr2->ts);
12389 2126 : if (expr1->ts.type == BT_CLASS)
12390 : {
12391 13 : tmp = gfc_class_vptr_get (sym->backend_decl);
12392 13 : tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
12393 13 : tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
12394 13 : gfc_add_modify (&se.pre, tmp, tmp2);
12395 13 : dtype = gfc_get_dtype_rank_type (expr1->rank,type);
12396 : }
12397 2126 : fcncall_realloc_result (&se, expr1->rank, dtype);
12398 : }
12399 : }
12400 :
12401 6860 : gfc_conv_function_expr (&se, expr2);
12402 :
12403 : /* Fix the result. */
12404 6860 : gfc_add_block_to_block (&se.pre, &se.post);
12405 6860 : if (finalizable)
12406 45 : gfc_add_block_to_block (&se.pre, &final_se.pre);
12407 :
12408 : /* Do the finalization, including final calls from function arguments. */
12409 45 : if (finalizable)
12410 : {
12411 45 : gfc_add_block_to_block (&se.pre, &final_se.post);
12412 45 : gfc_add_block_to_block (&se.pre, &se.finalblock);
12413 45 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
12414 : }
12415 :
12416 6860 : if (ss)
12417 203 : gfc_cleanup_loop (&loop);
12418 : else
12419 6657 : gfc_free_ss_chain (se.ss);
12420 :
12421 6860 : return gfc_finish_block (&se.pre);
12422 : }
12423 :
12424 :
12425 : /* Try to efficiently translate array(:) = 0. Return NULL if this
12426 : can't be done. */
12427 :
12428 : static tree
12429 3944 : gfc_trans_zero_assign (gfc_expr * expr)
12430 : {
12431 3944 : tree dest, len, type;
12432 3944 : tree tmp;
12433 3944 : gfc_symbol *sym;
12434 :
12435 3944 : sym = expr->symtree->n.sym;
12436 3944 : dest = gfc_get_symbol_decl (sym);
12437 :
12438 3944 : type = TREE_TYPE (dest);
12439 3944 : if (POINTER_TYPE_P (type))
12440 248 : type = TREE_TYPE (type);
12441 3944 : if (GFC_ARRAY_TYPE_P (type))
12442 : {
12443 : /* Determine the length of the array. */
12444 2765 : len = GFC_TYPE_ARRAY_SIZE (type);
12445 2765 : if (!len || TREE_CODE (len) != INTEGER_CST)
12446 : return NULL_TREE;
12447 : }
12448 1179 : else if (GFC_DESCRIPTOR_TYPE_P (type)
12449 1179 : && gfc_is_simply_contiguous (expr, false, false))
12450 : {
12451 1079 : if (POINTER_TYPE_P (TREE_TYPE (dest)))
12452 4 : dest = build_fold_indirect_ref_loc (input_location, dest);
12453 1079 : len = gfc_conv_descriptor_size (dest, GFC_TYPE_ARRAY_RANK (type));
12454 1079 : dest = gfc_conv_descriptor_data_get (dest);
12455 : }
12456 : else
12457 100 : return NULL_TREE;
12458 :
12459 : /* If we are zeroing a local array avoid taking its address by emitting
12460 : a = {} instead. */
12461 3665 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
12462 2544 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
12463 2544 : dest, build_constructor (TREE_TYPE (dest),
12464 2544 : NULL));
12465 :
12466 : /* Multiply len by element size. */
12467 1121 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
12468 1121 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12469 : len, fold_convert (gfc_array_index_type, tmp));
12470 :
12471 : /* Convert arguments to the correct types. */
12472 1121 : dest = fold_convert (pvoid_type_node, dest);
12473 1121 : len = fold_convert (size_type_node, len);
12474 :
12475 : /* Construct call to __builtin_memset. */
12476 1121 : tmp = build_call_expr_loc (input_location,
12477 : builtin_decl_explicit (BUILT_IN_MEMSET),
12478 : 3, dest, integer_zero_node, len);
12479 1121 : return fold_convert (void_type_node, tmp);
12480 : }
12481 :
12482 :
12483 : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
12484 : that constructs the call to __builtin_memcpy. */
12485 :
12486 : tree
12487 7932 : gfc_build_memcpy_call (tree dst, tree src, tree len)
12488 : {
12489 7932 : tree tmp;
12490 :
12491 : /* Convert arguments to the correct types. */
12492 7932 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
12493 7631 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
12494 : else
12495 301 : dst = fold_convert (pvoid_type_node, dst);
12496 :
12497 7932 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
12498 7530 : src = gfc_build_addr_expr (pvoid_type_node, src);
12499 : else
12500 402 : src = fold_convert (pvoid_type_node, src);
12501 :
12502 7932 : len = fold_convert (size_type_node, len);
12503 :
12504 : /* Construct call to __builtin_memcpy. */
12505 7932 : tmp = build_call_expr_loc (input_location,
12506 : builtin_decl_explicit (BUILT_IN_MEMCPY),
12507 : 3, dst, src, len);
12508 7932 : return fold_convert (void_type_node, tmp);
12509 : }
12510 :
12511 :
12512 : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
12513 : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
12514 : source/rhs, both are gfc_full_array_ref_p which have been checked for
12515 : dependencies. */
12516 :
12517 : static tree
12518 2591 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
12519 : {
12520 2591 : tree dst, dlen, dtype;
12521 2591 : tree src, slen, stype;
12522 2591 : tree tmp;
12523 :
12524 2591 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12525 2591 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
12526 :
12527 2591 : dtype = TREE_TYPE (dst);
12528 2591 : if (POINTER_TYPE_P (dtype))
12529 253 : dtype = TREE_TYPE (dtype);
12530 2591 : stype = TREE_TYPE (src);
12531 2591 : if (POINTER_TYPE_P (stype))
12532 281 : stype = TREE_TYPE (stype);
12533 :
12534 2591 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
12535 : return NULL_TREE;
12536 :
12537 : /* Determine the lengths of the arrays. */
12538 1581 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
12539 1581 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
12540 : return NULL_TREE;
12541 1492 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12542 1492 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12543 : dlen, fold_convert (gfc_array_index_type, tmp));
12544 :
12545 1492 : slen = GFC_TYPE_ARRAY_SIZE (stype);
12546 1492 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
12547 : return NULL_TREE;
12548 1486 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
12549 1486 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
12550 : slen, fold_convert (gfc_array_index_type, tmp));
12551 :
12552 : /* Sanity check that they are the same. This should always be
12553 : the case, as we should already have checked for conformance. */
12554 1486 : if (!tree_int_cst_equal (slen, dlen))
12555 : return NULL_TREE;
12556 :
12557 1486 : return gfc_build_memcpy_call (dst, src, dlen);
12558 : }
12559 :
12560 :
12561 : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
12562 : this can't be done. EXPR1 is the destination/lhs for which
12563 : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
12564 :
12565 : static tree
12566 8148 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
12567 : {
12568 8148 : unsigned HOST_WIDE_INT nelem;
12569 8148 : tree dst, dtype;
12570 8148 : tree src, stype;
12571 8148 : tree len;
12572 8148 : tree tmp;
12573 :
12574 8148 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
12575 8148 : if (nelem == 0)
12576 : return NULL_TREE;
12577 :
12578 6758 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
12579 6758 : dtype = TREE_TYPE (dst);
12580 6758 : if (POINTER_TYPE_P (dtype))
12581 258 : dtype = TREE_TYPE (dtype);
12582 6758 : if (!GFC_ARRAY_TYPE_P (dtype))
12583 : return NULL_TREE;
12584 :
12585 : /* Determine the lengths of the array. */
12586 5919 : len = GFC_TYPE_ARRAY_SIZE (dtype);
12587 5919 : if (!len || TREE_CODE (len) != INTEGER_CST)
12588 : return NULL_TREE;
12589 :
12590 : /* Confirm that the constructor is the same size. */
12591 5821 : if (compare_tree_int (len, nelem) != 0)
12592 : return NULL_TREE;
12593 :
12594 5821 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
12595 5821 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
12596 : fold_convert (gfc_array_index_type, tmp));
12597 :
12598 5821 : stype = gfc_typenode_for_spec (&expr2->ts);
12599 5821 : src = gfc_build_constant_array_constructor (expr2, stype);
12600 :
12601 5821 : return gfc_build_memcpy_call (dst, src, len);
12602 : }
12603 :
12604 :
12605 : /* Tells whether the expression is to be treated as a variable reference. */
12606 :
12607 : bool
12608 313604 : gfc_expr_is_variable (gfc_expr *expr)
12609 : {
12610 313864 : gfc_expr *arg;
12611 313864 : gfc_component *comp;
12612 313864 : gfc_symbol *func_ifc;
12613 :
12614 313864 : if (expr->expr_type == EXPR_VARIABLE)
12615 : return true;
12616 :
12617 278761 : arg = gfc_get_noncopying_intrinsic_argument (expr);
12618 278761 : if (arg)
12619 : {
12620 260 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
12621 : return gfc_expr_is_variable (arg);
12622 : }
12623 :
12624 : /* A data-pointer-returning function should be considered as a variable
12625 : too. */
12626 278501 : if (expr->expr_type == EXPR_FUNCTION
12627 36955 : && expr->ref == NULL)
12628 : {
12629 36566 : if (expr->value.function.isym != NULL)
12630 : return false;
12631 :
12632 9494 : if (expr->value.function.esym != NULL)
12633 : {
12634 9485 : func_ifc = expr->value.function.esym;
12635 9485 : goto found_ifc;
12636 : }
12637 9 : gcc_assert (expr->symtree);
12638 9 : func_ifc = expr->symtree->n.sym;
12639 9 : goto found_ifc;
12640 : }
12641 :
12642 241935 : comp = gfc_get_proc_ptr_comp (expr);
12643 241935 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
12644 389 : && comp)
12645 : {
12646 275 : func_ifc = comp->ts.interface;
12647 275 : goto found_ifc;
12648 : }
12649 :
12650 241660 : if (expr->expr_type == EXPR_COMPCALL)
12651 : {
12652 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
12653 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
12654 0 : goto found_ifc;
12655 : }
12656 :
12657 : return false;
12658 :
12659 9769 : found_ifc:
12660 9769 : gcc_assert (func_ifc->attr.function
12661 : && func_ifc->result != NULL);
12662 9769 : return func_ifc->result->attr.pointer;
12663 : }
12664 :
12665 :
12666 : /* Is the lhs OK for automatic reallocation? */
12667 :
12668 : static bool
12669 265345 : is_scalar_reallocatable_lhs (gfc_expr *expr)
12670 : {
12671 265345 : gfc_ref * ref;
12672 :
12673 : /* An allocatable variable with no reference. */
12674 265345 : if (expr->symtree->n.sym->attr.allocatable
12675 6770 : && !expr->ref)
12676 : return true;
12677 :
12678 : /* All that can be left are allocatable components. However, we do
12679 : not check for allocatable components here because the expression
12680 : could be an allocatable component of a pointer component. */
12681 262573 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
12682 240162 : && expr->symtree->n.sym->ts.type != BT_CLASS)
12683 : return false;
12684 :
12685 : /* Find an allocatable component ref last. */
12686 39741 : for (ref = expr->ref; ref; ref = ref->next)
12687 16381 : if (ref->type == REF_COMPONENT
12688 12137 : && !ref->next
12689 9373 : && ref->u.c.component->attr.allocatable)
12690 : return true;
12691 :
12692 : return false;
12693 : }
12694 :
12695 :
12696 : /* Allocate or reallocate scalar lhs, as necessary. */
12697 :
12698 : static void
12699 3624 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
12700 : tree string_length,
12701 : gfc_expr *expr1,
12702 : gfc_expr *expr2)
12703 :
12704 : {
12705 3624 : tree cond;
12706 3624 : tree tmp;
12707 3624 : tree size;
12708 3624 : tree size_in_bytes;
12709 3624 : tree jump_label1;
12710 3624 : tree jump_label2;
12711 3624 : gfc_se lse;
12712 3624 : gfc_ref *ref;
12713 :
12714 3624 : if (!expr1 || expr1->rank)
12715 0 : return;
12716 :
12717 3624 : if (!expr2 || expr2->rank)
12718 : return;
12719 :
12720 5084 : for (ref = expr1->ref; ref; ref = ref->next)
12721 1460 : if (ref->type == REF_SUBSTRING)
12722 : return;
12723 :
12724 3624 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
12725 :
12726 : /* Since this is a scalar lhs, we can afford to do this. That is,
12727 : there is no risk of side effects being repeated. */
12728 3624 : gfc_init_se (&lse, NULL);
12729 3624 : lse.want_pointer = 1;
12730 3624 : gfc_conv_expr (&lse, expr1);
12731 :
12732 3624 : jump_label1 = gfc_build_label_decl (NULL_TREE);
12733 3624 : jump_label2 = gfc_build_label_decl (NULL_TREE);
12734 :
12735 : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
12736 3624 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
12737 3624 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
12738 : lse.expr, tmp);
12739 3624 : tmp = build3_v (COND_EXPR, cond,
12740 : build1_v (GOTO_EXPR, jump_label1),
12741 : build_empty_stmt (input_location));
12742 3624 : gfc_add_expr_to_block (block, tmp);
12743 :
12744 3624 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12745 : {
12746 : /* Use the rhs string length and the lhs element size. Note that 'size' is
12747 : used below for the string-length comparison, only. */
12748 1512 : size = string_length;
12749 1512 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
12750 3024 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
12751 1512 : TREE_TYPE (tmp), tmp,
12752 1512 : fold_convert (TREE_TYPE (tmp), size));
12753 : }
12754 : else
12755 : {
12756 : /* Otherwise use the length in bytes of the rhs. */
12757 2112 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
12758 2112 : size_in_bytes = size;
12759 : }
12760 :
12761 3624 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
12762 : size_in_bytes, size_one_node);
12763 :
12764 3624 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
12765 : {
12766 32 : tree caf_decl, token;
12767 32 : gfc_se caf_se;
12768 32 : symbol_attribute attr;
12769 :
12770 32 : gfc_clear_attr (&attr);
12771 32 : gfc_init_se (&caf_se, NULL);
12772 :
12773 32 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
12774 32 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
12775 : NULL);
12776 32 : gfc_add_block_to_block (block, &caf_se.pre);
12777 32 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
12778 : gfc_build_addr_expr (NULL_TREE, token),
12779 : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
12780 : expr1, 1);
12781 : }
12782 3592 : else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
12783 : {
12784 55 : tmp = build_call_expr_loc (input_location,
12785 : builtin_decl_explicit (BUILT_IN_CALLOC),
12786 : 2, build_one_cst (size_type_node),
12787 : size_in_bytes);
12788 55 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12789 55 : gfc_add_modify (block, lse.expr, tmp);
12790 : }
12791 : else
12792 : {
12793 3537 : tmp = build_call_expr_loc (input_location,
12794 : builtin_decl_explicit (BUILT_IN_MALLOC),
12795 : 1, size_in_bytes);
12796 3537 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12797 3537 : gfc_add_modify (block, lse.expr, tmp);
12798 : }
12799 :
12800 3624 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12801 : {
12802 : /* Deferred characters need checking for lhs and rhs string
12803 : length. Other deferred parameter variables will have to
12804 : come here too. */
12805 1512 : tmp = build1_v (GOTO_EXPR, jump_label2);
12806 1512 : gfc_add_expr_to_block (block, tmp);
12807 : }
12808 3624 : tmp = build1_v (LABEL_EXPR, jump_label1);
12809 3624 : gfc_add_expr_to_block (block, tmp);
12810 :
12811 : /* For a deferred length character, reallocate if lengths of lhs and
12812 : rhs are different. */
12813 3624 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
12814 : {
12815 1512 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12816 : lse.string_length,
12817 1512 : fold_convert (TREE_TYPE (lse.string_length),
12818 : size));
12819 : /* Jump past the realloc if the lengths are the same. */
12820 1512 : tmp = build3_v (COND_EXPR, cond,
12821 : build1_v (GOTO_EXPR, jump_label2),
12822 : build_empty_stmt (input_location));
12823 1512 : gfc_add_expr_to_block (block, tmp);
12824 1512 : tmp = build_call_expr_loc (input_location,
12825 : builtin_decl_explicit (BUILT_IN_REALLOC),
12826 : 2, fold_convert (pvoid_type_node, lse.expr),
12827 : size_in_bytes);
12828 1512 : tree omp_cond = NULL_TREE;
12829 1512 : if (flag_openmp_allocators)
12830 : {
12831 1 : tree omp_tmp;
12832 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
12833 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
12834 :
12835 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
12836 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
12837 : fold_convert (pvoid_type_node,
12838 : lse.expr), size_in_bytes,
12839 : build_zero_cst (ptr_type_node),
12840 : build_zero_cst (ptr_type_node));
12841 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
12842 : omp_cond, omp_tmp, tmp);
12843 : }
12844 1512 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
12845 1512 : gfc_add_modify (block, lse.expr, tmp);
12846 1512 : if (omp_cond)
12847 1 : gfc_add_expr_to_block (block,
12848 : build3_loc (input_location, COND_EXPR,
12849 : void_type_node, omp_cond,
12850 : gfc_omp_call_add_alloc (lse.expr),
12851 : build_empty_stmt (input_location)));
12852 1512 : tmp = build1_v (LABEL_EXPR, jump_label2);
12853 1512 : gfc_add_expr_to_block (block, tmp);
12854 :
12855 : /* Update the lhs character length. */
12856 1512 : size = string_length;
12857 1512 : gfc_add_modify (block, lse.string_length,
12858 1512 : fold_convert (TREE_TYPE (lse.string_length), size));
12859 : }
12860 : }
12861 :
12862 : /* Check for assignments of the type
12863 :
12864 : a = a + 4
12865 :
12866 : to make sure we do not check for reallocation unneccessarily. */
12867 :
12868 :
12869 : /* Strip parentheses from an expression to get the underlying variable.
12870 : This is needed for self-assignment detection since (a) creates a
12871 : parentheses operator node. */
12872 :
12873 : static gfc_expr *
12874 7876 : strip_parentheses (gfc_expr *expr)
12875 : {
12876 0 : while (expr->expr_type == EXPR_OP
12877 315225 : && expr->value.op.op == INTRINSIC_PARENTHESES)
12878 590 : expr = expr->value.op.op1;
12879 313976 : return expr;
12880 : }
12881 :
12882 :
12883 : static bool
12884 7411 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
12885 : {
12886 7876 : gfc_actual_arglist *a;
12887 7876 : gfc_expr *e1, *e2;
12888 :
12889 : /* Strip parentheses to handle cases like a = (a). */
12890 15803 : expr1 = strip_parentheses (expr1);
12891 7876 : expr2 = strip_parentheses (expr2);
12892 :
12893 7876 : switch (expr2->expr_type)
12894 : {
12895 2140 : case EXPR_VARIABLE:
12896 2140 : return gfc_dep_compare_expr (expr1, expr2) == 0;
12897 :
12898 2827 : case EXPR_FUNCTION:
12899 2827 : if (expr2->value.function.esym
12900 293 : && expr2->value.function.esym->attr.elemental)
12901 : {
12902 75 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12903 : {
12904 74 : e1 = a->expr;
12905 74 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12906 : return false;
12907 : }
12908 : return true;
12909 : }
12910 2765 : else if (expr2->value.function.isym
12911 2520 : && expr2->value.function.isym->elemental)
12912 : {
12913 332 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
12914 : {
12915 322 : e1 = a->expr;
12916 322 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
12917 : return false;
12918 : }
12919 : return true;
12920 : }
12921 :
12922 : break;
12923 :
12924 659 : case EXPR_OP:
12925 659 : switch (expr2->value.op.op)
12926 : {
12927 19 : case INTRINSIC_NOT:
12928 19 : case INTRINSIC_UPLUS:
12929 19 : case INTRINSIC_UMINUS:
12930 19 : case INTRINSIC_PARENTHESES:
12931 19 : return is_runtime_conformable (expr1, expr2->value.op.op1);
12932 :
12933 615 : case INTRINSIC_PLUS:
12934 615 : case INTRINSIC_MINUS:
12935 615 : case INTRINSIC_TIMES:
12936 615 : case INTRINSIC_DIVIDE:
12937 615 : case INTRINSIC_POWER:
12938 615 : case INTRINSIC_AND:
12939 615 : case INTRINSIC_OR:
12940 615 : case INTRINSIC_EQV:
12941 615 : case INTRINSIC_NEQV:
12942 615 : case INTRINSIC_EQ:
12943 615 : case INTRINSIC_NE:
12944 615 : case INTRINSIC_GT:
12945 615 : case INTRINSIC_GE:
12946 615 : case INTRINSIC_LT:
12947 615 : case INTRINSIC_LE:
12948 615 : case INTRINSIC_EQ_OS:
12949 615 : case INTRINSIC_NE_OS:
12950 615 : case INTRINSIC_GT_OS:
12951 615 : case INTRINSIC_GE_OS:
12952 615 : case INTRINSIC_LT_OS:
12953 615 : case INTRINSIC_LE_OS:
12954 :
12955 615 : e1 = expr2->value.op.op1;
12956 615 : e2 = expr2->value.op.op2;
12957 :
12958 615 : if (e1->rank == 0 && e2->rank > 0)
12959 : return is_runtime_conformable (expr1, e2);
12960 557 : else if (e1->rank > 0 && e2->rank == 0)
12961 : return is_runtime_conformable (expr1, e1);
12962 169 : else if (e1->rank > 0 && e2->rank > 0)
12963 169 : return is_runtime_conformable (expr1, e1)
12964 169 : && is_runtime_conformable (expr1, e2);
12965 : break;
12966 :
12967 : default:
12968 : break;
12969 :
12970 : }
12971 :
12972 : break;
12973 :
12974 : default:
12975 : break;
12976 : }
12977 : return false;
12978 : }
12979 :
12980 :
12981 : static tree
12982 3318 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
12983 : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
12984 : bool class_realloc)
12985 : {
12986 3318 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
12987 3318 : vec<tree, va_gc> *args = NULL;
12988 3318 : bool final_expr;
12989 :
12990 3318 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
12991 3318 : if (final_expr)
12992 : {
12993 473 : if (rse->loop)
12994 226 : gfc_prepend_expr_to_block (&rse->loop->pre,
12995 : gfc_finish_block (&lse->finalblock));
12996 : else
12997 247 : gfc_add_block_to_block (block, &lse->finalblock);
12998 : }
12999 :
13000 : /* Store the old vptr so that dynamic types can be compared for
13001 : reallocation to occur or not. */
13002 3318 : if (class_realloc)
13003 : {
13004 283 : tmp = lse->expr;
13005 283 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13006 0 : tmp = gfc_get_class_from_expr (tmp);
13007 : }
13008 :
13009 3318 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
13010 : &from_len, &rhs_vptr);
13011 3318 : if (rhs_vptr == NULL_TREE)
13012 43 : rhs_vptr = vptr;
13013 :
13014 : /* Generate (re)allocation of the lhs. */
13015 3318 : if (class_realloc)
13016 : {
13017 283 : stmtblock_t alloc, re_alloc;
13018 283 : tree class_han, re, size;
13019 :
13020 283 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
13021 283 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
13022 : else
13023 0 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
13024 :
13025 283 : size = gfc_vptr_size_get (rhs_vptr);
13026 :
13027 : /* Take into account _len of unlimited polymorphic entities.
13028 : TODO: handle class(*) allocatable function results on rhs. */
13029 283 : if (UNLIMITED_POLY (rhs))
13030 : {
13031 18 : tree len;
13032 18 : if (rhs->expr_type == EXPR_VARIABLE)
13033 12 : len = trans_get_upoly_len (block, rhs);
13034 : else
13035 6 : len = gfc_class_len_get (tmp);
13036 18 : len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
13037 : fold_convert (size_type_node, len),
13038 : size_one_node);
13039 18 : size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
13040 18 : size, fold_convert (TREE_TYPE (size), len));
13041 18 : }
13042 265 : else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
13043 27 : size = fold_build2_loc (input_location, MULT_EXPR,
13044 : gfc_charlen_type_node, size,
13045 : rse->string_length);
13046 :
13047 :
13048 283 : tmp = lse->expr;
13049 283 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
13050 283 : ? gfc_class_data_get (tmp) : tmp;
13051 :
13052 283 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
13053 0 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
13054 :
13055 : /* Allocate block. */
13056 283 : gfc_init_block (&alloc);
13057 283 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
13058 :
13059 : /* Reallocate if dynamic types are different. */
13060 283 : gfc_init_block (&re_alloc);
13061 283 : if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
13062 : {
13063 27 : gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
13064 27 : gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
13065 : }
13066 : else
13067 : {
13068 256 : tmp = fold_convert (pvoid_type_node, class_han);
13069 256 : re = build_call_expr_loc (input_location,
13070 : builtin_decl_explicit (BUILT_IN_REALLOC),
13071 : 2, tmp, size);
13072 256 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
13073 : tmp, re);
13074 256 : tmp = fold_build2_loc (input_location, NE_EXPR,
13075 : logical_type_node, rhs_vptr, old_vptr);
13076 256 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13077 : tmp, re, build_empty_stmt (input_location));
13078 256 : gfc_add_expr_to_block (&re_alloc, re);
13079 : }
13080 283 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
13081 283 : gfc_finish_block (&re_alloc) :
13082 0 : build_empty_stmt (input_location);
13083 :
13084 : /* Allocate if _data is NULL, reallocate otherwise. */
13085 283 : tmp = fold_build2_loc (input_location, EQ_EXPR,
13086 : logical_type_node, class_han,
13087 : build_int_cst (prvoid_type_node, 0));
13088 283 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
13089 : gfc_unlikely (tmp,
13090 : PRED_FORTRAN_FAIL_ALLOC),
13091 : gfc_finish_block (&alloc),
13092 : realloc_expr);
13093 283 : gfc_add_expr_to_block (&lse->pre, tmp);
13094 : }
13095 :
13096 3318 : fcn = gfc_vptr_copy_get (vptr);
13097 :
13098 3318 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
13099 3318 : ? gfc_class_data_get (rse->expr) : rse->expr;
13100 3318 : if (use_vptr_copy)
13101 : {
13102 5584 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13103 524 : || INDIRECT_REF_P (tmp)
13104 403 : || (rhs->ts.type == BT_DERIVED
13105 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
13106 0 : && !rhs->ts.u.derived->attr.pointer
13107 0 : && !rhs->ts.u.derived->attr.allocatable)
13108 3454 : || (UNLIMITED_POLY (rhs)
13109 134 : && !CLASS_DATA (rhs)->attr.pointer
13110 43 : && !CLASS_DATA (rhs)->attr.allocatable))
13111 2648 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13112 : else
13113 403 : vec_safe_push (args, tmp);
13114 3051 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13115 3051 : ? gfc_class_data_get (lse->expr) : lse->expr;
13116 5322 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
13117 780 : || INDIRECT_REF_P (tmp)
13118 283 : || (lhs->ts.type == BT_DERIVED
13119 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
13120 0 : && !lhs->ts.u.derived->attr.pointer
13121 0 : && !lhs->ts.u.derived->attr.allocatable)
13122 3334 : || (UNLIMITED_POLY (lhs)
13123 119 : && !CLASS_DATA (lhs)->attr.pointer
13124 119 : && !CLASS_DATA (lhs)->attr.allocatable))
13125 2768 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
13126 : else
13127 283 : vec_safe_push (args, tmp);
13128 :
13129 3051 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13130 :
13131 3051 : if (to_len != NULL_TREE && !integer_zerop (from_len))
13132 : {
13133 406 : tree extcopy;
13134 406 : vec_safe_push (args, from_len);
13135 406 : vec_safe_push (args, to_len);
13136 406 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
13137 :
13138 406 : tmp = fold_build2_loc (input_location, GT_EXPR,
13139 : logical_type_node, from_len,
13140 406 : build_zero_cst (TREE_TYPE (from_len)));
13141 406 : return fold_build3_loc (input_location, COND_EXPR,
13142 : void_type_node, tmp,
13143 406 : extcopy, stdcopy);
13144 : }
13145 : else
13146 2645 : return stdcopy;
13147 : }
13148 : else
13149 : {
13150 267 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
13151 267 : ? gfc_class_data_get (lse->expr) : lse->expr;
13152 267 : stmtblock_t tblock;
13153 267 : gfc_init_block (&tblock);
13154 267 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
13155 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13156 267 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
13157 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
13158 : /* When coming from a ptr_copy lhs and rhs are swapped. */
13159 267 : gfc_add_modify_loc (input_location, &tblock, rhst,
13160 267 : fold_convert (TREE_TYPE (rhst), tmp));
13161 267 : return gfc_finish_block (&tblock);
13162 : }
13163 : }
13164 :
13165 : bool
13166 308043 : is_assoc_assign (gfc_expr *lhs, gfc_expr *rhs)
13167 : {
13168 308043 : if (lhs->expr_type != EXPR_VARIABLE || rhs->expr_type != EXPR_VARIABLE)
13169 : return false;
13170 :
13171 31728 : return lhs->symtree->n.sym->assoc
13172 31728 : && lhs->symtree->n.sym->assoc->target == rhs;
13173 : }
13174 :
13175 : /* Subroutine of gfc_trans_assignment that actually scalarizes the
13176 : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
13177 : init_flag indicates initialization expressions and dealloc that no
13178 : deallocate prior assignment is needed (if in doubt, set true).
13179 : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
13180 : routine instead of a pointer assignment. Alias resolution is only done,
13181 : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
13182 : where it is known, that newly allocated memory on the lhs can never be
13183 : an alias of the rhs. */
13184 :
13185 : static tree
13186 308043 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13187 : bool dealloc, bool use_vptr_copy, bool may_alias)
13188 : {
13189 308043 : gfc_se lse;
13190 308043 : gfc_se rse;
13191 308043 : gfc_ss *lss;
13192 308043 : gfc_ss *lss_section;
13193 308043 : gfc_ss *rss;
13194 308043 : gfc_loopinfo loop;
13195 308043 : tree tmp;
13196 308043 : stmtblock_t block;
13197 308043 : stmtblock_t body;
13198 308043 : bool final_expr;
13199 308043 : bool l_is_temp;
13200 308043 : bool scalar_to_array;
13201 308043 : tree string_length;
13202 308043 : int n;
13203 308043 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
13204 308043 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr, rhs_attr;
13205 308043 : bool is_poly_assign;
13206 308043 : bool realloc_flag;
13207 308043 : bool assoc_assign = false;
13208 308043 : bool dummy_class_array_copy;
13209 :
13210 : /* Assignment of the form lhs = rhs. */
13211 308043 : gfc_start_block (&block);
13212 :
13213 308043 : gfc_init_se (&lse, NULL);
13214 308043 : gfc_init_se (&rse, NULL);
13215 :
13216 308043 : gfc_fix_class_refs (expr1);
13217 :
13218 616086 : realloc_flag = flag_realloc_lhs
13219 301964 : && gfc_is_reallocatable_lhs (expr1)
13220 8216 : && expr2->rank
13221 314794 : && !is_runtime_conformable (expr1, expr2);
13222 :
13223 : /* Walk the lhs. */
13224 308043 : lss = gfc_walk_expr (expr1);
13225 308043 : if (realloc_flag)
13226 : {
13227 6380 : lss->no_bounds_check = 1;
13228 6380 : lss->is_alloc_lhs = 1;
13229 : }
13230 : else
13231 301663 : lss->no_bounds_check = expr1->no_bounds_check;
13232 :
13233 308043 : rss = NULL;
13234 :
13235 308043 : if (expr2->expr_type != EXPR_VARIABLE
13236 308043 : && expr2->expr_type != EXPR_CONSTANT
13237 308043 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
13238 : {
13239 881 : expr2->must_finalize = 1;
13240 : /* F2023 7.5.6.3: If an executable construct references a nonpointer
13241 : function, the result is finalized after execution of the innermost
13242 : executable construct containing the reference. */
13243 881 : if (expr2->expr_type == EXPR_FUNCTION
13244 881 : && (gfc_expr_attr (expr2).pointer
13245 292 : || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer)))
13246 146 : expr2->must_finalize = 0;
13247 : /* F2008 4.5.6.3 para 5: If an executable construct references a
13248 : structure constructor or array constructor, the entity created by
13249 : the constructor is finalized after execution of the innermost
13250 : executable construct containing the reference.
13251 : These finalizations were later deleted by the Combined Techical
13252 : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
13253 735 : else if (gfc_notification_std (GFC_STD_F2018_DEL)
13254 735 : && (expr2->expr_type == EXPR_STRUCTURE
13255 692 : || expr2->expr_type == EXPR_ARRAY))
13256 381 : expr2->must_finalize = 0;
13257 : }
13258 :
13259 :
13260 : /* Checking whether a class assignment is desired is quite complicated and
13261 : needed at two locations, so do it once only before the information is
13262 : needed. */
13263 308043 : lhs_attr = gfc_expr_attr (expr1);
13264 308043 : rhs_attr = gfc_expr_attr (expr2);
13265 308043 : dummy_class_array_copy
13266 616086 : = (expr2->expr_type == EXPR_VARIABLE
13267 31728 : && expr2->rank > 0
13268 8360 : && expr2->symtree != NULL
13269 8360 : && expr2->symtree->n.sym->attr.dummy
13270 1447 : && expr2->ts.type == BT_CLASS
13271 127 : && !rhs_attr.pointer
13272 127 : && !rhs_attr.allocatable
13273 114 : && !CLASS_DATA (expr2)->attr.class_pointer
13274 308157 : && !CLASS_DATA (expr2)->attr.allocatable);
13275 :
13276 : /* What can be sent to trans_class_assignment includes all the obvious
13277 : candidates but scalar assignment of a class expression to a derived type
13278 : must be done using gfc_trans_scalar_assign; partly because it is simpler
13279 : and partly because some cases fail, eg. class assignment to derived_type
13280 : select type temporaries. */
13281 308043 : is_poly_assign
13282 308043 : = (use_vptr_copy
13283 291261 : || ((lhs_attr.pointer || lhs_attr.allocatable) && !lhs_attr.dimension))
13284 22659 : && (expr1->ts.type == BT_CLASS || gfc_is_class_array_ref (expr1, NULL)
13285 20585 : || gfc_is_class_scalar_expr (expr1)
13286 19274 : || gfc_is_class_array_ref (expr2, NULL)
13287 19274 : || (gfc_is_class_scalar_expr (expr2)
13288 30 : && !(expr1->ts.type == BT_DERIVED && !lhs_attr.dimension)))
13289 311428 : && lhs_attr.flavor != FL_PROCEDURE;
13290 :
13291 308043 : assoc_assign = is_assoc_assign (expr1, expr2);
13292 :
13293 : /* Only analyze the expressions for coarray properties, when in coarray-lib
13294 : mode. Avoid false-positive uninitialized diagnostics with initializing
13295 : the codimension flag unconditionally. */
13296 308043 : lhs_caf_attr.codimension = false;
13297 308043 : rhs_caf_attr.codimension = false;
13298 308043 : if (flag_coarray == GFC_FCOARRAY_LIB)
13299 : {
13300 6687 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
13301 6687 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
13302 : }
13303 :
13304 308043 : tree reallocation = NULL_TREE;
13305 308043 : if (lss != gfc_ss_terminator)
13306 : {
13307 : /* The assignment needs scalarization. */
13308 : lss_section = lss;
13309 :
13310 : /* Find a non-scalar SS from the lhs. */
13311 : while (lss_section != gfc_ss_terminator
13312 39961 : && lss_section->info->type != GFC_SS_SECTION)
13313 0 : lss_section = lss_section->next;
13314 :
13315 39961 : gcc_assert (lss_section != gfc_ss_terminator);
13316 :
13317 : /* Initialize the scalarizer. */
13318 39961 : gfc_init_loopinfo (&loop);
13319 :
13320 : /* Walk the rhs. */
13321 39961 : rss = gfc_walk_expr (expr2);
13322 39961 : if (rss == gfc_ss_terminator)
13323 : {
13324 : /* The rhs is scalar. Add a ss for the expression. */
13325 15010 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
13326 15010 : lss->is_alloc_lhs = 0;
13327 : }
13328 :
13329 : /* When doing a class assign, then the handle to the rhs needs to be a
13330 : pointer to allow for polymorphism. */
13331 39961 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
13332 509 : rss->info->type = GFC_SS_REFERENCE;
13333 :
13334 39961 : rss->no_bounds_check = expr2->no_bounds_check;
13335 : /* Associate the SS with the loop. */
13336 39961 : gfc_add_ss_to_loop (&loop, lss);
13337 39961 : gfc_add_ss_to_loop (&loop, rss);
13338 :
13339 : /* Calculate the bounds of the scalarization. */
13340 39961 : gfc_conv_ss_startstride (&loop);
13341 : /* Enable loop reversal. */
13342 679337 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
13343 599415 : loop.reverse[n] = GFC_ENABLE_REVERSE;
13344 : /* Resolve any data dependencies in the statement. */
13345 39961 : if (may_alias)
13346 37676 : gfc_conv_resolve_dependencies (&loop, lss, rss);
13347 : /* Setup the scalarizing loops. */
13348 39961 : gfc_conv_loop_setup (&loop, &expr2->where);
13349 :
13350 : /* Setup the gfc_se structures. */
13351 39961 : gfc_copy_loopinfo_to_se (&lse, &loop);
13352 39961 : gfc_copy_loopinfo_to_se (&rse, &loop);
13353 :
13354 39961 : rse.ss = rss;
13355 39961 : gfc_mark_ss_chain_used (rss, 1);
13356 39961 : if (loop.temp_ss == NULL)
13357 : {
13358 38873 : lse.ss = lss;
13359 38873 : gfc_mark_ss_chain_used (lss, 1);
13360 : }
13361 : else
13362 : {
13363 1088 : lse.ss = loop.temp_ss;
13364 1088 : gfc_mark_ss_chain_used (lss, 3);
13365 1088 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
13366 : }
13367 :
13368 : /* Allow the scalarizer to workshare array assignments. */
13369 39961 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
13370 : == OMPWS_WORKSHARE_FLAG
13371 85 : && loop.temp_ss == NULL)
13372 : {
13373 73 : maybe_workshare = true;
13374 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
13375 : }
13376 :
13377 : /* F2003: Allocate or reallocate lhs of allocatable array. */
13378 39961 : if (realloc_flag)
13379 : {
13380 6380 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
13381 6380 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
13382 6380 : reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
13383 : expr2);
13384 : }
13385 :
13386 : /* Start the scalarized loop body. */
13387 39961 : gfc_start_scalarized_body (&loop, &body);
13388 : }
13389 : else
13390 268082 : gfc_init_block (&body);
13391 :
13392 308043 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
13393 :
13394 : /* Translate the expression. */
13395 616086 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB
13396 308043 : && (init_flag || assoc_assign) && lhs_caf_attr.codimension;
13397 308043 : rse.want_pointer = rse.want_coarray && !init_flag && !lhs_caf_attr.dimension;
13398 308043 : gfc_conv_expr (&rse, expr2);
13399 :
13400 : /* Deal with the case of a scalar class function assigned to a derived type.
13401 : */
13402 308043 : if (gfc_is_alloc_class_scalar_function (expr2)
13403 308043 : && expr1->ts.type == BT_DERIVED)
13404 : {
13405 60 : rse.expr = gfc_class_data_get (rse.expr);
13406 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
13407 : }
13408 :
13409 : /* Stabilize a string length for temporaries. */
13410 308043 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
13411 24489 : && !(VAR_P (rse.string_length)
13412 : || TREE_CODE (rse.string_length) == PARM_DECL
13413 : || INDIRECT_REF_P (rse.string_length)))
13414 23625 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
13415 284418 : else if (expr2->ts.type == BT_CHARACTER)
13416 : {
13417 4370 : if (expr1->ts.deferred
13418 6785 : && gfc_expr_attr (expr1).allocatable
13419 6905 : && gfc_check_dependency (expr1, expr2, true))
13420 120 : rse.string_length =
13421 120 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
13422 4370 : string_length = rse.string_length;
13423 : }
13424 : else
13425 : string_length = NULL_TREE;
13426 :
13427 308043 : if (l_is_temp)
13428 : {
13429 1088 : gfc_conv_tmp_array_ref (&lse);
13430 1088 : if (expr2->ts.type == BT_CHARACTER)
13431 123 : lse.string_length = string_length;
13432 : }
13433 : else
13434 : {
13435 306955 : gfc_conv_expr (&lse, expr1);
13436 : /* For some expression (e.g. complex numbers) fold_convert uses a
13437 : SAVE_EXPR, which is hazardous on the lhs, because the value is
13438 : not updated when assigned to. */
13439 306955 : if (TREE_CODE (lse.expr) == SAVE_EXPR)
13440 8 : lse.expr = TREE_OPERAND (lse.expr, 0);
13441 :
13442 6153 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM && !init_flag
13443 313108 : && gfc_expr_attr (expr1).allocatable && expr1->rank && !expr2->rank)
13444 : {
13445 36 : tree cond;
13446 36 : const char* msg;
13447 :
13448 36 : tmp = INDIRECT_REF_P (lse.expr)
13449 36 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
13450 36 : STRIP_NOPS (tmp);
13451 :
13452 : /* We should only get array references here. */
13453 36 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
13454 : || TREE_CODE (tmp) == ARRAY_REF);
13455 :
13456 : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
13457 : or the array itself(ARRAY_REF). */
13458 36 : tmp = TREE_OPERAND (tmp, 0);
13459 :
13460 : /* Provide the address of the array. */
13461 36 : if (TREE_CODE (lse.expr) == ARRAY_REF)
13462 18 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
13463 :
13464 36 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
13465 36 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
13466 36 : msg = _("Assignment of scalar to unallocated array");
13467 36 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
13468 : &expr1->where, msg);
13469 : }
13470 :
13471 : /* Deallocate the lhs parameterized components if required. */
13472 306955 : if (dealloc
13473 288615 : && !expr1->symtree->n.sym->attr.associate_var
13474 286680 : && expr2->expr_type != EXPR_ARRAY
13475 280708 : && (IS_PDT (expr1) || IS_CLASS_PDT (expr1)))
13476 : {
13477 295 : bool pdt_dep = gfc_check_dependency (expr1, expr2, true);
13478 :
13479 295 : tmp = lse.expr;
13480 295 : if (pdt_dep)
13481 : {
13482 : /* Create a temporary for deallocation after assignment. */
13483 126 : tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp");
13484 126 : gfc_add_modify (&lse.pre, tmp, lse.expr);
13485 : }
13486 :
13487 295 : if (expr1->ts.type == BT_DERIVED)
13488 295 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp,
13489 : expr1->rank);
13490 0 : else if (expr1->ts.type == BT_CLASS)
13491 : {
13492 0 : tmp = gfc_class_data_get (tmp);
13493 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
13494 : tmp, expr1->rank);
13495 : }
13496 :
13497 295 : if (tmp && pdt_dep)
13498 68 : gfc_add_expr_to_block (&rse.post, tmp);
13499 227 : else if (tmp)
13500 43 : gfc_add_expr_to_block (&lse.pre, tmp);
13501 : }
13502 : }
13503 :
13504 : /* Assignments of scalar derived types with allocatable components
13505 : to arrays must be done with a deep copy and the rhs temporary
13506 : must have its components deallocated afterwards. */
13507 616086 : scalar_to_array = (expr2->ts.type == BT_DERIVED
13508 19271 : && expr2->ts.u.derived->attr.alloc_comp
13509 6615 : && !gfc_expr_is_variable (expr2)
13510 311665 : && expr1->rank && !expr2->rank);
13511 616086 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
13512 19554 : && expr1->rank
13513 3814 : && expr1->ts.u.derived->attr.alloc_comp
13514 309428 : && gfc_is_alloc_class_scalar_function (expr2));
13515 308043 : if (scalar_to_array && dealloc)
13516 : {
13517 59 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
13518 59 : gfc_prepend_expr_to_block (&loop.post, tmp);
13519 : }
13520 :
13521 : /* When assigning a character function result to a deferred-length variable,
13522 : the function call must happen before the (re)allocation of the lhs -
13523 : otherwise the character length of the result is not known.
13524 : NOTE 1: This relies on having the exact dependence of the length type
13525 : parameter available to the caller; gfortran saves it in the .mod files.
13526 : NOTE 2: Vector array references generate an index temporary that must
13527 : not go outside the loop. Otherwise, variables should not generate
13528 : a pre block.
13529 : NOTE 3: The concatenation operation generates a temporary pointer,
13530 : whose allocation must go to the innermost loop.
13531 : NOTE 4: Elemental functions may generate a temporary, too. */
13532 308043 : if (flag_realloc_lhs
13533 301964 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
13534 2978 : && !(lss != gfc_ss_terminator
13535 928 : && rss != gfc_ss_terminator
13536 928 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
13537 741 : || (expr2->expr_type == EXPR_FUNCTION
13538 160 : && expr2->value.function.esym != NULL
13539 26 : && expr2->value.function.esym->attr.elemental)
13540 728 : || (expr2->expr_type == EXPR_FUNCTION
13541 147 : && expr2->value.function.isym != NULL
13542 134 : && expr2->value.function.isym->elemental)
13543 672 : || (expr2->expr_type == EXPR_OP
13544 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
13545 2697 : gfc_add_block_to_block (&block, &rse.pre);
13546 :
13547 : /* Nullify the allocatable components corresponding to those of the lhs
13548 : derived type, so that the finalization of the function result does not
13549 : affect the lhs of the assignment. Prepend is used to ensure that the
13550 : nullification occurs before the call to the finalizer. In the case of
13551 : a scalar to array assignment, this is done in gfc_trans_scalar_assign
13552 : as part of the deep copy. */
13553 307216 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
13554 326770 : && (gfc_is_class_array_function (expr2)
13555 18703 : || gfc_is_alloc_class_scalar_function (expr2)))
13556 : {
13557 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
13558 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
13559 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
13560 0 : gfc_add_block_to_block (&loop.post, &rse.post);
13561 : }
13562 :
13563 308043 : tmp = NULL_TREE;
13564 :
13565 308043 : if (is_poly_assign)
13566 : {
13567 3318 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
13568 3318 : use_vptr_copy || (lhs_attr.allocatable
13569 283 : && !lhs_attr.dimension),
13570 3062 : !realloc_flag && flag_realloc_lhs
13571 3868 : && !lhs_attr.pointer);
13572 3318 : if (expr2->expr_type == EXPR_FUNCTION
13573 219 : && expr2->ts.type == BT_DERIVED
13574 18 : && expr2->ts.u.derived->attr.alloc_comp)
13575 : {
13576 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
13577 : rse.expr, expr2->rank);
13578 18 : if (lss == gfc_ss_terminator)
13579 18 : gfc_add_expr_to_block (&rse.post, tmp2);
13580 : else
13581 0 : gfc_add_expr_to_block (&loop.post, tmp2);
13582 : }
13583 :
13584 3318 : expr1->must_finalize = 0;
13585 : }
13586 304725 : else if (!is_poly_assign
13587 304725 : && expr1->ts.type == BT_CLASS
13588 442 : && expr2->ts.type == BT_CLASS
13589 255 : && (expr2->must_finalize || dummy_class_array_copy))
13590 : {
13591 : /* This case comes about when the scalarizer provides array element
13592 : references to class temporaries or nonpointer dummy arrays. Use the
13593 : vptr copy function, since this does a deep copy of allocatable
13594 : components. */
13595 132 : tmp = gfc_get_vptr_from_expr (rse.expr);
13596 132 : if (tmp == NULL_TREE && dummy_class_array_copy)
13597 12 : tmp = gfc_get_vptr_from_expr (gfc_get_class_from_gfc_expr (expr2));
13598 132 : if (tmp != NULL_TREE)
13599 : {
13600 132 : tree fcn = gfc_vptr_copy_get (tmp);
13601 132 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
13602 132 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
13603 132 : tmp = build_call_expr_loc (input_location,
13604 : fcn, 2,
13605 : gfc_build_addr_expr (NULL, rse.expr),
13606 : gfc_build_addr_expr (NULL, lse.expr));
13607 : }
13608 : }
13609 :
13610 : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
13611 : after evaluation of the rhs and before reallocation.
13612 : Skip finalization for self-assignment to avoid use-after-free.
13613 : Strip parentheses from both sides to handle cases like a = (a). */
13614 308043 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
13615 308043 : if (final_expr
13616 660 : && gfc_dep_compare_expr (strip_parentheses (expr1),
13617 : strip_parentheses (expr2)) != 0
13618 308679 : && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE
13619 211 : && strip_parentheses (expr2)->symtree->n.sym->attr.artificial))
13620 : {
13621 636 : if (lss == gfc_ss_terminator)
13622 : {
13623 177 : gfc_add_block_to_block (&block, &rse.pre);
13624 177 : gfc_add_block_to_block (&block, &lse.finalblock);
13625 : }
13626 : else
13627 : {
13628 459 : gfc_add_block_to_block (&body, &rse.pre);
13629 459 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
13630 : &lse.finalblock);
13631 : }
13632 : }
13633 : else
13634 307407 : gfc_add_block_to_block (&body, &rse.pre);
13635 :
13636 308043 : if (flag_coarray != GFC_FCOARRAY_NONE && expr1->ts.type == BT_CHARACTER
13637 2994 : && assoc_assign)
13638 0 : tmp = gfc_trans_pointer_assignment (expr1, expr2);
13639 :
13640 : /* If nothing else works, do it the old fashioned way! */
13641 308043 : if (tmp == NULL_TREE)
13642 : {
13643 : /* Strip parentheses to detect cases like a = (a) which need deep_copy. */
13644 304593 : gfc_expr *expr2_stripped = strip_parentheses (expr2);
13645 304593 : tmp
13646 304593 : = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13647 304593 : gfc_expr_is_variable (expr2_stripped)
13648 274606 : || scalar_to_array
13649 578462 : || expr2->expr_type == EXPR_ARRAY,
13650 304593 : !(l_is_temp || init_flag) && dealloc,
13651 304593 : expr1->symtree->n.sym->attr.codimension,
13652 : assoc_assign);
13653 : }
13654 :
13655 : /* Add the lse pre block to the body */
13656 308043 : gfc_add_block_to_block (&body, &lse.pre);
13657 308043 : gfc_add_expr_to_block (&body, tmp);
13658 :
13659 : /* Add the post blocks to the body. Scalar finalization must appear before
13660 : the post block in case any dellocations are done. */
13661 308043 : if (rse.finalblock.head
13662 308043 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
13663 14 : && gfc_expr_attr (expr2).elemental)))
13664 : {
13665 136 : gfc_add_block_to_block (&body, &rse.finalblock);
13666 136 : gfc_add_block_to_block (&body, &rse.post);
13667 : }
13668 : else
13669 307907 : gfc_add_block_to_block (&body, &rse.post);
13670 :
13671 308043 : gfc_add_block_to_block (&body, &lse.post);
13672 :
13673 308043 : if (lss == gfc_ss_terminator)
13674 : {
13675 : /* F2003: Add the code for reallocation on assignment. */
13676 265345 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
13677 271706 : && !is_poly_assign)
13678 3624 : alloc_scalar_allocatable_for_assignment (&block, string_length,
13679 : expr1, expr2);
13680 :
13681 : /* Use the scalar assignment as is. */
13682 268082 : gfc_add_block_to_block (&block, &body);
13683 : }
13684 : else
13685 : {
13686 39961 : gcc_assert (lse.ss == gfc_ss_terminator
13687 : && rse.ss == gfc_ss_terminator);
13688 :
13689 39961 : if (l_is_temp)
13690 : {
13691 1088 : gfc_trans_scalarized_loop_boundary (&loop, &body);
13692 :
13693 : /* We need to copy the temporary to the actual lhs. */
13694 1088 : gfc_init_se (&lse, NULL);
13695 1088 : gfc_init_se (&rse, NULL);
13696 1088 : gfc_copy_loopinfo_to_se (&lse, &loop);
13697 1088 : gfc_copy_loopinfo_to_se (&rse, &loop);
13698 :
13699 1088 : rse.ss = loop.temp_ss;
13700 1088 : lse.ss = lss;
13701 :
13702 1088 : gfc_conv_tmp_array_ref (&rse);
13703 1088 : gfc_conv_expr (&lse, expr1);
13704 :
13705 1088 : gcc_assert (lse.ss == gfc_ss_terminator
13706 : && rse.ss == gfc_ss_terminator);
13707 :
13708 1088 : if (expr2->ts.type == BT_CHARACTER)
13709 123 : rse.string_length = string_length;
13710 :
13711 1088 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
13712 : false, dealloc);
13713 1088 : gfc_add_expr_to_block (&body, tmp);
13714 : }
13715 :
13716 39961 : if (reallocation != NULL_TREE)
13717 6380 : gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
13718 :
13719 39961 : if (maybe_workshare)
13720 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
13721 :
13722 : /* Generate the copying loops. */
13723 39961 : gfc_trans_scalarizing_loops (&loop, &body);
13724 :
13725 : /* Wrap the whole thing up. */
13726 39961 : gfc_add_block_to_block (&block, &loop.pre);
13727 39961 : gfc_add_block_to_block (&block, &loop.post);
13728 :
13729 39961 : gfc_cleanup_loop (&loop);
13730 : }
13731 :
13732 : /* Since parameterized components cannot have default initializers,
13733 : the default PDT constructor leaves them unallocated. Do the
13734 : allocation now. */
13735 308043 : if (init_flag && IS_PDT (expr1)
13736 329 : && !expr1->symtree->n.sym->attr.allocatable
13737 329 : && !expr1->symtree->n.sym->attr.dummy)
13738 : {
13739 67 : gfc_symbol *sym = expr1->symtree->n.sym;
13740 67 : tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
13741 : sym->backend_decl,
13742 67 : sym->as ? sym->as->rank : 0,
13743 67 : sym->param_list);
13744 67 : gfc_add_expr_to_block (&block, tmp);
13745 : }
13746 :
13747 308043 : return gfc_finish_block (&block);
13748 : }
13749 :
13750 :
13751 : /* Check whether EXPR is a copyable array. */
13752 :
13753 : static bool
13754 976248 : copyable_array_p (gfc_expr * expr)
13755 : {
13756 976248 : if (expr->expr_type != EXPR_VARIABLE)
13757 : return false;
13758 :
13759 : /* First check it's an array. */
13760 952572 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
13761 : return false;
13762 :
13763 146804 : if (!gfc_full_array_ref_p (expr->ref, NULL))
13764 : return false;
13765 :
13766 : /* Next check that it's of a simple enough type. */
13767 115980 : switch (expr->ts.type)
13768 : {
13769 : case BT_INTEGER:
13770 : case BT_REAL:
13771 : case BT_COMPLEX:
13772 : case BT_LOGICAL:
13773 : return true;
13774 :
13775 : case BT_CHARACTER:
13776 : return false;
13777 :
13778 6644 : case_bt_struct:
13779 6644 : return (!expr->ts.u.derived->attr.alloc_comp
13780 6644 : && !expr->ts.u.derived->attr.pdt_type);
13781 :
13782 : default:
13783 : break;
13784 : }
13785 :
13786 : return false;
13787 : }
13788 :
13789 : /* Translate an assignment. */
13790 :
13791 : tree
13792 325875 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
13793 : bool dealloc, bool use_vptr_copy, bool may_alias)
13794 : {
13795 325875 : tree tmp;
13796 :
13797 : /* Special case a single function returning an array. */
13798 325875 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
13799 : {
13800 14463 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
13801 14463 : if (tmp)
13802 : return tmp;
13803 : }
13804 :
13805 : /* Special case assigning an array to zero. */
13806 319015 : if (copyable_array_p (expr1)
13807 319015 : && is_zero_initializer_p (expr2))
13808 : {
13809 3944 : tmp = gfc_trans_zero_assign (expr1);
13810 3944 : if (tmp)
13811 : return tmp;
13812 : }
13813 :
13814 : /* Special case copying one array to another. */
13815 315350 : if (copyable_array_p (expr1)
13816 28019 : && copyable_array_p (expr2)
13817 2687 : && gfc_compare_types (&expr1->ts, &expr2->ts)
13818 318037 : && !gfc_check_dependency (expr1, expr2, 0))
13819 : {
13820 2591 : tmp = gfc_trans_array_copy (expr1, expr2);
13821 2591 : if (tmp)
13822 : return tmp;
13823 : }
13824 :
13825 : /* Special case initializing an array from a constant array constructor. */
13826 313864 : if (copyable_array_p (expr1)
13827 26533 : && expr2->expr_type == EXPR_ARRAY
13828 322012 : && gfc_compare_types (&expr1->ts, &expr2->ts))
13829 : {
13830 8148 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
13831 8148 : if (tmp)
13832 : return tmp;
13833 : }
13834 :
13835 308043 : if (UNLIMITED_POLY (expr1) && expr1->rank)
13836 308043 : use_vptr_copy = true;
13837 :
13838 : /* Fallback to the scalarizer to generate explicit loops. */
13839 308043 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
13840 308043 : use_vptr_copy, may_alias);
13841 : }
13842 :
13843 : tree
13844 12955 : gfc_trans_init_assign (gfc_code * code)
13845 : {
13846 12955 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
13847 : }
13848 :
13849 : tree
13850 304594 : gfc_trans_assign (gfc_code * code)
13851 : {
13852 304594 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
13853 : }
13854 :
13855 : /* Generate a simple loop for internal use of the form
13856 : for (var = begin; var <cond> end; var += step)
13857 : body; */
13858 : void
13859 12159 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
13860 : enum tree_code cond, tree step, tree body)
13861 : {
13862 12159 : tree tmp;
13863 :
13864 : /* var = begin. */
13865 12159 : gfc_add_modify (block, var, begin);
13866 :
13867 : /* Loop: for (var = begin; var <cond> end; var += step). */
13868 12159 : tree label_loop = gfc_build_label_decl (NULL_TREE);
13869 12159 : tree label_cond = gfc_build_label_decl (NULL_TREE);
13870 12159 : TREE_USED (label_loop) = 1;
13871 12159 : TREE_USED (label_cond) = 1;
13872 :
13873 12159 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
13874 12159 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
13875 :
13876 : /* Loop body. */
13877 12159 : gfc_add_expr_to_block (block, body);
13878 :
13879 : /* End of loop body. */
13880 12159 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
13881 12159 : gfc_add_modify (block, var, tmp);
13882 12159 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
13883 12159 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
13884 12159 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
13885 : build_empty_stmt (input_location));
13886 12159 : gfc_add_expr_to_block (block, tmp);
13887 12159 : }
|
