Branch data Line data Source code
1 : : /* Expression translation
2 : : Copyright (C) 2002-2024 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 : : #include "config.h"
25 : : #include "system.h"
26 : : #include "coretypes.h"
27 : : #include "options.h"
28 : : #include "tree.h"
29 : : #include "gfortran.h"
30 : : #include "trans.h"
31 : : #include "stringpool.h"
32 : : #include "diagnostic-core.h" /* For fatal_error. */
33 : : #include "fold-const.h"
34 : : #include "langhooks.h"
35 : : #include "arith.h"
36 : : #include "constructor.h"
37 : : #include "trans-const.h"
38 : : #include "trans-types.h"
39 : : #include "trans-array.h"
40 : : /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 : : #include "trans-stmt.h"
42 : : #include "dependency.h"
43 : : #include "gimplify.h"
44 : : #include "tm.h" /* For CHAR_TYPE_SIZE. */
45 : :
46 : :
47 : : /* Calculate the number of characters in a string. */
48 : :
49 : : static tree
50 : 33366 : gfc_get_character_len (tree type)
51 : : {
52 : 33366 : tree len;
53 : :
54 : 33366 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
55 : : && TYPE_STRING_FLAG (type));
56 : :
57 : 33366 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
58 : 33366 : len = (len) ? (len) : (integer_zero_node);
59 : 33366 : return fold_convert (gfc_charlen_type_node, len);
60 : : }
61 : :
62 : :
63 : :
64 : : /* Calculate the number of bytes in a string. */
65 : :
66 : : tree
67 : 33366 : gfc_get_character_len_in_bytes (tree type)
68 : : {
69 : 33366 : tree tmp, len;
70 : :
71 : 33366 : gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
72 : : && TYPE_STRING_FLAG (type));
73 : :
74 : 33366 : tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
75 : 33366 : tmp = (tmp && !integer_zerop (tmp))
76 : 66732 : ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
77 : 33366 : len = gfc_get_character_len (type);
78 : 33366 : if (tmp && len && !integer_zerop (len))
79 : 32632 : len = fold_build2_loc (input_location, MULT_EXPR,
80 : : gfc_charlen_type_node, len, tmp);
81 : 33366 : return len;
82 : : }
83 : :
84 : :
85 : : /* Convert a scalar to an array descriptor. To be used for assumed-rank
86 : : arrays. */
87 : :
88 : : static tree
89 : 5779 : get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
90 : : {
91 : 5779 : enum gfc_array_kind akind;
92 : :
93 : 5779 : if (attr.pointer)
94 : : akind = GFC_ARRAY_POINTER_CONT;
95 : 5538 : else if (attr.allocatable)
96 : : akind = GFC_ARRAY_ALLOCATABLE;
97 : : else
98 : 4844 : akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
99 : :
100 : 5779 : if (POINTER_TYPE_P (TREE_TYPE (scalar)))
101 : 4379 : scalar = TREE_TYPE (scalar);
102 : 5779 : return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
103 : 5779 : akind, !(attr.pointer || attr.target));
104 : : }
105 : :
106 : : tree
107 : 5104 : gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
108 : : {
109 : 5104 : tree desc, type, etype;
110 : :
111 : 5104 : type = get_scalar_to_descriptor_type (scalar, attr);
112 : 5104 : etype = TREE_TYPE (scalar);
113 : 5104 : desc = gfc_create_var (type, "desc");
114 : 5104 : DECL_ARTIFICIAL (desc) = 1;
115 : :
116 : 5104 : if (CONSTANT_CLASS_P (scalar))
117 : : {
118 : 91 : tree tmp;
119 : 91 : tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
120 : 91 : gfc_add_modify (&se->pre, tmp, scalar);
121 : 91 : scalar = tmp;
122 : : }
123 : 5104 : if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
124 : 1400 : scalar = gfc_build_addr_expr (NULL_TREE, scalar);
125 : 3704 : else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
126 : 110 : etype = TREE_TYPE (etype);
127 : 5104 : gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
128 : : gfc_get_dtype_rank_type (0, etype));
129 : 5104 : gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
130 : 5104 : gfc_conv_descriptor_span_set (&se->pre, desc,
131 : : gfc_conv_descriptor_elem_len (desc));
132 : :
133 : : /* Copy pointer address back - but only if it could have changed and
134 : : if the actual argument is a pointer and not, e.g., NULL(). */
135 : 5104 : if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
136 : 762 : gfc_add_modify (&se->post, scalar,
137 : 381 : fold_convert (TREE_TYPE (scalar),
138 : : gfc_conv_descriptor_data_get (desc)));
139 : 5104 : return desc;
140 : : }
141 : :
142 : :
143 : : /* Get the coarray token from the ultimate array or component ref.
144 : : Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
145 : :
146 : : tree
147 : 408 : gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
148 : : {
149 : 408 : gfc_symbol *sym = expr->symtree->n.sym;
150 : 408 : bool is_coarray = sym->attr.codimension;
151 : 408 : gfc_expr *caf_expr = gfc_copy_expr (expr);
152 : 408 : gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
153 : :
154 : 1385 : while (ref)
155 : : {
156 : 977 : if (ref->type == REF_COMPONENT
157 : 396 : && (ref->u.c.component->attr.allocatable
158 : 396 : || ref->u.c.component->attr.pointer)
159 : 396 : && (is_coarray || ref->u.c.component->attr.codimension))
160 : 977 : last_caf_ref = ref;
161 : 977 : ref = ref->next;
162 : : }
163 : :
164 : 408 : if (last_caf_ref == NULL)
165 : : return NULL_TREE;
166 : :
167 : 307 : tree comp = last_caf_ref->u.c.component->caf_token, caf;
168 : 307 : gfc_se se;
169 : 307 : bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
170 : 307 : if (comp == NULL_TREE && comp_ref)
171 : : return NULL_TREE;
172 : 277 : gfc_init_se (&se, outerse);
173 : 277 : gfc_free_ref_list (last_caf_ref->next);
174 : 277 : last_caf_ref->next = NULL;
175 : 277 : caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
176 : 277 : se.want_pointer = comp_ref;
177 : 277 : gfc_conv_expr (&se, caf_expr);
178 : 277 : gfc_add_block_to_block (&outerse->pre, &se.pre);
179 : :
180 : 277 : if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
181 : 152 : se.expr = TREE_OPERAND (se.expr, 0);
182 : 277 : gfc_free_expr (caf_expr);
183 : :
184 : 277 : if (comp_ref)
185 : 152 : caf = fold_build3_loc (input_location, COMPONENT_REF,
186 : 152 : TREE_TYPE (comp), se.expr, comp, NULL_TREE);
187 : : else
188 : 125 : caf = gfc_conv_descriptor_token (se.expr);
189 : 277 : return gfc_build_addr_expr (NULL_TREE, caf);
190 : : }
191 : :
192 : :
193 : : /* This is the seed for an eventual trans-class.c
194 : :
195 : : The following parameters should not be used directly since they might
196 : : in future implementations. Use the corresponding APIs. */
197 : : #define CLASS_DATA_FIELD 0
198 : : #define CLASS_VPTR_FIELD 1
199 : : #define CLASS_LEN_FIELD 2
200 : : #define VTABLE_HASH_FIELD 0
201 : : #define VTABLE_SIZE_FIELD 1
202 : : #define VTABLE_EXTENDS_FIELD 2
203 : : #define VTABLE_DEF_INIT_FIELD 3
204 : : #define VTABLE_COPY_FIELD 4
205 : : #define VTABLE_FINAL_FIELD 5
206 : : #define VTABLE_DEALLOCATE_FIELD 6
207 : :
208 : :
209 : : tree
210 : 39 : gfc_class_set_static_fields (tree decl, tree vptr, tree data)
211 : : {
212 : 39 : tree tmp;
213 : 39 : tree field;
214 : 39 : vec<constructor_elt, va_gc> *init = NULL;
215 : :
216 : 39 : field = TYPE_FIELDS (TREE_TYPE (decl));
217 : 39 : tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
218 : 39 : CONSTRUCTOR_APPEND_ELT (init, tmp, data);
219 : :
220 : 39 : tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
221 : 39 : CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
222 : :
223 : 39 : return build_constructor (TREE_TYPE (decl), init);
224 : : }
225 : :
226 : :
227 : : tree
228 : 25606 : gfc_class_data_get (tree decl)
229 : : {
230 : 25606 : tree data;
231 : 25606 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
232 : 4560 : decl = build_fold_indirect_ref_loc (input_location, decl);
233 : 25606 : data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
234 : : CLASS_DATA_FIELD);
235 : 25606 : return fold_build3_loc (input_location, COMPONENT_REF,
236 : 25606 : TREE_TYPE (data), decl, data,
237 : 25606 : NULL_TREE);
238 : : }
239 : :
240 : :
241 : : tree
242 : 34756 : gfc_class_vptr_get (tree decl)
243 : : {
244 : 34756 : tree vptr;
245 : : /* For class arrays decl may be a temporary descriptor handle, the vptr is
246 : : then available through the saved descriptor. */
247 : 20635 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
248 : 36145 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
249 : 1081 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
250 : 34756 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
251 : 2256 : decl = build_fold_indirect_ref_loc (input_location, decl);
252 : 34756 : vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
253 : : CLASS_VPTR_FIELD);
254 : 34756 : return fold_build3_loc (input_location, COMPONENT_REF,
255 : 34756 : TREE_TYPE (vptr), decl, vptr,
256 : 34756 : NULL_TREE);
257 : : }
258 : :
259 : :
260 : : tree
261 : 5045 : gfc_class_len_get (tree decl)
262 : : {
263 : 5045 : tree len;
264 : : /* For class arrays decl may be a temporary descriptor handle, the len is
265 : : then available through the saved descriptor. */
266 : 3559 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
267 : 5216 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
268 : 13 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
269 : 5045 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
270 : 513 : decl = build_fold_indirect_ref_loc (input_location, decl);
271 : 5045 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
272 : : CLASS_LEN_FIELD);
273 : 5045 : return fold_build3_loc (input_location, COMPONENT_REF,
274 : 5045 : TREE_TYPE (len), decl, len,
275 : 5045 : NULL_TREE);
276 : : }
277 : :
278 : :
279 : : /* Try to get the _len component of a class. When the class is not unlimited
280 : : poly, i.e. no _len field exists, then return a zero node. */
281 : :
282 : : static tree
283 : 3433 : gfc_class_len_or_zero_get (tree decl)
284 : : {
285 : 3433 : tree len;
286 : : /* For class arrays decl may be a temporary descriptor handle, the vptr is
287 : : then available through the saved descriptor. */
288 : 2216 : if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
289 : 3463 : && GFC_DECL_SAVED_DESCRIPTOR (decl))
290 : 0 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
291 : 3433 : if (POINTER_TYPE_P (TREE_TYPE (decl)))
292 : 0 : decl = build_fold_indirect_ref_loc (input_location, decl);
293 : 3433 : len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
294 : : CLASS_LEN_FIELD);
295 : 4247 : return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
296 : 814 : TREE_TYPE (len), decl, len,
297 : : NULL_TREE)
298 : 2619 : : build_zero_cst (gfc_charlen_type_node);
299 : : }
300 : :
301 : :
302 : : tree
303 : 3304 : gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
304 : : {
305 : 3304 : tree tmp;
306 : 3304 : tree tmp2;
307 : 3304 : tree type;
308 : :
309 : 3304 : tmp = gfc_class_len_or_zero_get (class_expr);
310 : :
311 : : /* Include the len value in the element size if present. */
312 : 3304 : if (!integer_zerop (tmp))
313 : : {
314 : 685 : type = TREE_TYPE (size);
315 : 685 : if (block)
316 : : {
317 : 617 : size = gfc_evaluate_now (size, block);
318 : 617 : tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
319 : : }
320 : 685 : tmp2 = fold_build2_loc (input_location, MULT_EXPR,
321 : : type, size, tmp);
322 : 685 : tmp = fold_build2_loc (input_location, GT_EXPR,
323 : : logical_type_node, tmp,
324 : : build_zero_cst (type));
325 : 685 : size = fold_build3_loc (input_location, COND_EXPR,
326 : : type, tmp, tmp2, size);
327 : : }
328 : : else
329 : : return size;
330 : :
331 : 685 : if (block)
332 : 617 : size = gfc_evaluate_now (size, block);
333 : :
334 : : return size;
335 : : }
336 : :
337 : :
338 : : /* Get the specified FIELD from the VPTR. */
339 : :
340 : : static tree
341 : 17241 : vptr_field_get (tree vptr, int fieldno)
342 : : {
343 : 17241 : tree field;
344 : 17241 : vptr = build_fold_indirect_ref_loc (input_location, vptr);
345 : 17241 : field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
346 : : fieldno);
347 : 17241 : field = fold_build3_loc (input_location, COMPONENT_REF,
348 : 17241 : TREE_TYPE (field), vptr, field,
349 : : NULL_TREE);
350 : 17241 : gcc_assert (field);
351 : 17241 : return field;
352 : : }
353 : :
354 : :
355 : : /* Get the field from the class' vptr. */
356 : :
357 : : static tree
358 : 8139 : class_vtab_field_get (tree decl, int fieldno)
359 : : {
360 : 8139 : tree vptr;
361 : 8139 : vptr = gfc_class_vptr_get (decl);
362 : 8139 : return vptr_field_get (vptr, fieldno);
363 : : }
364 : :
365 : :
366 : : /* Define a macro for creating the class_vtab_* and vptr_* accessors in
367 : : unison. */
368 : : #define VTAB_GET_FIELD_GEN(name, field) tree \
369 : : gfc_class_vtab_## name ##_get (tree cl) \
370 : : { \
371 : : return class_vtab_field_get (cl, field); \
372 : : } \
373 : : \
374 : : tree \
375 : : gfc_vptr_## name ##_get (tree vptr) \
376 : : { \
377 : : return vptr_field_get (vptr, field); \
378 : : }
379 : :
380 : 171 : VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
381 : 0 : VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
382 : 0 : VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
383 : 3722 : VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
384 : 1554 : VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
385 : 390 : VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
386 : : #undef VTAB_GET_FIELD_GEN
387 : :
388 : : /* The size field is returned as an array index type. Therefore treat
389 : : it and only it specially. */
390 : :
391 : : tree
392 : 6375 : gfc_class_vtab_size_get (tree cl)
393 : : {
394 : 6375 : tree size;
395 : 6375 : size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
396 : : /* Always return size as an array index type. */
397 : 6375 : size = fold_convert (gfc_array_index_type, size);
398 : 6375 : gcc_assert (size);
399 : 6375 : return size;
400 : : }
401 : :
402 : : tree
403 : 5029 : gfc_vptr_size_get (tree vptr)
404 : : {
405 : 5029 : tree size;
406 : 5029 : size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
407 : : /* Always return size as an array index type. */
408 : 5029 : size = fold_convert (gfc_array_index_type, size);
409 : 5029 : gcc_assert (size);
410 : 5029 : return size;
411 : : }
412 : :
413 : :
414 : : #undef CLASS_DATA_FIELD
415 : : #undef CLASS_VPTR_FIELD
416 : : #undef CLASS_LEN_FIELD
417 : : #undef VTABLE_HASH_FIELD
418 : : #undef VTABLE_SIZE_FIELD
419 : : #undef VTABLE_EXTENDS_FIELD
420 : : #undef VTABLE_DEF_INIT_FIELD
421 : : #undef VTABLE_COPY_FIELD
422 : : #undef VTABLE_FINAL_FIELD
423 : :
424 : :
425 : : /* IF ts is null (default), search for the last _class ref in the chain
426 : : of references of the expression and cut the chain there. Although
427 : : this routine is similiar to class.cc:gfc_add_component_ref (), there
428 : : is a significant difference: gfc_add_component_ref () concentrates
429 : : on an array ref that is the last ref in the chain and is oblivious
430 : : to the kind of refs following.
431 : : ELSE IF ts is non-null the cut is at the class entity or component
432 : : that is followed by an array reference, which is not an element.
433 : : These calls come from trans-array.cc:build_class_array_ref, which
434 : : handles scalarized class array references.*/
435 : :
436 : : gfc_expr *
437 : 7484 : gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
438 : : gfc_typespec **ts)
439 : : {
440 : 7484 : gfc_expr *base_expr;
441 : 7484 : gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
442 : :
443 : : /* Find the last class reference. */
444 : 7484 : class_ref = NULL;
445 : 7484 : array_ref = NULL;
446 : :
447 : 7484 : if (ts)
448 : : {
449 : 314 : if (e->symtree
450 : 289 : && e->symtree->n.sym->ts.type == BT_CLASS)
451 : 289 : *ts = &e->symtree->n.sym->ts;
452 : : else
453 : 25 : *ts = NULL;
454 : : }
455 : :
456 : 18635 : for (ref = e->ref; ref; ref = ref->next)
457 : : {
458 : 11450 : if (ts)
459 : : {
460 : 747 : if (ref->type == REF_COMPONENT
461 : 344 : && ref->u.c.component->ts.type == BT_CLASS
462 : 0 : && ref->next && ref->next->type == REF_COMPONENT
463 : 0 : && !strcmp (ref->next->u.c.component->name, "_data")
464 : 0 : && ref->next->next
465 : 0 : && ref->next->next->type == REF_ARRAY
466 : 0 : && ref->next->next->u.ar.type != AR_ELEMENT)
467 : : {
468 : 0 : *ts = &ref->u.c.component->ts;
469 : 0 : class_ref = ref;
470 : 0 : break;
471 : : }
472 : :
473 : 747 : if (ref->next == NULL)
474 : : break;
475 : : }
476 : : else
477 : : {
478 : 10703 : if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
479 : 10703 : array_ref = ref;
480 : :
481 : 10703 : if (ref->type == REF_COMPONENT
482 : 6639 : && ref->u.c.component->ts.type == BT_CLASS)
483 : : {
484 : : /* Component to the right of a part reference with nonzero
485 : : rank must not have the ALLOCATABLE attribute. If attempts
486 : : are made to reference such a component reference, an error
487 : : results followed by an ICE. */
488 : 1419 : if (array_ref
489 : 10 : && CLASS_DATA (ref->u.c.component)->attr.allocatable)
490 : : return NULL;
491 : : class_ref = ref;
492 : : }
493 : : }
494 : : }
495 : :
496 : 7474 : if (ts && *ts == NULL)
497 : : return NULL;
498 : :
499 : : /* Remove and store all subsequent references after the
500 : : CLASS reference. */
501 : 7449 : if (class_ref)
502 : : {
503 : 1229 : tail = class_ref->next;
504 : 1229 : class_ref->next = NULL;
505 : : }
506 : 6220 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
507 : : {
508 : 6202 : tail = e->ref;
509 : 6202 : e->ref = NULL;
510 : : }
511 : :
512 : 7449 : if (is_mold)
513 : 59 : base_expr = gfc_expr_to_initialize (e);
514 : : else
515 : 7390 : base_expr = gfc_copy_expr (e);
516 : :
517 : : /* Restore the original tail expression. */
518 : 7449 : if (class_ref)
519 : : {
520 : 1229 : gfc_free_ref_list (class_ref->next);
521 : 1229 : class_ref->next = tail;
522 : : }
523 : 6220 : else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
524 : : {
525 : 6202 : gfc_free_ref_list (e->ref);
526 : 6202 : e->ref = tail;
527 : : }
528 : : return base_expr;
529 : : }
530 : :
531 : :
532 : : /* Reset the vptr to the declared type, e.g. after deallocation.
533 : : Use the variable in CLASS_CONTAINER if available. Otherwise, recreate
534 : : one with E. The generated assignment code is added at the end of BLOCK. */
535 : :
536 : : void
537 : 1724 : gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container)
538 : : {
539 : 1724 : tree vptr = NULL_TREE;
540 : :
541 : 1724 : if (class_container != NULL_TREE)
542 : 110 : vptr = gfc_get_vptr_from_expr (class_container);
543 : :
544 : 110 : if (vptr == NULL_TREE)
545 : : {
546 : 1621 : gfc_se se;
547 : :
548 : : /* Evaluate the expression and obtain the vptr from it. */
549 : 1621 : gfc_init_se (&se, NULL);
550 : 1621 : if (e->rank)
551 : 838 : gfc_conv_expr_descriptor (&se, e);
552 : : else
553 : 783 : gfc_conv_expr (&se, e);
554 : 1621 : gfc_add_block_to_block (block, &se.pre);
555 : :
556 : 1621 : vptr = gfc_get_vptr_from_expr (se.expr);
557 : : }
558 : :
559 : : /* If a vptr is not found, we can do nothing more. */
560 : 1621 : if (vptr == NULL_TREE)
561 : : return;
562 : :
563 : 1714 : if (UNLIMITED_POLY (e))
564 : 441 : gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
565 : : else
566 : : {
567 : 1273 : gfc_symbol *vtab;
568 : 1273 : tree vtable;
569 : :
570 : : /* Return the vptr to the address of the declared type. */
571 : 1273 : vtab = gfc_find_derived_vtab (e->ts.u.derived);
572 : 1273 : vtable = vtab->backend_decl;
573 : 1273 : if (vtable == NULL_TREE)
574 : 21 : vtable = gfc_get_symbol_decl (vtab);
575 : 1273 : vtable = gfc_build_addr_expr (NULL, vtable);
576 : 1273 : vtable = fold_convert (TREE_TYPE (vptr), vtable);
577 : 1273 : gfc_add_modify (block, vptr, vtable);
578 : : }
579 : : }
580 : :
581 : :
582 : : /* Reset the len for unlimited polymorphic objects. */
583 : :
584 : : void
585 : 417 : gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
586 : : {
587 : 417 : gfc_expr *e;
588 : 417 : gfc_se se_len;
589 : 417 : e = gfc_find_and_cut_at_last_class_ref (expr);
590 : 417 : if (e == NULL)
591 : 0 : return;
592 : 417 : gfc_add_len_component (e);
593 : 417 : gfc_init_se (&se_len, NULL);
594 : 417 : gfc_conv_expr (&se_len, e);
595 : 417 : gfc_add_modify (block, se_len.expr,
596 : 417 : fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
597 : 417 : gfc_free_expr (e);
598 : : }
599 : :
600 : :
601 : : /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
602 : : reference is found. Note that it is up to the caller to avoid using this
603 : : for expressions other than variables. */
604 : :
605 : : tree
606 : 858 : gfc_get_class_from_gfc_expr (gfc_expr *e)
607 : : {
608 : 858 : gfc_expr *class_expr;
609 : 858 : gfc_se cse;
610 : 858 : class_expr = gfc_find_and_cut_at_last_class_ref (e);
611 : 858 : if (class_expr == NULL)
612 : : return NULL_TREE;
613 : 858 : gfc_init_se (&cse, NULL);
614 : 858 : gfc_conv_expr (&cse, class_expr);
615 : 858 : gfc_free_expr (class_expr);
616 : 858 : return cse.expr;
617 : : }
618 : :
619 : :
620 : : /* Obtain the last class reference in an expression.
621 : : Return NULL_TREE if no class reference is found. */
622 : :
623 : : tree
624 : 73640 : gfc_get_class_from_expr (tree expr)
625 : : {
626 : 73640 : tree tmp;
627 : 73640 : tree type;
628 : :
629 : 206147 : for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
630 : : {
631 : 206147 : if (CONSTANT_CLASS_P (tmp))
632 : : return NULL_TREE;
633 : :
634 : 206110 : type = TREE_TYPE (tmp);
635 : 241264 : while (type)
636 : : {
637 : 234908 : if (GFC_CLASS_TYPE_P (type))
638 : 8602 : return tmp;
639 : 226306 : if (type != TYPE_CANONICAL (type))
640 : 35154 : type = TYPE_CANONICAL (type);
641 : : else
642 : : type = NULL_TREE;
643 : : }
644 : 197508 : if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
645 : : break;
646 : : }
647 : :
648 : 65001 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
649 : 40178 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
650 : :
651 : 65001 : if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
652 : : return tmp;
653 : :
654 : : return NULL_TREE;
655 : : }
656 : :
657 : :
658 : : /* Obtain the vptr of the last class reference in an expression.
659 : : Return NULL_TREE if no class reference is found. */
660 : :
661 : : tree
662 : 1967 : gfc_get_vptr_from_expr (tree expr)
663 : : {
664 : 1967 : tree tmp;
665 : :
666 : 1967 : tmp = gfc_get_class_from_expr (expr);
667 : :
668 : 1967 : if (tmp != NULL_TREE)
669 : 1944 : return gfc_class_vptr_get (tmp);
670 : :
671 : : return NULL_TREE;
672 : : }
673 : :
674 : :
675 : : static void
676 : 1125 : class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
677 : : bool lhs_type)
678 : : {
679 : 1125 : tree tmp, tmp2, type;
680 : :
681 : 1125 : gfc_conv_descriptor_data_set (block, lhs_desc,
682 : : gfc_conv_descriptor_data_get (rhs_desc));
683 : 1125 : gfc_conv_descriptor_offset_set (block, lhs_desc,
684 : : gfc_conv_descriptor_offset_get (rhs_desc));
685 : :
686 : 1125 : gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
687 : : gfc_conv_descriptor_dtype (rhs_desc));
688 : :
689 : : /* Assign the dimension as range-ref. */
690 : 1125 : tmp = gfc_get_descriptor_dimension (lhs_desc);
691 : 1125 : tmp2 = gfc_get_descriptor_dimension (rhs_desc);
692 : :
693 : 1125 : type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
694 : 1125 : tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
695 : : gfc_index_zero_node, NULL_TREE, NULL_TREE);
696 : 1125 : tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
697 : : gfc_index_zero_node, NULL_TREE, NULL_TREE);
698 : 1125 : gfc_add_modify (block, tmp, tmp2);
699 : 1125 : }
700 : :
701 : :
702 : : /* Takes a derived type expression and returns the address of a temporary
703 : : class object of the 'declared' type. If vptr is not NULL, this is
704 : : used for the temporary class object.
705 : : optional_alloc_ptr is false when the dummy is neither allocatable
706 : : nor a pointer; that's only relevant for the optional handling.
707 : : The optional argument 'derived_array' is used to preserve the parmse
708 : : expression for deallocation of allocatable components. Assumed rank
709 : : formal arguments made this necessary. */
710 : : void
711 : 4332 : gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
712 : : gfc_typespec class_ts, tree vptr, bool optional,
713 : : bool optional_alloc_ptr,
714 : : tree *derived_array)
715 : : {
716 : 4332 : gfc_symbol *vtab;
717 : 4332 : tree cond_optional = NULL_TREE;
718 : 4332 : gfc_ss *ss;
719 : 4332 : tree ctree;
720 : 4332 : tree var;
721 : 4332 : tree tmp;
722 : 4332 : int dim;
723 : :
724 : : /* The derived type needs to be converted to a temporary
725 : : CLASS object. */
726 : 4332 : tmp = gfc_typenode_for_spec (&class_ts);
727 : 4332 : var = gfc_create_var (tmp, "class");
728 : :
729 : : /* Set the vptr. */
730 : 4332 : ctree = gfc_class_vptr_get (var);
731 : :
732 : 4332 : if (vptr != NULL_TREE)
733 : : {
734 : : /* Use the dynamic vptr. */
735 : : tmp = vptr;
736 : : }
737 : : else
738 : : {
739 : : /* In this case the vtab corresponds to the derived type and the
740 : : vptr must point to it. */
741 : 4222 : vtab = gfc_find_derived_vtab (e->ts.u.derived);
742 : 4222 : gcc_assert (vtab);
743 : 4222 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
744 : : }
745 : 4332 : gfc_add_modify (&parmse->pre, ctree,
746 : 4332 : fold_convert (TREE_TYPE (ctree), tmp));
747 : :
748 : : /* Now set the data field. */
749 : 4332 : ctree = gfc_class_data_get (var);
750 : :
751 : 4332 : if (optional)
752 : 576 : cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
753 : :
754 : 4332 : if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
755 : : {
756 : : /* If there is a ready made pointer to a derived type, use it
757 : : rather than evaluating the expression again. */
758 : 480 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
759 : 480 : gfc_add_modify (&parmse->pre, ctree, tmp);
760 : : }
761 : 3852 : else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
762 : : {
763 : : /* For an array reference in an elemental procedure call we need
764 : : to retain the ss to provide the scalarized array reference. */
765 : 221 : gfc_conv_expr_reference (parmse, e);
766 : 221 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
767 : 221 : if (optional)
768 : 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
769 : : cond_optional, tmp,
770 : 0 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
771 : 221 : gfc_add_modify (&parmse->pre, ctree, tmp);
772 : : }
773 : : else
774 : : {
775 : 3631 : ss = gfc_walk_expr (e);
776 : 3631 : if (ss == gfc_ss_terminator)
777 : : {
778 : 2596 : parmse->ss = NULL;
779 : 2596 : gfc_conv_expr_reference (parmse, e);
780 : :
781 : : /* Scalar to an assumed-rank array. */
782 : 2596 : if (class_ts.u.derived->components->as)
783 : : {
784 : 319 : tree type;
785 : 319 : type = get_scalar_to_descriptor_type (parmse->expr,
786 : : gfc_expr_attr (e));
787 : 319 : gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
788 : : gfc_get_dtype (type));
789 : 319 : if (optional)
790 : 192 : parmse->expr = build3_loc (input_location, COND_EXPR,
791 : 96 : TREE_TYPE (parmse->expr),
792 : : cond_optional, parmse->expr,
793 : 96 : fold_convert (TREE_TYPE (parmse->expr),
794 : : null_pointer_node));
795 : 319 : gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
796 : : }
797 : : else
798 : : {
799 : 2277 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
800 : 2277 : if (optional)
801 : 132 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
802 : : cond_optional, tmp,
803 : 132 : fold_convert (TREE_TYPE (tmp),
804 : : null_pointer_node));
805 : 2277 : gfc_add_modify (&parmse->pre, ctree, tmp);
806 : : }
807 : : }
808 : : else
809 : : {
810 : 1035 : stmtblock_t block;
811 : 1035 : gfc_init_block (&block);
812 : 1035 : gfc_ref *ref;
813 : :
814 : 1035 : parmse->ss = ss;
815 : 1035 : parmse->use_offset = 1;
816 : 1035 : gfc_conv_expr_descriptor (parmse, e);
817 : :
818 : : /* Detect any array references with vector subscripts. */
819 : 2069 : for (ref = e->ref; ref; ref = ref->next)
820 : 1040 : if (ref->type == REF_ARRAY
821 : 998 : && ref->u.ar.type != AR_ELEMENT
822 : 998 : && ref->u.ar.type != AR_FULL)
823 : : {
824 : 126 : for (dim = 0; dim < ref->u.ar.dimen; dim++)
825 : 78 : if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
826 : : break;
827 : 54 : if (dim < ref->u.ar.dimen)
828 : : break;
829 : : }
830 : :
831 : : /* Array references with vector subscripts and non-variable expressions
832 : : need be converted to a one-based descriptor. */
833 : 1035 : if (ref || e->expr_type != EXPR_VARIABLE)
834 : : {
835 : 86 : for (dim = 0; dim < e->rank; ++dim)
836 : 43 : gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
837 : : gfc_index_one_node);
838 : : }
839 : :
840 : 1035 : if (e->rank != class_ts.u.derived->components->as->rank)
841 : : {
842 : 397 : gcc_assert (class_ts.u.derived->components->as->type
843 : : == AS_ASSUMED_RANK);
844 : 397 : if (derived_array
845 : 397 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
846 : : {
847 : 397 : *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
848 : : "array");
849 : 397 : gfc_add_modify (&block, *derived_array , parmse->expr);
850 : : }
851 : 397 : class_array_data_assign (&block, ctree, parmse->expr, false);
852 : : }
853 : : else
854 : : {
855 : 638 : if (gfc_expr_attr (e).codimension)
856 : 72 : parmse->expr = fold_build1_loc (input_location,
857 : : VIEW_CONVERT_EXPR,
858 : 72 : TREE_TYPE (ctree),
859 : : parmse->expr);
860 : 638 : gfc_add_modify (&block, ctree, parmse->expr);
861 : : }
862 : :
863 : 1035 : if (optional)
864 : : {
865 : 348 : tmp = gfc_finish_block (&block);
866 : :
867 : 348 : gfc_init_block (&block);
868 : 348 : gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
869 : 348 : if (derived_array && *derived_array != NULL_TREE)
870 : 132 : gfc_conv_descriptor_data_set (&block, *derived_array,
871 : : null_pointer_node);
872 : :
873 : 348 : tmp = build3_v (COND_EXPR, cond_optional, tmp,
874 : : gfc_finish_block (&block));
875 : 348 : gfc_add_expr_to_block (&parmse->pre, tmp);
876 : : }
877 : : else
878 : 687 : gfc_add_block_to_block (&parmse->pre, &block);
879 : : }
880 : : }
881 : :
882 : 4332 : if (class_ts.u.derived->components->ts.type == BT_DERIVED
883 : 4332 : && class_ts.u.derived->components->ts.u.derived
884 : 4332 : ->attr.unlimited_polymorphic)
885 : : {
886 : : /* Take care about initializing the _len component correctly. */
887 : 296 : ctree = gfc_class_len_get (var);
888 : 296 : if (UNLIMITED_POLY (e))
889 : : {
890 : 6 : gfc_expr *len;
891 : 6 : gfc_se se;
892 : :
893 : 6 : len = gfc_find_and_cut_at_last_class_ref (e);
894 : 6 : gfc_add_len_component (len);
895 : 6 : gfc_init_se (&se, NULL);
896 : 6 : gfc_conv_expr (&se, len);
897 : 6 : if (optional)
898 : 0 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
899 : : cond_optional, se.expr,
900 : 0 : fold_convert (TREE_TYPE (se.expr),
901 : : integer_zero_node));
902 : : else
903 : 6 : tmp = se.expr;
904 : 6 : gfc_free_expr (len);
905 : 6 : }
906 : : else
907 : 290 : tmp = integer_zero_node;
908 : 296 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
909 : : tmp));
910 : : }
911 : : /* Pass the address of the class object. */
912 : 4332 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
913 : :
914 : 4332 : if (optional && optional_alloc_ptr)
915 : 168 : parmse->expr = build3_loc (input_location, COND_EXPR,
916 : 84 : TREE_TYPE (parmse->expr),
917 : : cond_optional, parmse->expr,
918 : 84 : fold_convert (TREE_TYPE (parmse->expr),
919 : : null_pointer_node));
920 : 4332 : }
921 : :
922 : :
923 : : /* Create a new class container, which is required as scalar coarrays
924 : : have an array descriptor while normal scalars haven't. Optionally,
925 : : NULL pointer checks are added if the argument is OPTIONAL. */
926 : :
927 : : static void
928 : 48 : class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
929 : : gfc_typespec class_ts, bool optional)
930 : : {
931 : 48 : tree var, ctree, tmp;
932 : 48 : stmtblock_t block;
933 : 48 : gfc_ref *ref;
934 : 48 : gfc_ref *class_ref;
935 : :
936 : 48 : gfc_init_block (&block);
937 : :
938 : 48 : class_ref = NULL;
939 : 144 : for (ref = e->ref; ref; ref = ref->next)
940 : : {
941 : 96 : if (ref->type == REF_COMPONENT
942 : 48 : && ref->u.c.component->ts.type == BT_CLASS)
943 : 96 : class_ref = ref;
944 : : }
945 : :
946 : 48 : if (class_ref == NULL
947 : 48 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
948 : 48 : tmp = e->symtree->n.sym->backend_decl;
949 : : else
950 : : {
951 : : /* Remove everything after the last class reference, convert the
952 : : expression and then recover its tailend once more. */
953 : 0 : gfc_se tmpse;
954 : 0 : ref = class_ref->next;
955 : 0 : class_ref->next = NULL;
956 : 0 : gfc_init_se (&tmpse, NULL);
957 : 0 : gfc_conv_expr (&tmpse, e);
958 : 0 : class_ref->next = ref;
959 : 0 : tmp = tmpse.expr;
960 : : }
961 : :
962 : 48 : var = gfc_typenode_for_spec (&class_ts);
963 : 48 : var = gfc_create_var (var, "class");
964 : :
965 : 48 : ctree = gfc_class_vptr_get (var);
966 : 96 : gfc_add_modify (&block, ctree,
967 : 48 : fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
968 : :
969 : 48 : ctree = gfc_class_data_get (var);
970 : 48 : tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
971 : 48 : gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
972 : :
973 : : /* Pass the address of the class object. */
974 : 48 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
975 : :
976 : 48 : if (optional)
977 : : {
978 : 48 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
979 : 48 : tree tmp2;
980 : :
981 : 48 : tmp = gfc_finish_block (&block);
982 : :
983 : 48 : gfc_init_block (&block);
984 : 48 : tmp2 = gfc_class_data_get (var);
985 : 48 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
986 : : null_pointer_node));
987 : 48 : tmp2 = gfc_finish_block (&block);
988 : :
989 : 48 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
990 : : cond, tmp, tmp2);
991 : 48 : gfc_add_expr_to_block (&parmse->pre, tmp);
992 : : }
993 : : else
994 : 0 : gfc_add_block_to_block (&parmse->pre, &block);
995 : 48 : }
996 : :
997 : :
998 : : /* Takes an intrinsic type expression and returns the address of a temporary
999 : : class object of the 'declared' type. */
1000 : : void
1001 : 732 : gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
1002 : : gfc_typespec class_ts)
1003 : : {
1004 : 732 : gfc_symbol *vtab;
1005 : 732 : gfc_ss *ss;
1006 : 732 : tree ctree;
1007 : 732 : tree var;
1008 : 732 : tree tmp;
1009 : 732 : int dim;
1010 : 732 : bool unlimited_poly;
1011 : :
1012 : 1464 : unlimited_poly = class_ts.type == BT_CLASS
1013 : 732 : && class_ts.u.derived->components->ts.type == BT_DERIVED
1014 : 732 : && class_ts.u.derived->components->ts.u.derived
1015 : 732 : ->attr.unlimited_polymorphic;
1016 : :
1017 : : /* The intrinsic type needs to be converted to a temporary
1018 : : CLASS object. */
1019 : 732 : tmp = gfc_typenode_for_spec (&class_ts);
1020 : 732 : var = gfc_create_var (tmp, "class");
1021 : :
1022 : : /* Force a temporary for component or substring references. */
1023 : 732 : if (unlimited_poly
1024 : 732 : && class_ts.u.derived->components->attr.dimension
1025 : : && !class_ts.u.derived->components->attr.allocatable
1026 : 732 : && !class_ts.u.derived->components->attr.class_pointer
1027 : 1271 : && is_subref_array (e))
1028 : 5 : parmse->force_tmp = 1;
1029 : :
1030 : : /* Set the vptr. */
1031 : 732 : ctree = gfc_class_vptr_get (var);
1032 : :
1033 : 732 : vtab = gfc_find_vtab (&e->ts);
1034 : 732 : gcc_assert (vtab);
1035 : 732 : tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
1036 : 732 : gfc_add_modify (&parmse->pre, ctree,
1037 : 732 : fold_convert (TREE_TYPE (ctree), tmp));
1038 : :
1039 : : /* Now set the data field. */
1040 : 732 : ctree = gfc_class_data_get (var);
1041 : 732 : if (parmse->ss && parmse->ss->info->useflags)
1042 : : {
1043 : : /* For an array reference in an elemental procedure call we need
1044 : : to retain the ss to provide the scalarized array reference. */
1045 : 0 : gfc_conv_expr_reference (parmse, e);
1046 : 0 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1047 : 0 : gfc_add_modify (&parmse->pre, ctree, tmp);
1048 : : }
1049 : : else
1050 : : {
1051 : 732 : ss = gfc_walk_expr (e);
1052 : 732 : if (ss == gfc_ss_terminator)
1053 : : {
1054 : 217 : parmse->ss = NULL;
1055 : 217 : gfc_conv_expr_reference (parmse, e);
1056 : 217 : if (class_ts.u.derived->components->as
1057 : 24 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
1058 : : {
1059 : 24 : tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
1060 : : gfc_expr_attr (e));
1061 : 24 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1062 : 24 : TREE_TYPE (ctree), tmp);
1063 : : }
1064 : : else
1065 : 193 : tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
1066 : 217 : gfc_add_modify (&parmse->pre, ctree, tmp);
1067 : : }
1068 : : else
1069 : : {
1070 : 515 : parmse->ss = ss;
1071 : 515 : parmse->use_offset = 1;
1072 : 515 : gfc_conv_expr_descriptor (parmse, e);
1073 : :
1074 : : /* Array references with vector subscripts and non-variable expressions
1075 : : need be converted to a one-based descriptor. */
1076 : 515 : if (e->expr_type != EXPR_VARIABLE)
1077 : : {
1078 : 368 : for (dim = 0; dim < e->rank; ++dim)
1079 : 193 : gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1080 : : dim, gfc_index_one_node);
1081 : : }
1082 : :
1083 : 515 : if (class_ts.u.derived->components->as->rank != e->rank)
1084 : : {
1085 : 49 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1086 : 49 : TREE_TYPE (ctree), parmse->expr);
1087 : 49 : gfc_add_modify (&parmse->pre, ctree, tmp);
1088 : : }
1089 : : else
1090 : 466 : gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1091 : : }
1092 : : }
1093 : :
1094 : 732 : gcc_assert (class_ts.type == BT_CLASS);
1095 : 732 : if (unlimited_poly)
1096 : : {
1097 : 732 : ctree = gfc_class_len_get (var);
1098 : : /* When the actual arg is a char array, then set the _len component of the
1099 : : unlimited polymorphic entity to the length of the string. */
1100 : 732 : if (e->ts.type == BT_CHARACTER)
1101 : : {
1102 : : /* Start with parmse->string_length because this seems to be set to a
1103 : : correct value more often. */
1104 : 115 : if (parmse->string_length)
1105 : : tmp = parmse->string_length;
1106 : : /* When the string_length is not yet set, then try the backend_decl of
1107 : : the cl. */
1108 : 0 : else if (e->ts.u.cl->backend_decl)
1109 : : tmp = e->ts.u.cl->backend_decl;
1110 : : /* If both of the above approaches fail, then try to generate an
1111 : : expression from the input, which is only feasible currently, when the
1112 : : expression can be evaluated to a constant one. */
1113 : : else
1114 : : {
1115 : : /* Try to simplify the expression. */
1116 : 0 : gfc_simplify_expr (e, 0);
1117 : 0 : if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1118 : : {
1119 : : /* Amazingly all data is present to compute the length of a
1120 : : constant string, but the expression is not yet there. */
1121 : 0 : e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1122 : : gfc_charlen_int_kind,
1123 : : &e->where);
1124 : 0 : mpz_set_ui (e->ts.u.cl->length->value.integer,
1125 : 0 : e->value.character.length);
1126 : 0 : gfc_conv_const_charlen (e->ts.u.cl);
1127 : 0 : e->ts.u.cl->resolved = 1;
1128 : 0 : tmp = e->ts.u.cl->backend_decl;
1129 : : }
1130 : : else
1131 : : {
1132 : 0 : gfc_error ("Cannot compute the length of the char array "
1133 : : "at %L.", &e->where);
1134 : : }
1135 : : }
1136 : : }
1137 : : else
1138 : 617 : tmp = integer_zero_node;
1139 : :
1140 : 732 : gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1141 : : }
1142 : :
1143 : : /* Pass the address of the class object. */
1144 : 732 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1145 : 732 : }
1146 : :
1147 : :
1148 : : /* Takes a scalarized class array expression and returns the
1149 : : address of a temporary scalar class object of the 'declared'
1150 : : type.
1151 : : OOP-TODO: This could be improved by adding code that branched on
1152 : : the dynamic type being the same as the declared type. In this case
1153 : : the original class expression can be passed directly.
1154 : : optional_alloc_ptr is false when the dummy is neither allocatable
1155 : : nor a pointer; that's relevant for the optional handling.
1156 : : Set copyback to true if class container's _data and _vtab pointers
1157 : : might get modified. */
1158 : :
1159 : : void
1160 : 3203 : gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1161 : : bool elemental, bool copyback, bool optional,
1162 : : bool optional_alloc_ptr)
1163 : : {
1164 : 3203 : tree ctree;
1165 : 3203 : tree var;
1166 : 3203 : tree tmp;
1167 : 3203 : tree vptr;
1168 : 3203 : tree cond = NULL_TREE;
1169 : 3203 : tree slen = NULL_TREE;
1170 : 3203 : gfc_ref *ref;
1171 : 3203 : gfc_ref *class_ref;
1172 : 3203 : stmtblock_t block;
1173 : 3203 : bool full_array = false;
1174 : :
1175 : 3203 : gfc_init_block (&block);
1176 : :
1177 : 3203 : class_ref = NULL;
1178 : 6424 : for (ref = e->ref; ref; ref = ref->next)
1179 : : {
1180 : 6063 : if (ref->type == REF_COMPONENT
1181 : 3254 : && ref->u.c.component->ts.type == BT_CLASS)
1182 : 6063 : class_ref = ref;
1183 : :
1184 : 6063 : if (ref->next == NULL)
1185 : : break;
1186 : : }
1187 : :
1188 : 3203 : if ((ref == NULL || class_ref == ref)
1189 : 472 : && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1190 : 3663 : && (!class_ts.u.derived->components->as
1191 : 378 : || class_ts.u.derived->components->as->rank != -1))
1192 : 128 : return;
1193 : :
1194 : : /* Test for FULL_ARRAY. */
1195 : 3075 : if (e->rank == 0
1196 : 3075 : && ((gfc_expr_attr (e).codimension && gfc_expr_attr (e).dimension)
1197 : 484 : || (class_ts.u.derived->components->as
1198 : 356 : && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)))
1199 : 403 : full_array = true;
1200 : : else
1201 : 2672 : gfc_is_class_array_ref (e, &full_array);
1202 : :
1203 : : /* The derived type needs to be converted to a temporary
1204 : : CLASS object. */
1205 : 3075 : tmp = gfc_typenode_for_spec (&class_ts);
1206 : 3075 : var = gfc_create_var (tmp, "class");
1207 : :
1208 : : /* Set the data. */
1209 : 3075 : ctree = gfc_class_data_get (var);
1210 : 3075 : if (class_ts.u.derived->components->as
1211 : 2821 : && e->rank != class_ts.u.derived->components->as->rank)
1212 : : {
1213 : 916 : if (e->rank == 0)
1214 : : {
1215 : 356 : tree type = get_scalar_to_descriptor_type (parmse->expr,
1216 : : gfc_expr_attr (e));
1217 : 356 : gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1218 : : gfc_get_dtype (type));
1219 : :
1220 : 356 : tmp = gfc_class_data_get (parmse->expr);
1221 : 356 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1222 : 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1223 : :
1224 : 356 : gfc_conv_descriptor_data_set (&block, ctree, tmp);
1225 : : }
1226 : : else
1227 : 560 : class_array_data_assign (&block, ctree, parmse->expr, false);
1228 : : }
1229 : : else
1230 : : {
1231 : 2159 : if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1232 : 1226 : parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1233 : 1226 : TREE_TYPE (ctree), parmse->expr);
1234 : 2159 : gfc_add_modify (&block, ctree, parmse->expr);
1235 : : }
1236 : :
1237 : : /* Return the data component, except in the case of scalarized array
1238 : : references, where nullification of the cannot occur and so there
1239 : : is no need. */
1240 : 3075 : if (!elemental && full_array && copyback)
1241 : : {
1242 : 1054 : if (class_ts.u.derived->components->as
1243 : 1054 : && e->rank != class_ts.u.derived->components->as->rank)
1244 : : {
1245 : 270 : if (e->rank == 0)
1246 : : {
1247 : 102 : tmp = gfc_class_data_get (parmse->expr);
1248 : 204 : gfc_add_modify (&parmse->post, tmp,
1249 : 102 : fold_convert (TREE_TYPE (tmp),
1250 : : gfc_conv_descriptor_data_get (ctree)));
1251 : : }
1252 : : else
1253 : 168 : class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1254 : : }
1255 : : else
1256 : 784 : gfc_add_modify (&parmse->post, parmse->expr, ctree);
1257 : : }
1258 : :
1259 : : /* Set the vptr. */
1260 : 3075 : ctree = gfc_class_vptr_get (var);
1261 : :
1262 : : /* The vptr is the second field of the actual argument.
1263 : : First we have to find the corresponding class reference. */
1264 : :
1265 : 3075 : tmp = NULL_TREE;
1266 : 3075 : if (gfc_is_class_array_function (e)
1267 : 3075 : && parmse->class_vptr != NULL_TREE)
1268 : : tmp = parmse->class_vptr;
1269 : 3063 : else if (class_ref == NULL
1270 : 2632 : && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1271 : : {
1272 : 2632 : tmp = e->symtree->n.sym->backend_decl;
1273 : :
1274 : 2632 : if (TREE_CODE (tmp) == FUNCTION_DECL)
1275 : 6 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1276 : :
1277 : 2632 : if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1278 : 304 : tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1279 : :
1280 : 2632 : slen = build_zero_cst (size_type_node);
1281 : : }
1282 : 431 : else if (parmse->class_container != NULL_TREE)
1283 : : /* Don't redundantly evaluate the expression if the required information
1284 : : is already available. */
1285 : : tmp = parmse->class_container;
1286 : : else
1287 : : {
1288 : : /* Remove everything after the last class reference, convert the
1289 : : expression and then recover its tailend once more. */
1290 : 18 : gfc_se tmpse;
1291 : 18 : ref = class_ref->next;
1292 : 18 : class_ref->next = NULL;
1293 : 18 : gfc_init_se (&tmpse, NULL);
1294 : 18 : gfc_conv_expr (&tmpse, e);
1295 : 18 : class_ref->next = ref;
1296 : 18 : tmp = tmpse.expr;
1297 : 18 : slen = tmpse.string_length;
1298 : : }
1299 : :
1300 : 3075 : gcc_assert (tmp != NULL_TREE);
1301 : :
1302 : : /* Dereference if needs be. */
1303 : 3075 : if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1304 : 269 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1305 : :
1306 : 3075 : if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1307 : 3063 : vptr = gfc_class_vptr_get (tmp);
1308 : : else
1309 : : vptr = tmp;
1310 : :
1311 : 3075 : gfc_add_modify (&block, ctree,
1312 : 3075 : fold_convert (TREE_TYPE (ctree), vptr));
1313 : :
1314 : : /* Return the vptr component, except in the case of scalarized array
1315 : : references, where the dynamic type cannot change. */
1316 : 3075 : if (!elemental && full_array && copyback)
1317 : 1054 : gfc_add_modify (&parmse->post, vptr,
1318 : 1054 : fold_convert (TREE_TYPE (vptr), ctree));
1319 : :
1320 : : /* For unlimited polymorphic objects also set the _len component. */
1321 : 3075 : if (class_ts.type == BT_CLASS
1322 : 3075 : && class_ts.u.derived->components
1323 : 3075 : && class_ts.u.derived->components->ts.u
1324 : 3075 : .derived->attr.unlimited_polymorphic)
1325 : : {
1326 : 874 : ctree = gfc_class_len_get (var);
1327 : 874 : if (UNLIMITED_POLY (e))
1328 : 702 : tmp = gfc_class_len_get (tmp);
1329 : 172 : else if (e->ts.type == BT_CHARACTER)
1330 : : {
1331 : 0 : gcc_assert (slen != NULL_TREE);
1332 : : tmp = slen;
1333 : : }
1334 : : else
1335 : 172 : tmp = build_zero_cst (size_type_node);
1336 : 874 : gfc_add_modify (&parmse->pre, ctree,
1337 : 874 : fold_convert (TREE_TYPE (ctree), tmp));
1338 : :
1339 : : /* Return the len component, except in the case of scalarized array
1340 : : references, where the dynamic type cannot change. */
1341 : 874 : if (!elemental && full_array && copyback
1342 : 392 : && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1343 : 380 : gfc_add_modify (&parmse->post, tmp,
1344 : 380 : fold_convert (TREE_TYPE (tmp), ctree));
1345 : : }
1346 : :
1347 : 3075 : if (optional)
1348 : : {
1349 : 510 : tree tmp2;
1350 : :
1351 : 510 : cond = gfc_conv_expr_present (e->symtree->n.sym);
1352 : : /* parmse->pre may contain some preparatory instructions for the
1353 : : temporary array descriptor. Those may only be executed when the
1354 : : optional argument is set, therefore add parmse->pre's instructions
1355 : : to block, which is later guarded by an if (optional_arg_given). */
1356 : 510 : gfc_add_block_to_block (&parmse->pre, &block);
1357 : 510 : block.head = parmse->pre.head;
1358 : 510 : parmse->pre.head = NULL_TREE;
1359 : 510 : tmp = gfc_finish_block (&block);
1360 : :
1361 : 510 : if (optional_alloc_ptr)
1362 : 102 : tmp2 = build_empty_stmt (input_location);
1363 : : else
1364 : : {
1365 : 408 : gfc_init_block (&block);
1366 : :
1367 : 408 : tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1368 : 408 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1369 : : null_pointer_node));
1370 : 408 : tmp2 = gfc_finish_block (&block);
1371 : : }
1372 : :
1373 : 510 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1374 : : cond, tmp, tmp2);
1375 : 510 : gfc_add_expr_to_block (&parmse->pre, tmp);
1376 : :
1377 : 510 : if (!elemental && full_array && copyback)
1378 : : {
1379 : 30 : tmp2 = build_empty_stmt (input_location);
1380 : 30 : tmp = gfc_finish_block (&parmse->post);
1381 : 30 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1382 : : cond, tmp, tmp2);
1383 : 30 : gfc_add_expr_to_block (&parmse->post, tmp);
1384 : : }
1385 : : }
1386 : : else
1387 : 2565 : gfc_add_block_to_block (&parmse->pre, &block);
1388 : :
1389 : : /* Pass the address of the class object. */
1390 : 3075 : parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1391 : :
1392 : 3075 : if (optional && optional_alloc_ptr)
1393 : 204 : parmse->expr = build3_loc (input_location, COND_EXPR,
1394 : 102 : TREE_TYPE (parmse->expr),
1395 : : cond, parmse->expr,
1396 : 102 : fold_convert (TREE_TYPE (parmse->expr),
1397 : : null_pointer_node));
1398 : : }
1399 : :
1400 : :
1401 : : /* Given a class array declaration and an index, returns the address
1402 : : of the referenced element. */
1403 : :
1404 : : static tree
1405 : 632 : gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1406 : : bool unlimited)
1407 : : {
1408 : 632 : tree data, size, tmp, ctmp, offset, ptr;
1409 : :
1410 : 632 : data = data_comp != NULL_TREE ? data_comp :
1411 : 0 : gfc_class_data_get (class_decl);
1412 : 632 : size = gfc_class_vtab_size_get (class_decl);
1413 : :
1414 : 632 : if (unlimited)
1415 : : {
1416 : 140 : tmp = fold_convert (gfc_array_index_type,
1417 : : gfc_class_len_get (class_decl));
1418 : 140 : ctmp = fold_build2_loc (input_location, MULT_EXPR,
1419 : : gfc_array_index_type, size, tmp);
1420 : 140 : tmp = fold_build2_loc (input_location, GT_EXPR,
1421 : : logical_type_node, tmp,
1422 : 140 : build_zero_cst (TREE_TYPE (tmp)));
1423 : 140 : size = fold_build3_loc (input_location, COND_EXPR,
1424 : : gfc_array_index_type, tmp, ctmp, size);
1425 : : }
1426 : :
1427 : 632 : offset = fold_build2_loc (input_location, MULT_EXPR,
1428 : : gfc_array_index_type,
1429 : : index, size);
1430 : :
1431 : 632 : data = gfc_conv_descriptor_data_get (data);
1432 : 632 : ptr = fold_convert (pvoid_type_node, data);
1433 : 632 : ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1434 : 632 : return fold_convert (TREE_TYPE (data), ptr);
1435 : : }
1436 : :
1437 : :
1438 : : /* Copies one class expression to another, assuming that if either
1439 : : 'to' or 'from' are arrays they are packed. Should 'from' be
1440 : : NULL_TREE, the initialization expression for 'to' is used, assuming
1441 : : that the _vptr is set. */
1442 : :
1443 : : tree
1444 : 669 : gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1445 : : {
1446 : 669 : tree fcn;
1447 : 669 : tree fcn_type;
1448 : 669 : tree from_data;
1449 : 669 : tree from_len;
1450 : 669 : tree to_data;
1451 : 669 : tree to_len;
1452 : 669 : tree to_ref;
1453 : 669 : tree from_ref;
1454 : 669 : vec<tree, va_gc> *args;
1455 : 669 : tree tmp;
1456 : 669 : tree stdcopy;
1457 : 669 : tree extcopy;
1458 : 669 : tree index;
1459 : 669 : bool is_from_desc = false, is_to_class = false;
1460 : :
1461 : 669 : args = NULL;
1462 : : /* To prevent warnings on uninitialized variables. */
1463 : 669 : from_len = to_len = NULL_TREE;
1464 : :
1465 : 669 : if (from != NULL_TREE)
1466 : 669 : fcn = gfc_class_vtab_copy_get (from);
1467 : : else
1468 : 0 : fcn = gfc_class_vtab_copy_get (to);
1469 : :
1470 : 669 : fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1471 : :
1472 : 669 : if (from != NULL_TREE)
1473 : : {
1474 : 669 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1475 : 669 : if (is_from_desc)
1476 : : {
1477 : 0 : from_data = from;
1478 : 0 : from = GFC_DECL_SAVED_DESCRIPTOR (from);
1479 : : }
1480 : : else
1481 : : {
1482 : : /* Check that from is a class. When the class is part of a coarray,
1483 : : then from is a common pointer and is to be used as is. */
1484 : 1338 : tmp = POINTER_TYPE_P (TREE_TYPE (from))
1485 : 669 : ? build_fold_indirect_ref (from) : from;
1486 : 1338 : from_data =
1487 : 669 : (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1488 : 0 : || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1489 : 669 : ? gfc_class_data_get (from) : from;
1490 : 669 : is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1491 : : }
1492 : : }
1493 : : else
1494 : 0 : from_data = gfc_class_vtab_def_init_get (to);
1495 : :
1496 : 669 : if (unlimited)
1497 : : {
1498 : 129 : if (from != NULL_TREE && unlimited)
1499 : 129 : from_len = gfc_class_len_or_zero_get (from);
1500 : : else
1501 : 0 : from_len = build_zero_cst (size_type_node);
1502 : : }
1503 : :
1504 : 669 : if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1505 : : {
1506 : 669 : is_to_class = true;
1507 : 669 : to_data = gfc_class_data_get (to);
1508 : 669 : if (unlimited)
1509 : 129 : to_len = gfc_class_len_get (to);
1510 : : }
1511 : : else
1512 : : /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1513 : 0 : to_data = to;
1514 : :
1515 : 669 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1516 : : {
1517 : 316 : stmtblock_t loopbody;
1518 : 316 : stmtblock_t body;
1519 : 316 : stmtblock_t ifbody;
1520 : 316 : gfc_loopinfo loop;
1521 : 316 : tree orig_nelems = nelems; /* Needed for bounds check. */
1522 : :
1523 : 316 : gfc_init_block (&body);
1524 : 316 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1525 : : gfc_array_index_type, nelems,
1526 : : gfc_index_one_node);
1527 : 316 : nelems = gfc_evaluate_now (tmp, &body);
1528 : 316 : index = gfc_create_var (gfc_array_index_type, "S");
1529 : :
1530 : 316 : if (is_from_desc)
1531 : : {
1532 : 316 : from_ref = gfc_get_class_array_ref (index, from, from_data,
1533 : : unlimited);
1534 : 316 : vec_safe_push (args, from_ref);
1535 : : }
1536 : : else
1537 : 0 : vec_safe_push (args, from_data);
1538 : :
1539 : 316 : if (is_to_class)
1540 : 316 : to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1541 : : else
1542 : : {
1543 : 0 : tmp = gfc_conv_array_data (to);
1544 : 0 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1545 : 0 : to_ref = gfc_build_addr_expr (NULL_TREE,
1546 : : gfc_build_array_ref (tmp, index, to));
1547 : : }
1548 : 316 : vec_safe_push (args, to_ref);
1549 : :
1550 : : /* Add bounds check. */
1551 : 316 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1552 : : {
1553 : 1 : char *msg;
1554 : 1 : const char *name = "<<unknown>>";
1555 : 1 : tree from_len;
1556 : :
1557 : 1 : if (DECL_P (to))
1558 : 0 : name = (const char *)(DECL_NAME (to)->identifier.id.str);
1559 : :
1560 : 1 : from_len = gfc_conv_descriptor_size (from_data, 1);
1561 : 1 : from_len = fold_convert (TREE_TYPE (orig_nelems), from_len);
1562 : 1 : tmp = fold_build2_loc (input_location, NE_EXPR,
1563 : : logical_type_node, from_len, orig_nelems);
1564 : 1 : msg = xasprintf ("Array bound mismatch for dimension %d "
1565 : : "of array '%s' (%%ld/%%ld)",
1566 : : 1, name);
1567 : :
1568 : 1 : gfc_trans_runtime_check (true, false, tmp, &body,
1569 : : &gfc_current_locus, msg,
1570 : : fold_convert (long_integer_type_node, orig_nelems),
1571 : : fold_convert (long_integer_type_node, from_len));
1572 : :
1573 : 1 : free (msg);
1574 : : }
1575 : :
1576 : 316 : tmp = build_call_vec (fcn_type, fcn, args);
1577 : :
1578 : : /* Build the body of the loop. */
1579 : 316 : gfc_init_block (&loopbody);
1580 : 316 : gfc_add_expr_to_block (&loopbody, tmp);
1581 : :
1582 : : /* Build the loop and return. */
1583 : 316 : gfc_init_loopinfo (&loop);
1584 : 316 : loop.dimen = 1;
1585 : 316 : loop.from[0] = gfc_index_zero_node;
1586 : 316 : loop.loopvar[0] = index;
1587 : 316 : loop.to[0] = nelems;
1588 : 316 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1589 : 316 : gfc_init_block (&ifbody);
1590 : 316 : gfc_add_block_to_block (&ifbody, &loop.pre);
1591 : 316 : stdcopy = gfc_finish_block (&ifbody);
1592 : : /* In initialization mode from_len is a constant zero. */
1593 : 316 : if (unlimited && !integer_zerop (from_len))
1594 : : {
1595 : 70 : vec_safe_push (args, from_len);
1596 : 70 : vec_safe_push (args, to_len);
1597 : 70 : tmp = build_call_vec (fcn_type, fcn, args);
1598 : : /* Build the body of the loop. */
1599 : 70 : gfc_init_block (&loopbody);
1600 : 70 : gfc_add_expr_to_block (&loopbody, tmp);
1601 : :
1602 : : /* Build the loop and return. */
1603 : 70 : gfc_init_loopinfo (&loop);
1604 : 70 : loop.dimen = 1;
1605 : 70 : loop.from[0] = gfc_index_zero_node;
1606 : 70 : loop.loopvar[0] = index;
1607 : 70 : loop.to[0] = nelems;
1608 : 70 : gfc_trans_scalarizing_loops (&loop, &loopbody);
1609 : 70 : gfc_init_block (&ifbody);
1610 : 70 : gfc_add_block_to_block (&ifbody, &loop.pre);
1611 : 70 : extcopy = gfc_finish_block (&ifbody);
1612 : :
1613 : 70 : tmp = fold_build2_loc (input_location, GT_EXPR,
1614 : : logical_type_node, from_len,
1615 : 70 : build_zero_cst (TREE_TYPE (from_len)));
1616 : 70 : tmp = fold_build3_loc (input_location, COND_EXPR,
1617 : : void_type_node, tmp, extcopy, stdcopy);
1618 : 70 : gfc_add_expr_to_block (&body, tmp);
1619 : 70 : tmp = gfc_finish_block (&body);
1620 : : }
1621 : : else
1622 : : {
1623 : 246 : gfc_add_expr_to_block (&body, stdcopy);
1624 : 246 : tmp = gfc_finish_block (&body);
1625 : : }
1626 : 316 : gfc_cleanup_loop (&loop);
1627 : : }
1628 : : else
1629 : : {
1630 : 353 : gcc_assert (!is_from_desc);
1631 : 353 : vec_safe_push (args, from_data);
1632 : 353 : vec_safe_push (args, to_data);
1633 : 353 : stdcopy = build_call_vec (fcn_type, fcn, args);
1634 : :
1635 : : /* In initialization mode from_len is a constant zero. */
1636 : 353 : if (unlimited && !integer_zerop (from_len))
1637 : : {
1638 : 59 : vec_safe_push (args, from_len);
1639 : 59 : vec_safe_push (args, to_len);
1640 : 59 : extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args);
1641 : 59 : tmp = fold_build2_loc (input_location, GT_EXPR,
1642 : : logical_type_node, from_len,
1643 : 59 : build_zero_cst (TREE_TYPE (from_len)));
1644 : 59 : tmp = fold_build3_loc (input_location, COND_EXPR,
1645 : : void_type_node, tmp, extcopy, stdcopy);
1646 : : }
1647 : : else
1648 : : tmp = stdcopy;
1649 : : }
1650 : :
1651 : : /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1652 : 669 : if (from == NULL_TREE)
1653 : : {
1654 : 0 : tree cond;
1655 : 0 : cond = fold_build2_loc (input_location, NE_EXPR,
1656 : : logical_type_node,
1657 : : from_data, null_pointer_node);
1658 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
1659 : : void_type_node, cond,
1660 : : tmp, build_empty_stmt (input_location));
1661 : : }
1662 : :
1663 : 669 : return tmp;
1664 : : }
1665 : :
1666 : :
1667 : : static tree
1668 : 94 : gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1669 : : {
1670 : 94 : gfc_actual_arglist *actual;
1671 : 94 : gfc_expr *ppc;
1672 : 94 : gfc_code *ppc_code;
1673 : 94 : tree res;
1674 : :
1675 : 94 : actual = gfc_get_actual_arglist ();
1676 : 94 : actual->expr = gfc_copy_expr (rhs);
1677 : 94 : actual->next = gfc_get_actual_arglist ();
1678 : 94 : actual->next->expr = gfc_copy_expr (lhs);
1679 : 94 : ppc = gfc_copy_expr (obj);
1680 : 94 : gfc_add_vptr_component (ppc);
1681 : 94 : gfc_add_component_ref (ppc, "_copy");
1682 : 94 : ppc_code = gfc_get_code (EXEC_CALL);
1683 : 94 : ppc_code->resolved_sym = ppc->symtree->n.sym;
1684 : : /* Although '_copy' is set to be elemental in class.cc, it is
1685 : : not staying that way. Find out why, sometime.... */
1686 : 94 : ppc_code->resolved_sym->attr.elemental = 1;
1687 : 94 : ppc_code->ext.actual = actual;
1688 : 94 : ppc_code->expr1 = ppc;
1689 : : /* Since '_copy' is elemental, the scalarizer will take care
1690 : : of arrays in gfc_trans_call. */
1691 : 94 : res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1692 : 94 : gfc_free_statements (ppc_code);
1693 : :
1694 : 94 : if (UNLIMITED_POLY(obj))
1695 : : {
1696 : : /* Check if rhs is non-NULL. */
1697 : 18 : gfc_se src;
1698 : 18 : gfc_init_se (&src, NULL);
1699 : 18 : gfc_conv_expr (&src, rhs);
1700 : 18 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1701 : 18 : tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1702 : 18 : src.expr, fold_convert (TREE_TYPE (src.expr),
1703 : : null_pointer_node));
1704 : 18 : res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1705 : : build_empty_stmt (input_location));
1706 : : }
1707 : :
1708 : 94 : return res;
1709 : : }
1710 : :
1711 : : /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1712 : : A MEMCPY is needed to copy the full data from the default initializer
1713 : : of the dynamic type. */
1714 : :
1715 : : tree
1716 : 403 : gfc_trans_class_init_assign (gfc_code *code)
1717 : : {
1718 : 403 : stmtblock_t block;
1719 : 403 : tree tmp;
1720 : 403 : gfc_se dst,src,memsz;
1721 : 403 : gfc_expr *lhs, *rhs, *sz;
1722 : 403 : gfc_component *cmp;
1723 : :
1724 : 403 : gfc_start_block (&block);
1725 : :
1726 : 403 : lhs = gfc_copy_expr (code->expr1);
1727 : :
1728 : 403 : rhs = gfc_copy_expr (code->expr1);
1729 : 403 : gfc_add_vptr_component (rhs);
1730 : :
1731 : : /* Make sure that the component backend_decls have been built, which
1732 : : will not have happened if the derived types concerned have not
1733 : : been referenced. */
1734 : 403 : gfc_get_derived_type (rhs->ts.u.derived);
1735 : 403 : gfc_add_def_init_component (rhs);
1736 : : /* The _def_init is always scalar. */
1737 : 403 : rhs->rank = 0;
1738 : :
1739 : : /* Check def_init for initializers. If this is a dummy with all default
1740 : : initializer components NULL, return NULL_TREE and use the passed value as
1741 : : required by F2018(8.5.10). */
1742 : 403 : if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
1743 : : {
1744 : 294 : cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
1745 : 362 : for (; cmp; cmp = cmp->next)
1746 : : {
1747 : 340 : if (cmp->initializer)
1748 : : break;
1749 : 199 : else if (!cmp->next)
1750 : 131 : return build_empty_stmt (input_location);
1751 : : }
1752 : : }
1753 : :
1754 : 272 : if (code->expr1->ts.type == BT_CLASS
1755 : 251 : && CLASS_DATA (code->expr1)->attr.dimension)
1756 : : {
1757 : 94 : gfc_array_spec *tmparr = gfc_get_array_spec ();
1758 : 94 : *tmparr = *CLASS_DATA (code->expr1)->as;
1759 : : /* Adding the array ref to the class expression results in correct
1760 : : indexing to the dynamic type. */
1761 : 94 : gfc_add_full_array_ref (lhs, tmparr);
1762 : 94 : tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1763 : 94 : }
1764 : : else
1765 : : {
1766 : : /* Scalar initialization needs the _data component. */
1767 : 178 : gfc_add_data_component (lhs);
1768 : 178 : sz = gfc_copy_expr (code->expr1);
1769 : 178 : gfc_add_vptr_component (sz);
1770 : 178 : gfc_add_size_component (sz);
1771 : :
1772 : 178 : gfc_init_se (&dst, NULL);
1773 : 178 : gfc_init_se (&src, NULL);
1774 : 178 : gfc_init_se (&memsz, NULL);
1775 : 178 : gfc_conv_expr (&dst, lhs);
1776 : 178 : gfc_conv_expr (&src, rhs);
1777 : 178 : gfc_conv_expr (&memsz, sz);
1778 : 178 : gfc_add_block_to_block (&block, &src.pre);
1779 : 178 : src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1780 : :
1781 : 178 : tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1782 : :
1783 : 178 : if (UNLIMITED_POLY(code->expr1))
1784 : : {
1785 : : /* Check if _def_init is non-NULL. */
1786 : 7 : tree cond = fold_build2_loc (input_location, NE_EXPR,
1787 : : logical_type_node, src.expr,
1788 : 7 : fold_convert (TREE_TYPE (src.expr),
1789 : : null_pointer_node));
1790 : 7 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1791 : : tmp, build_empty_stmt (input_location));
1792 : : }
1793 : : }
1794 : :
1795 : 272 : if (code->expr1->symtree->n.sym->attr.dummy
1796 : 221 : && (code->expr1->symtree->n.sym->attr.optional
1797 : 215 : || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1798 : : {
1799 : 6 : tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1800 : 6 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1801 : : present, tmp,
1802 : : build_empty_stmt (input_location));
1803 : : }
1804 : :
1805 : 272 : gfc_add_expr_to_block (&block, tmp);
1806 : :
1807 : 272 : return gfc_finish_block (&block);
1808 : : }
1809 : :
1810 : :
1811 : : /* Class valued elemental function calls or class array elements arriving
1812 : : in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1813 : : is used to ensure that the rhs dynamic type is assigned to the lhs. */
1814 : :
1815 : : static bool
1816 : 642 : trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1817 : : {
1818 : 642 : tree fcn;
1819 : 642 : tree rse_expr;
1820 : 642 : tree class_data;
1821 : 642 : tree tmp;
1822 : 642 : tree zero;
1823 : 642 : tree cond;
1824 : 642 : tree final_cond;
1825 : 642 : stmtblock_t inner_block;
1826 : 642 : bool is_descriptor;
1827 : 642 : bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
1828 : 642 : bool not_lhs_array_type;
1829 : :
1830 : : /* Temporaries arising from dependencies in assignment get cast as a
1831 : : character type of the dynamic size of the rhs. Use the vptr copy
1832 : : for this case. */
1833 : 642 : tmp = TREE_TYPE (lse->expr);
1834 : 642 : not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
1835 : 0 : && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
1836 : :
1837 : : /* Use ordinary assignment if the rhs is not a call expression or
1838 : : the lhs is not a class entity or an array(ie. character) type. */
1839 : 612 : if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
1840 : 878 : && not_lhs_array_type)
1841 : : return false;
1842 : :
1843 : : /* Ordinary assignment can be used if both sides are class expressions
1844 : : since the dynamic type is preserved by copying the vptr. This
1845 : : should only occur, where temporaries are involved. */
1846 : 406 : if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
1847 : 406 : && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
1848 : : return false;
1849 : :
1850 : : /* Fix the class expression and the class data of the rhs. */
1851 : 369 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
1852 : 369 : || not_call_expr)
1853 : : {
1854 : 369 : tmp = gfc_get_class_from_expr (rse->expr);
1855 : 369 : if (tmp == NULL_TREE)
1856 : : return false;
1857 : 116 : rse_expr = gfc_evaluate_now (tmp, block);
1858 : : }
1859 : : else
1860 : 0 : rse_expr = gfc_evaluate_now (rse->expr, block);
1861 : :
1862 : 116 : class_data = gfc_class_data_get (rse_expr);
1863 : :
1864 : : /* Check that the rhs data is not null. */
1865 : 116 : is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
1866 : 116 : if (is_descriptor)
1867 : 116 : class_data = gfc_conv_descriptor_data_get (class_data);
1868 : 116 : class_data = gfc_evaluate_now (class_data, block);
1869 : :
1870 : 116 : zero = build_int_cst (TREE_TYPE (class_data), 0);
1871 : 116 : cond = fold_build2_loc (input_location, NE_EXPR,
1872 : : logical_type_node,
1873 : : class_data, zero);
1874 : :
1875 : : /* Copy the rhs to the lhs. */
1876 : 116 : fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
1877 : 116 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
1878 : 116 : tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
1879 : 116 : tmp = is_descriptor ? tmp : class_data;
1880 : 116 : tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
1881 : : gfc_build_addr_expr (NULL, lse->expr));
1882 : 116 : gfc_add_expr_to_block (block, tmp);
1883 : :
1884 : : /* Only elemental function results need to be finalised and freed. */
1885 : 116 : if (not_call_expr)
1886 : : return true;
1887 : :
1888 : : /* Finalize the class data if needed. */
1889 : 0 : gfc_init_block (&inner_block);
1890 : 0 : fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
1891 : 0 : zero = build_int_cst (TREE_TYPE (fcn), 0);
1892 : 0 : final_cond = fold_build2_loc (input_location, NE_EXPR,
1893 : : logical_type_node, fcn, zero);
1894 : 0 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
1895 : 0 : tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
1896 : 0 : tmp = build3_v (COND_EXPR, final_cond,
1897 : : tmp, build_empty_stmt (input_location));
1898 : 0 : gfc_add_expr_to_block (&inner_block, tmp);
1899 : :
1900 : : /* Free the class data. */
1901 : 0 : tmp = gfc_call_free (class_data);
1902 : 0 : tmp = build3_v (COND_EXPR, cond, tmp,
1903 : : build_empty_stmt (input_location));
1904 : 0 : gfc_add_expr_to_block (&inner_block, tmp);
1905 : :
1906 : : /* Finish the inner block and subject it to the condition on the
1907 : : class data being non-zero. */
1908 : 0 : tmp = gfc_finish_block (&inner_block);
1909 : 0 : tmp = build3_v (COND_EXPR, cond, tmp,
1910 : : build_empty_stmt (input_location));
1911 : 0 : gfc_add_expr_to_block (block, tmp);
1912 : :
1913 : 0 : return true;
1914 : : }
1915 : :
1916 : : /* End of prototype trans-class.c */
1917 : :
1918 : :
1919 : : static void
1920 : 7302 : realloc_lhs_warning (bt type, bool array, locus *where)
1921 : : {
1922 : 7302 : if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1923 : 35 : gfc_warning (OPT_Wrealloc_lhs,
1924 : : "Code for reallocating the allocatable array at %L will "
1925 : : "be added", where);
1926 : 7267 : else if (warn_realloc_lhs_all)
1927 : 4 : gfc_warning (OPT_Wrealloc_lhs_all,
1928 : : "Code for reallocating the allocatable variable at %L "
1929 : : "will be added", where);
1930 : 7302 : }
1931 : :
1932 : :
1933 : : static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1934 : : gfc_expr *);
1935 : :
1936 : : /* Copy the scalarization loop variables. */
1937 : :
1938 : : static void
1939 : 918852 : gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1940 : : {
1941 : 918852 : dest->ss = src->ss;
1942 : 918852 : dest->loop = src->loop;
1943 : 918852 : }
1944 : :
1945 : :
1946 : : /* Initialize a simple expression holder.
1947 : :
1948 : : Care must be taken when multiple se are created with the same parent.
1949 : : The child se must be kept in sync. The easiest way is to delay creation
1950 : : of a child se until after the previous se has been translated. */
1951 : :
1952 : : void
1953 : 3512088 : gfc_init_se (gfc_se * se, gfc_se * parent)
1954 : : {
1955 : 3512088 : memset (se, 0, sizeof (gfc_se));
1956 : 3512088 : gfc_init_block (&se->pre);
1957 : 3512088 : gfc_init_block (&se->finalblock);
1958 : 3512088 : gfc_init_block (&se->post);
1959 : :
1960 : 3512088 : se->parent = parent;
1961 : :
1962 : 3512088 : if (parent)
1963 : 918852 : gfc_copy_se_loopvars (se, parent);
1964 : 3512088 : }
1965 : :
1966 : :
1967 : : /* Advances to the next SS in the chain. Use this rather than setting
1968 : : se->ss = se->ss->next because all the parents needs to be kept in sync.
1969 : : See gfc_init_se. */
1970 : :
1971 : : void
1972 : 187001 : gfc_advance_se_ss_chain (gfc_se * se)
1973 : : {
1974 : 187001 : gfc_se *p;
1975 : 187001 : gfc_ss *ss;
1976 : :
1977 : 187001 : gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1978 : :
1979 : : p = se;
1980 : : /* Walk down the parent chain. */
1981 : 481413 : while (p != NULL)
1982 : : {
1983 : : /* Simple consistency check. */
1984 : 294412 : gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1985 : : || p->parent->ss->nested_ss == p->ss);
1986 : :
1987 : : /* If we were in a nested loop, the next scalarized expression can be
1988 : : on the parent ss' next pointer. Thus we should not take the next
1989 : : pointer blindly, but rather go up one nest level as long as next
1990 : : is the end of chain. */
1991 : 294412 : ss = p->ss;
1992 : 295632 : while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1993 : : ss = ss->parent;
1994 : :
1995 : 294412 : p->ss = ss->next;
1996 : :
1997 : 294412 : p = p->parent;
1998 : : }
1999 : 187001 : }
2000 : :
2001 : :
2002 : : /* Ensures the result of the expression as either a temporary variable
2003 : : or a constant so that it can be used repeatedly. */
2004 : :
2005 : : void
2006 : 7894 : gfc_make_safe_expr (gfc_se * se)
2007 : : {
2008 : 7894 : tree var;
2009 : :
2010 : 7894 : if (CONSTANT_CLASS_P (se->expr))
2011 : : return;
2012 : :
2013 : : /* We need a temporary for this result. */
2014 : 202 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2015 : 202 : gfc_add_modify (&se->pre, var, se->expr);
2016 : 202 : se->expr = var;
2017 : : }
2018 : :
2019 : :
2020 : : /* Return an expression which determines if a dummy parameter is present.
2021 : : Also used for arguments to procedures with multiple entry points. */
2022 : :
2023 : : tree
2024 : 9869 : gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
2025 : : {
2026 : 9869 : tree decl, orig_decl, cond;
2027 : :
2028 : 9869 : gcc_assert (sym->attr.dummy);
2029 : 9869 : orig_decl = decl = gfc_get_symbol_decl (sym);
2030 : :
2031 : : /* Intrinsic scalars with VALUE attribute which are passed by value
2032 : : use a hidden argument to denote the present status. */
2033 : 9869 : if (sym->attr.value && !sym->attr.dimension
2034 : 860 : && sym->ts.type != BT_CLASS && !gfc_bt_struct (sym->ts.type))
2035 : : {
2036 : 860 : char name[GFC_MAX_SYMBOL_LEN + 2];
2037 : 860 : tree tree_name;
2038 : :
2039 : 860 : gcc_assert (TREE_CODE (decl) == PARM_DECL);
2040 : 860 : name[0] = '.';
2041 : 860 : strcpy (&name[1], sym->name);
2042 : 860 : tree_name = get_identifier (name);
2043 : :
2044 : : /* Walk function argument list to find hidden arg. */
2045 : 860 : cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
2046 : 4936 : for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
2047 : 4936 : if (DECL_NAME (cond) == tree_name
2048 : 4936 : && DECL_ARTIFICIAL (cond))
2049 : : break;
2050 : :
2051 : 860 : gcc_assert (cond);
2052 : 860 : return cond;
2053 : : }
2054 : :
2055 : : /* Assumed-shape arrays use a local variable for the array data;
2056 : : the actual PARAM_DECL is in a saved decl. As the local variable
2057 : : is NULL, it can be checked instead, unless use_saved_desc is
2058 : : requested. */
2059 : :
2060 : 9009 : if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
2061 : : {
2062 : 682 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
2063 : : || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
2064 : 682 : decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
2065 : : }
2066 : :
2067 : 9009 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
2068 : 9009 : fold_convert (TREE_TYPE (decl), null_pointer_node));
2069 : :
2070 : : /* Fortran 2008 allows to pass null pointers and non-associated pointers
2071 : : as actual argument to denote absent dummies. For array descriptors,
2072 : : we thus also need to check the array descriptor. For BT_CLASS, it
2073 : : can also occur for scalars and F2003 due to type->class wrapping and
2074 : : class->class wrapping. Note further that BT_CLASS always uses an
2075 : : array descriptor for arrays, also for explicit-shape/assumed-size.
2076 : : For assumed-rank arrays, no local variable is generated, hence,
2077 : : the following also applies with !use_saved_desc. */
2078 : :
2079 : 9009 : if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
2080 : 6445 : && !sym->attr.allocatable
2081 : 5445 : && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
2082 : 2142 : || (sym->ts.type == BT_CLASS
2083 : 1086 : && !CLASS_DATA (sym)->attr.allocatable
2084 : 1086 : && !CLASS_DATA (sym)->attr.class_pointer))
2085 : 3555 : && ((gfc_option.allow_std & GFC_STD_F2008) != 0
2086 : 6 : || sym->ts.type == BT_CLASS))
2087 : : {
2088 : 3549 : tree tmp;
2089 : :
2090 : 3549 : if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
2091 : 1415 : || sym->as->type == AS_ASSUMED_RANK
2092 : 1345 : || sym->attr.codimension))
2093 : 2836 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2094 : : {
2095 : 929 : tmp = build_fold_indirect_ref_loc (input_location, decl);
2096 : 929 : if (sym->ts.type == BT_CLASS)
2097 : 216 : tmp = gfc_class_data_get (tmp);
2098 : 929 : tmp = gfc_conv_array_data (tmp);
2099 : : }
2100 : 2620 : else if (sym->ts.type == BT_CLASS)
2101 : 36 : tmp = gfc_class_data_get (decl);
2102 : : else
2103 : : tmp = NULL_TREE;
2104 : :
2105 : 965 : if (tmp != NULL_TREE)
2106 : : {
2107 : 965 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2108 : 965 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2109 : 965 : cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2110 : : logical_type_node, cond, tmp);
2111 : : }
2112 : : }
2113 : :
2114 : : return cond;
2115 : : }
2116 : :
2117 : :
2118 : : /* Converts a missing, dummy argument into a null or zero. */
2119 : :
2120 : : void
2121 : 701 : gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2122 : : {
2123 : 701 : tree present;
2124 : 701 : tree tmp;
2125 : :
2126 : 701 : present = gfc_conv_expr_present (arg->symtree->n.sym);
2127 : :
2128 : 701 : if (kind > 0)
2129 : : {
2130 : : /* Create a temporary and convert it to the correct type. */
2131 : 54 : tmp = gfc_get_int_type (kind);
2132 : 54 : tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2133 : : se->expr));
2134 : :
2135 : : /* Test for a NULL value. */
2136 : 54 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2137 : 54 : tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2138 : 54 : tmp = gfc_evaluate_now (tmp, &se->pre);
2139 : 54 : se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2140 : : }
2141 : : else
2142 : : {
2143 : 647 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2144 : : present, se->expr,
2145 : 647 : build_zero_cst (TREE_TYPE (se->expr)));
2146 : 647 : tmp = gfc_evaluate_now (tmp, &se->pre);
2147 : 647 : se->expr = tmp;
2148 : : }
2149 : :
2150 : 701 : if (ts.type == BT_CHARACTER)
2151 : : {
2152 : : /* Handle deferred-length dummies that pass the character length by
2153 : : reference so that the value can be returned. */
2154 : 240 : if (ts.deferred && INDIRECT_REF_P (se->string_length))
2155 : : {
2156 : 18 : tmp = gfc_build_addr_expr (NULL_TREE, se->string_length);
2157 : 18 : tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
2158 : : present, tmp, null_pointer_node);
2159 : 18 : tmp = gfc_evaluate_now (tmp, &se->pre);
2160 : 18 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
2161 : : }
2162 : : else
2163 : : {
2164 : 222 : tmp = build_int_cst (gfc_charlen_type_node, 0);
2165 : 222 : tmp = fold_build3_loc (input_location, COND_EXPR,
2166 : : gfc_charlen_type_node,
2167 : : present, se->string_length, tmp);
2168 : 222 : tmp = gfc_evaluate_now (tmp, &se->pre);
2169 : : }
2170 : 240 : se->string_length = tmp;
2171 : : }
2172 : 701 : return;
2173 : : }
2174 : :
2175 : :
2176 : : /* Get the character length of an expression, looking through gfc_refs
2177 : : if necessary. */
2178 : :
2179 : : tree
2180 : 18699 : gfc_get_expr_charlen (gfc_expr *e)
2181 : : {
2182 : 18699 : gfc_ref *r;
2183 : 18699 : tree length;
2184 : 18699 : tree previous = NULL_TREE;
2185 : 18699 : gfc_se se;
2186 : :
2187 : 18699 : gcc_assert (e->expr_type == EXPR_VARIABLE
2188 : : && e->ts.type == BT_CHARACTER);
2189 : :
2190 : 18699 : length = NULL; /* To silence compiler warning. */
2191 : :
2192 : 18699 : if (is_subref_array (e) && e->ts.u.cl->length)
2193 : : {
2194 : 742 : gfc_se tmpse;
2195 : 742 : gfc_init_se (&tmpse, NULL);
2196 : 742 : gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2197 : 742 : e->ts.u.cl->backend_decl = tmpse.expr;
2198 : 742 : return tmpse.expr;
2199 : : }
2200 : :
2201 : : /* First candidate: if the variable is of type CHARACTER, the
2202 : : expression's length could be the length of the character
2203 : : variable. */
2204 : 17957 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2205 : 17671 : length = e->symtree->n.sym->ts.u.cl->backend_decl;
2206 : :
2207 : : /* Look through the reference chain for component references. */
2208 : 36037 : for (r = e->ref; r; r = r->next)
2209 : : {
2210 : 18080 : previous = length;
2211 : 18080 : switch (r->type)
2212 : : {
2213 : 286 : case REF_COMPONENT:
2214 : 286 : if (r->u.c.component->ts.type == BT_CHARACTER)
2215 : 286 : length = r->u.c.component->ts.u.cl->backend_decl;
2216 : : break;
2217 : :
2218 : : case REF_ARRAY:
2219 : : /* Do nothing. */
2220 : : break;
2221 : :
2222 : 12 : case REF_SUBSTRING:
2223 : 12 : gfc_init_se (&se, NULL);
2224 : 12 : gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2225 : 12 : length = se.expr;
2226 : 12 : if (r->u.ss.end)
2227 : 6 : gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2228 : : else
2229 : 6 : se.expr = previous;
2230 : 12 : length = fold_build2_loc (input_location, MINUS_EXPR,
2231 : : gfc_charlen_type_node,
2232 : : se.expr, length);
2233 : 12 : length = fold_build2_loc (input_location, PLUS_EXPR,
2234 : : gfc_charlen_type_node, length,
2235 : : gfc_index_one_node);
2236 : 12 : break;
2237 : :
2238 : 0 : default:
2239 : 0 : gcc_unreachable ();
2240 : 18080 : break;
2241 : : }
2242 : : }
2243 : :
2244 : 17957 : gcc_assert (length != NULL);
2245 : : return length;
2246 : : }
2247 : :
2248 : :
2249 : : /* Return for an expression the backend decl of the coarray. */
2250 : :
2251 : : tree
2252 : 1432 : gfc_get_tree_for_caf_expr (gfc_expr *expr)
2253 : : {
2254 : 1432 : tree caf_decl;
2255 : 1432 : bool found = false;
2256 : 1432 : gfc_ref *ref;
2257 : :
2258 : 1432 : gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2259 : :
2260 : : /* Not-implemented diagnostic. */
2261 : 1432 : if (expr->symtree->n.sym->ts.type == BT_CLASS
2262 : 17 : && UNLIMITED_POLY (expr->symtree->n.sym)
2263 : 0 : && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2264 : 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2265 : : "%L is not supported", &expr->where);
2266 : :
2267 : 4893 : for (ref = expr->ref; ref; ref = ref->next)
2268 : 3461 : if (ref->type == REF_COMPONENT)
2269 : : {
2270 : 1312 : if (ref->u.c.component->ts.type == BT_CLASS
2271 : 0 : && UNLIMITED_POLY (ref->u.c.component)
2272 : 0 : && CLASS_DATA (ref->u.c.component)->attr.codimension)
2273 : 0 : gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2274 : : "component at %L is not supported", &expr->where);
2275 : : }
2276 : :
2277 : : /* Make sure the backend_decl is present before accessing it. */
2278 : 2864 : caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2279 : 1432 : ? gfc_get_symbol_decl (expr->symtree->n.sym)
2280 : : : expr->symtree->n.sym->backend_decl;
2281 : :
2282 : 1432 : if (expr->symtree->n.sym->ts.type == BT_CLASS)
2283 : : {
2284 : 17 : if (expr->ref && expr->ref->type == REF_ARRAY)
2285 : : {
2286 : 0 : caf_decl = gfc_class_data_get (caf_decl);
2287 : 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2288 : : return caf_decl;
2289 : : }
2290 : 37 : for (ref = expr->ref; ref; ref = ref->next)
2291 : : {
2292 : 34 : if (ref->type == REF_COMPONENT
2293 : 17 : && strcmp (ref->u.c.component->name, "_data") != 0)
2294 : : {
2295 : 0 : caf_decl = gfc_class_data_get (caf_decl);
2296 : 0 : if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2297 : : return caf_decl;
2298 : : break;
2299 : : }
2300 : 34 : else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2301 : : break;
2302 : : }
2303 : : }
2304 : 1432 : if (expr->symtree->n.sym->attr.codimension)
2305 : : return caf_decl;
2306 : :
2307 : : /* The following code assumes that the coarray is a component reachable via
2308 : : only scalar components/variables; the Fortran standard guarantees this. */
2309 : :
2310 : 35 : for (ref = expr->ref; ref; ref = ref->next)
2311 : 35 : if (ref->type == REF_COMPONENT)
2312 : : {
2313 : 35 : gfc_component *comp = ref->u.c.component;
2314 : :
2315 : 35 : if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2316 : 12 : caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2317 : 35 : caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2318 : 35 : TREE_TYPE (comp->backend_decl), caf_decl,
2319 : : comp->backend_decl, NULL_TREE);
2320 : 35 : if (comp->ts.type == BT_CLASS)
2321 : : {
2322 : 0 : caf_decl = gfc_class_data_get (caf_decl);
2323 : 0 : if (CLASS_DATA (comp)->attr.codimension)
2324 : : {
2325 : : found = true;
2326 : : break;
2327 : : }
2328 : : }
2329 : 35 : if (comp->attr.codimension)
2330 : : {
2331 : : found = true;
2332 : : break;
2333 : : }
2334 : : }
2335 : 35 : gcc_assert (found && caf_decl);
2336 : : return caf_decl;
2337 : : }
2338 : :
2339 : :
2340 : : /* Obtain the Coarray token - and optionally also the offset. */
2341 : :
2342 : : void
2343 : 1353 : gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2344 : : tree se_expr, gfc_expr *expr)
2345 : : {
2346 : 1353 : tree tmp;
2347 : :
2348 : : /* Coarray token. */
2349 : 1353 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2350 : : {
2351 : 264 : gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
2352 : : == GFC_ARRAY_ALLOCATABLE
2353 : : || expr->symtree->n.sym->attr.select_type_temporary);
2354 : 264 : *token = gfc_conv_descriptor_token (caf_decl);
2355 : : }
2356 : 1089 : else if (DECL_LANG_SPECIFIC (caf_decl)
2357 : 1089 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2358 : 3 : *token = GFC_DECL_TOKEN (caf_decl);
2359 : : else
2360 : : {
2361 : 1086 : gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2362 : : && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2363 : 1086 : *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2364 : : }
2365 : :
2366 : 1353 : if (offset == NULL)
2367 : : return;
2368 : :
2369 : : /* Offset between the coarray base address and the address wanted. */
2370 : 468 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2371 : 468 : && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2372 : 48 : || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2373 : 79 : *offset = build_int_cst (gfc_array_index_type, 0);
2374 : 389 : else if (DECL_LANG_SPECIFIC (caf_decl)
2375 : 389 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2376 : 3 : *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2377 : 386 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2378 : 0 : *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2379 : : else
2380 : 386 : *offset = build_int_cst (gfc_array_index_type, 0);
2381 : :
2382 : 468 : if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2383 : 468 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2384 : : {
2385 : 377 : tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2386 : 377 : tmp = gfc_conv_descriptor_data_get (tmp);
2387 : : }
2388 : 91 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2389 : 0 : tmp = gfc_conv_descriptor_data_get (se_expr);
2390 : : else
2391 : : {
2392 : 91 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2393 : : tmp = se_expr;
2394 : : }
2395 : :
2396 : 468 : *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2397 : : *offset, fold_convert (gfc_array_index_type, tmp));
2398 : :
2399 : 468 : if (expr->symtree->n.sym->ts.type == BT_DERIVED
2400 : 115 : && expr->symtree->n.sym->attr.codimension
2401 : 115 : && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2402 : : {
2403 : 0 : gfc_expr *base_expr = gfc_copy_expr (expr);
2404 : 0 : gfc_ref *ref = base_expr->ref;
2405 : 0 : gfc_se base_se;
2406 : :
2407 : : // Iterate through the refs until the last one.
2408 : 0 : while (ref->next)
2409 : : ref = ref->next;
2410 : :
2411 : 0 : if (ref->type == REF_ARRAY
2412 : 0 : && ref->u.ar.type != AR_FULL)
2413 : : {
2414 : 0 : const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2415 : 0 : int i;
2416 : 0 : for (i = 0; i < ranksum; ++i)
2417 : : {
2418 : 0 : ref->u.ar.start[i] = NULL;
2419 : 0 : ref->u.ar.end[i] = NULL;
2420 : : }
2421 : 0 : ref->u.ar.type = AR_FULL;
2422 : : }
2423 : 0 : gfc_init_se (&base_se, NULL);
2424 : 0 : if (gfc_caf_attr (base_expr).dimension)
2425 : : {
2426 : 0 : gfc_conv_expr_descriptor (&base_se, base_expr);
2427 : 0 : tmp = gfc_conv_descriptor_data_get (base_se.expr);
2428 : : }
2429 : : else
2430 : : {
2431 : 0 : gfc_conv_expr (&base_se, base_expr);
2432 : 0 : tmp = base_se.expr;
2433 : : }
2434 : :
2435 : 0 : gfc_free_expr (base_expr);
2436 : 0 : gfc_add_block_to_block (&se->pre, &base_se.pre);
2437 : 0 : gfc_add_block_to_block (&se->post, &base_se.post);
2438 : 0 : }
2439 : 468 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2440 : 97 : tmp = gfc_conv_descriptor_data_get (caf_decl);
2441 : : else
2442 : : {
2443 : 371 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2444 : : tmp = caf_decl;
2445 : : }
2446 : :
2447 : 468 : *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2448 : : fold_convert (gfc_array_index_type, *offset),
2449 : : fold_convert (gfc_array_index_type, tmp));
2450 : : }
2451 : :
2452 : :
2453 : : /* Convert the coindex of a coarray into an image index; the result is
2454 : : image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2455 : : + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2456 : :
2457 : : tree
2458 : 1151 : gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2459 : : {
2460 : 1151 : gfc_ref *ref;
2461 : 1151 : tree lbound, ubound, extent, tmp, img_idx;
2462 : 1151 : gfc_se se;
2463 : 1151 : int i;
2464 : :
2465 : 1175 : for (ref = e->ref; ref; ref = ref->next)
2466 : 1175 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2467 : : break;
2468 : 1151 : gcc_assert (ref != NULL);
2469 : :
2470 : 1151 : if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2471 : : {
2472 : 6 : return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2473 : 6 : integer_zero_node);
2474 : : }
2475 : :
2476 : 1145 : img_idx = build_zero_cst (gfc_array_index_type);
2477 : 1145 : extent = build_one_cst (gfc_array_index_type);
2478 : 1145 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2479 : 366 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2480 : : {
2481 : 183 : gfc_init_se (&se, NULL);
2482 : 183 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2483 : 183 : gfc_add_block_to_block (block, &se.pre);
2484 : 183 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2485 : 183 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2486 : 183 : TREE_TYPE (lbound), se.expr, lbound);
2487 : 183 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2488 : : extent, tmp);
2489 : 183 : img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2490 : 183 : TREE_TYPE (tmp), img_idx, tmp);
2491 : 183 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2492 : : {
2493 : 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2494 : 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2495 : 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
2496 : 0 : TREE_TYPE (tmp), extent, tmp);
2497 : : }
2498 : : }
2499 : : else
2500 : 1932 : for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2501 : : {
2502 : 970 : gfc_init_se (&se, NULL);
2503 : 970 : gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2504 : 970 : gfc_add_block_to_block (block, &se.pre);
2505 : 970 : lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2506 : 970 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2507 : 970 : TREE_TYPE (lbound), se.expr, lbound);
2508 : 970 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2509 : : extent, tmp);
2510 : 970 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2511 : : img_idx, tmp);
2512 : 970 : if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2513 : : {
2514 : 8 : ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2515 : 8 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
2516 : 8 : TREE_TYPE (ubound), ubound, lbound);
2517 : 8 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2518 : 8 : tmp, build_one_cst (TREE_TYPE (tmp)));
2519 : 8 : extent = fold_build2_loc (input_location, MULT_EXPR,
2520 : 8 : TREE_TYPE (tmp), extent, tmp);
2521 : : }
2522 : : }
2523 : 1145 : img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2524 : 1145 : img_idx, build_one_cst (TREE_TYPE (img_idx)));
2525 : 1145 : return fold_convert (integer_type_node, img_idx);
2526 : : }
2527 : :
2528 : :
2529 : : /* For each character array constructor subexpression without a ts.u.cl->length,
2530 : : replace it by its first element (if there aren't any elements, the length
2531 : : should already be set to zero). */
2532 : :
2533 : : static void
2534 : 123 : flatten_array_ctors_without_strlen (gfc_expr* e)
2535 : : {
2536 : 123 : gfc_actual_arglist* arg;
2537 : 123 : gfc_constructor* c;
2538 : :
2539 : 123 : if (!e)
2540 : : return;
2541 : :
2542 : 123 : switch (e->expr_type)
2543 : : {
2544 : :
2545 : 0 : case EXPR_OP:
2546 : 0 : flatten_array_ctors_without_strlen (e->value.op.op1);
2547 : 0 : flatten_array_ctors_without_strlen (e->value.op.op2);
2548 : 0 : break;
2549 : :
2550 : 0 : case EXPR_COMPCALL:
2551 : : /* TODO: Implement as with EXPR_FUNCTION when needed. */
2552 : 0 : gcc_unreachable ();
2553 : :
2554 : 12 : case EXPR_FUNCTION:
2555 : 36 : for (arg = e->value.function.actual; arg; arg = arg->next)
2556 : 24 : flatten_array_ctors_without_strlen (arg->expr);
2557 : : break;
2558 : :
2559 : 0 : case EXPR_ARRAY:
2560 : :
2561 : : /* We've found what we're looking for. */
2562 : 0 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2563 : : {
2564 : 0 : gfc_constructor *c;
2565 : 0 : gfc_expr* new_expr;
2566 : :
2567 : 0 : gcc_assert (e->value.constructor);
2568 : :
2569 : 0 : c = gfc_constructor_first (e->value.constructor);
2570 : 0 : new_expr = c->expr;
2571 : 0 : c->expr = NULL;
2572 : :
2573 : 0 : flatten_array_ctors_without_strlen (new_expr);
2574 : 0 : gfc_replace_expr (e, new_expr);
2575 : 0 : break;
2576 : : }
2577 : :
2578 : : /* Otherwise, fall through to handle constructor elements. */
2579 : 0 : gcc_fallthrough ();
2580 : 0 : case EXPR_STRUCTURE:
2581 : 0 : for (c = gfc_constructor_first (e->value.constructor);
2582 : 0 : c; c = gfc_constructor_next (c))
2583 : 0 : flatten_array_ctors_without_strlen (c->expr);
2584 : : break;
2585 : :
2586 : : default:
2587 : : break;
2588 : :
2589 : : }
2590 : : }
2591 : :
2592 : :
2593 : : /* Generate code to initialize a string length variable. Returns the
2594 : : value. For array constructors, cl->length might be NULL and in this case,
2595 : : the first element of the constructor is needed. expr is the original
2596 : : expression so we can access it but can be NULL if this is not needed. */
2597 : :
2598 : : void
2599 : 3412 : gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2600 : : {
2601 : 3412 : gfc_se se;
2602 : :
2603 : 3412 : gfc_init_se (&se, NULL);
2604 : :
2605 : 3412 : if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2606 : 1155 : return;
2607 : :
2608 : : /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2609 : : "flatten" array constructors by taking their first element; all elements
2610 : : should be the same length or a cl->length should be present. */
2611 : 2327 : if (!cl->length)
2612 : : {
2613 : 169 : gfc_expr* expr_flat;
2614 : 169 : if (!expr)
2615 : : return;
2616 : 99 : expr_flat = gfc_copy_expr (expr);
2617 : 99 : flatten_array_ctors_without_strlen (expr_flat);
2618 : 99 : gfc_resolve_expr (expr_flat);
2619 : 99 : if (expr_flat->rank)
2620 : 30 : gfc_conv_expr_descriptor (&se, expr_flat);
2621 : : else
2622 : 69 : gfc_conv_expr (&se, expr_flat);
2623 : 99 : if (expr_flat->expr_type != EXPR_VARIABLE)
2624 : 75 : gfc_add_block_to_block (pblock, &se.pre);
2625 : 99 : se.expr = convert (gfc_charlen_type_node, se.string_length);
2626 : 99 : gfc_add_block_to_block (pblock, &se.post);
2627 : 99 : gfc_free_expr (expr_flat);
2628 : : }
2629 : : else
2630 : : {
2631 : : /* Convert cl->length. */
2632 : 2158 : gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2633 : 2158 : se.expr = fold_build2_loc (input_location, MAX_EXPR,
2634 : : gfc_charlen_type_node, se.expr,
2635 : 2158 : build_zero_cst (TREE_TYPE (se.expr)));
2636 : 2158 : gfc_add_block_to_block (pblock, &se.pre);
2637 : : }
2638 : :
2639 : 2257 : if (cl->backend_decl && VAR_P (cl->backend_decl))
2640 : 1470 : gfc_add_modify (pblock, cl->backend_decl, se.expr);
2641 : : else
2642 : 787 : cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2643 : : }
2644 : :
2645 : :
2646 : : static void
2647 : 6519 : gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2648 : : const char *name, locus *where)
2649 : : {
2650 : 6519 : tree tmp;
2651 : 6519 : tree type;
2652 : 6519 : tree fault;
2653 : 6519 : gfc_se start;
2654 : 6519 : gfc_se end;
2655 : 6519 : char *msg;
2656 : 6519 : mpz_t length;
2657 : :
2658 : 6519 : type = gfc_get_character_type (kind, ref->u.ss.length);
2659 : 6519 : type = build_pointer_type (type);
2660 : :
2661 : 6519 : gfc_init_se (&start, se);
2662 : 6519 : gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2663 : 6519 : gfc_add_block_to_block (&se->pre, &start.pre);
2664 : :
2665 : 6519 : if (integer_onep (start.expr))
2666 : 2165 : gfc_conv_string_parameter (se);
2667 : : else
2668 : : {
2669 : 4354 : tmp = start.expr;
2670 : 4354 : STRIP_NOPS (tmp);
2671 : : /* Avoid multiple evaluation of substring start. */
2672 : 4354 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2673 : 1617 : start.expr = gfc_evaluate_now (start.expr, &se->pre);
2674 : :
2675 : : /* Change the start of the string. */
2676 : 4354 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2677 : 1070 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2678 : 4474 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2679 : : tmp = se->expr;
2680 : : else
2681 : 950 : tmp = build_fold_indirect_ref_loc (input_location,
2682 : : se->expr);
2683 : : /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2684 : 4354 : if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2685 : : {
2686 : 4234 : tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
2687 : 4234 : se->expr = gfc_build_addr_expr (type, tmp);
2688 : : }
2689 : : }
2690 : :
2691 : : /* Length = end + 1 - start. */
2692 : 6519 : gfc_init_se (&end, se);
2693 : 6519 : if (ref->u.ss.end == NULL)
2694 : 177 : end.expr = se->string_length;
2695 : : else
2696 : : {
2697 : 6342 : gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2698 : 6342 : gfc_add_block_to_block (&se->pre, &end.pre);
2699 : : }
2700 : 6519 : tmp = end.expr;
2701 : 6519 : STRIP_NOPS (tmp);
2702 : 6519 : if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2703 : 2269 : end.expr = gfc_evaluate_now (end.expr, &se->pre);
2704 : :
2705 : 6519 : if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2706 : 428 : && (ref->u.ss.start->symtree
2707 : 167 : && !ref->u.ss.start->symtree->n.sym->attr.implied_index))
2708 : : {
2709 : 160 : tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2710 : : logical_type_node, start.expr,
2711 : : end.expr);
2712 : :
2713 : : /* Check lower bound. */
2714 : 160 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2715 : : start.expr,
2716 : 160 : build_one_cst (TREE_TYPE (start.expr)));
2717 : 160 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2718 : : logical_type_node, nonempty, fault);
2719 : 160 : if (name)
2720 : 159 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2721 : : "is less than one", name);
2722 : : else
2723 : 1 : msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2724 : : "is less than one");
2725 : 160 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2726 : : fold_convert (long_integer_type_node,
2727 : : start.expr));
2728 : 160 : free (msg);
2729 : :
2730 : : /* Check upper bound. */
2731 : 160 : fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2732 : : end.expr, se->string_length);
2733 : 160 : fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2734 : : logical_type_node, nonempty, fault);
2735 : 160 : if (name)
2736 : 159 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2737 : : "exceeds string length (%%ld)", name);
2738 : : else
2739 : 1 : msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2740 : : "exceeds string length (%%ld)");
2741 : 160 : gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2742 : : fold_convert (long_integer_type_node, end.expr),
2743 : : fold_convert (long_integer_type_node,
2744 : : se->string_length));
2745 : 160 : free (msg);
2746 : : }
2747 : :
2748 : : /* Try to calculate the length from the start and end expressions. */
2749 : 6519 : if (ref->u.ss.end
2750 : 6519 : && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2751 : : {
2752 : 5323 : HOST_WIDE_INT i_len;
2753 : :
2754 : 5323 : i_len = gfc_mpz_get_hwi (length) + 1;
2755 : 5323 : if (i_len < 0)
2756 : : i_len = 0;
2757 : :
2758 : 5323 : tmp = build_int_cst (gfc_charlen_type_node, i_len);
2759 : 5323 : mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2760 : : }
2761 : : else
2762 : : {
2763 : 1196 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2764 : : fold_convert (gfc_charlen_type_node, end.expr),
2765 : : fold_convert (gfc_charlen_type_node, start.expr));
2766 : 1196 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2767 : 1196 : build_int_cst (gfc_charlen_type_node, 1), tmp);
2768 : 1196 : tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2769 : 1196 : tmp, build_int_cst (gfc_charlen_type_node, 0));
2770 : : }
2771 : :
2772 : 6519 : se->string_length = tmp;
2773 : 6519 : }
2774 : :
2775 : :
2776 : : /* Convert a derived type component reference. */
2777 : :
2778 : : void
2779 : 146065 : gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2780 : : {
2781 : 146065 : gfc_component *c;
2782 : 146065 : tree tmp;
2783 : 146065 : tree decl;
2784 : 146065 : tree field;
2785 : 146065 : tree context;
2786 : :
2787 : 146065 : c = ref->u.c.component;
2788 : :
2789 : 146065 : if (c->backend_decl == NULL_TREE
2790 : 6 : && ref->u.c.sym != NULL)
2791 : 6 : gfc_get_derived_type (ref->u.c.sym);
2792 : :
2793 : 146065 : field = c->backend_decl;
2794 : 146065 : gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2795 : 146065 : decl = se->expr;
2796 : 146065 : context = DECL_FIELD_CONTEXT (field);
2797 : :
2798 : : /* Components can correspond to fields of different containing
2799 : : types, as components are created without context, whereas
2800 : : a concrete use of a component has the type of decl as context.
2801 : : So, if the type doesn't match, we search the corresponding
2802 : : FIELD_DECL in the parent type. To not waste too much time
2803 : : we cache this result in norestrict_decl.
2804 : : On the other hand, if the context is a UNION or a MAP (a
2805 : : RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2806 : :
2807 : 146065 : if (context != TREE_TYPE (decl)
2808 : 146065 : && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2809 : 9483 : || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2810 : : {
2811 : 9483 : tree f2 = c->norestrict_decl;
2812 : 16381 : if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2813 : 5014 : for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2814 : 5014 : if (TREE_CODE (f2) == FIELD_DECL
2815 : 5014 : && DECL_NAME (f2) == DECL_NAME (field))
2816 : : break;
2817 : 9483 : gcc_assert (f2);
2818 : 9483 : c->norestrict_decl = f2;
2819 : 9483 : field = f2;
2820 : : }
2821 : :
2822 : 146065 : if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2823 : 0 : && strcmp ("_data", c->name) == 0)
2824 : : {
2825 : : /* Found a ref to the _data component. Store the associated ref to
2826 : : the vptr in se->class_vptr. */
2827 : 0 : se->class_vptr = gfc_class_vptr_get (decl);
2828 : : }
2829 : : else
2830 : 146065 : se->class_vptr = NULL_TREE;
2831 : :
2832 : 146065 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2833 : : decl, field, NULL_TREE);
2834 : :
2835 : 146065 : se->expr = tmp;
2836 : :
2837 : : /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2838 : : strlen () conditional below. */
2839 : 146065 : if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2840 : 8133 : && !c->ts.deferred
2841 : 5295 : && !c->attr.pdt_string)
2842 : : {
2843 : 5169 : tmp = c->ts.u.cl->backend_decl;
2844 : : /* Components must always be constant length. */
2845 : 5169 : gcc_assert (tmp && INTEGER_CST_P (tmp));
2846 : 5169 : se->string_length = tmp;
2847 : : }
2848 : :
2849 : 146065 : if (gfc_deferred_strlen (c, &field))
2850 : : {
2851 : 2964 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
2852 : 2964 : TREE_TYPE (field),
2853 : : decl, field, NULL_TREE);
2854 : 2964 : se->string_length = tmp;
2855 : : }
2856 : :
2857 : 146065 : if (((c->attr.pointer || c->attr.allocatable)
2858 : 84583 : && (!c->attr.dimension && !c->attr.codimension)
2859 : 49586 : && c->ts.type != BT_CHARACTER)
2860 : 98384 : || c->attr.proc_pointer)
2861 : 52751 : se->expr = build_fold_indirect_ref_loc (input_location,
2862 : : se->expr);
2863 : 146065 : }
2864 : :
2865 : :
2866 : : /* This function deals with component references to components of the
2867 : : parent type for derived type extensions. */
2868 : : void
2869 : 57892 : conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2870 : : {
2871 : 57892 : gfc_component *c;
2872 : 57892 : gfc_component *cmp;
2873 : 57892 : gfc_symbol *dt;
2874 : 57892 : gfc_ref parent;
2875 : :
2876 : 57892 : dt = ref->u.c.sym;
2877 : 57892 : c = ref->u.c.component;
2878 : :
2879 : : /* Return if the component is in this type, i.e. not in the parent type. */
2880 : 100891 : for (cmp = dt->components; cmp; cmp = cmp->next)
2881 : 91677 : if (c == cmp)
2882 : 48678 : return;
2883 : :
2884 : : /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2885 : 9214 : parent.type = REF_COMPONENT;
2886 : 9214 : parent.next = NULL;
2887 : 9214 : parent.u.c.sym = dt;
2888 : 9214 : parent.u.c.component = dt->components;
2889 : :
2890 : 9214 : if (dt->backend_decl == NULL)
2891 : 0 : gfc_get_derived_type (dt);
2892 : :
2893 : : /* Build the reference and call self. */
2894 : 9214 : gfc_conv_component_ref (se, &parent);
2895 : 9214 : parent.u.c.sym = dt->components->ts.u.derived;
2896 : 9214 : parent.u.c.component = c;
2897 : 9214 : conv_parent_component_references (se, &parent);
2898 : : }
2899 : :
2900 : :
2901 : : static void
2902 : 375 : conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2903 : : {
2904 : 375 : tree res = se->expr;
2905 : :
2906 : 375 : switch (ref->u.i)
2907 : : {
2908 : 172 : case INQUIRY_RE:
2909 : 344 : res = fold_build1_loc (input_location, REALPART_EXPR,
2910 : 172 : TREE_TYPE (TREE_TYPE (res)), res);
2911 : 172 : break;
2912 : :
2913 : 158 : case INQUIRY_IM:
2914 : 316 : res = fold_build1_loc (input_location, IMAGPART_EXPR,
2915 : 158 : TREE_TYPE (TREE_TYPE (res)), res);
2916 : 158 : break;
2917 : :
2918 : 7 : case INQUIRY_KIND:
2919 : 7 : res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2920 : 7 : ts->kind);
2921 : 7 : se->string_length = NULL_TREE;
2922 : 7 : break;
2923 : :
2924 : 38 : case INQUIRY_LEN:
2925 : 38 : res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2926 : : se->string_length);
2927 : 38 : se->string_length = NULL_TREE;
2928 : 38 : break;
2929 : :
2930 : 0 : default:
2931 : 0 : gcc_unreachable ();
2932 : : }
2933 : 375 : se->expr = res;
2934 : 375 : }
2935 : :
2936 : : /* Dereference VAR where needed if it is a pointer, reference, etc.
2937 : : according to Fortran semantics. */
2938 : :
2939 : : tree
2940 : 1057113 : gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
2941 : : bool is_classarray)
2942 : : {
2943 : 1057113 : if (!POINTER_TYPE_P (TREE_TYPE (var)))
2944 : : return var;
2945 : 252716 : if (is_CFI_desc (sym, NULL))
2946 : 11882 : return build_fold_indirect_ref_loc (input_location, var);
2947 : :
2948 : : /* Characters are entirely different from other types, they are treated
2949 : : separately. */
2950 : 240834 : if (sym->ts.type == BT_CHARACTER)
2951 : : {
2952 : : /* Dereference character pointer dummy arguments
2953 : : or results. */
2954 : 27992 : if ((sym->attr.pointer || sym->attr.allocatable
2955 : 16596 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2956 : 11732 : && (sym->attr.dummy
2957 : : || sym->attr.function
2958 : 11732 : || sym->attr.result))
2959 : 3747 : var = build_fold_indirect_ref_loc (input_location, var);
2960 : : }
2961 : 212842 : else if (!sym->attr.value)
2962 : : {
2963 : : /* Dereference temporaries for class array dummy arguments. */
2964 : 148988 : if (sym->attr.dummy && is_classarray
2965 : 218245 : && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
2966 : : {
2967 : 4264 : if (!descriptor_only_p)
2968 : 2116 : var = GFC_DECL_SAVED_DESCRIPTOR (var);
2969 : :
2970 : 4264 : var = build_fold_indirect_ref_loc (input_location, var);
2971 : : }
2972 : :
2973 : : /* Dereference non-character scalar dummy arguments. */
2974 : 212165 : if (sym->attr.dummy && !sym->attr.dimension
2975 : 91664 : && !(sym->attr.codimension && sym->attr.allocatable)
2976 : 91602 : && (sym->ts.type != BT_CLASS
2977 : 16634 : || (!CLASS_DATA (sym)->attr.dimension
2978 : 9825 : && !(CLASS_DATA (sym)->attr.codimension
2979 : : && CLASS_DATA (sym)->attr.allocatable))))
2980 : 84661 : var = build_fold_indirect_ref_loc (input_location, var);
2981 : :
2982 : : /* Dereference scalar hidden result. */
2983 : 212165 : if (flag_f2c && sym->ts.type == BT_COMPLEX
2984 : 306 : && (sym->attr.function || sym->attr.result)
2985 : 108 : && !sym->attr.dimension && !sym->attr.pointer
2986 : 60 : && !sym->attr.always_explicit)
2987 : 36 : var = build_fold_indirect_ref_loc (input_location, var);
2988 : :
2989 : : /* Dereference non-character, non-class pointer variables.
2990 : : These must be dummies, results, or scalars. */
2991 : 212165 : if (!is_classarray
2992 : 205682 : && (sym->attr.pointer || sym->attr.allocatable
2993 : 164342 : || gfc_is_associate_pointer (sym)
2994 : 160096 : || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2995 : 212165 : && (sym->attr.dummy
2996 : : || sym->attr.function
2997 : 62963 : || sym->attr.result
2998 : 28886 : || (!sym->attr.dimension
2999 : 28885 : && (!sym->attr.codimension || !sym->attr.allocatable))))
3000 : 62962 : var = build_fold_indirect_ref_loc (input_location, var);
3001 : : /* Now treat the class array pointer variables accordingly. */
3002 : 149203 : else if (sym->ts.type == BT_CLASS
3003 : 17037 : && sym->attr.dummy
3004 : 16634 : && (CLASS_DATA (sym)->attr.dimension
3005 : 16634 : || CLASS_DATA (sym)->attr.codimension)
3006 : 7036 : && ((CLASS_DATA (sym)->as
3007 : 7036 : && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
3008 : : || CLASS_DATA (sym)->attr.allocatable
3009 : 6130 : || CLASS_DATA (sym)->attr.class_pointer))
3010 : 2677 : var = build_fold_indirect_ref_loc (input_location, var);
3011 : : /* And the case where a non-dummy, non-result, non-function,
3012 : : non-allocable and non-pointer classarray is present. This case was
3013 : : previously covered by the first if, but with introducing the
3014 : : condition !is_classarray there, that case has to be covered
3015 : : explicitly. */
3016 : 146526 : else if (sym->ts.type == BT_CLASS
3017 : : && !sym->attr.dummy
3018 : : && !sym->attr.function
3019 : 14360 : && !sym->attr.result
3020 : 403 : && (CLASS_DATA (sym)->attr.dimension
3021 : 403 : || CLASS_DATA (sym)->attr.codimension)
3022 : 403 : && (sym->assoc
3023 : 0 : || !CLASS_DATA (sym)->attr.allocatable)
3024 : 403 : && !CLASS_DATA (sym)->attr.class_pointer)
3025 : 403 : var = build_fold_indirect_ref_loc (input_location, var);
3026 : : }
3027 : :
3028 : : return var;
3029 : : }
3030 : :
3031 : : /* Return the contents of a variable. Also handles reference/pointer
3032 : : variables (all Fortran pointer references are implicit). */
3033 : :
3034 : : static void
3035 : 1176392 : gfc_conv_variable (gfc_se * se, gfc_expr * expr)
3036 : : {
3037 : 1176392 : gfc_ss *ss;
3038 : 1176392 : gfc_ref *ref;
3039 : 1176392 : gfc_symbol *sym;
3040 : 1176392 : tree parent_decl = NULL_TREE;
3041 : 1176392 : int parent_flag;
3042 : 1176392 : bool return_value;
3043 : 1176392 : bool alternate_entry;
3044 : 1176392 : bool entry_master;
3045 : 1176392 : bool is_classarray;
3046 : 1176392 : bool first_time = true;
3047 : :
3048 : 1176392 : sym = expr->symtree->n.sym;
3049 : 1176392 : is_classarray = IS_CLASS_ARRAY (sym);
3050 : 1176392 : ss = se->ss;
3051 : 1176392 : if (ss != NULL)
3052 : : {
3053 : 102955 : gfc_ss_info *ss_info = ss->info;
3054 : :
3055 : : /* Check that something hasn't gone horribly wrong. */
3056 : 102955 : gcc_assert (ss != gfc_ss_terminator);
3057 : 102955 : gcc_assert (ss_info->expr == expr);
3058 : :
3059 : : /* A scalarized term. We already know the descriptor. */
3060 : 102955 : se->expr = ss_info->data.array.descriptor;
3061 : 102955 : se->string_length = ss_info->string_length;
3062 : 102955 : ref = ss_info->data.array.ref;
3063 : 102955 : if (ref)
3064 : 102813 : gcc_assert (ref->type == REF_ARRAY
3065 : : && ref->u.ar.type != AR_ELEMENT);
3066 : : else
3067 : 142 : gfc_conv_tmp_array_ref (se);
3068 : : }
3069 : : else
3070 : : {
3071 : 1073437 : tree se_expr = NULL_TREE;
3072 : :
3073 : 1073437 : se->expr = gfc_get_symbol_decl (sym);
3074 : :
3075 : : /* Deal with references to a parent results or entries by storing
3076 : : the current_function_decl and moving to the parent_decl. */
3077 : 1073437 : return_value = sym->attr.function && sym->result == sym;
3078 : 18361 : alternate_entry = sym->attr.function && sym->attr.entry
3079 : 1074511 : && sym->result == sym;
3080 : 2146874 : entry_master = sym->attr.result
3081 : 10191 : && sym->ns->proc_name->attr.entry_master
3082 : 1073818 : && !gfc_return_by_reference (sym->ns->proc_name);
3083 : 1073437 : if (current_function_decl)
3084 : 1055947 : parent_decl = DECL_CONTEXT (current_function_decl);
3085 : :
3086 : 1073437 : if ((se->expr == parent_decl && return_value)
3087 : 1073326 : || (sym->ns && sym->ns->proc_name
3088 : 1068827 : && parent_decl
3089 : 1049898 : && sym->ns->proc_name->backend_decl == parent_decl
3090 : 31020 : && (alternate_entry || entry_master)))
3091 : : parent_flag = 1;
3092 : : else
3093 : 1073293 : parent_flag = 0;
3094 : :
3095 : : /* Special case for assigning the return value of a function.
3096 : : Self recursive functions must have an explicit return value. */
3097 : 1073437 : if (return_value && (se->expr == current_function_decl || parent_flag))
3098 : 11102 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3099 : :
3100 : : /* Similarly for alternate entry points. */
3101 : 1062335 : else if (alternate_entry
3102 : 1041 : && (sym->ns->proc_name->backend_decl == current_function_decl
3103 : 0 : || parent_flag))
3104 : : {
3105 : 1041 : gfc_entry_list *el = NULL;
3106 : :
3107 : 1608 : for (el = sym->ns->entries; el; el = el->next)
3108 : 1608 : if (sym == el->sym)
3109 : : {
3110 : 1041 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3111 : 1041 : break;
3112 : : }
3113 : : }
3114 : :
3115 : 1061294 : else if (entry_master
3116 : 295 : && (sym->ns->proc_name->backend_decl == current_function_decl
3117 : 0 : || parent_flag))
3118 : 295 : se_expr = gfc_get_fake_result_decl (sym, parent_flag);
3119 : :
3120 : 12438 : if (se_expr)
3121 : 12438 : se->expr = se_expr;
3122 : :
3123 : : /* Procedure actual arguments. Look out for temporary variables
3124 : : with the same attributes as function values. */
3125 : 1060999 : else if (!sym->attr.temporary
3126 : 1060931 : && sym->attr.flavor == FL_PROCEDURE
3127 : 17970 : && se->expr != current_function_decl)
3128 : : {
3129 : 17944 : if (!sym->attr.dummy && !sym->attr.proc_pointer)
3130 : : {
3131 : 16430 : gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3132 : 16430 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3133 : : }
3134 : 17944 : return;
3135 : : }
3136 : :
3137 : 1055493 : if (sym->ts.type == BT_CLASS
3138 : 61016 : && sym->attr.class_ok
3139 : 60840 : && sym->ts.u.derived->attr.is_class)
3140 : 60840 : se->class_container = se->expr;
3141 : :
3142 : : /* Dereference the expression, where needed. */
3143 : 1055493 : se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3144 : : is_classarray);
3145 : :
3146 : 1055493 : ref = expr->ref;
3147 : : }
3148 : :
3149 : : /* For character variables, also get the length. */
3150 : 1158448 : if (sym->ts.type == BT_CHARACTER)
3151 : : {
3152 : : /* If the character length of an entry isn't set, get the length from
3153 : : the master function instead. */
3154 : 151779 : if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3155 : 0 : se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3156 : : else
3157 : 151779 : se->string_length = sym->ts.u.cl->backend_decl;
3158 : 151779 : gcc_assert (se->string_length);
3159 : : }
3160 : :
3161 : : /* Some expressions leak through that haven't been fixed up. */
3162 : 1158448 : if (IS_INFERRED_TYPE (expr) && expr->ref)
3163 : 354 : gfc_fixup_inferred_type_refs (expr);
3164 : :
3165 : 1158448 : gfc_typespec *ts = &sym->ts;
3166 : 1517907 : while (ref)
3167 : : {
3168 : 644870 : switch (ref->type)
3169 : : {
3170 : 501183 : case REF_ARRAY:
3171 : : /* Return the descriptor if that's what we want and this is an array
3172 : : section reference. */
3173 : 501183 : if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3174 : : return;
3175 : : /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3176 : : /* Return the descriptor for array pointers and allocations. */
3177 : 223386 : if (se->want_pointer
3178 : 20336 : && ref->next == NULL && (se->descriptor_only))
3179 : : return;
3180 : :
3181 : 215772 : gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3182 : : /* Return a pointer to an element. */
3183 : 215772 : break;
3184 : :
3185 : 137066 : case REF_COMPONENT:
3186 : 137066 : ts = &ref->u.c.component->ts;
3187 : 137066 : if (first_time && is_classarray && sym->attr.dummy
3188 : 4865 : && se->descriptor_only
3189 : 3471 : && !CLASS_DATA (sym)->attr.allocatable
3190 : 3471 : && !CLASS_DATA (sym)->attr.class_pointer
3191 : 2560 : && CLASS_DATA (sym)->as
3192 : 2560 : && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3193 : 2148 : && strcmp ("_data", ref->u.c.component->name) == 0)
3194 : : /* Skip the first ref of a _data component, because for class
3195 : : arrays that one is already done by introducing a temporary
3196 : : array descriptor. */
3197 : : break;
3198 : :
3199 : 134918 : if (ref->u.c.sym->attr.extension)
3200 : 48587 : conv_parent_component_references (se, ref);
3201 : :
3202 : 134918 : gfc_conv_component_ref (se, ref);
3203 : :
3204 : 134918 : if (ref->u.c.component->ts.type == BT_CLASS
3205 : 10337 : && ref->u.c.component->attr.class_ok
3206 : 10337 : && ref->u.c.component->ts.u.derived->attr.is_class)
3207 : 10337 : se->class_container = se->expr;
3208 : 124581 : else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
3209 : 122087 : && ref->u.c.sym->attr.is_class))
3210 : 66127 : se->class_container = NULL_TREE;
3211 : :
3212 : 134918 : if (!ref->next && ref->u.c.sym->attr.codimension
3213 : 0 : && se->want_pointer && se->descriptor_only)
3214 : : return;
3215 : :
3216 : : break;
3217 : :
3218 : 6246 : case REF_SUBSTRING:
3219 : 6246 : gfc_conv_substring (se, ref, expr->ts.kind,
3220 : 6246 : expr->symtree->name, &expr->where);
3221 : 6246 : break;
3222 : :
3223 : 375 : case REF_INQUIRY:
3224 : 375 : conv_inquiry (se, ref, expr, ts);
3225 : 375 : break;
3226 : :
3227 : 0 : default:
3228 : 0 : gcc_unreachable ();
3229 : 359459 : break;
3230 : : }
3231 : 359459 : first_time = false;
3232 : 359459 : ref = ref->next;
3233 : : }
3234 : : /* Pointer assignment, allocation or pass by reference. Arrays are handled
3235 : : separately. */
3236 : 873037 : if (se->want_pointer)
3237 : : {
3238 : 120700 : if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3239 : 6820 : gfc_conv_string_parameter (se);
3240 : : else
3241 : 113880 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3242 : : }
3243 : : }
3244 : :
3245 : :
3246 : : /* Unary ops are easy... Or they would be if ! was a valid op. */
3247 : :
3248 : : static void
3249 : 26949 : gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3250 : : {
3251 : 26949 : gfc_se operand;
3252 : 26949 : tree type;
3253 : :
3254 : 26949 : gcc_assert (expr->ts.type != BT_CHARACTER);
3255 : : /* Initialize the operand. */
3256 : 26949 : gfc_init_se (&operand, se);
3257 : 26949 : gfc_conv_expr_val (&operand, expr->value.op.op1);
3258 : 26949 : gfc_add_block_to_block (&se->pre, &operand.pre);
3259 : :
3260 : 26949 : type = gfc_typenode_for_spec (&expr->ts);
3261 : :
3262 : : /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3263 : : We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3264 : : All other unary operators have an equivalent GIMPLE unary operator. */
3265 : 26949 : if (code == TRUTH_NOT_EXPR)
3266 : 18694 : se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3267 : 18694 : build_int_cst (type, 0));
3268 : : else
3269 : 8255 : se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3270 : :
3271 : 26949 : }
3272 : :
3273 : : /* Expand power operator to optimal multiplications when a value is raised
3274 : : to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3275 : : Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3276 : : Programming", 3rd Edition, 1998. */
3277 : :
3278 : : /* This code is mostly duplicated from expand_powi in the backend.
3279 : : We establish the "optimal power tree" lookup table with the defined size.
3280 : : The items in the table are the exponents used to calculate the index
3281 : : exponents. Any integer n less than the value can get an "addition chain",
3282 : : with the first node being one. */
3283 : : #define POWI_TABLE_SIZE 256
3284 : :
3285 : : /* The table is from builtins.cc. */
3286 : : static const unsigned char powi_table[POWI_TABLE_SIZE] =
3287 : : {
3288 : : 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3289 : : 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3290 : : 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3291 : : 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3292 : : 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3293 : : 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3294 : : 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3295 : : 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3296 : : 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3297 : : 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3298 : : 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3299 : : 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3300 : : 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3301 : : 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3302 : : 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3303 : : 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3304 : : 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3305 : : 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3306 : : 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3307 : : 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3308 : : 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3309 : : 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3310 : : 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3311 : : 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3312 : : 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3313 : : 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3314 : : 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3315 : : 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3316 : : 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3317 : : 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3318 : : 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3319 : : 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3320 : : };
3321 : :
3322 : : /* If n is larger than lookup table's max index, we use the "window
3323 : : method". */
3324 : : #define POWI_WINDOW_SIZE 3
3325 : :
3326 : : /* Recursive function to expand the power operator. The temporary
3327 : : values are put in tmpvar. The function returns tmpvar[1] ** n. */
3328 : : static tree
3329 : 4368 : gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3330 : : {
3331 : 4368 : tree op0;
3332 : 4368 : tree op1;
3333 : 4368 : tree tmp;
3334 : 4368 : int digit;
3335 : :
3336 : 4368 : if (n < POWI_TABLE_SIZE)
3337 : : {
3338 : 3509 : if (tmpvar[n])
3339 : : return tmpvar[n];
3340 : :
3341 : 1177 : op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3342 : 1177 : op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3343 : : }
3344 : 859 : else if (n & 1)
3345 : : {
3346 : 223 : digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3347 : 223 : op0 = gfc_conv_powi (se, n - digit, tmpvar);
3348 : 223 : op1 = gfc_conv_powi (se, digit, tmpvar);
3349 : : }
3350 : : else
3351 : : {
3352 : 636 : op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3353 : 636 : op1 = op0;
3354 : : }
3355 : :
3356 : 2036 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3357 : 2036 : tmp = gfc_evaluate_now (tmp, &se->pre);
3358 : :
3359 : 2036 : if (n < POWI_TABLE_SIZE)
3360 : 1177 : tmpvar[n] = tmp;
3361 : :
3362 : : return tmp;
3363 : : }
3364 : :
3365 : :
3366 : : /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3367 : : return 1. Else return 0 and a call to runtime library functions
3368 : : will have to be built. */
3369 : : static int
3370 : 1727 : gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3371 : : {
3372 : 1727 : tree cond;
3373 : 1727 : tree tmp;
3374 : 1727 : tree type;
3375 : 1727 : tree vartmp[POWI_TABLE_SIZE];
3376 : 1727 : HOST_WIDE_INT m;
3377 : 1727 : unsigned HOST_WIDE_INT n;
3378 : 1727 : int sgn;
3379 : 1727 : wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3380 : :
3381 : : /* If exponent is too large, we won't expand it anyway, so don't bother
3382 : : with large integer values. */
3383 : 1727 : if (!wi::fits_shwi_p (wrhs))
3384 : : return 0;
3385 : :
3386 : 1727 : m = wrhs.to_shwi ();
3387 : : /* Use the wide_int's routine to reliably get the absolute value on all
3388 : : platforms. Then convert it to a HOST_WIDE_INT like above. */
3389 : 1727 : n = wi::abs (wrhs).to_shwi ();
3390 : :
3391 : 1727 : type = TREE_TYPE (lhs);
3392 : 1727 : sgn = tree_int_cst_sgn (rhs);
3393 : :
3394 : 1727 : if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3395 : 3454 : || optimize_size) && (m > 2 || m < -1))
3396 : : return 0;
3397 : :
3398 : : /* rhs == 0 */
3399 : 1251 : if (sgn == 0)
3400 : : {
3401 : 167 : se->expr = gfc_build_const (type, integer_one_node);
3402 : 167 : return 1;
3403 : : }
3404 : :
3405 : : /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3406 : 1084 : if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3407 : : {
3408 : 152 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3409 : 152 : lhs, build_int_cst (TREE_TYPE (lhs), -1));
3410 : 152 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3411 : 152 : lhs, build_int_cst (TREE_TYPE (lhs), 1));
3412 : :
3413 : : /* If rhs is even,
3414 : : result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3415 : 152 : if ((n & 1) == 0)
3416 : : {
3417 : 72 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3418 : : logical_type_node, tmp, cond);
3419 : 72 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3420 : 72 : tmp, build_int_cst (type, 1),
3421 : 72 : build_int_cst (type, 0));
3422 : 72 : return 1;
3423 : : }
3424 : : /* If rhs is odd,
3425 : : result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3426 : 80 : tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3427 : 80 : build_int_cst (type, -1),
3428 : 80 : build_int_cst (type, 0));
3429 : 80 : se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3430 : 80 : cond, build_int_cst (type, 1), tmp);
3431 : 80 : return 1;
3432 : : }
3433 : :
3434 : 932 : memset (vartmp, 0, sizeof (vartmp));
3435 : 932 : vartmp[1] = lhs;
3436 : 932 : if (sgn == -1)
3437 : : {
3438 : 91 : tmp = gfc_build_const (type, integer_one_node);
3439 : 91 : vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3440 : : vartmp[1]);
3441 : : }
3442 : :
3443 : 932 : se->expr = gfc_conv_powi (se, n, vartmp);
3444 : :
3445 : 932 : return 1;
3446 : : }
3447 : :
3448 : :
3449 : : /* Power op (**). Constant integer exponent has special handling. */
3450 : :
3451 : : static void
3452 : 3182 : gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3453 : : {
3454 : 3182 : tree gfc_int4_type_node;
3455 : 3182 : int kind;
3456 : 3182 : int ikind;
3457 : 3182 : int res_ikind_1, res_ikind_2;
3458 : 3182 : gfc_se lse;
3459 : 3182 : gfc_se rse;
3460 : 3182 : tree fndecl = NULL;
3461 : :
3462 : 3182 : gfc_init_se (&lse, se);
3463 : 3182 : gfc_conv_expr_val (&lse, expr->value.op.op1);
3464 : 3182 : lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3465 : 3182 : gfc_add_block_to_block (&se->pre, &lse.pre);
3466 : :
3467 : 3182 : gfc_init_se (&rse, se);
3468 : 3182 : gfc_conv_expr_val (&rse, expr->value.op.op2);
3469 : 3182 : gfc_add_block_to_block (&se->pre, &rse.pre);
3470 : :
3471 : 3182 : if (expr->value.op.op2->ts.type == BT_INTEGER
3472 : 2316 : && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3473 : 1727 : if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3474 : 1476 : return;
3475 : :
3476 : 1931 : if (INTEGER_CST_P (lse.expr)
3477 : 1931 : && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3478 : : {
3479 : 231 : wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3480 : 231 : HOST_WIDE_INT v;
3481 : 231 : unsigned HOST_WIDE_INT w;
3482 : 231 : int kind, ikind, bit_size;
3483 : :
3484 : 231 : v = wlhs.to_shwi ();
3485 : 231 : w = absu_hwi (v);
3486 : :
3487 : 231 : kind = expr->value.op.op1->ts.kind;
3488 : 231 : ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3489 : 231 : bit_size = gfc_integer_kinds[ikind].bit_size;
3490 : :
3491 : 231 : if (v == 1)
3492 : : {
3493 : : /* 1**something is always 1. */
3494 : 35 : se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3495 : 225 : return;
3496 : : }
3497 : 196 : else if (v == -1)
3498 : : {
3499 : : /* (-1)**n is 1 - ((n & 1) << 1) */
3500 : 44 : tree type;
3501 : 44 : tree tmp;
3502 : :
3503 : 44 : type = TREE_TYPE (lse.expr);
3504 : 44 : tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3505 : 44 : rse.expr, build_int_cst (type, 1));
3506 : 44 : tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3507 : 44 : tmp, build_int_cst (type, 1));
3508 : 44 : tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3509 : 44 : build_int_cst (type, 1), tmp);
3510 : 44 : se->expr = tmp;
3511 : 44 : return;
3512 : : }
3513 : 152 : else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3514 : : {
3515 : : /* Here v is +/- 2**e. The further simplification uses
3516 : : 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3517 : : 1<<(4*n), etc., but we have to make sure to return zero
3518 : : if the number of bits is too large. */
3519 : 146 : tree lshift;
3520 : 146 : tree type;
3521 : 146 : tree shift;
3522 : 146 : tree ge;
3523 : 146 : tree cond;
3524 : 146 : tree num_bits;
3525 : 146 : tree cond2;
3526 : 146 : tree tmp1;
3527 : :
3528 : 146 : type = TREE_TYPE (lse.expr);
3529 : :
3530 : 146 : if (w == 2)
3531 : 86 : shift = rse.expr;
3532 : 60 : else if (w == 4)
3533 : 12 : shift = fold_build2_loc (input_location, PLUS_EXPR,
3534 : 12 : TREE_TYPE (rse.expr),
3535 : : rse.expr, rse.expr);
3536 : : else
3537 : : {
3538 : : /* use popcount for fast log2(w) */
3539 : 48 : int e = wi::popcount (w-1);
3540 : 96 : shift = fold_build2_loc (input_location, MULT_EXPR,
3541 : 48 : TREE_TYPE (rse.expr),
3542 : 48 : build_int_cst (TREE_TYPE (rse.expr), e),
3543 : : rse.expr);
3544 : : }
3545 : :
3546 : 146 : lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3547 : 146 : build_int_cst (type, 1), shift);
3548 : 146 : ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3549 : 146 : rse.expr, build_int_cst (type, 0));
3550 : 146 : cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3551 : 146 : build_int_cst (type, 0));
3552 : 146 : num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3553 : 146 : cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3554 : : rse.expr, num_bits);
3555 : 146 : tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3556 : 146 : build_int_cst (type, 0), cond);
3557 : 146 : if (v > 0)
3558 : : {
3559 : 104 : se->expr = tmp1;
3560 : : }
3561 : : else
3562 : : {
3563 : : /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3564 : 42 : tree tmp2;
3565 : 42 : tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3566 : 42 : rse.expr, build_int_cst (type, 1));
3567 : 42 : tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3568 : 42 : tmp2, build_int_cst (type, 1));
3569 : 42 : tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3570 : 42 : build_int_cst (type, 1), tmp2);
3571 : 42 : se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3572 : : tmp1, tmp2);
3573 : : }
3574 : 146 : return;
3575 : : }
3576 : : }
3577 : :
3578 : 1706 : gfc_int4_type_node = gfc_get_int_type (4);
3579 : :
3580 : : /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3581 : : library routine. But in the end, we have to convert the result back
3582 : : if this case applies -- with res_ikind_K, we keep track whether operand K
3583 : : falls into this case. */
3584 : 1706 : res_ikind_1 = -1;
3585 : 1706 : res_ikind_2 = -1;
3586 : :
3587 : 1706 : kind = expr->value.op.op1->ts.kind;
3588 : 1706 : switch (expr->value.op.op2->ts.type)
3589 : : {
3590 : 840 : case BT_INTEGER:
3591 : 840 : ikind = expr->value.op.op2->ts.kind;
3592 : 840 : switch (ikind)
3593 : : {
3594 : 144 : case 1:
3595 : 144 : case 2:
3596 : 144 : rse.expr = convert (gfc_int4_type_node, rse.expr);
3597 : 144 : res_ikind_2 = ikind;
3598 : : /* Fall through. */
3599 : :
3600 : : case 4:
3601 : : ikind = 0;
3602 : : break;
3603 : :
3604 : : case 8:
3605 : : ikind = 1;
3606 : : break;
3607 : :
3608 : 6 : case 16:
3609 : 6 : ikind = 2;
3610 : 6 : break;
3611 : :
3612 : 0 : default:
3613 : 0 : gcc_unreachable ();
3614 : : }
3615 : 840 : switch (kind)
3616 : : {
3617 : 0 : case 1:
3618 : 0 : case 2:
3619 : 0 : if (expr->value.op.op1->ts.type == BT_INTEGER)
3620 : : {
3621 : 0 : lse.expr = convert (gfc_int4_type_node, lse.expr);
3622 : 0 : res_ikind_1 = kind;
3623 : : }
3624 : : else
3625 : 0 : gcc_unreachable ();
3626 : : /* Fall through. */
3627 : :
3628 : : case 4:
3629 : : kind = 0;
3630 : : break;
3631 : :
3632 : : case 8:
3633 : : kind = 1;
3634 : : break;
3635 : :
3636 : 6 : case 10:
3637 : 6 : kind = 2;
3638 : 6 : break;
3639 : :
3640 : 18 : case 16:
3641 : 18 : kind = 3;
3642 : 18 : break;
3643 : :
3644 : 0 : default:
3645 : 0 : gcc_unreachable ();
3646 : : }
3647 : :
3648 : 840 : switch (expr->value.op.op1->ts.type)
3649 : : {
3650 : 96 : case BT_INTEGER:
3651 : 96 : if (kind == 3) /* Case 16 was not handled properly above. */
3652 : 6 : kind = 2;
3653 : 96 : fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3654 : 96 : break;
3655 : :
3656 : 557 : case BT_REAL:
3657 : : /* Use builtins for real ** int4. */
3658 : 557 : if (ikind == 0)
3659 : : {
3660 : 500 : switch (kind)
3661 : : {
3662 : 327 : case 0:
3663 : 327 : fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3664 : 327 : break;
3665 : :
3666 : 155 : case 1:
3667 : 155 : fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3668 : 155 : break;
3669 : :
3670 : 6 : case 2:
3671 : 6 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3672 : 6 : break;
3673 : :
3674 : 12 : case 3:
3675 : : /* Use the __builtin_powil() only if real(kind=16) is
3676 : : actually the C long double type. */
3677 : 12 : if (!gfc_real16_is_float128)
3678 : 0 : fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3679 : : break;
3680 : :
3681 : : default:
3682 : : gcc_unreachable ();
3683 : : }
3684 : : }
3685 : :
3686 : : /* If we don't have a good builtin for this, go for the
3687 : : library function. */
3688 : 488 : if (!fndecl)
3689 : 69 : fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3690 : : break;
3691 : :
3692 : 187 : case BT_COMPLEX:
3693 : 187 : fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3694 : 187 : break;
3695 : :
3696 : 0 : default:
3697 : 0 : gcc_unreachable ();
3698 : : }
3699 : : break;
3700 : :
3701 : 137 : case BT_REAL:
3702 : 137 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3703 : 137 : break;
3704 : :
3705 : 729 : case BT_COMPLEX:
3706 : 729 : fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3707 : 729 : break;
3708 : :
3709 : 0 : default:
3710 : 0 : gcc_unreachable ();
3711 : 1706 : break;
3712 : : }
3713 : :
3714 : 1706 : se->expr = build_call_expr_loc (input_location,
3715 : : fndecl, 2, lse.expr, rse.expr);
3716 : :
3717 : : /* Convert the result back if it is of wrong integer kind. */
3718 : 1706 : if (res_ikind_1 != -1 && res_ikind_2 != -1)
3719 : : {
3720 : : /* We want the maximum of both operand kinds as result. */
3721 : 0 : if (res_ikind_1 < res_ikind_2)
3722 : 0 : res_ikind_1 = res_ikind_2;
3723 : 0 : se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3724 : : }
3725 : : }
3726 : :
3727 : :
3728 : : /* Generate code to allocate a string temporary. */
3729 : :
3730 : : tree
3731 : 4436 : gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3732 : : {
3733 : 4436 : tree var;
3734 : 4436 : tree tmp;
3735 : :
3736 : 4436 : if (gfc_can_put_var_on_stack (len))
3737 : : {
3738 : : /* Create a temporary variable to hold the result. */
3739 : 3928 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
3740 : 1964 : TREE_TYPE (len), len,
3741 : 1964 : build_int_cst (TREE_TYPE (len), 1));
3742 : 1964 : tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3743 : :
3744 : 1964 : if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3745 : 1964 : tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3746 : : else
3747 : 0 : tmp = build_array_type (TREE_TYPE (type), tmp);
3748 : :
3749 : 1964 : var = gfc_create_var (tmp, "str");
3750 : 1964 : var = gfc_build_addr_expr (type, var);
3751 : : }
3752 : : else
3753 : : {
3754 : : /* Allocate a temporary to hold the result. */
3755 : 2472 : var = gfc_create_var (type, "pstr");
3756 : 2472 : gcc_assert (POINTER_TYPE_P (type));
3757 : 2472 : tmp = TREE_TYPE (type);
3758 : 2472 : if (TREE_CODE (tmp) == ARRAY_TYPE)
3759 : 2472 : tmp = TREE_TYPE (tmp);
3760 : 2472 : tmp = TYPE_SIZE_UNIT (tmp);
3761 : 2472 : tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3762 : : fold_convert (size_type_node, len),
3763 : : fold_convert (size_type_node, tmp));
3764 : 2472 : tmp = gfc_call_malloc (&se->pre, type, tmp);
3765 : 2472 : gfc_add_modify (&se->pre, var, tmp);
3766 : :
3767 : : /* Free the temporary afterwards. */
3768 : 2472 : tmp = gfc_call_free (var);
3769 : 2472 : gfc_add_expr_to_block (&se->post, tmp);
3770 : : }
3771 : :
3772 : 4436 : return var;
3773 : : }
3774 : :
3775 : :
3776 : : /* Handle a string concatenation operation. A temporary will be allocated to
3777 : : hold the result. */
3778 : :
3779 : : static void
3780 : 1162 : gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3781 : : {
3782 : 1162 : gfc_se lse, rse;
3783 : 1162 : tree len, type, var, tmp, fndecl;
3784 : :
3785 : 1162 : gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3786 : : && expr->value.op.op2->ts.type == BT_CHARACTER);
3787 : 1162 : gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3788 : :
3789 : 1162 : gfc_init_se (&lse, se);
3790 : 1162 : gfc_conv_expr (&lse, expr->value.op.op1);
3791 : 1162 : gfc_conv_string_parameter (&lse);
3792 : 1162 : gfc_init_se (&rse, se);
3793 : 1162 : gfc_conv_expr (&rse, expr->value.op.op2);
3794 : 1162 : gfc_conv_string_parameter (&rse);
3795 : :
3796 : 1162 : gfc_add_block_to_block (&se->pre, &lse.pre);
3797 : 1162 : gfc_add_block_to_block (&se->pre, &rse.pre);
3798 : :
3799 : 1162 : type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3800 : 1162 : len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3801 : 1162 : if (len == NULL_TREE)
3802 : : {
3803 : 1031 : len = fold_build2_loc (input_location, PLUS_EXPR,
3804 : : gfc_charlen_type_node,
3805 : : fold_convert (gfc_charlen_type_node,
3806 : : lse.string_length),
3807 : : fold_convert (gfc_charlen_type_node,
3808 : : rse.string_length));
3809 : : }
3810 : :
3811 : 1162 : type = build_pointer_type (type);
3812 : :
3813 : 1162 : var = gfc_conv_string_tmp (se, type, len);
3814 : :
3815 : : /* Do the actual concatenation. */
3816 : 1162 : if (expr->ts.kind == 1)
3817 : 1098 : fndecl = gfor_fndecl_concat_string;
3818 : 64 : else if (expr->ts.kind == 4)
3819 : 64 : fndecl = gfor_fndecl_concat_string_char4;
3820 : : else
3821 : 0 : gcc_unreachable ();
3822 : :
3823 : 1162 : tmp = build_call_expr_loc (input_location,
3824 : : fndecl, 6, len, var, lse.string_length, lse.expr,
3825 : : rse.string_length, rse.expr);
3826 : 1162 : gfc_add_expr_to_block (&se->pre, tmp);
3827 : :
3828 : : /* Add the cleanup for the operands. */
3829 : 1162 : gfc_add_block_to_block (&se->pre, &rse.post);
3830 : 1162 : gfc_add_block_to_block (&se->pre, &lse.post);
3831 : :
3832 : 1162 : se->expr = var;
3833 : 1162 : se->string_length = len;
3834 : 1162 : }
3835 : :
3836 : : /* Translates an op expression. Common (binary) cases are handled by this
3837 : : function, others are passed on. Recursion is used in either case.
3838 : : We use the fact that (op1.ts == op2.ts) (except for the power
3839 : : operator **).
3840 : : Operators need no special handling for scalarized expressions as long as
3841 : : they call gfc_conv_simple_val to get their operands.
3842 : : Character strings get special handling. */
3843 : :
3844 : : static void
3845 : 348088 : gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3846 : : {
3847 : 348088 : enum tree_code code;
3848 : 348088 : gfc_se lse;
3849 : 348088 : gfc_se rse;
3850 : 348088 : tree tmp, type;
3851 : 348088 : int lop;
3852 : 348088 : int checkstring;
3853 : :
3854 : 348088 : checkstring = 0;
3855 : 348088 : lop = 0;
3856 : 348088 : switch (expr->value.op.op)
3857 : : {
3858 : 14575 : case INTRINSIC_PARENTHESES:
3859 : 14575 : if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3860 : 3577 : && flag_protect_parens)
3861 : : {
3862 : 3434 : gfc_conv_unary_op (PAREN_EXPR, se, expr);
3863 : 3434 : gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3864 : 42440 : return;
3865 : : }
3866 : :
3867 : : /* Fallthrough. */
3868 : 11147 : case INTRINSIC_UPLUS:
3869 : 11147 : gfc_conv_expr (se, expr->value.op.op1);
3870 : 11147 : return;
3871 : :
3872 : 4821 : case INTRINSIC_UMINUS:
3873 : 4821 : gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3874 : 4821 : return;
3875 : :
3876 : 18694 : case INTRINSIC_NOT:
3877 : 18694 : gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3878 : 18694 : return;
3879 : :
3880 : : case INTRINSIC_PLUS:
3881 : : code = PLUS_EXPR;
3882 : : break;
3883 : :
3884 : 26240 : case INTRINSIC_MINUS:
3885 : 26240 : code = MINUS_EXPR;
3886 : 26240 : break;
3887 : :
3888 : 29595 : case INTRINSIC_TIMES:
3889 : 29595 : code = MULT_EXPR;
3890 : 29595 : break;
3891 : :
3892 : 5971 : case INTRINSIC_DIVIDE:
3893 : : /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3894 : : an integer, we must round towards zero, so we use a
3895 : : TRUNC_DIV_EXPR. */
3896 : 5971 : if (expr->ts.type == BT_INTEGER)
3897 : : code = TRUNC_DIV_EXPR;
3898 : : else
3899 : 2607 : code = RDIV_EXPR;
3900 : : break;
3901 : :
3902 : 3182 : case INTRINSIC_POWER:
3903 : 3182 : gfc_conv_power_op (se, expr);
3904 : 3182 : return;
3905 : :
3906 : 1162 : case INTRINSIC_CONCAT:
3907 : 1162 : gfc_conv_concat_op (se, expr);
3908 : 1162 : return;
3909 : :
3910 : 4625 : case INTRINSIC_AND:
3911 : 4625 : code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3912 : : lop = 1;
3913 : : break;
3914 : :
3915 : 24229 : case INTRINSIC_OR:
3916 : 24229 : code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3917 : : lop = 1;
3918 : : break;
3919 : :
3920 : : /* EQV and NEQV only work on logicals, but since we represent them
3921 : : as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3922 : 12012 : case INTRINSIC_EQ:
3923 : 12012 : case INTRINSIC_EQ_OS:
3924 : 12012 : case INTRINSIC_EQV:
3925 : 12012 : code = EQ_EXPR;
3926 : 12012 : checkstring = 1;
3927 : 12012 : lop = 1;
3928 : 12012 : break;
3929 : :
3930 : 139953 : case INTRINSIC_NE:
3931 : 139953 : case INTRINSIC_NE_OS:
3932 : 139953 : case INTRINSIC_NEQV:
3933 : 139953 : code = NE_EXPR;
3934 : 139953 : checkstring = 1;
3935 : 139953 : lop = 1;
3936 : 139953 : break;
3937 : :
3938 : 11388 : case INTRINSIC_GT:
3939 : 11388 : case INTRINSIC_GT_OS:
3940 : 11388 : code = GT_EXPR;
3941 : 11388 : checkstring = 1;
3942 : 11388 : lop = 1;
3943 : 11388 : break;
3944 : :
3945 : 1675 : case INTRINSIC_GE:
3946 : 1675 : case INTRINSIC_GE_OS:
3947 : 1675 : code = GE_EXPR;
3948 : 1675 : checkstring = 1;
3949 : 1675 : lop = 1;
3950 : 1675 : break;
3951 : :
3952 : 4062 : case INTRINSIC_LT:
3953 : 4062 : case INTRINSIC_LT_OS:
3954 : 4062 : code = LT_EXPR;
3955 : 4062 : checkstring = 1;
3956 : 4062 : lop = 1;
3957 : 4062 : break;
3958 : :
3959 : 2533 : case INTRINSIC_LE:
3960 : 2533 : case INTRINSIC_LE_OS:
3961 : 2533 : code = LE_EXPR;
3962 : 2533 : checkstring = 1;
3963 : 2533 : lop = 1;
3964 : 2533 : break;
3965 : :
3966 : 0 : case INTRINSIC_USER:
3967 : 0 : case INTRINSIC_ASSIGN:
3968 : : /* These should be converted into function calls by the frontend. */
3969 : 0 : gcc_unreachable ();
3970 : :
3971 : 0 : default:
3972 : 0 : fatal_error (input_location, "Unknown intrinsic op");
3973 : 305648 : return;
3974 : : }
3975 : :
3976 : : /* The only exception to this is **, which is handled separately anyway. */
3977 : 305648 : gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3978 : :
3979 : 305648 : if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3980 : 274260 : checkstring = 0;
3981 : :
3982 : : /* lhs */
3983 : 305648 : gfc_init_se (&lse, se);
3984 : 305648 : gfc_conv_expr (&lse, expr->value.op.op1);
3985 : 305648 : gfc_add_block_to_block (&se->pre, &lse.pre);
3986 : :
3987 : : /* rhs */
3988 : 305648 : gfc_init_se (&rse, se);
3989 : 305648 : gfc_conv_expr (&rse, expr->value.op.op2);
3990 : 305648 : gfc_add_block_to_block (&se->pre, &rse.pre);
3991 : :
3992 : 305648 : if (checkstring)
3993 : : {
3994 : 31388 : gfc_conv_string_parameter (&lse);
3995 : 31388 : gfc_conv_string_parameter (&rse);
3996 : :
3997 : 62776 : lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3998 : : rse.string_length, rse.expr,
3999 : 31388 : expr->value.op.op1->ts.kind,
4000 : : code);
4001 : 31388 : rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
4002 : 31388 : gfc_add_block_to_block (&lse.post, &rse.post);
4003 : : }
4004 : :
4005 : 305648 : type = gfc_typenode_for_spec (&expr->ts);
4006 : :
4007 : 305648 : if (lop)
4008 : : {
4009 : : /* The result of logical ops is always logical_type_node. */
4010 : 200477 : tmp = fold_build2_loc (input_location, code, logical_type_node,
4011 : : lse.expr, rse.expr);
4012 : 200477 : se->expr = convert (type, tmp);
4013 : : }
4014 : : else
4015 : 105171 : se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
4016 : :
4017 : : /* Add the post blocks. */
4018 : 305648 : gfc_add_block_to_block (&se->post, &rse.post);
4019 : 305648 : gfc_add_block_to_block (&se->post, &lse.post);
4020 : : }
4021 : :
4022 : : /* If a string's length is one, we convert it to a single character. */
4023 : :
4024 : : tree
4025 : 127962 : gfc_string_to_single_character (tree len, tree str, int kind)
4026 : : {
4027 : :
4028 : 127962 : if (len == NULL
4029 : 127962 : || !tree_fits_uhwi_p (len)
4030 : 235758 : || !POINTER_TYPE_P (TREE_TYPE (str)))
4031 : : return NULL_TREE;
4032 : :
4033 : 107745 : if (TREE_INT_CST_LOW (len) == 1)
4034 : : {
4035 : 21309 : str = fold_convert (gfc_get_pchar_type (kind), str);
4036 : 21309 : return build_fold_indirect_ref_loc (input_location, str);
4037 : : }
4038 : :
4039 : 86436 : if (kind == 1
4040 : 70685 : && TREE_CODE (str) == ADDR_EXPR
4041 : 60926 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4042 : 43909 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4043 : 26792 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4044 : 26792 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4045 : 26792 : && TREE_INT_CST_LOW (len) > 1
4046 : 111498 : && TREE_INT_CST_LOW (len)
4047 : : == (unsigned HOST_WIDE_INT)
4048 : 25062 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4049 : : {
4050 : 25062 : tree ret = fold_convert (gfc_get_pchar_type (kind), str);
4051 : 25062 : ret = build_fold_indirect_ref_loc (input_location, ret);
4052 : 25062 : if (TREE_CODE (ret) == INTEGER_CST)
4053 : : {
4054 : 25062 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4055 : 25062 : int i, length = TREE_STRING_LENGTH (string_cst);
4056 : 25062 : const char *ptr = TREE_STRING_POINTER (string_cst);
4057 : :
4058 : 36683 : for (i = 1; i < length; i++)
4059 : 36106 : if (ptr[i] != ' ')
4060 : : return NULL_TREE;
4061 : :
4062 : : return ret;
4063 : : }
4064 : : }
4065 : :
4066 : : return NULL_TREE;
4067 : : }
4068 : :
4069 : :
4070 : : static void
4071 : 171 : conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
4072 : : {
4073 : 171 : gcc_assert (expr);
4074 : :
4075 : : /* We used to modify the tree here. Now it is done earlier in
4076 : : the front-end, so we only check it here to avoid regressions. */
4077 : 171 : if (sym->backend_decl)
4078 : : {
4079 : 66 : gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
4080 : 66 : gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
4081 : 66 : gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
4082 : 66 : gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
4083 : : }
4084 : :
4085 : : /* If we have a constant character expression, make it into an
4086 : : integer of type C char. */
4087 : 171 : if ((*expr)->expr_type == EXPR_CONSTANT)
4088 : : {
4089 : 165 : gfc_typespec ts;
4090 : 165 : gfc_clear_ts (&ts);
4091 : :
4092 : 330 : gfc_expr *tmp = gfc_get_int_expr (gfc_default_character_kind, NULL,
4093 : 165 : (*expr)->value.character.string[0]);
4094 : 165 : gfc_replace_expr (*expr, tmp);
4095 : : }
4096 : 6 : else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
4097 : : {
4098 : 6 : if ((*expr)->ref == NULL)
4099 : : {
4100 : 6 : se->expr = gfc_string_to_single_character
4101 : 6 : (integer_one_node,
4102 : 6 : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4103 : : gfc_get_symbol_decl
4104 : 6 : ((*expr)->symtree->n.sym)),
4105 : : (*expr)->ts.kind);
4106 : : }
4107 : : else
4108 : : {
4109 : 0 : gfc_conv_variable (se, *expr);
4110 : 0 : se->expr = gfc_string_to_single_character
4111 : 0 : (integer_one_node,
4112 : : gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
4113 : : se->expr),
4114 : 0 : (*expr)->ts.kind);
4115 : : }
4116 : : }
4117 : 171 : }
4118 : :
4119 : : /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
4120 : : if STR is a string literal, otherwise return -1. */
4121 : :
4122 : : static int
4123 : 29462 : gfc_optimize_len_trim (tree len, tree str, int kind)
4124 : : {
4125 : 29462 : if (kind == 1
4126 : 24806 : && TREE_CODE (str) == ADDR_EXPR
4127 : 21494 : && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
4128 : 13932 : && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4129 : 8891 : && array_ref_low_bound (TREE_OPERAND (str, 0))
4130 : 8891 : == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4131 : 8891 : && tree_fits_uhwi_p (len)
4132 : 8891 : && tree_to_uhwi (len) >= 1
4133 : 29462 : && tree_to_uhwi (len)
4134 : 8847 : == (unsigned HOST_WIDE_INT)
4135 : 8847 : TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4136 : : {
4137 : 8847 : tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4138 : 8847 : folded = build_fold_indirect_ref_loc (input_location, folded);
4139 : 8847 : if (TREE_CODE (folded) == INTEGER_CST)
4140 : : {
4141 : 8847 : tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4142 : 8847 : int length = TREE_STRING_LENGTH (string_cst);
4143 : 8847 : const char *ptr = TREE_STRING_POINTER (string_cst);
4144 : :
4145 : 12098 : for (; length > 0; length--)
4146 : 12098 : if (ptr[length - 1] != ' ')
4147 : : break;
4148 : :
4149 : 8847 : return length;
4150 : : }
4151 : : }
4152 : : return -1;
4153 : : }
4154 : :
4155 : : /* Helper to build a call to memcmp. */
4156 : :
4157 : : static tree
4158 : 11781 : build_memcmp_call (tree s1, tree s2, tree n)
4159 : : {
4160 : 11781 : tree tmp;
4161 : :
4162 : 11781 : if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4163 : 0 : s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4164 : : else
4165 : 11781 : s1 = fold_convert (pvoid_type_node, s1);
4166 : :
4167 : 11781 : if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4168 : 0 : s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4169 : : else
4170 : 11781 : s2 = fold_convert (pvoid_type_node, s2);
4171 : :
4172 : 11781 : n = fold_convert (size_type_node, n);
4173 : :
4174 : 11781 : tmp = build_call_expr_loc (input_location,
4175 : : builtin_decl_explicit (BUILT_IN_MEMCMP),
4176 : : 3, s1, s2, n);
4177 : :
4178 : 11781 : return fold_convert (integer_type_node, tmp);
4179 : : }
4180 : :
4181 : : /* Compare two strings. If they are all single characters, the result is the
4182 : : subtraction of them. Otherwise, we build a library call. */
4183 : :
4184 : : tree
4185 : 31487 : gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4186 : : enum tree_code code)
4187 : : {
4188 : 31487 : tree sc1;
4189 : 31487 : tree sc2;
4190 : 31487 : tree fndecl;
4191 : :
4192 : 31487 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4193 : 31487 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4194 : :
4195 : 31487 : sc1 = gfc_string_to_single_character (len1, str1, kind);
4196 : 31487 : sc2 = gfc_string_to_single_character (len2, str2, kind);
4197 : :
4198 : 31487 : if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4199 : : {
4200 : : /* Deal with single character specially. */
4201 : 4696 : sc1 = fold_convert (integer_type_node, sc1);
4202 : 4696 : sc2 = fold_convert (integer_type_node, sc2);
4203 : 4696 : return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4204 : 4696 : sc1, sc2);
4205 : : }
4206 : :
4207 : 26791 : if ((code == EQ_EXPR || code == NE_EXPR)
4208 : 26225 : && optimize
4209 : 22016 : && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4210 : : {
4211 : : /* If one string is a string literal with LEN_TRIM longer
4212 : : than the length of the second string, the strings
4213 : : compare unequal. */
4214 : 14731 : int len = gfc_optimize_len_trim (len1, str1, kind);
4215 : 14731 : if (len > 0 && compare_tree_int (len2, len) < 0)
4216 : 0 : return integer_one_node;
4217 : 14731 : len = gfc_optimize_len_trim (len2, str2, kind);
4218 : 14731 : if (len > 0 && compare_tree_int (len1, len) < 0)
4219 : 0 : return integer_one_node;
4220 : : }
4221 : :
4222 : : /* We can compare via memcpy if the strings are known to be equal
4223 : : in length and they are
4224 : : - kind=1
4225 : : - kind=4 and the comparison is for (in)equality. */
4226 : :
4227 : 17903 : if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4228 : 17570 : && tree_int_cst_equal (len1, len2)
4229 : 38632 : && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4230 : : {
4231 : 11781 : tree tmp;
4232 : 11781 : tree chartype;
4233 : :
4234 : 11781 : chartype = gfc_get_char_type (kind);
4235 : 11781 : tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4236 : 11781 : fold_convert (TREE_TYPE(len1),
4237 : : TYPE_SIZE_UNIT(chartype)),
4238 : : len1);
4239 : 11781 : return build_memcmp_call (str1, str2, tmp);
4240 : : }
4241 : :
4242 : : /* Build a call for the comparison. */
4243 : 15010 : if (kind == 1)
4244 : 12263 : fndecl = gfor_fndecl_compare_string;
4245 : 2747 : else if (kind == 4)
4246 : 2747 : fndecl = gfor_fndecl_compare_string_char4;
4247 : : else
4248 : 0 : gcc_unreachable ();
4249 : :
4250 : 15010 : return build_call_expr_loc (input_location, fndecl, 4,
4251 : 15010 : len1, str1, len2, str2);
4252 : : }
4253 : :
4254 : :
4255 : : /* Return the backend_decl for a procedure pointer component. */
4256 : :
4257 : : static tree
4258 : 1621 : get_proc_ptr_comp (gfc_expr *e)
4259 : : {
4260 : 1621 : gfc_se comp_se;
4261 : 1621 : gfc_expr *e2;
4262 : 1621 : expr_t old_type;
4263 : :
4264 : 1621 : gfc_init_se (&comp_se, NULL);
4265 : 1621 : e2 = gfc_copy_expr (e);
4266 : : /* We have to restore the expr type later so that gfc_free_expr frees
4267 : : the exact same thing that was allocated.
4268 : : TODO: This is ugly. */
4269 : 1621 : old_type = e2->expr_type;
4270 : 1621 : e2->expr_type = EXPR_VARIABLE;
4271 : 1621 : gfc_conv_expr (&comp_se, e2);
4272 : 1621 : e2->expr_type = old_type;
4273 : 1621 : gfc_free_expr (e2);
4274 : 1621 : return build_fold_addr_expr_loc (input_location, comp_se.expr);
4275 : : }
4276 : :
4277 : :
4278 : : /* Convert a typebound function reference from a class object. */
4279 : : static void
4280 : 80 : conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4281 : : {
4282 : 80 : gfc_ref *ref;
4283 : 80 : tree var;
4284 : :
4285 : 80 : if (!VAR_P (base_object))
4286 : : {
4287 : 0 : var = gfc_create_var (TREE_TYPE (base_object), NULL);
4288 : 0 : gfc_add_modify (&se->pre, var, base_object);
4289 : : }
4290 : 80 : se->expr = gfc_class_vptr_get (base_object);
4291 : 80 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4292 : 80 : ref = expr->ref;
4293 : 308 : while (ref && ref->next)
4294 : : ref = ref->next;
4295 : 80 : gcc_assert (ref && ref->type == REF_COMPONENT);
4296 : 80 : if (ref->u.c.sym->attr.extension)
4297 : 0 : conv_parent_component_references (se, ref);
4298 : 80 : gfc_conv_component_ref (se, ref);
4299 : 80 : se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4300 : 80 : }
4301 : :
4302 : :
4303 : : static void
4304 : 113249 : conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
4305 : : gfc_actual_arglist *actual_args)
4306 : : {
4307 : 113249 : tree tmp;
4308 : :
4309 : 113249 : if (gfc_is_proc_ptr_comp (expr))
4310 : 1621 : tmp = get_proc_ptr_comp (expr);
4311 : 111628 : else if (sym->attr.dummy)
4312 : : {
4313 : 771 : tmp = gfc_get_symbol_decl (sym);
4314 : 771 : if (sym->attr.proc_pointer)
4315 : 83 : tmp = build_fold_indirect_ref_loc (input_location,
4316 : : tmp);
4317 : 771 : gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4318 : : && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4319 : : }
4320 : : else
4321 : : {
4322 : 110857 : if (!sym->backend_decl)
4323 : 28176 : sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4324 : :
4325 : 110857 : TREE_USED (sym->backend_decl) = 1;
4326 : :
4327 : 110857 : tmp = sym->backend_decl;
4328 : :
4329 : 110857 : if (sym->attr.cray_pointee)
4330 : : {
4331 : : /* TODO - make the cray pointee a pointer to a procedure,
4332 : : assign the pointer to it and use it for the call. This
4333 : : will do for now! */
4334 : 19 : tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4335 : : gfc_get_symbol_decl (sym->cp_pointer));
4336 : 19 : tmp = gfc_evaluate_now (tmp, &se->pre);
4337 : : }
4338 : :
4339 : 110857 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4340 : : {
4341 : 110278 : gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4342 : 110278 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4343 : : }
4344 : : }
4345 : 113249 : se->expr = tmp;
4346 : 113249 : }
4347 : :
4348 : :
4349 : : /* Initialize MAPPING. */
4350 : :
4351 : : void
4352 : 113366 : gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4353 : : {
4354 : 113366 : mapping->syms = NULL;
4355 : 113366 : mapping->charlens = NULL;
4356 : 113366 : }
4357 : :
4358 : :
4359 : : /* Free all memory held by MAPPING (but not MAPPING itself). */
4360 : :
4361 : : void
4362 : 113366 : gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4363 : : {
4364 : 113366 : gfc_interface_sym_mapping *sym;
4365 : 113366 : gfc_interface_sym_mapping *nextsym;
4366 : 113366 : gfc_charlen *cl;
4367 : 113366 : gfc_charlen *nextcl;
4368 : :
4369 : 144634 : for (sym = mapping->syms; sym; sym = nextsym)
4370 : : {
4371 : 31268 : nextsym = sym->next;
4372 : 31268 : sym->new_sym->n.sym->formal = NULL;
4373 : 31268 : gfc_free_symbol (sym->new_sym->n.sym);
4374 : 31268 : gfc_free_expr (sym->expr);
4375 : 31268 : free (sym->new_sym);
4376 : 31268 : free (sym);
4377 : : }
4378 : 117734 : for (cl = mapping->charlens; cl; cl = nextcl)
4379 : : {
4380 : 4368 : nextcl = cl->next;
4381 : 4368 : gfc_free_expr (cl->length);
4382 : 4368 : free (cl);
4383 : : }
4384 : 113366 : }
4385 : :
4386 : :
4387 : : /* Return a copy of gfc_charlen CL. Add the returned structure to
4388 : : MAPPING so that it will be freed by gfc_free_interface_mapping. */
4389 : :
4390 : : static gfc_charlen *
4391 : 4368 : gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4392 : : gfc_charlen * cl)
4393 : : {
4394 : 4368 : gfc_charlen *new_charlen;
4395 : :
4396 : 4368 : new_charlen = gfc_get_charlen ();
4397 : 4368 : new_charlen->next = mapping->charlens;
4398 : 4368 : new_charlen->length = gfc_copy_expr (cl->length);
4399 : :
4400 : 4368 : mapping->charlens = new_charlen;
4401 : 4368 : return new_charlen;
4402 : : }
4403 : :
4404 : :
4405 : : /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4406 : : array variable that can be used as the actual argument for dummy
4407 : : argument SYM. Add any initialization code to BLOCK. PACKED is as
4408 : : for gfc_get_nodesc_array_type and DATA points to the first element
4409 : : in the passed array. */
4410 : :
4411 : : static tree
4412 : 6493 : gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4413 : : gfc_packed packed, tree data)
4414 : : {
4415 : 6493 : tree type;
4416 : 6493 : tree var;
4417 : :
4418 : 6493 : type = gfc_typenode_for_spec (&sym->ts);
4419 : 12986 : type = gfc_get_nodesc_array_type (type, sym->as, packed,
4420 : : !sym->attr.target && !sym->attr.pointer
4421 : 6493 : && !sym->attr.proc_pointer);
4422 : :
4423 : 6493 : var = gfc_create_var (type, "ifm");
4424 : 6493 : gfc_add_modify (block, var, fold_convert (type, data));
4425 : :
4426 : 6493 : return var;
4427 : : }
4428 : :
4429 : :
4430 : : /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4431 : : and offset of descriptorless array type TYPE given that it has the same
4432 : : size as DESC. Add any set-up code to BLOCK. */
4433 : :
4434 : : static void
4435 : 6223 : gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4436 : : {
4437 : 6223 : int n;
4438 : 6223 : tree dim;
4439 : 6223 : tree offset;
4440 : 6223 : tree tmp;
4441 : :
4442 : 6223 : offset = gfc_index_zero_node;
4443 : 7270 : for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4444 : : {
4445 : 1047 : dim = gfc_rank_cst[n];
4446 : 1047 : GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4447 : 1047 : if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4448 : : {
4449 : 1 : GFC_TYPE_ARRAY_LBOUND (type, n)
4450 : 1 : = gfc_conv_descriptor_lbound_get (desc, dim);
4451 : 1 : GFC_TYPE_ARRAY_UBOUND (type, n)
4452 : 2 : = gfc_conv_descriptor_ubound_get (desc, dim);
4453 : : }
4454 : 1046 : else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4455 : : {
4456 : 1046 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4457 : : gfc_array_index_type,
4458 : : gfc_conv_descriptor_ubound_get (desc, dim),
4459 : : gfc_conv_descriptor_lbound_get (desc, dim));
4460 : 3138 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4461 : : gfc_array_index_type,
4462 : 1046 : GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4463 : 1046 : tmp = gfc_evaluate_now (tmp, block);
4464 : 1046 : GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4465 : : }
4466 : 4188 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4467 : 1047 : GFC_TYPE_ARRAY_LBOUND (type, n),
4468 : 1047 : GFC_TYPE_ARRAY_STRIDE (type, n));
4469 : 1047 : offset = fold_build2_loc (input_location, MINUS_EXPR,
4470 : : gfc_array_index_type, offset, tmp);
4471 : : }
4472 : 6223 : offset = gfc_evaluate_now (offset, block);
4473 : 6223 : GFC_TYPE_ARRAY_OFFSET (type) = offset;
4474 : 6223 : }
4475 : :
4476 : :
4477 : : /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4478 : : in SE. The caller may still use se->expr and se->string_length after
4479 : : calling this function. */
4480 : :
4481 : : void
4482 : 31268 : gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4483 : : gfc_symbol * sym, gfc_se * se,
4484 : : gfc_expr *expr)
4485 : : {
4486 : 31268 : gfc_interface_sym_mapping *sm;
4487 : 31268 : tree desc;
4488 : 31268 : tree tmp;
4489 : 31268 : tree value;
4490 : 31268 : gfc_symbol *new_sym;
4491 : 31268 : gfc_symtree *root;
4492 : 31268 : gfc_symtree *new_symtree;
4493 : :
4494 : : /* Create a new symbol to represent the actual argument. */
4495 : 31268 : new_sym = gfc_new_symbol (sym->name, NULL);
4496 : 31268 : new_sym->ts = sym->ts;
4497 : 31268 : new_sym->as = gfc_copy_array_spec (sym->as);
4498 : 31268 : new_sym->attr.referenced = 1;
4499 : 31268 : new_sym->attr.dimension = sym->attr.dimension;
4500 : 31268 : new_sym->attr.contiguous = sym->attr.contiguous;
4501 : 31268 : new_sym->attr.codimension = sym->attr.codimension;
4502 : 31268 : new_sym->attr.pointer = sym->attr.pointer;
4503 : 31268 : new_sym->attr.allocatable = sym->attr.allocatable;
4504 : 31268 : new_sym->attr.flavor = sym->attr.flavor;
4505 : 31268 : new_sym->attr.function = sym->attr.function;
4506 : :
4507 : : /* Ensure that the interface is available and that
4508 : : descriptors are passed for array actual arguments. */
4509 : 31268 : if (sym->attr.flavor == FL_PROCEDURE)
4510 : : {
4511 : 36 : new_sym->formal = expr->symtree->n.sym->formal;
4512 : 36 : new_sym->attr.always_explicit
4513 : 36 : = expr->symtree->n.sym->attr.always_explicit;
4514 : : }
4515 : :
4516 : : /* Create a fake symtree for it. */
4517 : 31268 : root = NULL;
4518 : 31268 : new_symtree = gfc_new_symtree (&root, sym->name);
4519 : 31268 : new_symtree->n.sym = new_sym;
4520 : 31268 : gcc_assert (new_symtree == root);
4521 : :
4522 : : /* Create a dummy->actual mapping. */
4523 : 31268 : sm = XCNEW (gfc_interface_sym_mapping);
4524 : 31268 : sm->next = mapping->syms;
4525 : 31268 : sm->old = sym;
4526 : 31268 : sm->new_sym = new_symtree;
4527 : 31268 : sm->expr = gfc_copy_expr (expr);
4528 : 31268 : mapping->syms = sm;
4529 : :
4530 : : /* Stabilize the argument's value. */
4531 : 31268 : if (!sym->attr.function && se)
4532 : 31170 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
4533 : :
4534 : 31268 : if (sym->ts.type == BT_CHARACTER)
4535 : : {
4536 : : /* Create a copy of the dummy argument's length. */
4537 : 2497 : new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4538 : 2497 : sm->expr->ts.u.cl = new_sym->ts.u.cl;
4539 : :
4540 : : /* If the length is specified as "*", record the length that
4541 : : the caller is passing. We should use the callee's length
4542 : : in all other cases. */
4543 : 2497 : if (!new_sym->ts.u.cl->length && se)
4544 : : {
4545 : 2293 : se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4546 : 2293 : new_sym->ts.u.cl->backend_decl = se->string_length;
4547 : : }
4548 : : }
4549 : :
4550 : 31254 : if (!se)
4551 : 62 : return;
4552 : :
4553 : : /* Use the passed value as-is if the argument is a function. */
4554 : 31206 : if (sym->attr.flavor == FL_PROCEDURE)
4555 : 36 : value = se->expr;
4556 : :
4557 : : /* If the argument is a pass-by-value scalar, use the value as is. */
4558 : 31170 : else if (!sym->attr.dimension && sym->attr.value)
4559 : 39 : value = se->expr;
4560 : :
4561 : : /* If the argument is either a string or a pointer to a string,
4562 : : convert it to a boundless character type. */
4563 : 31131 : else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4564 : : {
4565 : 1192 : tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4566 : 1192 : tmp = build_pointer_type (tmp);
4567 : 1192 : if (sym->attr.pointer)
4568 : 126 : value = build_fold_indirect_ref_loc (input_location,
4569 : : se->expr);
4570 : : else
4571 : 1066 : value = se->expr;
4572 : 1192 : value = fold_convert (tmp, value);
4573 : : }
4574 : :
4575 : : /* If the argument is a scalar, a pointer to an array or an allocatable,
4576 : : dereference it. */
4577 : 29939 : else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4578 : 22189 : value = build_fold_indirect_ref_loc (input_location,
4579 : : se->expr);
4580 : :
4581 : : /* For character(*), use the actual argument's descriptor. */
4582 : 7750 : else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4583 : 1257 : value = build_fold_indirect_ref_loc (input_location,
4584 : : se->expr);
4585 : :
4586 : : /* If the argument is an array descriptor, use it to determine
4587 : : information about the actual argument's shape. */
4588 : 6493 : else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4589 : 6493 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4590 : : {
4591 : : /* Get the actual argument's descriptor. */
4592 : 6223 : desc = build_fold_indirect_ref_loc (input_location,
4593 : : se->expr);
4594 : :
4595 : : /* Create the replacement variable. */
4596 : 6223 : tmp = gfc_conv_descriptor_data_get (desc);
4597 : 6223 : value = gfc_get_interface_mapping_array (&se->pre, sym,
4598 : : PACKED_NO, tmp);
4599 : :
4600 : : /* Use DESC to work out the upper bounds, strides and offset. */
4601 : 6223 : gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4602 : : }
4603 : : else
4604 : : /* Otherwise we have a packed array. */
4605 : 270 : value = gfc_get_interface_mapping_array (&se->pre, sym,
4606 : : PACKED_FULL, se->expr);
4607 : :
4608 : 31206 : new_sym->backend_decl = value;
4609 : : }
4610 : :
4611 : :
4612 : : /* Called once all dummy argument mappings have been added to MAPPING,
4613 : : but before the mapping is used to evaluate expressions. Pre-evaluate
4614 : : the length of each argument, adding any initialization code to PRE and
4615 : : any finalization code to POST. */
4616 : :
4617 : : static void
4618 : 113329 : gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4619 : : stmtblock_t * pre, stmtblock_t * post)
4620 : : {
4621 : 113329 : gfc_interface_sym_mapping *sym;
4622 : 113329 : gfc_expr *expr;
4623 : 113329 : gfc_se se;
4624 : :
4625 : 144535 : for (sym = mapping->syms; sym; sym = sym->next)
4626 : 31206 : if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4627 : 2483 : && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4628 : : {
4629 : 190 : expr = sym->new_sym->n.sym->ts.u.cl->length;
4630 : 190 : gfc_apply_interface_mapping_to_expr (mapping, expr);
4631 : 190 : gfc_init_se (&se, NULL);
4632 : 190 : gfc_conv_expr (&se, expr);
4633 : 190 : se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4634 : 190 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
4635 : 190 : gfc_add_block_to_block (pre, &se.pre);
4636 : 190 : gfc_add_block_to_block (post, &se.post);
4637 : :
4638 : 190 : sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4639 : : }
4640 : 113329 : }
4641 : :
4642 : :
4643 : : /* Like gfc_apply_interface_mapping_to_expr, but applied to
4644 : : constructor C. */
4645 : :
4646 : : static void
4647 : 47 : gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4648 : : gfc_constructor_base base)
4649 : : {
4650 : 47 : gfc_constructor *c;
4651 : 428 : for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4652 : : {
4653 : 381 : gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4654 : 381 : if (c->iterator)
4655 : : {
4656 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4657 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4658 : 6 : gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4659 : : }
4660 : : }
4661 : 47 : }
4662 : :
4663 : :
4664 : : /* Like gfc_apply_interface_mapping_to_expr, but applied to
4665 : : reference REF. */
4666 : :
4667 : : static void
4668 : 13304 : gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4669 : : gfc_ref * ref)
4670 : : {
4671 : 13304 : int n;
4672 : :
4673 : 14712 : for (; ref; ref = ref->next)
4674 : 1408 : switch (ref->type)
4675 : : {
4676 : : case REF_ARRAY:
4677 : 2845 : for (n = 0; n < ref->u.ar.dimen; n++)
4678 : : {
4679 : 1615 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4680 : 1615 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4681 : 1615 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4682 : : }
4683 : : break;
4684 : :
4685 : : case REF_COMPONENT:
4686 : : case REF_INQUIRY:
4687 : : break;
4688 : :
4689 : 43 : case REF_SUBSTRING:
4690 : 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4691 : 43 : gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4692 : 43 : break;
4693 : : }
4694 : 13304 : }
4695 : :
4696 : :
4697 : : /* Convert intrinsic function calls into result expressions. */
4698 : :
4699 : : static bool
4700 : 2198 : gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4701 : : {
4702 : 2198 : gfc_symbol *sym;
4703 : 2198 : gfc_expr *new_expr;
4704 : 2198 : gfc_expr *arg1;
4705 : 2198 : gfc_expr *arg2;
4706 : 2198 : int d, dup;
4707 : :
4708 : 2198 : arg1 = expr->value.function.actual->expr;
4709 : 2198 : if (expr->value.function.actual->next)
4710 : 2077 : arg2 = expr->value.function.actual->next->expr;
4711 : : else
4712 : : arg2 = NULL;
4713 : :
4714 : 2198 : sym = arg1->symtree->n.sym;
4715 : :
4716 : 2198 : if (sym->attr.dummy)
4717 : : return false;
4718 : :
4719 : 2131 : new_expr = NULL;
4720 : :
4721 : 2131 : switch (expr->value.function.isym->id)
4722 : : {
4723 : 875 : case GFC_ISYM_LEN:
4724 : : /* TODO figure out why this condition is necessary. */
4725 : 875 : if (sym->attr.function
4726 : 43 : && (arg1->ts.u.cl->length == NULL
4727 : 42 : || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4728 : 42 : && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4729 : : return false;
4730 : :
4731 : 832 : new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4732 : 832 : break;
4733 : :
4734 : 277 : case GFC_ISYM_LEN_TRIM:
4735 : 277 : new_expr = gfc_copy_expr (arg1);
4736 : 277 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4737 : :
4738 : 277 : if (!new_expr)
4739 : : return false;
4740 : :
4741 : 277 : gfc_replace_expr (arg1, new_expr);
4742 : 277 : return true;
4743 : :
4744 : 564 : case GFC_ISYM_SIZE:
4745 : 564 : if (!sym->as || sym->as->rank == 0)
4746 : : return false;
4747 : :
4748 : 506 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4749 : : {
4750 : 336 : dup = mpz_get_si (arg2->value.integer);
4751 : 336 : d = dup - 1;
4752 : : }
4753 : : else
4754 : : {
4755 : 506 : dup = sym->as->rank;
4756 : 506 : d = 0;
4757 : : }
4758 : :
4759 : 518 : for (; d < dup; d++)
4760 : : {
4761 : 506 : gfc_expr *tmp;
4762 : :
4763 : 506 : if (!sym->as->upper[d] || !sym->as->lower[d])
4764 : : {
4765 : 494 : gfc_free_expr (new_expr);
4766 : 494 : return false;
4767 : : }
4768 : :
4769 : 12 : tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4770 : : gfc_get_int_expr (gfc_default_integer_kind,
4771 : : NULL, 1));
4772 : 12 : tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4773 : 12 : if (new_expr)
4774 : 0 : new_expr = gfc_multiply (new_expr, tmp);
4775 : : else
4776 : : new_expr = tmp;
4777 : : }
4778 : : break;
4779 : :
4780 : 44 : case GFC_ISYM_LBOUND:
4781 : 44 : case GFC_ISYM_UBOUND:
4782 : : /* TODO These implementations of lbound and ubound do not limit if
4783 : : the size < 0, according to F95's 13.14.53 and 13.14.113. */
4784 : :
4785 : 44 : if (!sym->as || sym->as->rank == 0)
4786 : : return false;
4787 : :
4788 : 44 : if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4789 : 38 : d = mpz_get_si (arg2->value.integer) - 1;
4790 : : else
4791 : : return false;
4792 : :
4793 : 38 : if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4794 : : {
4795 : 23 : if (sym->as->lower[d])
4796 : 23 : new_expr = gfc_copy_expr (sym->as->lower[d]);
4797 : : }
4798 : : else
4799 : : {
4800 : 15 : if (sym->as->upper[d])
4801 : 9 : new_expr = gfc_copy_expr (sym->as->upper[d]);
4802 : : }
4803 : : break;
4804 : :
4805 : : default:
4806 : : break;
4807 : : }
4808 : :
4809 : 1253 : gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4810 : 1253 : if (!new_expr)
4811 : : return false;
4812 : :
4813 : 113 : gfc_replace_expr (expr, new_expr);
4814 : 113 : return true;
4815 : : }
4816 : :
4817 : :
4818 : : static void
4819 : 24 : gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4820 : : gfc_interface_mapping * mapping)
4821 : : {
4822 : 24 : gfc_formal_arglist *f;
4823 : 24 : gfc_actual_arglist *actual;
4824 : :
4825 : 24 : actual = expr->value.function.actual;
4826 : 24 : f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4827 : :
4828 : 72 : for (; f && actual; f = f->next, actual = actual->next)
4829 : : {
4830 : 24 : if (!actual->expr)
4831 : 0 : continue;
4832 : :
4833 : 24 : gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4834 : : }
4835 : :
4836 : 24 : if (map_expr->symtree->n.sym->attr.dimension)
4837 : : {
4838 : 6 : int d;
4839 : 6 : gfc_array_spec *as;
4840 : :
4841 : 6 : as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4842 : :
4843 : 18 : for (d = 0; d < as->rank; d++)
4844 : : {
4845 : 6 : gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4846 : 6 : gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4847 : : }
4848 : :
4849 : 6 : expr->value.function.esym->as = as;
4850 : : }
4851 : :
4852 : 24 : if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4853 : : {
4854 : 0 : expr->value.function.esym->ts.u.cl->length
4855 : 0 : = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4856 : :
4857 : 0 : gfc_apply_interface_mapping_to_expr (mapping,
4858 : 0 : expr->value.function.esym->ts.u.cl->length);
4859 : : }
4860 : 24 : }
4861 : :
4862 : :
4863 : : /* EXPR is a copy of an expression that appeared in the interface
4864 : : associated with MAPPING. Walk it recursively looking for references to
4865 : : dummy arguments that MAPPING maps to actual arguments. Replace each such
4866 : : reference with a reference to the associated actual argument. */
4867 : :
4868 : : static void
4869 : 21645 : gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4870 : : gfc_expr * expr)
4871 : : {
4872 : 23174 : gfc_interface_sym_mapping *sym;
4873 : 23174 : gfc_actual_arglist *actual;
4874 : :
4875 : 23174 : if (!expr)
4876 : : return;
4877 : :
4878 : : /* Copying an expression does not copy its length, so do that here. */
4879 : 13304 : if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4880 : : {
4881 : 1871 : expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4882 : 1871 : gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4883 : : }
4884 : :
4885 : : /* Apply the mapping to any references. */
4886 : 13304 : gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4887 : :
4888 : : /* ...and to the expression's symbol, if it has one. */
4889 : : /* TODO Find out why the condition on expr->symtree had to be moved into
4890 : : the loop rather than being outside it, as originally. */
4891 : 32757 : for (sym = mapping->syms; sym; sym = sym->next)
4892 : 19453 : if (expr->symtree && sym->old == expr->symtree->n.sym)
4893 : : {
4894 : 2827 : if (sym->new_sym->n.sym->backend_decl)
4895 : 2783 : expr->symtree = sym->new_sym;
4896 : 44 : else if (sym->expr)
4897 : 44 : gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4898 : : }
4899 : :
4900 : : /* ...and to subexpressions in expr->value. */
4901 : 13304 : switch (expr->expr_type)
4902 : : {
4903 : : case EXPR_VARIABLE:
4904 : : case EXPR_CONSTANT:
4905 : : case EXPR_NULL:
4906 : : case EXPR_SUBSTRING:
4907 : : break;
4908 : :
4909 : 1529 : case EXPR_OP:
4910 : 1529 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4911 : 1529 : gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4912 : 1529 : break;
4913 : :
4914 : 2927 : case EXPR_FUNCTION:
4915 : 9378 : for (actual = expr->value.function.actual; actual; actual = actual->next)
4916 : 6451 : gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4917 : :
4918 : 2927 : if (expr->value.function.esym == NULL
4919 : 2616 : && expr->value.function.isym != NULL
4920 : 2616 : && expr->value.function.actual
4921 : 2615 : && expr->value.function.actual->expr
4922 : 2615 : && expr->value.function.actual->expr->symtree
4923 : 5125 : && gfc_map_intrinsic_function (expr, mapping))
4924 : : break;
4925 : :
4926 : 5961 : for (sym = mapping->syms; sym; sym = sym->next)
4927 : 3424 : if (sym->old == expr->value.function.esym)
4928 : : {
4929 : 24 : expr->value.function.esym = sym->new_sym->n.sym;
4930 : 24 : gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4931 : 24 : expr->value.function.esym->result = sym->new_sym->n.sym;
4932 : : }
4933 : : break;
4934 : :
4935 : 47 : case EXPR_ARRAY:
4936 : 47 : case EXPR_STRUCTURE:
4937 : 47 : gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4938 : 47 : break;
4939 : :
4940 : 0 : case EXPR_COMPCALL:
4941 : 0 : case EXPR_PPC:
4942 : 0 : case EXPR_UNKNOWN:
4943 : 0 : gcc_unreachable ();
4944 : : break;
4945 : : }
4946 : :
4947 : : return;
4948 : : }
4949 : :
4950 : :
4951 : : /* Evaluate interface expression EXPR using MAPPING. Store the result
4952 : : in SE. */
4953 : :
4954 : : void
4955 : 4732 : gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4956 : : gfc_se * se, gfc_expr * expr)
4957 : : {
4958 : 4732 : expr = gfc_copy_expr (expr);
4959 : 4732 : gfc_apply_interface_mapping_to_expr (mapping, expr);
4960 : 4732 : gfc_conv_expr (se, expr);
4961 : 4732 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
4962 : 4732 : gfc_free_expr (expr);
4963 : 4732 : }
4964 : :
4965 : :
4966 : : /* Returns a reference to a temporary array into which a component of
4967 : : an actual argument derived type array is copied and then returned
4968 : : after the function call. */
4969 : : void
4970 : 2172 : gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
4971 : : sym_intent intent, bool formal_ptr,
4972 : : const gfc_symbol *fsym, const char *proc_name,
4973 : : gfc_symbol *sym, bool check_contiguous)
4974 : : {
4975 : 2172 : gfc_se lse;
4976 : 2172 : gfc_se rse;
4977 : 2172 : gfc_ss *lss;
4978 : 2172 : gfc_ss *rss;
4979 : 2172 : gfc_loopinfo loop;
4980 : 2172 : gfc_loopinfo loop2;
4981 : 2172 : gfc_array_info *info;
4982 : 2172 : tree offset;
4983 : 2172 : tree tmp_index;
4984 : 2172 : tree tmp;
4985 : 2172 : tree base_type;
4986 : 2172 : tree size;
4987 : 2172 : stmtblock_t body;
4988 : 2172 : int n;
4989 : 2172 : int dimen;
4990 : 2172 : gfc_se work_se;
4991 : 2172 : gfc_se *parmse;
4992 : 2172 : bool pass_optional;
4993 : :
4994 : 2172 : pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
4995 : :
4996 : 2172 : if (pass_optional || check_contiguous)
4997 : : {
4998 : 1353 : gfc_init_se (&work_se, NULL);
4999 : 1353 : parmse = &work_se;
5000 : : }
5001 : : else
5002 : : parmse = se;
5003 : :
5004 : 2172 : if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
5005 : : {
5006 : : /* We will create a temporary array, so let us warn. */
5007 : 868 : char * msg;
5008 : :
5009 : 868 : if (fsym && proc_name)
5010 : 868 : msg = xasprintf ("An array temporary was created for argument "
5011 : 868 : "'%s' of procedure '%s'", fsym->name, proc_name);
5012 : : else
5013 : 0 : msg = xasprintf ("An array temporary was created");
5014 : :
5015 : 868 : tmp = build_int_cst (logical_type_node, 1);
5016 : 868 : gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
5017 : : &expr->where, msg);
5018 : 868 : free (msg);
5019 : : }
5020 : :
5021 : 2172 : gfc_init_se (&lse, NULL);
5022 : 2172 : gfc_init_se (&rse, NULL);
5023 : :
5024 : : /* Walk the argument expression. */
5025 : 2172 : rss = gfc_walk_expr (expr);
5026 : :
5027 : 2172 : gcc_assert (rss != gfc_ss_terminator);
5028 : :
5029 : : /* Initialize the scalarizer. */
5030 : 2172 : gfc_init_loopinfo (&loop);
5031 : 2172 : gfc_add_ss_to_loop (&loop, rss);
5032 : :
5033 : : /* Calculate the bounds of the scalarization. */
5034 : 2172 : gfc_conv_ss_startstride (&loop);
5035 : :
5036 : : /* Build an ss for the temporary. */
5037 : 2172 : if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
5038 : 150 : gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
5039 : :
5040 : 2172 : base_type = gfc_typenode_for_spec (&expr->ts);
5041 : 2172 : if (GFC_ARRAY_TYPE_P (base_type)
5042 : 2172 : || GFC_DESCRIPTOR_TYPE_P (base_type))
5043 : 0 : base_type = gfc_get_element_type (base_type);
5044 : :
5045 : 2172 : if (expr->ts.type == BT_CLASS)
5046 : 121 : base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
5047 : :
5048 : 3278 : loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
5049 : 1106 : ? expr->ts.u.cl->backend_decl
5050 : : : NULL),
5051 : : loop.dimen);
5052 : :
5053 : 2172 : parmse->string_length = loop.temp_ss->info->string_length;
5054 : :
5055 : : /* Associate the SS with the loop. */
5056 : 2172 : gfc_add_ss_to_loop (&loop, loop.temp_ss);
5057 : :
5058 : : /* Setup the scalarizing loops. */
5059 : 2172 : gfc_conv_loop_setup (&loop, &expr->where);
5060 : :
5061 : : /* Pass the temporary descriptor back to the caller. */
5062 : 2172 : info = &loop.temp_ss->info->data.array;
5063 : 2172 : parmse->expr = info->descriptor;
5064 : :
5065 : : /* Setup the gfc_se structures. */
5066 : 2172 : gfc_copy_loopinfo_to_se (&lse, &loop);
5067 : 2172 : gfc_copy_loopinfo_to_se (&rse, &loop);
5068 : :
5069 : 2172 : rse.ss = rss;
5070 : 2172 : lse.ss = loop.temp_ss;
5071 : 2172 : gfc_mark_ss_chain_used (rss, 1);
5072 : 2172 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5073 : :
5074 : : /* Start the scalarized loop body. */
5075 : 2172 : gfc_start_scalarized_body (&loop, &body);
5076 : :
5077 : : /* Translate the expression. */
5078 : 2172 : gfc_conv_expr (&rse, expr);
5079 : :
5080 : : /* Reset the offset for the function call since the loop
5081 : : is zero based on the data pointer. Note that the temp
5082 : : comes first in the loop chain since it is added second. */
5083 : 2172 : if (gfc_is_class_array_function (expr))
5084 : : {
5085 : 13 : tmp = loop.ss->loop_chain->info->data.array.descriptor;
5086 : 13 : gfc_conv_descriptor_offset_set (&loop.pre, tmp,
5087 : : gfc_index_zero_node);
5088 : : }
5089 : :
5090 : 2172 : gfc_conv_tmp_array_ref (&lse);
5091 : :
5092 : 2172 : if (intent != INTENT_OUT)
5093 : : {
5094 : 2129 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
5095 : 2129 : gfc_add_expr_to_block (&body, tmp);
5096 : 2129 : gcc_assert (rse.ss == gfc_ss_terminator);
5097 : 2129 : gfc_trans_scalarizing_loops (&loop, &body);
5098 : : }
5099 : : else
5100 : : {
5101 : : /* Make sure that the temporary declaration survives by merging
5102 : : all the loop declarations into the current context. */
5103 : 100 : for (n = 0; n < loop.dimen; n++)
5104 : : {
5105 : 57 : gfc_merge_block_scope (&body);
5106 : 57 : body = loop.code[loop.order[n]];
5107 : : }
5108 : 43 : gfc_merge_block_scope (&body);
5109 : : }
5110 : :
5111 : : /* Add the post block after the second loop, so that any
5112 : : freeing of allocated memory is done at the right time. */
5113 : 2172 : gfc_add_block_to_block (&parmse->pre, &loop.pre);
5114 : :
5115 : : /**********Copy the temporary back again.*********/
5116 : :
5117 : 2172 : gfc_init_se (&lse, NULL);
5118 : 2172 : gfc_init_se (&rse, NULL);
5119 : :
5120 : : /* Walk the argument expression. */
5121 : 2172 : lss = gfc_walk_expr (expr);
5122 : 2172 : rse.ss = loop.temp_ss;
5123 : 2172 : lse.ss = lss;
5124 : :
5125 : : /* Initialize the scalarizer. */
5126 : 2172 : gfc_init_loopinfo (&loop2);
5127 : 2172 : gfc_add_ss_to_loop (&loop2, lss);
5128 : :
5129 : 2172 : dimen = rse.ss->dimen;
5130 : :
5131 : : /* Skip the write-out loop for this case. */
5132 : 2172 : if (gfc_is_class_array_function (expr))
5133 : 13 : goto class_array_fcn;
5134 : :
5135 : : /* Calculate the bounds of the scalarization. */
5136 : 2159 : gfc_conv_ss_startstride (&loop2);
5137 : :
5138 : : /* Setup the scalarizing loops. */
5139 : 2159 : gfc_conv_loop_setup (&loop2, &expr->where);
5140 : :
5141 : 2159 : gfc_copy_loopinfo_to_se (&lse, &loop2);
5142 : 2159 : gfc_copy_loopinfo_to_se (&rse, &loop2);
5143 : :
5144 : 2159 : gfc_mark_ss_chain_used (lss, 1);
5145 : 2159 : gfc_mark_ss_chain_used (loop.temp_ss, 1);
5146 : :
5147 : : /* Declare the variable to hold the temporary offset and start the
5148 : : scalarized loop body. */
5149 : 2159 : offset = gfc_create_var (gfc_array_index_type, NULL);
5150 : 2159 : gfc_start_scalarized_body (&loop2, &body);
5151 : :
5152 : : /* Build the offsets for the temporary from the loop variables. The
5153 : : temporary array has lbounds of zero and strides of one in all
5154 : : dimensions, so this is very simple. The offset is only computed
5155 : : outside the innermost loop, so the overall transfer could be
5156 : : optimized further. */
5157 : 2159 : info = &rse.ss->info->data.array;
5158 : :
5159 : 2159 : tmp_index = gfc_index_zero_node;
5160 : 3445 : for (n = dimen - 1; n > 0; n--)
5161 : : {
5162 : 1286 : tree tmp_str;
5163 : 1286 : tmp = rse.loop->loopvar[n];
5164 : 1286 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5165 : : tmp, rse.loop->from[n]);
5166 : 1286 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5167 : : tmp, tmp_index);
5168 : :
5169 : 2572 : tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5170 : : gfc_array_index_type,
5171 : 1286 : rse.loop->to[n-1], rse.loop->from[n-1]);
5172 : 1286 : tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5173 : : gfc_array_index_type,
5174 : : tmp_str, gfc_index_one_node);
5175 : :
5176 : 1286 : tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5177 : : gfc_array_index_type, tmp, tmp_str);
5178 : : }
5179 : :
5180 : 4318 : tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5181 : : gfc_array_index_type,
5182 : 2159 : tmp_index, rse.loop->from[0]);
5183 : 2159 : gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5184 : :
5185 : 4318 : tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5186 : : gfc_array_index_type,
5187 : 2159 : rse.loop->loopvar[0], offset);
5188 : :
5189 : : /* Now use the offset for the reference. */
5190 : 2159 : tmp = build_fold_indirect_ref_loc (input_location,
5191 : : info->data);
5192 : 2159 : rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5193 : :
5194 : 2159 : if (expr->ts.type == BT_CHARACTER)
5195 : 1106 : rse.string_length = expr->ts.u.cl->backend_decl;
5196 : :
5197 : 2159 : gfc_conv_expr (&lse, expr);
5198 : :
5199 : 2159 : gcc_assert (lse.ss == gfc_ss_terminator);
5200 : :
5201 : 2159 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
5202 : 2159 : gfc_add_expr_to_block (&body, tmp);
5203 : :
5204 : : /* Generate the copying loops. */
5205 : 2159 : gfc_trans_scalarizing_loops (&loop2, &body);
5206 : :
5207 : : /* Wrap the whole thing up by adding the second loop to the post-block
5208 : : and following it by the post-block of the first loop. In this way,
5209 : : if the temporary needs freeing, it is done after use! */
5210 : 2159 : if (intent != INTENT_IN)
5211 : : {
5212 : 1166 : gfc_add_block_to_block (&parmse->post, &loop2.pre);
5213 : 1166 : gfc_add_block_to_block (&parmse->post, &loop2.post);
5214 : : }
5215 : :
5216 : 993 : class_array_fcn:
5217 : :
5218 : 2172 : gfc_add_block_to_block (&parmse->post, &loop.post);
5219 : :
5220 : 2172 : gfc_cleanup_loop (&loop);
5221 : 2172 : gfc_cleanup_loop (&loop2);
5222 : :
5223 : : /* Pass the string length to the argument expression. */
5224 : 2172 : if (expr->ts.type == BT_CHARACTER)
5225 : 1106 : parmse->string_length = expr->ts.u.cl->backend_decl;
5226 : :
5227 : : /* Determine the offset for pointer formal arguments and set the
5228 : : lbounds to one. */
5229 : 2172 : if (formal_ptr)
5230 : : {
5231 : 0 : size = gfc_index_one_node;
5232 : 0 : offset = gfc_index_zero_node;
5233 : 0 : for (n = 0; n < dimen; n++)
5234 : : {
5235 : 0 : tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5236 : : gfc_rank_cst[n]);
5237 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5238 : : gfc_array_index_type, tmp,
5239 : : gfc_index_one_node);
5240 : 0 : gfc_conv_descriptor_ubound_set (&parmse->pre,
5241 : : parmse->expr,
5242 : : gfc_rank_cst[n],
5243 : : tmp);
5244 : 0 : gfc_conv_descriptor_lbound_set (&parmse->pre,
5245 : : parmse->expr,
5246 : : gfc_rank_cst[n],
5247 : : gfc_index_one_node);
5248 : 0 : size = gfc_evaluate_now (size, &parmse->pre);
5249 : 0 : offset = fold_build2_loc (input_location, MINUS_EXPR,
5250 : : gfc_array_index_type,
5251 : : offset, size);
5252 : 0 : offset = gfc_evaluate_now (offset, &parmse->pre);
5253 : 0 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
5254 : : gfc_array_index_type,
5255 : 0 : rse.loop->to[n], rse.loop->from[n]);
5256 : 0 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
5257 : : gfc_array_index_type,
5258 : : tmp, gfc_index_one_node);
5259 : 0 : size = fold_build2_loc (input_location, MULT_EXPR,
5260 : : gfc_array_index_type, size, tmp);
5261 : : }
5262 : :
5263 : 0 : gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5264 : : offset);
5265 : : }
5266 : :
5267 : : /* We want either the address for the data or the address of the descriptor,
5268 : : depending on the mode of passing array arguments. */
5269 : 2172 : if (g77)
5270 : 377 : parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5271 : : else
5272 : 1795 : parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5273 : :
5274 : : /* Basically make this into
5275 : :
5276 : : if (present)
5277 : : {
5278 : : if (contiguous)
5279 : : {
5280 : : pointer = a;
5281 : : }
5282 : : else
5283 : : {
5284 : : parmse->pre();
5285 : : pointer = parmse->expr;
5286 : : }
5287 : : }
5288 : : else
5289 : : pointer = NULL;
5290 : :
5291 : : foo (pointer);
5292 : : if (present && !contiguous)
5293 : : se->post();
5294 : :
5295 : : */
5296 : :
5297 : 2172 : if (pass_optional || check_contiguous)
5298 : : {
5299 : 1353 : tree type;
5300 : 1353 : stmtblock_t else_block;
5301 : 1353 : tree pre_stmts, post_stmts;
5302 : 1353 : tree pointer;
5303 : 1353 : tree else_stmt;
5304 : 1353 : tree present_var = NULL_TREE;
5305 : 1353 : tree cont_var = NULL_TREE;
5306 : 1353 : tree post_cond;
5307 : :
5308 : 1353 : type = TREE_TYPE (parmse->expr);
5309 : 1353 : if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
5310 : 1021 : type = TREE_TYPE (type);
5311 : 1353 : pointer = gfc_create_var (type, "arg_ptr");
5312 : :
5313 : 1353 : if (check_contiguous)
5314 : : {
5315 : 1353 : gfc_se cont_se, array_se;
5316 : 1353 : stmtblock_t if_block, else_block;
5317 : 1353 : tree if_stmt, else_stmt;
5318 : 1353 : mpz_t size;
5319 : 1353 : bool size_set;
5320 : :
5321 : 1353 : cont_var = gfc_create_var (boolean_type_node, "contiguous");
5322 : :
5323 : : /* If the size is known to be one at compile-time, set
5324 : : cont_var to true unconditionally. This may look
5325 : : inelegant, but we're only doing this during
5326 : : optimization, so the statements will be optimized away,
5327 : : and this saves complexity here. */
5328 : :
5329 : 1353 : size_set = gfc_array_size (expr, &size);
5330 : 1353 : if (size_set && mpz_cmp_ui (size, 1) == 0)
5331 : : {
5332 : 36 : gfc_add_modify (&se->pre, cont_var,
5333 : : build_one_cst (boolean_type_node));
5334 : : }
5335 : : else
5336 : : {
5337 : : /* cont_var = is_contiguous (expr); . */
5338 : 1317 : gfc_init_se (&cont_se, parmse);
5339 : 1317 : gfc_conv_is_contiguous_expr (&cont_se, expr);
5340 : 1317 : gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5341 : 1317 : gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5342 : 1317 : gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5343 : : }
5344 : :
5345 : 1353 : if (size_set)
5346 : 1167 : mpz_clear (size);
5347 : :
5348 : : /* arrayse->expr = descriptor of a. */
5349 : 1353 : gfc_init_se (&array_se, se);
5350 : 1353 : gfc_conv_expr_descriptor (&array_se, expr);
5351 : 1353 : gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5352 : 1353 : gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5353 : :
5354 : : /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
5355 : 1353 : gfc_init_block (&if_block);
5356 : 1353 : if (GFC_DESCRIPTOR_TYPE_P (type))
5357 : 1021 : gfc_add_modify (&if_block, pointer, array_se.expr);
5358 : : else
5359 : : {
5360 : 332 : tmp = gfc_conv_array_data (array_se.expr);
5361 : 332 : tmp = fold_convert (type, tmp);
5362 : 332 : gfc_add_modify (&if_block, pointer, tmp);
5363 : : }
5364 : 1353 : if_stmt = gfc_finish_block (&if_block);
5365 : :
5366 : : /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5367 : 1353 : gfc_init_block (&else_block);
5368 : 1353 : gfc_add_block_to_block (&else_block, &parmse->pre);
5369 : 1353 : tmp = (GFC_DESCRIPTOR_TYPE_P (type)
5370 : 1353 : ? build_fold_indirect_ref_loc (input_location, parmse->expr)
5371 : : : parmse->expr);
5372 : 1353 : gfc_add_modify (&else_block, pointer, tmp);
5373 : 1353 : else_stmt = gfc_finish_block (&else_block);
5374 : :
5375 : : /* And put the above into an if statement. */
5376 : 1353 : pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5377 : : gfc_likely (cont_var,
5378 : : PRED_FORTRAN_CONTIGUOUS),
5379 : : if_stmt, else_stmt);
5380 : : }
5381 : : else
5382 : : {
5383 : : /* pointer = pramse->expr; . */
5384 : 0 : gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5385 : 0 : pre_stmts = gfc_finish_block (&parmse->pre);
5386 : : }
5387 : :
5388 : 1353 : if (pass_optional)
5389 : : {
5390 : 26 : present_var = gfc_create_var (boolean_type_node, "present");
5391 : :
5392 : : /* present_var = present(sym); . */
5393 : 26 : tmp = gfc_conv_expr_present (sym);
5394 : 26 : tmp = fold_convert (boolean_type_node, tmp);
5395 : 26 : gfc_add_modify (&se->pre, present_var, tmp);
5396 : :
5397 : : /* else_stmt = { pointer = NULL; } . */
5398 : 26 : gfc_init_block (&else_block);
5399 : 26 : if (GFC_DESCRIPTOR_TYPE_P (type))
5400 : 0 : gfc_conv_descriptor_data_set (&else_block, pointer,
5401 : : null_pointer_node);
5402 : : else
5403 : 26 : gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5404 : 26 : else_stmt = gfc_finish_block (&else_block);
5405 : :
5406 : 26 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5407 : : gfc_likely (present_var,
5408 : : PRED_FORTRAN_ABSENT_DUMMY),
5409 : : pre_stmts, else_stmt);
5410 : 26 : gfc_add_expr_to_block (&se->pre, tmp);
5411 : : }
5412 : : else
5413 : 1327 : gfc_add_expr_to_block (&se->pre, pre_stmts);
5414 : :
5415 : 1353 : post_stmts = gfc_finish_block (&parmse->post);
5416 : :
5417 : : /* Put together the post stuff, plus the optional
5418 : : deallocation. */
5419 : 1353 : if (check_contiguous)
5420 : : {
5421 : : /* !cont_var. */
5422 : 1353 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5423 : : cont_var,
5424 : : build_zero_cst (boolean_type_node));
5425 : 1353 : tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5426 : :
5427 : 1353 : if (pass_optional)
5428 : : {
5429 : 26 : tree present_likely = gfc_likely (present_var,
5430 : : PRED_FORTRAN_ABSENT_DUMMY);
5431 : 26 : post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5432 : : boolean_type_node, present_likely,
5433 : : tmp);
5434 : : }
5435 : : else
5436 : : post_cond = tmp;
5437 : : }
5438 : : else
5439 : : {
5440 : 0 : gcc_assert (pass_optional);
5441 : : post_cond = present_var;
5442 : : }
5443 : :
5444 : 1353 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5445 : : post_stmts, build_empty_stmt (input_location));
5446 : 1353 : gfc_add_expr_to_block (&se->post, tmp);
5447 : 1353 : if (GFC_DESCRIPTOR_TYPE_P (type))
5448 : : {
5449 : 1021 : type = TREE_TYPE (parmse->expr);
5450 : 1021 : if (POINTER_TYPE_P (type))
5451 : : {
5452 : 1021 : pointer = gfc_build_addr_expr (type, pointer);
5453 : 1021 : if (pass_optional)
5454 : : {
5455 : 0 : tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
5456 : 0 : pointer = fold_build3_loc (input_location, COND_EXPR, type,
5457 : : tmp, pointer,
5458 : : fold_convert (type,
5459 : : null_pointer_node));
5460 : : }
5461 : : }
5462 : : else
5463 : 0 : gcc_assert (!pass_optional);
5464 : : }
5465 : 1353 : se->expr = pointer;
5466 : : }
5467 : :
5468 : 2172 : return;
5469 : : }
5470 : :
5471 : :
5472 : : /* Generate the code for argument list functions. */
5473 : :
5474 : : static void
5475 : 4027 : conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5476 : : {
5477 : : /* Pass by value for g77 %VAL(arg), pass the address
5478 : : indirectly for %LOC, else by reference. Thus %REF
5479 : : is a "do-nothing" and %LOC is the same as an F95
5480 : : pointer. */
5481 : 4027 : if (strcmp (name, "%VAL") == 0)
5482 : 3955 : gfc_conv_expr (se, expr);
5483 : 72 : else if (strcmp (name, "%LOC") == 0)
5484 : : {
5485 : 36 : gfc_conv_expr_reference (se, expr);
5486 : 36 : se->expr = gfc_build_addr_expr (NULL, se->expr);
5487 : : }
5488 : 36 : else if (strcmp (name, "%REF") == 0)
5489 : 36 : gfc_conv_expr_reference (se, expr);
5490 : : else
5491 : 0 : gfc_error ("Unknown argument list function at %L", &expr->where);
5492 : 4027 : }
5493 : :
5494 : :
5495 : : /* This function tells whether the middle-end representation of the expression
5496 : : E given as input may point to data otherwise accessible through a variable
5497 : : (sub-)reference.
5498 : : It is assumed that the only expressions that may alias are variables,
5499 : : and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5500 : : may alias.
5501 : : This function is used to decide whether freeing an expression's allocatable
5502 : : components is safe or should be avoided.
5503 : :
5504 : : If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5505 : : its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5506 : : is necessary because for array constructors, aliasing depends on how
5507 : : the array is used:
5508 : : - If E is an array constructor used as argument to an elemental procedure,
5509 : : the array, which is generated through shallow copy by the scalarizer,
5510 : : is used directly and can alias the expressions it was copied from.
5511 : : - If E is an array constructor used as argument to a non-elemental
5512 : : procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5513 : : the array as in the previous case, but then that array is used
5514 : : to initialize a new descriptor through deep copy. There is no alias
5515 : : possible in that case.
5516 : : Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5517 : : above. */
5518 : :
5519 : : static bool
5520 : 6957 : expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5521 : : {
5522 : 6957 : gfc_constructor *c;
5523 : :
5524 : 6957 : if (e->expr_type == EXPR_VARIABLE)
5525 : : return true;
5526 : 344 : else if (e->expr_type == EXPR_FUNCTION)
5527 : : {
5528 : 138 : gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5529 : :
5530 : 138 : if (proc_ifc->result != NULL
5531 : 138 : && ((proc_ifc->result->ts.type == BT_CLASS
5532 : 25 : && proc_ifc->result->ts.u.derived->attr.is_class
5533 : 25 : && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
5534 : 138 : || proc_ifc->result->attr.pointer))
5535 : : return true;
5536 : : else
5537 : : return false;
5538 : : }
5539 : 206 : else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
5540 : : return false;
5541 : :
5542 : 54 : for (c = gfc_constructor_first (e->value.constructor);
5543 : 78 : c; c = gfc_constructor_next (c))
5544 : 54 : if (c->expr
5545 : 54 : && expr_may_alias_variables (c->expr, array_may_alias))
5546 : : return true;
5547 : :
5548 : : return false;
5549 : : }
5550 : :
5551 : :
5552 : : /* A helper function to set the dtype for unallocated or unassociated
5553 : : entities. */
5554 : :
5555 : : static void
5556 : 723 : set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
5557 : : {
5558 : 723 : tree tmp;
5559 : 723 : tree desc;
5560 : 723 : tree cond;
5561 : 723 : tree type;
5562 : 723 : stmtblock_t block;
5563 : :
5564 : : /* TODO Figure out how to handle optional dummies. */
5565 : 723 : if (e && e->expr_type == EXPR_VARIABLE
5566 : 723 : && e->symtree->n.sym->attr.optional)
5567 : 72 : return;
5568 : :
5569 : 651 : desc = parmse->expr;
5570 : 651 : if (desc == NULL_TREE)
5571 : : return;
5572 : :
5573 : 651 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
5574 : 651 : desc = build_fold_indirect_ref_loc (input_location, desc);
5575 : 651 : if (GFC_CLASS_TYPE_P (TREE_TYPE (desc)))
5576 : 192 : desc = gfc_class_data_get (desc);
5577 : 651 : if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5578 : : return;
5579 : :
5580 : 651 : gfc_init_block (&block);
5581 : 651 : tmp = gfc_conv_descriptor_data_get (desc);
5582 : 651 : cond = fold_build2_loc (input_location, EQ_EXPR,
5583 : : logical_type_node, tmp,
5584 : 651 : build_int_cst (TREE_TYPE (tmp), 0));
5585 : 651 : tmp = gfc_conv_descriptor_dtype (desc);
5586 : 651 : type = gfc_get_element_type (TREE_TYPE (desc));
5587 : 1302 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5588 : 651 : TREE_TYPE (tmp), tmp,
5589 : : gfc_get_dtype_rank_type (e->rank, type));
5590 : 651 : gfc_add_expr_to_block (&block, tmp);
5591 : 651 : cond = build3_v (COND_EXPR, cond,
5592 : : gfc_finish_block (&block),
5593 : : build_empty_stmt (input_location));
5594 : 651 : gfc_add_expr_to_block (&parmse->pre, cond);
5595 : : }
5596 : :
5597 : :
5598 : :
5599 : : /* Provide an interface between gfortran array descriptors and the F2018:18.4
5600 : : ISO_Fortran_binding array descriptors. */
5601 : :
5602 : : static void
5603 : 6536 : gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
5604 : : {
5605 : 6536 : stmtblock_t block, block2;
5606 : 6536 : tree cfi, gfc, tmp, tmp2;
5607 : 6536 : tree present = NULL;
5608 : 6536 : tree gfc_strlen = NULL;
5609 : 6536 : tree rank;
5610 : 6536 : gfc_se se;
5611 : :
5612 : 6536 : if (fsym->attr.optional
5613 : 1094 : && e->expr_type == EXPR_VARIABLE
5614 : 1094 : && e->symtree->n.sym->attr.optional)
5615 : 103 : present = gfc_conv_expr_present (e->symtree->n.sym);
5616 : :
5617 : 6536 : gfc_init_block (&block);
5618 : :
5619 : : /* Convert original argument to a tree. */
5620 : 6536 : gfc_init_se (&se, NULL);
5621 : 6536 : if (e->rank == 0)
5622 : : {
5623 : 686 : se.want_pointer = 1;
5624 : 686 : gfc_conv_expr (&se, e);
5625 : 686 : gfc = se.expr;
5626 : : /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
5627 : 686 : if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
5628 : 20 : gfc = gfc_build_addr_expr (NULL, gfc);
5629 : : }
5630 : : else
5631 : : {
5632 : : /* If the actual argument can be noncontiguous, copy-in/out is required,
5633 : : if the dummy has either the CONTIGUOUS attribute or is an assumed-
5634 : : length assumed-length/assumed-size CHARACTER array. This only
5635 : : applies if the actual argument is a "variable"; if it's some
5636 : : non-lvalue expression, we are going to evaluate it to a
5637 : : temporary below anyway. */
5638 : 5850 : se.force_no_tmp = 1;
5639 : 5850 : if ((fsym->attr.contiguous
5640 : 4769 : || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
5641 : 1375 : && (fsym->as->type == AS_ASSUMED_SIZE
5642 : 937 : || fsym->as->type == AS_EXPLICIT)))
5643 : 2023 : && !gfc_is_simply_contiguous (e, false, true)
5644 : 6877 : && gfc_expr_is_variable (e))
5645 : : {
5646 : 1021 : bool optional = fsym->attr.optional;
5647 : 1021 : fsym->attr.optional = 0;
5648 : 1021 : gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
5649 : 1021 : fsym->attr.pointer, fsym,
5650 : 1021 : fsym->ns->proc_name->name, NULL,
5651 : : /* check_contiguous= */ true);
5652 : 1021 : fsym->attr.optional = optional;
5653 : : }
5654 : : else
5655 : 4829 : gfc_conv_expr_descriptor (&se, e);
5656 : 5850 : gfc = se.expr;
5657 : : /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
5658 : : elem_len = sizeof(dt) and base_addr = dt(lb) instead.
5659 : : gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
5660 : : While sm is fine as it uses span*stride and not elem_len. */
5661 : 5850 : if (POINTER_TYPE_P (TREE_TYPE (gfc)))
5662 : 1021 : gfc = build_fold_indirect_ref_loc (input_location, gfc);
5663 : 4829 : else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
5664 : 12 : gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
5665 : : }
5666 : 6536 : if (e->ts.type == BT_CHARACTER)
5667 : : {
5668 : 3409 : if (se.string_length)
5669 : : gfc_strlen = se.string_length;
5670 : 883 : else if (e->ts.u.cl->backend_decl)
5671 : : gfc_strlen = e->ts.u.cl->backend_decl;
5672 : : else
5673 : 0 : gcc_unreachable ();
5674 : : }
5675 : 6536 : gfc_add_block_to_block (&block, &se.pre);
5676 : :
5677 : : /* Create array descriptor and set version, rank, attribute, type. */
5678 : 12767 : cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
5679 : : ? GFC_MAX_DIMENSIONS : e->rank,
5680 : : false), "cfi");
5681 : : /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
5682 : 6536 : if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
5683 : : {
5684 : 2338 : tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
5685 : 2338 : tmp = build_pointer_type (tmp);
5686 : 2338 : parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
5687 : 2338 : cfi = build_fold_indirect_ref_loc (input_location, cfi);
5688 : : }
5689 : : else
5690 : 4198 : parmse->expr = gfc_build_addr_expr (NULL, cfi);
5691 : :
5692 : 6536 : tmp = gfc_get_cfi_desc_version (cfi);
5693 : 6536 : gfc_add_modify (&block, tmp,
5694 : 6536 : build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
5695 : 6536 : if (e->rank < 0)
5696 : 305 : rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
5697 : : else
5698 : 6231 : rank = build_int_cst (signed_char_type_node, e->rank);
5699 : 6536 : tmp = gfc_get_cfi_desc_rank (cfi);
5700 : 6536 : gfc_add_modify (&block, tmp, rank);
5701 : 6536 : int itype = CFI_type_other;
5702 : 6536 : if (e->ts.f90_type == BT_VOID)
5703 : 96 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5704 : 96 : ? CFI_type_cfunptr : CFI_type_cptr);
5705 : : else
5706 : : {
5707 : 6440 : if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN)
5708 : 1 : e->ts = fsym->ts;
5709 : 6440 : switch (e->ts.type)
5710 : : {
5711 : 2296 : case BT_INTEGER:
5712 : 2296 : case BT_LOGICAL:
5713 : 2296 : case BT_REAL:
5714 : 2296 : case BT_COMPLEX:
5715 : 2296 : itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
5716 : 2296 : break;
5717 : 3410 : case BT_CHARACTER:
5718 : 3410 : itype = CFI_type_from_type_kind (CFI_type_Character, e->ts.kind);
5719 : 3410 : break;
5720 : : case BT_DERIVED:
5721 : 6536 : itype = CFI_type_struct;
5722 : : break;
5723 : 0 : case BT_VOID:
5724 : 0 : itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
5725 : 0 : ? CFI_type_cfunptr : CFI_type_cptr);
5726 : : break;
5727 : : case BT_ASSUMED:
5728 : : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
5729 : : break;
5730 : 1 : case BT_CLASS:
5731 : 1 : if (fsym->ts.type == BT_ASSUMED)
5732 : : {
5733 : : // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
5734 : : // type specifier is assumed-type and is an unlimited polymorphic
5735 : : // entity." The actual argument _data component is passed.
5736 : : itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
5737 : : break;
5738 : : }
5739 : : else
5740 : 0 : gcc_unreachable ();
5741 : 0 : case BT_PROCEDURE:
5742 : 0 : case BT_HOLLERITH:
5743 : 0 : case BT_UNION:
5744 : 0 : case BT_BOZ:
5745 : 0 : case BT_UNKNOWN:
5746 : : // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
5747 : 0 : gcc_unreachable ();
5748 : : }
5749 : : }
5750 : :
5751 : 6536 : tmp = gfc_get_cfi_desc_type (cfi);
5752 : 6536 : gfc_add_modify (&block, tmp,
5753 : 6536 : build_int_cst (TREE_TYPE (tmp), itype));
5754 : :
5755 : 6536 : int attr = CFI_attribute_other;
5756 : 6536 : if (fsym->attr.pointer)
5757 : : attr = CFI_attribute_pointer;
5758 : 5774 : else if (fsym->attr.allocatable)
5759 : 433 : attr = CFI_attribute_allocatable;
5760 : 6536 : tmp = gfc_get_cfi_desc_attribute (cfi);
5761 : 6536 : gfc_add_modify (&block, tmp,
5762 : 6536 : build_int_cst (TREE_TYPE (tmp), attr));
5763 : :
5764 : : /* The cfi-base_addr assignment could be skipped for 'pointer, intent(out)'.
5765 : : That is very sensible for undefined pointers, but the C code might assume
5766 : : that the pointer retains the value, in particular, if it was NULL. */
5767 : 6536 : if (e->rank == 0)
5768 : : {
5769 : 686 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5770 : 686 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
5771 : : }
5772 : : else
5773 : : {
5774 : 5850 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5775 : 5850 : tmp2 = gfc_conv_descriptor_data_get (gfc);
5776 : 5850 : gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
5777 : : }
5778 : :
5779 : : /* Set elem_len if known - must be before the next if block.
5780 : : Note that allocatable implies 'len=:'. */
5781 : 6536 : if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
5782 : : {
5783 : : /* Length is known at compile time; use 'block' for it. */
5784 : 3072 : tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
5785 : 3072 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5786 : 3072 : gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5787 : : }
5788 : :
5789 : 6536 : if (fsym->attr.pointer && fsym->attr.intent == INTENT_OUT)
5790 : 91 : goto done;
5791 : :
5792 : : /* When allocatable + intent out, free the cfi descriptor. */
5793 : 6445 : if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
5794 : : {
5795 : 90 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5796 : 90 : tree call = builtin_decl_explicit (BUILT_IN_FREE);
5797 : 90 : call = build_call_expr_loc (input_location, call, 1, tmp);
5798 : 90 : gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
5799 : 90 : gfc_add_modify (&block, tmp,
5800 : 90 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
5801 : 90 : goto done;
5802 : : }
5803 : :
5804 : : /* If not unallocated/unassociated. */
5805 : 6355 : gfc_init_block (&block2);
5806 : :
5807 : : /* Set elem_len, which may be only known at run time. */
5808 : 6355 : if (e->ts.type == BT_CHARACTER
5809 : 3410 : && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE))
5810 : : {
5811 : 3408 : gcc_assert (gfc_strlen);
5812 : 3409 : tmp = gfc_strlen;
5813 : 3409 : if (e->ts.kind != 1)
5814 : 1117 : tmp = fold_build2_loc (input_location, MULT_EXPR,
5815 : : gfc_charlen_type_node, tmp,
5816 : : build_int_cst (gfc_charlen_type_node,
5817 : 1117 : e->ts.kind));
5818 : 3409 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5819 : 3409 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5820 : : }
5821 : 2946 : else if (e->ts.type == BT_ASSUMED)
5822 : : {
5823 : 54 : tmp = gfc_conv_descriptor_elem_len (gfc);
5824 : 54 : tmp2 = gfc_get_cfi_desc_elem_len (cfi);
5825 : 54 : gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
5826 : : }
5827 : :
5828 : 6355 : if (e->ts.type == BT_ASSUMED)
5829 : : {
5830 : : /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
5831 : : an CFI descriptor. Use the type in the descriptor as it provide
5832 : : mode information. (Quality of implementation feature.) */
5833 : 54 : tree cond;
5834 : 54 : tree ctype = gfc_get_cfi_desc_type (cfi);
5835 : 54 : tree type = fold_convert (TREE_TYPE (ctype),
5836 : : gfc_conv_descriptor_type (gfc));
5837 : 54 : tree kind = fold_convert (TREE_TYPE (ctype),
5838 : : gfc_conv_descriptor_elem_len (gfc));
5839 : 54 : kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
5840 : 54 : kind, build_int_cst (TREE_TYPE (type),
5841 : 54 : CFI_type_kind_shift));
5842 : :
5843 : : /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
5844 : : /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
5845 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5846 : 54 : build_int_cst (TREE_TYPE (type), BT_VOID));
5847 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
5848 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_cptr));
5849 : 54 : tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5850 : : ctype,
5851 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_other));
5852 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5853 : : tmp, tmp2);
5854 : : /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
5855 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5856 : 54 : build_int_cst (TREE_TYPE (type), BT_DERIVED));
5857 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
5858 : 54 : build_int_cst (TREE_TYPE (type), CFI_type_struct));
5859 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5860 : : tmp, tmp2);
5861 : : /* if (BT_CHARACTER) CFI_type_Character + kind=1 else < tmp2 > */
5862 : : /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len*4. */
5863 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5864 : 54 : build_int_cst (TREE_TYPE (type), BT_CHARACTER));
5865 : 54 : tmp = build_int_cst (TREE_TYPE (type),
5866 : 54 : CFI_type_from_type_kind (CFI_type_Character, 1));
5867 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5868 : : ctype, tmp);
5869 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5870 : : tmp, tmp2);
5871 : : /* if (BT_COMPLEX) CFI_type_Complex + kind/2 else < tmp2 > */
5872 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5873 : 54 : build_int_cst (TREE_TYPE (type), BT_COMPLEX));
5874 : 54 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
5875 : 54 : kind, build_int_cst (TREE_TYPE (type), 2));
5876 : 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
5877 : 54 : build_int_cst (TREE_TYPE (type),
5878 : 54 : CFI_type_Complex));
5879 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5880 : : ctype, tmp);
5881 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5882 : : tmp, tmp2);
5883 : : /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
5884 : 54 : cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5885 : 54 : build_int_cst (TREE_TYPE (type), BT_INTEGER));
5886 : 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5887 : 54 : build_int_cst (TREE_TYPE (type), BT_LOGICAL));
5888 : 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
5889 : : cond, tmp);
5890 : 54 : tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
5891 : 54 : build_int_cst (TREE_TYPE (type), BT_REAL));
5892 : 54 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
5893 : : cond, tmp);
5894 : 54 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
5895 : : type, kind);
5896 : 54 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5897 : : ctype, tmp);
5898 : 54 : tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
5899 : : tmp, tmp2);
5900 : 54 : gfc_add_expr_to_block (&block2, tmp2);
5901 : : }
5902 : :
5903 : 6355 : if (e->rank != 0)
5904 : : {
5905 : : /* Loop: for (i = 0; i < rank; ++i). */
5906 : 5735 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
5907 : : /* Loop body. */
5908 : 5735 : stmtblock_t loop_body;
5909 : 5735 : gfc_init_block (&loop_body);
5910 : : /* cfi->dim[i].lower_bound = (allocatable/pointer)
5911 : : ? gfc->dim[i].lbound : 0 */
5912 : 5735 : if (fsym->attr.pointer || fsym->attr.allocatable)
5913 : 648 : tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
5914 : : else
5915 : 5087 : tmp = gfc_index_zero_node;
5916 : 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
5917 : : /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
5918 : 5735 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5919 : : gfc_conv_descriptor_ubound_get (gfc, idx),
5920 : : gfc_conv_descriptor_lbound_get (gfc, idx));
5921 : 5735 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5922 : : tmp, gfc_index_one_node);
5923 : 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
5924 : : /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
5925 : 5735 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5926 : : gfc_conv_descriptor_stride_get (gfc, idx),
5927 : : gfc_conv_descriptor_span_get (gfc));
5928 : 5735 : gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
5929 : :
5930 : : /* Generate loop. */
5931 : 5735 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
5932 : 5735 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
5933 : : gfc_finish_block (&loop_body));
5934 : :
5935 : 5735 : if (e->expr_type == EXPR_VARIABLE
5936 : 5573 : && e->ref
5937 : 5573 : && e->ref->u.ar.type == AR_FULL
5938 : 2732 : && e->symtree->n.sym->attr.dummy
5939 : 988 : && e->symtree->n.sym->as
5940 : 988 : && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
5941 : : {
5942 : 138 : tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
5943 : 138 : gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
5944 : : }
5945 : : }
5946 : :
5947 : 6355 : if (fsym->attr.allocatable || fsym->attr.pointer)
5948 : : {
5949 : 1014 : tmp = gfc_get_cfi_desc_base_addr (cfi),
5950 : 1014 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5951 : : tmp, null_pointer_node);
5952 : 1014 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
5953 : : build_empty_stmt (input_location));
5954 : 1014 : gfc_add_expr_to_block (&block, tmp);
5955 : : }
5956 : : else
5957 : 5341 : gfc_add_block_to_block (&block, &block2);
5958 : :
5959 : :
5960 : 6536 : done:
5961 : 6536 : if (present)
5962 : : {
5963 : 103 : parmse->expr = build3_loc (input_location, COND_EXPR,
5964 : 103 : TREE_TYPE (parmse->expr),
5965 : : present, parmse->expr, null_pointer_node);
5966 : 103 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
5967 : : build_empty_stmt (input_location));
5968 : 103 : gfc_add_expr_to_block (&parmse->pre, tmp);
5969 : : }
5970 : : else
5971 : 6433 : gfc_add_block_to_block (&parmse->pre, &block);
5972 : :
5973 : 6536 : gfc_init_block (&block);
5974 : :
5975 : 6536 : if ((!fsym->attr.allocatable && !fsym->attr.pointer)
5976 : 1195 : || fsym->attr.intent == INTENT_IN)
5977 : 5549 : goto post_call;
5978 : :
5979 : 987 : gfc_init_block (&block2);
5980 : 987 : if (e->rank == 0)
5981 : : {
5982 : 428 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5983 : 428 : gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
5984 : : }
5985 : : else
5986 : : {
5987 : 559 : tmp = gfc_get_cfi_desc_base_addr (cfi);
5988 : 559 : gfc_conv_descriptor_data_set (&block, gfc, tmp);
5989 : :
5990 : 559 : if (fsym->attr.allocatable)
5991 : : {
5992 : : /* gfc->span = cfi->elem_len. */
5993 : 252 : tmp = fold_convert (gfc_array_index_type,
5994 : : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
5995 : : }
5996 : : else
5997 : : {
5998 : : /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
5999 : : ? cfi->dim[0].sm : cfi->elem_len). */
6000 : 307 : tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
6001 : 307 : tmp2 = fold_convert (gfc_array_index_type,
6002 : : gfc_get_cfi_desc_elem_len (cfi));
6003 : 307 : tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
6004 : : gfc_array_index_type, tmp, tmp2);
6005 : 307 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6006 : : tmp, gfc_index_zero_node);
6007 : 307 : tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
6008 : : gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
6009 : : }
6010 : 559 : gfc_conv_descriptor_span_set (&block2, gfc, tmp);
6011 : :
6012 : : /* Calculate offset + set lbound, ubound and stride. */
6013 : 559 : gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
6014 : : /* Loop: for (i = 0; i < rank; ++i). */
6015 : 559 : tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
6016 : : /* Loop body. */
6017 : 559 : stmtblock_t loop_body;
6018 : 559 : gfc_init_block (&loop_body);
6019 : : /* gfc->dim[i].lbound = ... */
6020 : 559 : tmp = gfc_get_cfi_dim_lbound (cfi, idx);
6021 : 559 : gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
6022 : :
6023 : : /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
6024 : 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6025 : : gfc_conv_descriptor_lbound_get (gfc, idx),
6026 : : gfc_index_one_node);
6027 : 559 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6028 : : gfc_get_cfi_dim_extent (cfi, idx), tmp);
6029 : 559 : gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
6030 : :
6031 : : /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
6032 : 559 : tmp = gfc_get_cfi_dim_sm (cfi, idx);
6033 : 559 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6034 : : gfc_array_index_type, tmp,
6035 : : fold_convert (gfc_array_index_type,
6036 : : gfc_get_cfi_desc_elem_len (cfi)));
6037 : 559 : gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
6038 : :
6039 : : /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
6040 : 559 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6041 : : gfc_conv_descriptor_stride_get (gfc, idx),
6042 : : gfc_conv_descriptor_lbound_get (gfc, idx));
6043 : 559 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
6044 : : gfc_conv_descriptor_offset_get (gfc), tmp);
6045 : 559 : gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
6046 : : /* Generate loop. */
6047 : 559 : gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
6048 : 559 : rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
6049 : : gfc_finish_block (&loop_body));
6050 : : }
6051 : :
6052 : 987 : if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
6053 : : {
6054 : 60 : tmp = fold_convert (gfc_charlen_type_node,
6055 : : gfc_get_cfi_desc_elem_len (cfi));
6056 : 60 : if (e->ts.kind != 1)
6057 : 24 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
6058 : : gfc_charlen_type_node, tmp,
6059 : : build_int_cst (gfc_charlen_type_node,
6060 : 24 : e->ts.kind));
6061 : 60 : gfc_add_modify (&block2, gfc_strlen, tmp);
6062 : : }
6063 : :
6064 : 987 : tmp = gfc_get_cfi_desc_base_addr (cfi),
6065 : 987 : tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6066 : : tmp, null_pointer_node);
6067 : 987 : tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
6068 : : build_empty_stmt (input_location));
6069 : 987 : gfc_add_expr_to_block (&block, tmp);
6070 : :
6071 : 6536 : post_call:
6072 : 6536 : gfc_add_block_to_block (&block, &se.post);
6073 : 6536 : if (present && block.head)
6074 : : {
6075 : 6 : tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
6076 : : build_empty_stmt (input_location));
6077 : 6 : gfc_add_expr_to_block (&parmse->post, tmp);
6078 : : }
6079 : 6530 : else if (block.head)
6080 : 1558 : gfc_add_block_to_block (&parmse->post, &block);
6081 : 6536 : }
6082 : :
6083 : :
6084 : : /* Create "conditional temporary" to handle scalar dummy variables with the
6085 : : OPTIONAL+VALUE attribute that shall not be dereferenced. Use null value
6086 : : as fallback. Only instances of intrinsic basic type are supported. */
6087 : :
6088 : : static void
6089 : 186 : conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
6090 : : {
6091 : 186 : tree temp;
6092 : 186 : gcc_assert (e->ts.type != BT_DERIVED && e->ts.type != BT_CLASS);
6093 : 186 : gcc_assert (e->rank == 0);
6094 : 186 : temp = gfc_create_var (TREE_TYPE (parmse->expr), "condtemp");
6095 : 186 : TREE_STATIC (temp) = 1;
6096 : 186 : TREE_CONSTANT (temp) = 1;
6097 : 186 : TREE_READONLY (temp) = 1;
6098 : 186 : DECL_INITIAL (temp) = build_zero_cst (TREE_TYPE (temp));
6099 : 186 : parmse->expr = fold_build3_loc (input_location, COND_EXPR,
6100 : 186 : TREE_TYPE (parmse->expr),
6101 : : cond, parmse->expr, temp);
6102 : 186 : parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
6103 : 186 : }
6104 : :
6105 : :
6106 : : /* Helper function for the handling of (currently) scalar dummy variables
6107 : : with the VALUE attribute. Argument parmse should already be set up. */
6108 : : static void
6109 : 21499 : conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
6110 : : vec<tree, va_gc> *& optionalargs)
6111 : : {
6112 : 21499 : tree tmp;
6113 : :
6114 : 21499 : gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension);
6115 : :
6116 : : /* Absent actual argument for optional scalar dummy. */
6117 : 21499 : if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional)
6118 : : {
6119 : : /* For scalar arguments with VALUE attribute which are passed by
6120 : : value, pass "0" and a hidden argument for the optional status. */
6121 : 373 : if (fsym->ts.type == BT_CHARACTER)
6122 : : {
6123 : : /* Pass a NULL pointer for an absent CHARACTER arg and a length of
6124 : : zero. */
6125 : 90 : parmse->expr = null_pointer_node;
6126 : 90 : parmse->string_length = build_int_cst (gfc_charlen_type_node, 0);
6127 : : }
6128 : : else
6129 : 283 : parmse->expr = fold_convert (gfc_sym_type (fsym),
6130 : : integer_zero_node);
6131 : 373 : vec_safe_push (optionalargs, boolean_false_node);
6132 : :
6133 : 373 : return;
6134 : : }
6135 : :
6136 : : /* gfortran argument passing conventions:
6137 : : actual arguments to CHARACTER(len=1),VALUE
6138 : : dummy arguments are actually passed by value.
6139 : : Strings are truncated to length 1. */
6140 : 21126 : if (gfc_length_one_character_type_p (&fsym->ts))
6141 : : {
6142 : 390 : if (e->expr_type == EXPR_CONSTANT
6143 : 66 : && e->value.character.length > 1)
6144 : : {
6145 : 12 : e->value.character.length = 1;
6146 : 12 : gfc_conv_expr (parmse, e);
6147 : : }
6148 : :
6149 : 390 : tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
6150 : 390 : gfc_conv_string_parameter (parmse);
6151 : 390 : parmse->expr = gfc_string_to_single_character (slen1, parmse->expr,
6152 : : e->ts.kind);
6153 : : /* Truncate resulting string to length 1. */
6154 : 390 : parmse->string_length = slen1;
6155 : : }
6156 : :
6157 : 21126 : if (fsym->attr.optional
6158 : 604 : && fsym->ts.type != BT_CLASS
6159 : 604 : && fsym->ts.type != BT_DERIVED)
6160 : : {
6161 : : /* F2018:15.5.2.12 Argument presence and
6162 : : restrictions on arguments not present. */
6163 : 604 : if (e->expr_type == EXPR_VARIABLE
6164 : 479 : && e->rank == 0
6165 : 1029 : && (gfc_expr_attr (e).allocatable
6166 : 323 : || gfc_expr_attr (e).pointer))
6167 : : {
6168 : 186 : gfc_se argse;
6169 : 186 : tree cond;
6170 : 186 : gfc_init_se (&argse, NULL);
6171 : 186 : argse.want_pointer = 1;
6172 : 186 : gfc_conv_expr (&argse, e);
6173 : 186 : cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node);
6174 : 186 : cond = fold_build2_loc (input_location, NE_EXPR,
6175 : : logical_type_node,
6176 : : argse.expr, cond);
6177 : 372 : vec_safe_push (optionalargs,
6178 : 186 : fold_convert (boolean_type_node, cond));
6179 : : /* Create "conditional temporary". */
6180 : 186 : conv_cond_temp (parmse, e, cond);
6181 : : }
6182 : 418 : else if (e->expr_type != EXPR_VARIABLE
6183 : 293 : || !e->symtree->n.sym->attr.optional
6184 : 188 : || (e->ref != NULL && e->ref->type != REF_ARRAY))
6185 : 230 : vec_safe_push (optionalargs, boolean_true_node);
6186 : : else
6187 : : {
6188 : 188 : tmp = gfc_conv_expr_present (e->symtree->n.sym);
6189 : 188 : if (e->ts.type != BT_CHARACTER && !e->symtree->n.sym->attr.value)
6190 : 60 : parmse->expr
6191 : 120 : = fold_build3_loc (input_location, COND_EXPR,
6192 : 60 : TREE_TYPE (parmse->expr),
6193 : : tmp, parmse->expr,
6194 : 60 : fold_convert (TREE_TYPE (parmse->expr),
6195 : : integer_zero_node));
6196 : :
6197 : 376 : vec_safe_push (optionalargs,
6198 : 188 : fold_convert (boolean_type_node, tmp));
6199 : : }
6200 : : }
6201 : : }
6202 : :
6203 : :
6204 : :
6205 : : /* Generate code for a procedure call. Note can return se->post != NULL.
6206 : : If se->direct_byref is set then se->expr contains the return parameter.
6207 : : Return nonzero, if the call has alternate specifiers.
6208 : : 'expr' is only needed for procedure pointer components. */
6209 : :
6210 : : int
6211 : 119709 : gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
6212 : : gfc_actual_arglist * args, gfc_expr * expr,
6213 : : vec<tree, va_gc> *append_args)
6214 : : {
6215 : 119709 : gfc_interface_mapping mapping;
6216 : 119709 : vec<tree, va_gc> *arglist;
6217 : 119709 : vec<tree, va_gc> *retargs;
6218 : 119709 : tree tmp;
6219 : 119709 : tree fntype;
6220 : 119709 : gfc_se parmse;
6221 : 119709 : gfc_array_info *info;
6222 : 119709 : int byref;
6223 : 119709 : int parm_kind;
6224 : 119709 : tree type;
6225 : 119709 : tree var;
6226 : 119709 : tree len;
6227 : 119709 : tree base_object;
6228 : 119709 : vec<tree, va_gc> *stringargs;
6229 : 119709 : vec<tree, va_gc> *optionalargs;
6230 : 119709 : tree result = NULL;
6231 : 119709 : gfc_formal_arglist *formal;
6232 : 119709 : gfc_actual_arglist *arg;
6233 : 119709 : int has_alternate_specifier = 0;
6234 : 119709 : bool need_interface_mapping;
6235 : 119709 : bool callee_alloc;
6236 : 119709 : bool ulim_copy;
6237 : 119709 : gfc_typespec ts;
6238 : 119709 : gfc_charlen cl;
6239 : 119709 : gfc_expr *e;
6240 : 119709 : gfc_symbol *fsym;
6241 : 119709 : enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
6242 : 119709 : gfc_component *comp = NULL;
6243 : 119709 : int arglen;
6244 : 119709 : unsigned int argc;
6245 : :
6246 : 119709 : arglist = NULL;
6247 : 119709 : retargs = NULL;
6248 : 119709 : stringargs = NULL;
6249 : 119709 : optionalargs = NULL;
6250 : 119709 : var = NULL_TREE;
6251 : 119709 : len = NULL_TREE;
6252 : 119709 : gfc_clear_ts (&ts);
6253 : :
6254 : 119709 : comp = gfc_get_proc_ptr_comp (expr);
6255 : :
6256 : 239418 : bool elemental_proc = (comp
6257 : 1749 : && comp->ts.interface
6258 : 1704 : && comp->ts.interface->attr.elemental)
6259 : 1562 : || (comp && comp->attr.elemental)
6260 : 121271 : || sym->attr.elemental;
6261 : :
6262 : 119709 : if (se->ss != NULL)
6263 : : {
6264 : 21121 : if (!elemental_proc)
6265 : : {
6266 : 18460 : gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
6267 : 18460 : if (se->ss->info->useflags)
6268 : : {
6269 : 6380 : gcc_assert ((!comp && gfc_return_by_reference (sym)
6270 : : && sym->result->attr.dimension)
6271 : : || (comp && comp->attr.dimension)
6272 : : || gfc_is_class_array_function (expr));
6273 : 6380 : gcc_assert (se->loop != NULL);
6274 : : /* Access the previously obtained result. */
6275 : 6380 : gfc_conv_tmp_array_ref (se);
6276 : 6380 : return 0;
6277 : : }
6278 : : }
6279 : 14741 : info = &se->ss->info->data.array;
6280 : : }
6281 : : else
6282 : : info = NULL;
6283 : :
6284 : 113329 : stmtblock_t post, clobbers, dealloc_blk;
6285 : 113329 : gfc_init_block (&post);
6286 : 113329 : gfc_init_block (&clobbers);
6287 : 113329 : gfc_init_block (&dealloc_blk);
6288 : 113329 : gfc_init_interface_mapping (&mapping);
6289 : 113329 : if (!comp)
6290 : : {
6291 : 111628 : formal = gfc_sym_get_dummy_args (sym);
6292 : 111628 : need_interface_mapping = sym->attr.dimension ||
6293 : 99762 : (sym->ts.type == BT_CHARACTER
6294 : 2759 : && sym->ts.u.cl->length
6295 : 2302 : && sym->ts.u.cl->length->expr_type
6296 : : != EXPR_CONSTANT);
6297 : : }
6298 : : else
6299 : : {
6300 : 1701 : formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
6301 : 1701 : need_interface_mapping = comp->attr.dimension ||
6302 : 1640 : (comp->ts.type == BT_CHARACTER
6303 : 67 : && comp->ts.u.cl->length
6304 : 58 : && comp->ts.u.cl->length->expr_type
6305 : : != EXPR_CONSTANT);
6306 : : }
6307 : :
6308 : 113329 : base_object = NULL_TREE;
6309 : : /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
6310 : : is the third and fourth argument to such a function call a value
6311 : : denoting the number of elements to copy (i.e., most of the time the
6312 : : length of a deferred length string). */
6313 : 226658 : ulim_copy = (formal == NULL)
6314 : 26875 : && UNLIMITED_POLY (sym)
6315 : 113366 : && comp && (strcmp ("_copy", comp->name) == 0);
6316 : :
6317 : : /* Scan for allocatable actual arguments passed to allocatable dummy
6318 : : arguments with INTENT(OUT). As the corresponding actual arguments are
6319 : : deallocated before execution of the procedure, we evaluate actual
6320 : : argument expressions to avoid problems with possible dependencies. */
6321 : 113329 : bool force_eval_args = false;
6322 : 113329 : gfc_formal_arglist *tmp_formal;
6323 : 353303 : for (arg = args, tmp_formal = formal; arg != NULL;
6324 : 206946 : arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
6325 : : {
6326 : 240461 : e = arg->expr;
6327 : 240461 : fsym = tmp_formal ? tmp_formal->sym : NULL;
6328 : 231471 : if (e && fsym
6329 : 199726 : && e->expr_type == EXPR_VARIABLE
6330 : 85894 : && fsym->attr.intent == INTENT_OUT
6331 : 5558 : && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
6332 : 5558 : ? CLASS_DATA (fsym)->attr.allocatable
6333 : 4300 : : fsym->attr.allocatable)
6334 : 487 : && e->symtree
6335 : 487 : && e->symtree->n.sym
6336 : 471932 : && gfc_variable_attr (e, NULL).allocatable)
6337 : : {
6338 : : force_eval_args = true;
6339 : : break;
6340 : : }
6341 : : }
6342 : :
6343 : : /* Evaluate the arguments. */
6344 : 354180 : for (arg = args, argc = 0; arg != NULL;
6345 : 240851 : arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
6346 : : {
6347 : 240851 : bool finalized = false;
6348 : 240851 : tree derived_array = NULL_TREE;
6349 : :
6350 : 240851 : e = arg->expr;
6351 : 240851 : fsym = formal ? formal->sym : NULL;
6352 : 448674 : parm_kind = MISSING;
6353 : :
6354 : : /* If the procedure requires an explicit interface, the actual
6355 : : argument is passed according to the corresponding formal
6356 : : argument. If the corresponding formal argument is a POINTER,
6357 : : ALLOCATABLE or assumed shape, we do not use g77's calling
6358 : : convention, and pass the address of the array descriptor
6359 : : instead. Otherwise we use g77's calling convention, in other words
6360 : : pass the array data pointer without descriptor. */
6361 : 448674 : bool nodesc_arg = fsym != NULL
6362 : 207770 : && !(fsym->attr.pointer || fsym->attr.allocatable)
6363 : 200059 : && fsym->as
6364 : 33969 : && fsym->as->type != AS_ASSUMED_SHAPE
6365 : 229070 : && fsym->as->type != AS_ASSUMED_RANK;
6366 : 240851 : if (comp)
6367 : 2592 : nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
6368 : : else
6369 : 238259 : nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
6370 : :
6371 : : /* Class array expressions are sometimes coming completely unadorned
6372 : : with either arrayspec or _data component. Correct that here.
6373 : : OOP-TODO: Move this to the frontend. */
6374 : 240851 : if (e && e->expr_type == EXPR_VARIABLE
6375 : 99944 : && !e->ref
6376 : 47470 : && e->ts.type == BT_CLASS
6377 : 2434 : && (CLASS_DATA (e)->attr.codimension
6378 : 2434 : || CLASS_DATA (e)->attr.dimension))
6379 : : {
6380 : 0 : gfc_typespec temp_ts = e->ts;
6381 : 0 : gfc_add_class_array_ref (e);
6382 : 0 : e->ts = temp_ts;
6383 : : }
6384 : :
6385 : 240851 : if (e == NULL
6386 : 231855 : || (e->expr_type == EXPR_NULL
6387 : 331 : && fsym
6388 : : && fsym->attr.value
6389 : : && fsym->attr.optional
6390 : 331 : && !fsym->attr.dimension
6391 : 72 : && fsym->ts.type != BT_DERIVED
6392 : 72 : && fsym->ts.type != BT_CLASS))
6393 : : {
6394 : 9068 : if (se->ignore_optional)
6395 : : {
6396 : : /* Some intrinsics have already been resolved to the correct
6397 : : parameters. */
6398 : 386 : continue;
6399 : : }
6400 : 8906 : else if (arg->label)
6401 : : {
6402 : 224 : has_alternate_specifier = 1;
6403 : 224 : continue;
6404 : : }
6405 : : else
6406 : : {
6407 : 8682 : gfc_init_se (&parmse, NULL);
6408 : :
6409 : : /* For scalar arguments with VALUE attribute which are passed by
6410 : : value, pass "0" and a hidden argument gives the optional
6411 : : status. */
6412 : 8682 : if (fsym && fsym->attr.optional && fsym->attr.value
6413 : 7732 : && !fsym->attr.dimension && fsym->ts.type != BT_CLASS
6414 : 373 : && !gfc_bt_struct (sym->ts.type))
6415 : : {
6416 : 373 : conv_dummy_value (&parmse, e, fsym, optionalargs);
6417 : : }
6418 : : else
6419 : : {
6420 : : /* Pass a NULL pointer for an absent arg. */
6421 : 8309 : parmse.expr = null_pointer_node;
6422 : 8309 : gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
6423 : 8309 : if (dummy_arg
6424 : 8309 : && gfc_dummy_arg_get_typespec (*dummy_arg).type
6425 : : == BT_CHARACTER)
6426 : 1115 : parmse.string_length = build_int_cst (gfc_charlen_type_node,
6427 : 1115 : 0);
6428 : : }
6429 : : }
6430 : : }
6431 : 231783 : else if (arg->expr->expr_type == EXPR_NULL
6432 : 259 : && fsym && !fsym->attr.pointer
6433 : 163 : && (fsym->ts.type != BT_CLASS
6434 : 6 : || !CLASS_DATA (fsym)->attr.class_pointer))
6435 : : {
6436 : : /* Pass a NULL pointer to denote an absent arg. */
6437 : 163 : gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
6438 : : && (fsym->ts.type != BT_CLASS
6439 : : || !CLASS_DATA (fsym)->attr.allocatable));
6440 : 163 : gfc_init_se (&parmse, NULL);
6441 : 163 : parmse.expr = null_pointer_node;
6442 : 163 : if (arg->associated_dummy
6443 : 163 : && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
6444 : : == BT_CHARACTER)
6445 : 42 : parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
6446 : : }
6447 : 231620 : else if (fsym && fsym->ts.type == BT_CLASS
6448 : 9713 : && e->ts.type == BT_DERIVED)
6449 : : {
6450 : : /* The derived type needs to be converted to a temporary
6451 : : CLASS object. */
6452 : 3852 : gfc_init_se (&parmse, se);
6453 : 3852 : gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
6454 : 3852 : fsym->attr.optional
6455 : 1008 : && e->expr_type == EXPR_VARIABLE
6456 : 1008 : && e->symtree->n.sym->attr.optional,
6457 : 3852 : CLASS_DATA (fsym)->attr.class_pointer
6458 : 3852 : || CLASS_DATA (fsym)->attr.allocatable,
6459 : : &derived_array);
6460 : : }
6461 : 196023 : else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
6462 : 744 : && e->ts.type != BT_PROCEDURE
6463 : 732 : && (gfc_expr_attr (e).flavor != FL_PROCEDURE
6464 : 12 : || gfc_expr_attr (e).proc != PROC_UNKNOWN))
6465 : : {
6466 : : /* The intrinsic type needs to be converted to a temporary
6467 : : CLASS object for the unlimited polymorphic formal. */
6468 : 732 : gfc_find_vtab (&e->ts);
6469 : 732 : gfc_init_se (&parmse, se);
6470 : 732 : gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
6471 : :
6472 : : }
6473 : 227036 : else if (se->ss && se->ss->info->useflags)
6474 : : {
6475 : 4572 : gfc_ss *ss;
6476 : :
6477 : 4572 : ss = se->ss;
6478 : :
6479 : : /* An elemental function inside a scalarized loop. */
6480 : 4572 : gfc_init_se (&parmse, se);
6481 : 4572 : parm_kind = ELEMENTAL;
6482 : :
6483 : : /* When no fsym is present, ulim_copy is set and this is a third or
6484 : : fourth argument, use call-by-value instead of by reference to
6485 : : hand the length properties to the copy routine (i.e., most of the
6486 : : time this will be a call to a __copy_character_* routine where the
6487 : : third and fourth arguments are the lengths of a deferred length
6488 : : char array). */
6489 : 4572 : if ((fsym && fsym->attr.value)
6490 : 4410 : || (ulim_copy && (argc == 2 || argc == 3)))
6491 : 162 : gfc_conv_expr (&parmse, e);
6492 : : else
6493 : 4410 : gfc_conv_expr_reference (&parmse, e);
6494 : :
6495 : 4572 : if (e->ts.type == BT_CHARACTER && !e->rank
6496 : 174 : && e->expr_type == EXPR_FUNCTION)
6497 : 12 : parmse.expr = build_fold_indirect_ref_loc (input_location,
6498 : : parmse.expr);
6499 : :
6500 : 4534 : if (fsym && fsym->ts.type == BT_DERIVED
6501 : 5822 : && gfc_is_class_container_ref (e))
6502 : : {
6503 : 24 : parmse.expr = gfc_class_data_get (parmse.expr);
6504 : :
6505 : 24 : if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
6506 : 24 : && e->symtree->n.sym->attr.optional)
6507 : : {
6508 : 0 : tree cond = gfc_conv_expr_present (e->symtree->n.sym);
6509 : 0 : parmse.expr = build3_loc (input_location, COND_EXPR,
6510 : 0 : TREE_TYPE (parmse.expr),
6511 : : cond, parmse.expr,
6512 : 0 : fold_convert (TREE_TYPE (parmse.expr),
6513 : : null_pointer_node));
6514 : : }
6515 : : }
6516 : :
6517 : : /* Scalar dummy arguments of intrinsic type with VALUE attribute. */
6518 : 4572 : if (fsym
6519 : 4534 : && fsym->attr.value
6520 : 162 : && fsym->ts.type != BT_DERIVED
6521 : 162 : && fsym->ts.type != BT_CLASS)
6522 : 162 : conv_dummy_value (&parmse, e, fsym, optionalargs);
6523 : :
6524 : : /* If we are passing an absent array as optional dummy to an
6525 : : elemental procedure, make sure that we pass NULL when the data
6526 : : pointer is NULL. We need this extra conditional because of
6527 : : scalarization which passes arrays elements to the procedure,
6528 : : ignoring the fact that the array can be absent/unallocated/... */
6529 : 4410 : else if (ss->info->can_be_null_ref
6530 : 413 : && ss->info->type != GFC_SS_REFERENCE)
6531 : : {
6532 : 191 : tree descriptor_data;
6533 : :
6534 : 191 : descriptor_data = ss->info->data.array.data;
6535 : 191 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
6536 : : descriptor_data,
6537 : 191 : fold_convert (TREE_TYPE (descriptor_data),
6538 : : null_pointer_node));
6539 : 191 : parmse.expr
6540 : 382 : = fold_build3_loc (input_location, COND_EXPR,
6541 : 191 : TREE_TYPE (parmse.expr),
6542 : : gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
6543 : 191 : fold_convert (TREE_TYPE (parmse.expr),
6544 : : null_pointer_node),
6545 : : parmse.expr);
6546 : : }
6547 : :
6548 : : /* The scalarizer does not repackage the reference to a class
6549 : : array - instead it returns a pointer to the data element. */
6550 : 4572 : if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
6551 : 156 : gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
6552 : 156 : fsym->attr.intent != INTENT_IN
6553 : 156 : && (CLASS_DATA (fsym)->attr.class_pointer
6554 : : || CLASS_DATA (fsym)->attr.allocatable),
6555 : 156 : fsym->attr.optional
6556 : 0 : && e->expr_type == EXPR_VARIABLE
6557 : 0 : && e->symtree->n.sym->attr.optional,
6558 : 156 : CLASS_DATA (fsym)->attr.class_pointer
6559 : 156 : || CLASS_DATA (fsym)->attr.allocatable);
6560 : : }
6561 : : else
6562 : : {
6563 : 222464 : bool scalar;
6564 : 222464 : gfc_ss *argss;
6565 : :
6566 : 222464 : gfc_init_se (&parmse, NULL);
6567 : :
6568 : : /* Check whether the expression is a scalar or not; we cannot use
6569 : : e->rank as it can be nonzero for functions arguments. */
6570 : 222464 : argss = gfc_walk_expr (e);
6571 : 222464 : scalar = argss == gfc_ss_terminator;
6572 : 222464 : if (!scalar)
6573 : 49651 : gfc_free_ss_chain (argss);
6574 : :
6575 : : /* Special handling for passing scalar polymorphic coarrays;
6576 : : otherwise one passes "class->_data.data" instead of "&class". */
6577 : 222464 : if (e->rank == 0 && e->ts.type == BT_CLASS
6578 : 3342 : && fsym && fsym->ts.type == BT_CLASS
6579 : 2932 : && CLASS_DATA (fsym)->attr.codimension
6580 : 2932 : && !CLASS_DATA (fsym)->attr.dimension)
6581 : : {
6582 : 47 : gfc_add_class_array_ref (e);
6583 : 47 : parmse.want_coarray = 1;
6584 : 47 : scalar = false;
6585 : : }
6586 : :
6587 : : /* A scalar or transformational function. */
6588 : 222464 : if (scalar)
6589 : : {
6590 : 172766 : if (e->expr_type == EXPR_VARIABLE
6591 : 51011 : && e->symtree->n.sym->attr.cray_pointee
6592 : 378 : && fsym && fsym->attr.flavor == FL_PROCEDURE)
6593 : : {
6594 : : /* The Cray pointer needs to be converted to a pointer to
6595 : : a type given by the expression. */
6596 : 6 : gfc_conv_expr (&parmse, e);
6597 : 6 : type = build_pointer_type (TREE_TYPE (parmse.expr));
6598 : 6 : tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
6599 : 6 : parmse.expr = convert (type, tmp);
6600 : : }
6601 : :
6602 : 172760 : else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
6603 : : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
6604 : 686 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
6605 : :
6606 : 172074 : else if (fsym && fsym->attr.value)
6607 : : {
6608 : 21135 : if (fsym->ts.type == BT_CHARACTER
6609 : 537 : && fsym->ts.is_c_interop
6610 : 180 : && fsym->ns->proc_name != NULL
6611 : 180 : && fsym->ns->proc_name->attr.is_bind_c)
6612 : : {
6613 : 171 : parmse.expr = NULL;
6614 : 171 : conv_scalar_char_value (fsym, &parmse, &e);
6615 : 171 : if (parmse.expr == NULL)
6616 : 165 : gfc_conv_expr (&parmse, e);
6617 : : }
6618 : : else
6619 : : {
6620 : 20964 : gfc_conv_expr (&parmse, e);
6621 : 20964 : conv_dummy_value (&parmse, e, fsym, optionalargs);
6622 : : }
6623 : : }
6624 : :
6625 : 150939 : else if (arg->name && arg->name[0] == '%')
6626 : : /* Argument list functions %VAL, %LOC and %REF are signalled
6627 : : through arg->name. */
6628 : 4027 : conv_arglist_function (&parmse, arg->expr, arg->name);
6629 : 146912 : else if ((e->expr_type == EXPR_FUNCTION)
6630 : 8029 : && ((e->value.function.esym
6631 : 2055 : && e->value.function.esym->result->attr.pointer)
6632 : 7929 : || (!e->value.function.esym
6633 : 5974 : && e->symtree->n.sym->attr.pointer))
6634 : 100 : && fsym && fsym->attr.target)
6635 : : /* Make sure the function only gets called once. */
6636 : 8 : gfc_conv_expr_reference (&parmse, e);
6637 : 146904 : else if (e->expr_type == EXPR_FUNCTION
6638 : 8021 : && e->symtree->n.sym->result
6639 : 6994 : && e->symtree->n.sym->result != e->symtree->n.sym
6640 : 141 : && e->symtree->n.sym->result->attr.proc_pointer)
6641 : : {
6642 : : /* Functions returning procedure pointers. */
6643 : 18 : gfc_conv_expr (&parmse, e);
6644 : 18 : if (fsym && fsym->attr.proc_pointer)
6645 : 6 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6646 : : }
6647 : :
6648 : : else
6649 : : {
6650 : 146886 : bool defer_to_dealloc_blk = false;
6651 : 146886 : if (e->ts.type == BT_CLASS && fsym
6652 : 3283 : && fsym->ts.type == BT_CLASS
6653 : 2873 : && (!CLASS_DATA (fsym)->as
6654 : 356 : || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
6655 : 2517 : && CLASS_DATA (e)->attr.codimension)
6656 : : {
6657 : 48 : gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
6658 : 48 : gcc_assert (!CLASS_DATA (fsym)->as);
6659 : 48 : gfc_add_class_array_ref (e);
6660 : 48 : parmse.want_coarray = 1;
6661 : 48 : gfc_conv_expr_reference (&parmse, e);
6662 : 48 : class_scalar_coarray_to_class (&parmse, e, fsym->ts,
6663 : 48 : fsym->attr.optional
6664 : 48 : && e->expr_type == EXPR_VARIABLE);
6665 : : }
6666 : 146838 : else if (e->ts.type == BT_CLASS && fsym
6667 : 3235 : && fsym->ts.type == BT_CLASS
6668 : 2825 : && !CLASS_DATA (fsym)->as
6669 : 2469 : && !CLASS_DATA (e)->as
6670 : 2359 : && strcmp (fsym->ts.u.derived->name,
6671 : : e->ts.u.derived->name))
6672 : : {
6673 : 1537 : type = gfc_typenode_for_spec (&fsym->ts);
6674 : 1537 : var = gfc_create_var (type, fsym->name);
6675 : 1537 : gfc_conv_expr (&parmse, e);
6676 : 1537 : if (fsym->attr.optional
6677 : 153 : && e->expr_type == EXPR_VARIABLE
6678 : 153 : && e->symtree->n.sym->attr.optional)
6679 : : {
6680 : 66 : stmtblock_t block;
6681 : 66 : tree cond;
6682 : 66 : tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6683 : 66 : cond = fold_build2_loc (input_location, NE_EXPR,
6684 : : logical_type_node, tmp,
6685 : 66 : fold_convert (TREE_TYPE (tmp),
6686 : : null_pointer_node));
6687 : 66 : gfc_start_block (&block);
6688 : 66 : gfc_add_modify (&block, var,
6689 : : fold_build1_loc (input_location,
6690 : : VIEW_CONVERT_EXPR,
6691 : : type, parmse.expr));
6692 : 66 : gfc_add_expr_to_block (&parmse.pre,
6693 : : fold_build3_loc (input_location,
6694 : : COND_EXPR, void_type_node,
6695 : : cond, gfc_finish_block (&block),
6696 : : build_empty_stmt (input_location)));
6697 : 66 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6698 : 132 : parmse.expr = build3_loc (input_location, COND_EXPR,
6699 : 66 : TREE_TYPE (parmse.expr),
6700 : : cond, parmse.expr,
6701 : 66 : fold_convert (TREE_TYPE (parmse.expr),
6702 : : null_pointer_node));
6703 : 66 : }
6704 : : else
6705 : : {
6706 : : /* Since the internal representation of unlimited
6707 : : polymorphic expressions includes an extra field
6708 : : that other class objects do not, a cast to the
6709 : : formal type does not work. */
6710 : 1471 : if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
6711 : : {
6712 : 89 : tree efield;
6713 : :
6714 : : /* Evaluate arguments just once. */
6715 : 89 : if (e->expr_type != EXPR_VARIABLE)
6716 : 24 : parmse.expr = save_expr (parmse.expr);
6717 : :
6718 : : /* Set the _data field. */
6719 : 89 : tmp = gfc_class_data_get (var);
6720 : 89 : efield = fold_convert (TREE_TYPE (tmp),
6721 : : gfc_class_data_get (parmse.expr));
6722 : 89 : gfc_add_modify (&parmse.pre, tmp, efield);
6723 : :
6724 : : /* Set the _vptr field. */
6725 : 89 : tmp = gfc_class_vptr_get (var);
6726 : 89 : efield = fold_convert (TREE_TYPE (tmp),
6727 : : gfc_class_vptr_get (parmse.expr));
6728 : 89 : gfc_add_modify (&parmse.pre, tmp, efield);
6729 : :
6730 : : /* Set the _len field. */
6731 : 89 : tmp = gfc_class_len_get (var);
6732 : 89 : gfc_add_modify (&parmse.pre, tmp,
6733 : 89 : build_int_cst (TREE_TYPE (tmp), 0));
6734 : 89 : }
6735 : : else
6736 : : {
6737 : 1382 : tmp = fold_build1_loc (input_location,
6738 : : VIEW_CONVERT_EXPR,
6739 : : type, parmse.expr);
6740 : 1382 : gfc_add_modify (&parmse.pre, var, tmp);
6741 : 1471 : ;
6742 : : }
6743 : 1471 : parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6744 : : }
6745 : : }
6746 : : else
6747 : : {
6748 : 145301 : gfc_conv_expr_reference (&parmse, e);
6749 : :
6750 : 145301 : gfc_symbol *dsym = fsym;
6751 : 145301 : gfc_dummy_arg *dummy;
6752 : :
6753 : : /* Use associated dummy as fallback for formal
6754 : : argument if there is no explicit interface. */
6755 : 145301 : if (dsym == NULL
6756 : 27286 : && (dummy = arg->associated_dummy)
6757 : 24849 : && dummy->intrinsicness == GFC_NON_INTRINSIC_DUMMY_ARG
6758 : 168708 : && dummy->u.non_intrinsic->sym)
6759 : : dsym = dummy->u.non_intrinsic->sym;
6760 : :
6761 : 145301 : if (dsym
6762 : 141422 : && dsym->attr.intent == INTENT_OUT
6763 : : && !dsym->attr.allocatable
6764 : 3113 : && !dsym->attr.pointer
6765 : 2954 : && e->expr_type == EXPR_VARIABLE
6766 : 2948 : && e->ref == NULL
6767 : 2846 : && e->symtree
6768 : 2846 : && e->symtree->n.sym
6769 : 2846 : && !e->symtree->n.sym->attr.dimension
6770 : 2846 : && e->ts.type != BT_CHARACTER
6771 : 2749 : && e->ts.type != BT_CLASS
6772 : 2520 : && (e->ts.type != BT_DERIVED
6773 : 486 : || (dsym->ts.type == BT_DERIVED
6774 : 486 : && e->ts.u.derived == dsym->ts.u.derived
6775 : : /* Types with allocatable components are
6776 : : excluded from clobbering because we need
6777 : : the unclobbered pointers to free the
6778 : : allocatable components in the callee.
6779 : : Same goes for finalizable types or types
6780 : : with finalizable components, we need to
6781 : : pass the unclobbered values to the
6782 : : finalization routines.
6783 : : For parameterized types, it's less clear
6784 : : but they may not have a constant size
6785 : : so better exclude them in any case. */
6786 : : && !e->ts.u.derived->attr.alloc_comp
6787 : 471 : && !e->ts.u.derived->attr.pdt_type
6788 : 345 : && !gfc_is_finalizable (e->ts.u.derived, NULL)))
6789 : 147644 : && !sym->attr.elemental)
6790 : : {
6791 : 1010 : tree var;
6792 : 1010 : var = build_fold_indirect_ref_loc (input_location,
6793 : : parmse.expr);
6794 : 1010 : tree clobber = build_clobber (TREE_TYPE (var));
6795 : 1010 : gfc_add_modify (&clobbers, var, clobber);
6796 : : }
6797 : : }
6798 : : /* Catch base objects that are not variables. */
6799 : 146886 : if (e->ts.type == BT_CLASS
6800 : 3283 : && e->expr_type != EXPR_VARIABLE
6801 : 305 : && expr && e == expr->base_expr)
6802 : 80 : base_object = build_fold_indirect_ref_loc (input_location,
6803 : : parmse.expr);
6804 : :
6805 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6806 : : allocated on entry, it must be deallocated. */
6807 : 119600 : if (fsym && fsym->attr.intent == INTENT_OUT
6808 : 3022 : && (fsym->attr.allocatable
6809 : 2881 : || (fsym->ts.type == BT_CLASS
6810 : 258 : && CLASS_DATA (fsym)->attr.allocatable))
6811 : 147176 : && !is_CFI_desc (fsym, NULL))
6812 : : {
6813 : 290 : stmtblock_t block;
6814 : 290 : tree ptr;
6815 : :
6816 : 290 : defer_to_dealloc_blk = true;
6817 : :
6818 : 290 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
6819 : : &parmse.pre);
6820 : :
6821 : 290 : if (parmse.class_container != NULL_TREE)
6822 : 156 : parmse.class_container
6823 : 156 : = gfc_evaluate_data_ref_now (parmse.class_container,
6824 : : &parmse.pre);
6825 : :
6826 : 290 : gfc_init_block (&block);
6827 : 290 : ptr = parmse.expr;
6828 : 290 : if (e->ts.type == BT_CLASS)
6829 : 156 : ptr = gfc_class_data_get (ptr);
6830 : :
6831 : 290 : tree cls = parmse.class_container;
6832 : 290 : tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
6833 : : NULL_TREE, true,
6834 : : e, e->ts, cls);
6835 : 290 : gfc_add_expr_to_block (&block, tmp);
6836 : 290 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6837 : : void_type_node, ptr,
6838 : : null_pointer_node);
6839 : 290 : gfc_add_expr_to_block (&block, tmp);
6840 : :
6841 : 290 : if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
6842 : : {
6843 : 18 : gfc_add_modify (&block, ptr,
6844 : 18 : fold_convert (TREE_TYPE (ptr),
6845 : : null_pointer_node));
6846 : 18 : gfc_add_expr_to_block (&block, tmp);
6847 : : }
6848 : 272 : else if (fsym->ts.type == BT_CLASS)
6849 : : {
6850 : 131 : gfc_symbol *vtab;
6851 : 131 : vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
6852 : 131 : tmp = gfc_get_symbol_decl (vtab);
6853 : 131 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6854 : 131 : ptr = gfc_class_vptr_get (parmse.expr);
6855 : 131 : gfc_add_modify (&block, ptr,
6856 : 131 : fold_convert (TREE_TYPE (ptr), tmp));
6857 : 131 : gfc_add_expr_to_block (&block, tmp);
6858 : : }
6859 : :
6860 : 290 : if (fsym->attr.optional
6861 : 42 : && e->expr_type == EXPR_VARIABLE
6862 : 42 : && e->symtree->n.sym->attr.optional)
6863 : : {
6864 : 36 : tmp = fold_build3_loc (input_location, COND_EXPR,
6865 : : void_type_node,
6866 : 18 : gfc_conv_expr_present (e->symtree->n.sym),
6867 : : gfc_finish_block (&block),
6868 : : build_empty_stmt (input_location));
6869 : : }
6870 : : else
6871 : 272 : tmp = gfc_finish_block (&block);
6872 : :
6873 : 290 : gfc_add_expr_to_block (&dealloc_blk, tmp);
6874 : : }
6875 : :
6876 : : /* A class array element needs converting back to be a
6877 : : class object, if the formal argument is a class object. */
6878 : 146886 : if (fsym && fsym->ts.type == BT_CLASS
6879 : 2885 : && e->ts.type == BT_CLASS
6880 : 2873 : && ((CLASS_DATA (fsym)->as
6881 : 356 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
6882 : 2517 : || CLASS_DATA (e)->attr.dimension))
6883 : : {
6884 : 466 : gfc_se class_se = parmse;
6885 : 466 : gfc_init_block (&class_se.pre);
6886 : 466 : gfc_init_block (&class_se.post);
6887 : :
6888 : 466 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
6889 : 466 : fsym->attr.intent != INTENT_IN
6890 : 466 : && (CLASS_DATA (fsym)->attr.class_pointer
6891 : : || CLASS_DATA (fsym)->attr.allocatable),
6892 : 466 : fsym->attr.optional
6893 : 198 : && e->expr_type == EXPR_VARIABLE
6894 : 198 : && e->symtree->n.sym->attr.optional,
6895 : 466 : CLASS_DATA (fsym)->attr.class_pointer
6896 : 466 : || CLASS_DATA (fsym)->attr.allocatable);
6897 : :
6898 : 466 : parmse.expr = class_se.expr;
6899 : 932 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
6900 : 466 : ? &dealloc_blk
6901 : : : &parmse.pre;
6902 : 466 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
6903 : 466 : gfc_add_block_to_block (&parmse.post, &class_se.post);
6904 : : }
6905 : :
6906 : 119600 : if (fsym && (fsym->ts.type == BT_DERIVED
6907 : 108397 : || fsym->ts.type == BT_ASSUMED)
6908 : 12054 : && e->ts.type == BT_CLASS
6909 : 410 : && !CLASS_DATA (e)->attr.dimension
6910 : 410 : && !CLASS_DATA (e)->attr.codimension)
6911 : : {
6912 : 374 : parmse.expr = gfc_class_data_get (parmse.expr);
6913 : : /* The result is a class temporary, whose _data component
6914 : : must be freed to avoid a memory leak. */
6915 : 374 : if (e->expr_type == EXPR_FUNCTION
6916 : 23 : && CLASS_DATA (e)->attr.allocatable)
6917 : : {
6918 : 19 : tree zero;
6919 : :
6920 : : /* Finalize the expression. */
6921 : 19 : gfc_finalize_tree_expr (&parmse, NULL,
6922 : : gfc_expr_attr (e), e->rank);
6923 : 19 : gfc_add_block_to_block (&parmse.post,
6924 : : &parmse.finalblock);
6925 : :
6926 : : /* Then free the class _data. */
6927 : 19 : zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
6928 : 19 : tmp = fold_build2_loc (input_location, NE_EXPR,
6929 : : logical_type_node,
6930 : : parmse.expr, zero);
6931 : 19 : tmp = build3_v (COND_EXPR, tmp,
6932 : : gfc_call_free (parmse.expr),
6933 : : build_empty_stmt (input_location));
6934 : 19 : gfc_add_expr_to_block (&parmse.post, tmp);
6935 : 19 : gfc_add_modify (&parmse.post, parmse.expr, zero);
6936 : : }
6937 : : }
6938 : :
6939 : : /* Wrap scalar variable in a descriptor. We need to convert
6940 : : the address of a pointer back to the pointer itself before,
6941 : : we can assign it to the data field. */
6942 : :
6943 : 119600 : if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
6944 : 1167 : && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
6945 : : {
6946 : 1131 : tmp = parmse.expr;
6947 : 1131 : if (TREE_CODE (tmp) == ADDR_EXPR)
6948 : 643 : tmp = TREE_OPERAND (tmp, 0);
6949 : 1131 : parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
6950 : : fsym->attr);
6951 : 1131 : parmse.expr = gfc_build_addr_expr (NULL_TREE,
6952 : : parmse.expr);
6953 : : }
6954 : 118469 : else if (fsym && e->expr_type != EXPR_NULL
6955 : 118375 : && ((fsym->attr.pointer
6956 : 1659 : && fsym->attr.flavor != FL_PROCEDURE)
6957 : 116722 : || (fsym->attr.proc_pointer
6958 : 154 : && !(e->expr_type == EXPR_VARIABLE
6959 : 154 : && e->symtree->n.sym->attr.dummy))
6960 : 116580 : || (fsym->attr.proc_pointer
6961 : 12 : && e->expr_type == EXPR_VARIABLE
6962 : 12 : && gfc_is_proc_ptr_comp (e))
6963 : 116574 : || (fsym->attr.allocatable
6964 : 924 : && fsym->attr.flavor != FL_PROCEDURE)))
6965 : : {
6966 : : /* Scalar pointer dummy args require an extra level of
6967 : : indirection. The null pointer already contains
6968 : : this level of indirection. */
6969 : 2719 : parm_kind = SCALAR_POINTER;
6970 : 2719 : parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6971 : : }
6972 : : }
6973 : : }
6974 : 49698 : else if (e->ts.type == BT_CLASS
6975 : 2338 : && fsym && fsym->ts.type == BT_CLASS
6976 : 2076 : && (CLASS_DATA (fsym)->attr.dimension
6977 : 2076 : || CLASS_DATA (fsym)->attr.codimension))
6978 : : {
6979 : : /* Pass a class array. */
6980 : 2076 : parmse.use_offset = 1;
6981 : 2076 : gfc_conv_expr_descriptor (&parmse, e);
6982 : 2076 : bool defer_to_dealloc_blk = false;
6983 : :
6984 : 2076 : if (fsym->attr.optional
6985 : 798 : && e->expr_type == EXPR_VARIABLE
6986 : 798 : && e->symtree->n.sym->attr.optional)
6987 : : {
6988 : 438 : stmtblock_t block;
6989 : :
6990 : 438 : gfc_init_block (&block);
6991 : 438 : gfc_add_block_to_block (&block, &parmse.pre);
6992 : :
6993 : 876 : tree t = fold_build3_loc (input_location, COND_EXPR,
6994 : : void_type_node,
6995 : 438 : gfc_conv_expr_present (e->symtree->n.sym),
6996 : : gfc_finish_block (&block),
6997 : : build_empty_stmt (input_location));
6998 : :
6999 : 438 : gfc_add_expr_to_block (&parmse.pre, t);
7000 : : }
7001 : :
7002 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7003 : : allocated on entry, it must be deallocated. */
7004 : 2076 : if (fsym->attr.intent == INTENT_OUT
7005 : 141 : && CLASS_DATA (fsym)->attr.allocatable)
7006 : : {
7007 : 110 : stmtblock_t block;
7008 : 110 : tree ptr;
7009 : :
7010 : : /* In case the data reference to deallocate is dependent on
7011 : : its own content, save the resulting pointer to a variable
7012 : : and only use that variable from now on, before the
7013 : : expression becomes invalid. */
7014 : 110 : parmse.expr = gfc_evaluate_data_ref_now (parmse.expr,
7015 : : &parmse.pre);
7016 : :
7017 : 110 : if (parmse.class_container != NULL_TREE)
7018 : 110 : parmse.class_container
7019 : 110 : = gfc_evaluate_data_ref_now (parmse.class_container,
7020 : : &parmse.pre);
7021 : :
7022 : 110 : gfc_init_block (&block);
7023 : 110 : ptr = parmse.expr;
7024 : 110 : ptr = gfc_class_data_get (ptr);
7025 : :
7026 : 110 : tree cls = parmse.class_container;
7027 : 110 : tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
7028 : : NULL_TREE, NULL_TREE,
7029 : : NULL_TREE, true, e,
7030 : : GFC_CAF_COARRAY_NOCOARRAY,
7031 : : cls);
7032 : 110 : gfc_add_expr_to_block (&block, tmp);
7033 : 110 : tmp = fold_build2_loc (input_location, MODIFY_EXPR,
7034 : : void_type_node, ptr,
7035 : : null_pointer_node);
7036 : 110 : gfc_add_expr_to_block (&block, tmp);
7037 : 110 : gfc_reset_vptr (&block, e, parmse.class_container);
7038 : :
7039 : 110 : if (fsym->attr.optional
7040 : 30 : && e->expr_type == EXPR_VARIABLE
7041 : 30 : && (!e->ref
7042 : 30 : || (e->ref->type == REF_ARRAY
7043 : 0 : && e->ref->u.ar.type != AR_FULL))
7044 : 0 : && e->symtree->n.sym->attr.optional)
7045 : : {
7046 : 0 : tmp = fold_build3_loc (input_location, COND_EXPR,
7047 : : void_type_node,
7048 : 0 : gfc_conv_expr_present (e->symtree->n.sym),
7049 : : gfc_finish_block (&block),
7050 : : build_empty_stmt (input_location));
7051 : : }
7052 : : else
7053 : 110 : tmp = gfc_finish_block (&block);
7054 : :
7055 : 110 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7056 : 110 : defer_to_dealloc_blk = true;
7057 : : }
7058 : :
7059 : 2076 : gfc_se class_se = parmse;
7060 : 2076 : gfc_init_block (&class_se.pre);
7061 : 2076 : gfc_init_block (&class_se.post);
7062 : :
7063 : : /* The conversion does not repackage the reference to a class
7064 : : array - _data descriptor. */
7065 : 2076 : gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
7066 : 2076 : fsym->attr.intent != INTENT_IN
7067 : 2076 : && (CLASS_DATA (fsym)->attr.class_pointer
7068 : : || CLASS_DATA (fsym)->attr.allocatable),
7069 : 2076 : fsym->attr.optional
7070 : 798 : && e->expr_type == EXPR_VARIABLE
7071 : 798 : && e->symtree->n.sym->attr.optional,
7072 : 2076 : CLASS_DATA (fsym)->attr.class_pointer
7073 : 2076 : || CLASS_DATA (fsym)->attr.allocatable);
7074 : :
7075 : 2076 : parmse.expr = class_se.expr;
7076 : 4152 : stmtblock_t *class_pre_block = defer_to_dealloc_blk
7077 : 2076 : ? &dealloc_blk
7078 : : : &parmse.pre;
7079 : 2076 : gfc_add_block_to_block (class_pre_block, &class_se.pre);
7080 : 2076 : gfc_add_block_to_block (&parmse.post, &class_se.post);
7081 : 2076 : }
7082 : : else
7083 : : {
7084 : : /* If the argument is a function call that may not create
7085 : : a temporary for the result, we have to check that we
7086 : : can do it, i.e. that there is no alias between this
7087 : : argument and another one. */
7088 : 47622 : if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
7089 : : {
7090 : 377 : gfc_expr *iarg;
7091 : 377 : sym_intent intent;
7092 : :
7093 : 377 : if (fsym != NULL)
7094 : 368 : intent = fsym->attr.intent;
7095 : : else
7096 : : intent = INTENT_UNKNOWN;
7097 : :
7098 : 377 : if (gfc_check_fncall_dependency (e, intent, sym, args,
7099 : : NOT_ELEMENTAL))
7100 : 21 : parmse.force_tmp = 1;
7101 : :
7102 : 377 : iarg = e->value.function.actual->expr;
7103 : :
7104 : : /* Temporary needed if aliasing due to host association. */
7105 : 377 : if (sym->attr.contained
7106 : 114 : && !sym->attr.pure
7107 : 114 : && !sym->attr.implicit_pure
7108 : 36 : && !sym->attr.use_assoc
7109 : 36 : && iarg->expr_type == EXPR_VARIABLE
7110 : 36 : && sym->ns == iarg->symtree->n.sym->ns)
7111 : 36 : parmse.force_tmp = 1;
7112 : :
7113 : : /* Ditto within module. */
7114 : 377 : if (sym->attr.use_assoc
7115 : 377 : && !sym->attr.pure
7116 : 6 : && !sym->attr.implicit_pure
7117 : 0 : && iarg->expr_type == EXPR_VARIABLE
7118 : 0 : && sym->module == iarg->symtree->n.sym->module)
7119 : 0 : parmse.force_tmp = 1;
7120 : : }
7121 : :
7122 : : /* Special case for assumed-rank arrays: when passing an
7123 : : argument to a nonallocatable/nonpointer dummy, the bounds have
7124 : : to be reset as otherwise a last-dim ubound of -1 is
7125 : : indistinguishable from an assumed-size array in the callee. */
7126 : 47622 : if (!sym->attr.is_bind_c && e && fsym && fsym->as
7127 : 28125 : && fsym->as->type == AS_ASSUMED_RANK
7128 : 9181 : && e->rank != -1
7129 : 8892 : && e->expr_type == EXPR_VARIABLE
7130 : 8482 : && ((fsym->ts.type == BT_CLASS
7131 : 0 : && !CLASS_DATA (fsym)->attr.class_pointer
7132 : 0 : && !CLASS_DATA (fsym)->attr.allocatable)
7133 : 8482 : || (fsym->ts.type != BT_CLASS
7134 : 8482 : && !fsym->attr.pointer && !fsym->attr.allocatable)))
7135 : : {
7136 : : /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
7137 : 8023 : gfc_ref *ref;
7138 : 8269 : for (ref = e->ref; ref->next; ref = ref->next)
7139 : : ;
7140 : 8023 : if (ref->u.ar.type == AR_FULL
7141 : 7207 : && ref->u.ar.as->type != AS_ASSUMED_SIZE)
7142 : 7099 : ref->u.ar.type = AR_SECTION;
7143 : : }
7144 : :
7145 : 47622 : if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
7146 : : /* Implement F2018, 18.3.6, list item (5), bullet point 2. */
7147 : 5850 : gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
7148 : :
7149 : 41772 : else if (e->expr_type == EXPR_VARIABLE
7150 : 33446 : && is_subref_array (e)
7151 : 42288 : && !(fsym && fsym->attr.pointer))
7152 : : /* The actual argument is a component reference to an
7153 : : array of derived types. In this case, the argument
7154 : : is converted to a temporary, which is passed and then
7155 : : written back after the procedure call. */
7156 : 311 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7157 : 311 : fsym ? fsym->attr.intent : INTENT_INOUT,
7158 : 311 : fsym && fsym->attr.pointer);
7159 : :
7160 : 41461 : else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
7161 : 261 : && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
7162 : 18 : && nodesc_arg && fsym->ts.type == BT_DERIVED)
7163 : : /* An assumed size class actual argument being passed to
7164 : : a 'no descriptor' formal argument just requires the
7165 : : data pointer to be passed. For class dummy arguments
7166 : : this is stored in the symbol backend decl.. */
7167 : 6 : parmse.expr = e->symtree->n.sym->backend_decl;
7168 : :
7169 : 41455 : else if (gfc_is_class_array_ref (e, NULL)
7170 : 41455 : && fsym && fsym->ts.type == BT_DERIVED)
7171 : : /* The actual argument is a component reference to an
7172 : : array of derived types. In this case, the argument
7173 : : is converted to a temporary, which is passed and then
7174 : : written back after the procedure call.
7175 : : OOP-TODO: Insert code so that if the dynamic type is
7176 : : the same as the declared type, copy-in/copy-out does
7177 : : not occur. */
7178 : 108 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7179 : 108 : fsym->attr.intent,
7180 : 108 : fsym->attr.pointer);
7181 : :
7182 : 41347 : else if (gfc_is_class_array_function (e)
7183 : 41347 : && fsym && fsym->ts.type == BT_DERIVED)
7184 : : /* See previous comment. For function actual argument,
7185 : : the write out is not needed so the intent is set as
7186 : : intent in. */
7187 : : {
7188 : 13 : e->must_finalize = 1;
7189 : 13 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7190 : 13 : INTENT_IN, fsym->attr.pointer);
7191 : : }
7192 : 37831 : else if (fsym && fsym->attr.contiguous
7193 : 48 : && (fsym->attr.target
7194 : 1662 : ? gfc_is_not_contiguous (e)
7195 : 1614 : : !gfc_is_simply_contiguous (e, false, true))
7196 : 43311 : && gfc_expr_is_variable (e))
7197 : : {
7198 : 303 : gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
7199 : 303 : fsym->attr.intent,
7200 : 303 : fsym->attr.pointer);
7201 : : }
7202 : : else
7203 : : /* This is where we introduce a temporary to store the
7204 : : result of a non-lvalue array expression. */
7205 : 41031 : gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
7206 : : sym->name, NULL);
7207 : :
7208 : : /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
7209 : : allocated on entry, it must be deallocated.
7210 : : CFI descriptors are handled elsewhere. */
7211 : 44119 : if (fsym && fsym->attr.allocatable
7212 : 1306 : && fsym->attr.intent == INTENT_OUT
7213 : 47385 : && !is_CFI_desc (fsym, NULL))
7214 : : {
7215 : 145 : if (fsym->ts.type == BT_DERIVED
7216 : 45 : && fsym->ts.u.derived->attr.alloc_comp)
7217 : : {
7218 : : // deallocate the components first
7219 : 9 : tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
7220 : : parmse.expr, e->rank);
7221 : : /* But check whether dummy argument is optional. */
7222 : 9 : if (tmp != NULL_TREE
7223 : 9 : && fsym->attr.optional
7224 : 6 : && e->expr_type == EXPR_VARIABLE
7225 : 6 : && e->symtree->n.sym->attr.optional)
7226 : : {
7227 : 6 : tree present;
7228 : 6 : present = gfc_conv_expr_present (e->symtree->n.sym);
7229 : 6 : tmp = build3_v (COND_EXPR, present, tmp,
7230 : : build_empty_stmt (input_location));
7231 : : }
7232 : 9 : if (tmp != NULL_TREE)
7233 : 9 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7234 : : }
7235 : :
7236 : 145 : tmp = parmse.expr;
7237 : : /* With bind(C), the actual argument is replaced by a bind-C
7238 : : descriptor; in this case, the data component arrives here,
7239 : : which shall not be dereferenced, but still freed and
7240 : : nullified. */
7241 : 145 : if (TREE_TYPE(tmp) != pvoid_type_node)
7242 : 145 : tmp = build_fold_indirect_ref_loc (input_location,
7243 : : parmse.expr);
7244 : 145 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7245 : : NULL_TREE, NULL_TREE, true,
7246 : : e,
7247 : : GFC_CAF_COARRAY_NOCOARRAY);
7248 : 145 : if (fsym->attr.optional
7249 : 48 : && e->expr_type == EXPR_VARIABLE
7250 : 48 : && e->symtree->n.sym->attr.optional)
7251 : 48 : tmp = fold_build3_loc (input_location, COND_EXPR,
7252 : : void_type_node,
7253 : 24 : gfc_conv_expr_present (e->symtree->n.sym),
7254 : : tmp, build_empty_stmt (input_location));
7255 : 145 : gfc_add_expr_to_block (&dealloc_blk, tmp);
7256 : : }
7257 : : }
7258 : : }
7259 : : /* Special case for an assumed-rank dummy argument. */
7260 : 240465 : if (!sym->attr.is_bind_c && e && fsym && e->rank > 0
7261 : 44357 : && (fsym->ts.type == BT_CLASS
7262 : 44357 : ? (CLASS_DATA (fsym)->as
7263 : 3763 : && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
7264 : 40594 : : (fsym->as && fsym->as->type == AS_ASSUMED_RANK)))
7265 : : {
7266 : 9898 : if (fsym->ts.type == BT_CLASS
7267 : 9898 : ? (CLASS_DATA (fsym)->attr.class_pointer
7268 : 1006 : || CLASS_DATA (fsym)->attr.allocatable)
7269 : 8892 : : (fsym->attr.pointer || fsym->attr.allocatable))
7270 : : {
7271 : : /* Unallocated allocatable arrays and unassociated pointer
7272 : : arrays need their dtype setting if they are argument
7273 : : associated with assumed rank dummies to set the rank. */
7274 : 723 : set_dtype_for_unallocated (&parmse, e);
7275 : : }
7276 : 9175 : else if (e->expr_type == EXPR_VARIABLE
7277 : 8727 : && e->symtree->n.sym->attr.dummy
7278 : 578 : && (e->ts.type == BT_CLASS
7279 : 758 : ? (e->ref && e->ref->next
7280 : 180 : && e->ref->next->type == REF_ARRAY
7281 : 180 : && e->ref->next->u.ar.type == AR_FULL
7282 : 360 : && e->ref->next->u.ar.as->type == AS_ASSUMED_SIZE)
7283 : 398 : : (e->ref && e->ref->type == REF_ARRAY
7284 : 398 : && e->ref->u.ar.type == AR_FULL
7285 : 614 : && e->ref->u.ar.as->type == AS_ASSUMED_SIZE)))
7286 : : {
7287 : : /* Assumed-size actual to assumed-rank dummy requires
7288 : : dim[rank-1].ubound = -1. */
7289 : 168 : tree minus_one;
7290 : 168 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
7291 : 168 : if (fsym->ts.type == BT_CLASS)
7292 : 60 : tmp = gfc_class_data_get (tmp);
7293 : 168 : minus_one = build_int_cst (gfc_array_index_type, -1);
7294 : 168 : gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
7295 : 168 : gfc_rank_cst[e->rank - 1],
7296 : : minus_one);
7297 : : }
7298 : : }
7299 : :
7300 : : /* The case with fsym->attr.optional is that of a user subroutine
7301 : : with an interface indicating an optional argument. When we call
7302 : : an intrinsic subroutine, however, fsym is NULL, but we might still
7303 : : have an optional argument, so we proceed to the substitution
7304 : : just in case. Arguments passed to bind(c) procedures via CFI
7305 : : descriptors are handled elsewhere. */
7306 : 231855 : if (e && (fsym == NULL || fsym->attr.optional)
7307 : 295077 : && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
7308 : : {
7309 : : /* If an optional argument is itself an optional dummy argument,
7310 : : check its presence and substitute a null if absent. This is
7311 : : only needed when passing an array to an elemental procedure
7312 : : as then array elements are accessed - or no NULL pointer is
7313 : : allowed and a "1" or "0" should be passed if not present.
7314 : : When passing a non-array-descriptor full array to a
7315 : : non-array-descriptor dummy, no check is needed. For
7316 : : array-descriptor actual to array-descriptor dummy, see
7317 : : PR 41911 for why a check has to be inserted.
7318 : : fsym == NULL is checked as intrinsics required the descriptor
7319 : : but do not always set fsym.
7320 : : Also, it is necessary to pass a NULL pointer to library routines
7321 : : which usually ignore optional arguments, so they can handle
7322 : : these themselves. */
7323 : 53518 : if (e->expr_type == EXPR_VARIABLE
7324 : 24806 : && e->symtree->n.sym->attr.optional
7325 : 2249 : && (((e->rank != 0 && elemental_proc)
7326 : 2076 : || e->representation.length || e->ts.type == BT_CHARACTER
7327 : 1854 : || (e->rank == 0 && e->symtree->n.sym->attr.value)
7328 : 1792 : || (e->rank != 0
7329 : 1018 : && (fsym == NULL
7330 : 982 : || (fsym->as
7331 : 220 : && (fsym->as->type == AS_ASSUMED_SHAPE
7332 : 188 : || fsym->as->type == AS_ASSUMED_RANK
7333 : 116 : || fsym->as->type == AS_DEFERRED)))))
7334 : 1622 : || se->ignore_optional))
7335 : 651 : gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
7336 : 651 : e->representation.length);
7337 : : }
7338 : :
7339 : 240465 : if (fsym && e)
7340 : : {
7341 : : /* Obtain the character length of an assumed character length
7342 : : length procedure from the typespec. */
7343 : 200110 : if (fsym->ts.type == BT_CHARACTER
7344 : 30181 : && parmse.string_length == NULL_TREE
7345 : 3292 : && e->ts.type == BT_PROCEDURE
7346 : 15 : && e->symtree->n.sym->ts.type == BT_CHARACTER
7347 : 15 : && e->symtree->n.sym->ts.u.cl->length != NULL
7348 : 15 : && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
7349 : : {
7350 : 8 : gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
7351 : 8 : parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
7352 : : }
7353 : : }
7354 : :
7355 : : /* If any actual argument of the procedure is allocatable and passed
7356 : : to an allocatable dummy with INTENT(OUT), we conservatively
7357 : : evaluate actual argument expressions before deallocations are
7358 : : performed and the procedure is executed. May create temporaries.
7359 : : This ensures we conform to F2023:15.5.3, 15.5.4. */
7360 : 231855 : if (e && fsym && force_eval_args
7361 : 1078 : && fsym->attr.intent != INTENT_OUT
7362 : 240862 : && !gfc_is_constant_expr (e))
7363 : 256 : parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
7364 : :
7365 : 240465 : if (fsym && need_interface_mapping && e)
7366 : 31206 : gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
7367 : :
7368 : 240465 : gfc_add_block_to_block (&se->pre, &parmse.pre);
7369 : 240465 : gfc_add_block_to_block (&post, &parmse.post);
7370 : 240465 : gfc_add_block_to_block (&se->finalblock, &parmse.finalblock);
7371 : :
7372 : : /* Allocated allocatable components of derived types must be
7373 : : deallocated for non-variable scalars, array arguments to elemental
7374 : : procedures, and array arguments with descriptor to non-elemental
7375 : : procedures. As bounds information for descriptorless arrays is no
7376 : : longer available here, they are dealt with in trans-array.cc
7377 : : (gfc_conv_array_parameter). */
7378 : 231855 : if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
7379 : 25242 : && e->ts.u.derived->attr.alloc_comp
7380 : 7021 : && (e->rank == 0 || elemental_proc || !nodesc_arg)
7381 : 247368 : && !expr_may_alias_variables (e, elemental_proc))
7382 : : {
7383 : 289 : int parm_rank;
7384 : : /* It is known the e returns a structure type with at least one
7385 : : allocatable component. When e is a function, ensure that the
7386 : : function is called once only by using a temporary variable. */
7387 : 289 : if (!DECL_P (parmse.expr))
7388 : 247 : parmse.expr = gfc_evaluate_now_loc (input_location,
7389 : : parmse.expr, &se->pre);
7390 : :
7391 : 289 : if (fsym && fsym->attr.value)
7392 : 66 : tmp = parmse.expr;
7393 : : else
7394 : 223 : tmp = build_fold_indirect_ref_loc (input_location,
7395 : : parmse.expr);
7396 : :
7397 : 289 : parm_rank = e->rank;
7398 : 289 : switch (parm_kind)
7399 : : {
7400 : : case (ELEMENTAL):
7401 : : case (SCALAR):
7402 : 289 : parm_rank = 0;
7403 : : break;
7404 : :
7405 : 0 : case (SCALAR_POINTER):
7406 : 0 : tmp = build_fold_indirect_ref_loc (input_location,
7407 : : tmp);
7408 : 0 : break;
7409 : : }
7410 : :
7411 : 289 : if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
7412 : : {
7413 : : /* The derived type is passed to gfc_deallocate_alloc_comp.
7414 : : Therefore, class actuals can be handled correctly but derived
7415 : : types passed to class formals need the _data component. */
7416 : 62 : tmp = gfc_class_data_get (tmp);
7417 : 62 : if (!CLASS_DATA (fsym)->attr.dimension)
7418 : : {
7419 : 36 : if (UNLIMITED_POLY (fsym))
7420 : : {
7421 : 12 : tree type = gfc_typenode_for_spec (&e->ts);
7422 : 12 : type = build_pointer_type (type);
7423 : 12 : tmp = fold_convert (type, tmp);
7424 : : }
7425 : 36 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7426 : : }
7427 : : }
7428 : :
7429 : 289 : if (e->expr_type == EXPR_OP
7430 : 24 : && e->value.op.op == INTRINSIC_PARENTHESES
7431 : 24 : && e->value.op.op1->expr_type == EXPR_VARIABLE)
7432 : : {
7433 : 24 : tree local_tmp;
7434 : 24 : local_tmp = gfc_evaluate_now (tmp, &se->pre);
7435 : 24 : local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
7436 : : parm_rank, 0);
7437 : 24 : gfc_add_expr_to_block (&se->post, local_tmp);
7438 : : }
7439 : :
7440 : 289 : if (!finalized && !e->must_finalize)
7441 : : {
7442 : 288 : bool scalar_res_outside_loop;
7443 : 852 : scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
7444 : 136 : && parm_rank == 0
7445 : 412 : && parmse.loop;
7446 : :
7447 : : /* Scalars passed to an assumed rank argument are converted to
7448 : : a descriptor. Obtain the data field before deallocating any
7449 : : allocatable components. */
7450 : 276 : if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
7451 : 19 : tmp = gfc_conv_descriptor_data_get (tmp);
7452 : :
7453 : 288 : if (scalar_res_outside_loop)
7454 : : {
7455 : : /* Go through the ss chain to find the argument and use
7456 : : the stored value. */
7457 : 18 : gfc_ss *tmp_ss = parmse.loop->ss;
7458 : 36 : for (; tmp_ss; tmp_ss = tmp_ss->next)
7459 : 36 : if (tmp_ss->info
7460 : 36 : && tmp_ss->info->expr == e
7461 : 18 : && tmp_ss->info->data.scalar.value != NULL_TREE)
7462 : : {
7463 : 18 : tmp = tmp_ss->info->data.scalar.value;
7464 : 18 : break;
7465 : : }
7466 : : }
7467 : :
7468 : 288 : STRIP_NOPS (tmp);
7469 : :
7470 : 288 : if (derived_array != NULL_TREE)
7471 : 13 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
7472 : : derived_array,
7473 : : parm_rank);
7474 : 275 : else if ((e->ts.type == BT_CLASS
7475 : 24 : && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
7476 : 275 : || e->ts.type == BT_DERIVED)
7477 : 275 : tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
7478 : : parm_rank);
7479 : 0 : else if (e->ts.type == BT_CLASS)
7480 : 0 : tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
7481 : : tmp, parm_rank);
7482 : :
7483 : 288 : if (scalar_res_outside_loop)
7484 : 18 : gfc_add_expr_to_block (&parmse.loop->post, tmp);
7485 : : else
7486 : 270 : gfc_prepend_expr_to_block (&post, tmp);
7487 : : }
7488 : : }
7489 : :
7490 : : /* Add argument checking of passing an unallocated/NULL actual to
7491 : : a nonallocatable/nonpointer dummy. */
7492 : :
7493 : 240465 : if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
7494 : : {
7495 : 6529 : symbol_attribute attr;
7496 : 6529 : char *msg;
7497 : 6529 : tree cond;
7498 : 6529 : tree tmp;
7499 : 6529 : symbol_attribute fsym_attr;
7500 : :
7501 : 6529 : if (fsym)
7502 : : {
7503 : 6343 : if (fsym->ts.type == BT_CLASS)
7504 : : {
7505 : 303 : fsym_attr = CLASS_DATA (fsym)->attr;
7506 : 303 : fsym_attr.pointer = fsym_attr.class_pointer;
7507 : : }
7508 : : else
7509 : 6040 : fsym_attr = fsym->attr;
7510 : : }
7511 : :
7512 : 6529 : if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
7513 : 4075 : attr = gfc_expr_attr (e);
7514 : : else
7515 : 6061 : goto end_pointer_check;
7516 : :
7517 : : /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
7518 : : allocatable to an optional dummy, cf. 12.5.2.12. */
7519 : 4075 : if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
7520 : 1038 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
7521 : 1032 : goto end_pointer_check;
7522 : :
7523 : 3043 : if (attr.optional)
7524 : : {
7525 : : /* If the actual argument is an optional pointer/allocatable and
7526 : : the formal argument takes an nonpointer optional value,
7527 : : it is invalid to pass a non-present argument on, even
7528 : : though there is no technical reason for this in gfortran.
7529 : : See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
7530 : 60 : tree present, null_ptr, type;
7531 : :
7532 : 60 : if (attr.allocatable
7533 : 0 : && (fsym == NULL || !fsym_attr.allocatable))
7534 : 0 : msg = xasprintf ("Allocatable actual argument '%s' is not "
7535 : : "allocated or not present",
7536 : 0 : e->symtree->n.sym->name);
7537 : 60 : else if (attr.pointer
7538 : 12 : && (fsym == NULL || !fsym_attr.pointer))
7539 : 12 : msg = xasprintf ("Pointer actual argument '%s' is not "
7540 : : "associated or not present",
7541 : 12 : e->symtree->n.sym->name);
7542 : 48 : else if (attr.proc_pointer && !e->value.function.actual
7543 : 0 : && (fsym == NULL || !fsym_attr.proc_pointer))
7544 : 0 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
7545 : : "associated or not present",
7546 : 0 : e->symtree->n.sym->name);
7547 : : else
7548 : 48 : goto end_pointer_check;
7549 : :
7550 : 12 : present = gfc_conv_expr_present (e->symtree->n.sym);
7551 : 12 : type = TREE_TYPE (present);
7552 : 12 : present = fold_build2_loc (input_location, EQ_EXPR,
7553 : : logical_type_node, present,
7554 : : fold_convert (type,
7555 : : null_pointer_node));
7556 : 12 : type = TREE_TYPE (parmse.expr);
7557 : 12 : null_ptr = fold_build2_loc (input_location, EQ_EXPR,
7558 : : logical_type_node, parmse.expr,
7559 : : fold_convert (type,
7560 : : null_pointer_node));
7561 : 12 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
7562 : : logical_type_node, present, null_ptr);
7563 : : }
7564 : : else
7565 : : {
7566 : 2983 : if (attr.allocatable
7567 : 266 : && (fsym == NULL || !fsym_attr.allocatable))
7568 : 200 : msg = xasprintf ("Allocatable actual argument '%s' is not "
7569 : 200 : "allocated", e->symtree->n.sym->name);
7570 : 2783 : else if (attr.pointer
7571 : 253 : && (fsym == NULL || !fsym_attr.pointer))
7572 : 184 : msg = xasprintf ("Pointer actual argument '%s' is not "
7573 : 184 : "associated", e->symtree->n.sym->name);
7574 : 2599 : else if (attr.proc_pointer && !e->value.function.actual
7575 : 72 : && (fsym == NULL || !fsym_attr.proc_pointer))
7576 : 72 : msg = xasprintf ("Proc-pointer actual argument '%s' is not "
7577 : 72 : "associated", e->symtree->n.sym->name);
7578 : : else
7579 : 2527 : goto end_pointer_check;
7580 : :
7581 : 456 : tmp = parmse.expr;
7582 : 456 : if (fsym && fsym->ts.type == BT_CLASS)
7583 : : {
7584 : 76 : if (POINTER_TYPE_P (TREE_TYPE (tmp)))
7585 : 70 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
7586 : 76 : tmp = gfc_class_data_get (tmp);
7587 : 76 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
7588 : 3 : tmp = gfc_conv_descriptor_data_get (tmp);
7589 : : }
7590 : :
7591 : : /* If the argument is passed by value, we need to strip the
7592 : : INDIRECT_REF. */
7593 : 456 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
7594 : 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
7595 : :
7596 : 456 : cond = fold_build2_loc (input_location, EQ_EXPR,
7597 : : logical_type_node, tmp,
7598 : 456 : fold_convert (TREE_TYPE (tmp),
7599 : : null_pointer_node));
7600 : : }
7601 : :
7602 : 468 : gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
7603 : : msg);
7604 : 468 : free (msg);
7605 : : }
7606 : 233936 : end_pointer_check:
7607 : :
7608 : : /* Deferred length dummies pass the character length by reference
7609 : : so that the value can be returned. */
7610 : 240465 : if (parmse.string_length && fsym && fsym->ts.deferred)
7611 : : {
7612 : 613 : if (INDIRECT_REF_P (parmse.string_length))
7613 : : {
7614 : : /* In chains of functions/procedure calls the string_length already
7615 : : is a pointer to the variable holding the length. Therefore
7616 : : remove the deref on call. */
7617 : 72 : tmp = parmse.string_length;
7618 : 72 : parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
7619 : : }
7620 : : else
7621 : : {
7622 : 541 : tmp = parmse.string_length;
7623 : 541 : if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
7624 : 61 : tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
7625 : 541 : parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
7626 : : }
7627 : :
7628 : 613 : if (e && e->expr_type == EXPR_VARIABLE
7629 : 546 : && fsym->attr.allocatable
7630 : 336 : && e->ts.u.cl->backend_decl
7631 : 336 : && VAR_P (e->ts.u.cl->backend_decl))
7632 : : {
7633 : 252 : if (INDIRECT_REF_P (tmp))
7634 : 0 : tmp = TREE_OPERAND (tmp, 0);
7635 : 252 : gfc_add_modify (&se->post, e->ts.u.cl->backend_decl,
7636 : : fold_convert (gfc_charlen_type_node, tmp));
7637 : : }
7638 : : }
7639 : :
7640 : : /* Character strings are passed as two parameters, a length and a
7641 : : pointer - except for Bind(c) and c_ptrs which only passe the pointer.
7642 : : An unlimited polymorphic formal argument likewise does not
7643 : : need the length. */
7644 : 240465 : if (parmse.string_length != NULL_TREE
7645 : 35323 : && !sym->attr.is_bind_c
7646 : 34687 : && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived
7647 : : && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7648 : : && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING )
7649 : 28775 : && !(fsym && fsym->ts.type == BT_ASSUMED)
7650 : 28666 : && !(fsym && UNLIMITED_POLY (fsym)))
7651 : 34457 : vec_safe_push (stringargs, parmse.string_length);
7652 : :
7653 : : /* When calling __copy for character expressions to unlimited
7654 : : polymorphic entities, the dst argument needs a string length. */
7655 : 37832 : if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
7656 : 4830 : && startswith (sym->name, "__vtab_CHARACTER")
7657 : 0 : && arg->next && arg->next->expr
7658 : 0 : && (arg->next->expr->ts.type == BT_DERIVED
7659 : 0 : || arg->next->expr->ts.type == BT_CLASS)
7660 : 240465 : && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
7661 : 0 : vec_safe_push (stringargs, parmse.string_length);
7662 : :
7663 : : /* For descriptorless coarrays and assumed-shape coarray dummies, we
7664 : : pass the token and the offset as additional arguments. */
7665 : 240465 : if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
7666 : 71 : && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
7667 : 68 : && !fsym->attr.allocatable)
7668 : 69 : || (fsym->ts.type == BT_CLASS
7669 : 3 : && CLASS_DATA (fsym)->attr.codimension
7670 : 3 : && !CLASS_DATA (fsym)->attr.allocatable)))
7671 : : {
7672 : : /* Token and offset. */
7673 : 5 : vec_safe_push (stringargs, null_pointer_node);
7674 : 5 : vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
7675 : 5 : gcc_assert (fsym->attr.optional);
7676 : : }
7677 : 207765 : else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
7678 : 318 : && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
7679 : 312 : && !fsym->attr.allocatable)
7680 : 252 : || (fsym->ts.type == BT_CLASS
7681 : 6 : && CLASS_DATA (fsym)->attr.codimension
7682 : 6 : && !CLASS_DATA (fsym)->attr.allocatable)))
7683 : : {
7684 : 71 : tree caf_decl, caf_type;
7685 : 71 : tree offset, tmp2;
7686 : :
7687 : 71 : caf_decl = gfc_get_tree_for_caf_expr (e);
7688 : 71 : caf_type = TREE_TYPE (caf_decl);
7689 : :
7690 : 71 : if (GFC_DESCRIPTOR_TYPE_P (caf_type)
7691 : 71 : && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
7692 : 0 : || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
7693 : 28 : tmp = gfc_conv_descriptor_token (caf_decl);
7694 : 43 : else if (DECL_LANG_SPECIFIC (caf_decl)
7695 : 43 : && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
7696 : 8 : tmp = GFC_DECL_TOKEN (caf_decl);
7697 : : else
7698 : : {
7699 : 35 : gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
7700 : : && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
7701 : 35 : tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
7702 : : }
7703 : :
7704 : 71 : vec_safe_push (stringargs, tmp);
7705 : :
7706 : 71 : if (GFC_DESCRIPTOR_TYPE_P (caf_type)
7707 : 71 : && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
7708 : 28 : offset = build_int_cst (gfc_array_index_type, 0);
7709 : 43 : else if (DECL_LANG_SPECIFIC (caf_decl)
7710 : 43 : && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
7711 : 8 : offset = GFC_DECL_CAF_OFFSET (caf_decl);
7712 : 35 : else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
7713 : 0 : offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
7714 : : else
7715 : 35 : offset = build_int_cst (gfc_array_index_type, 0);
7716 : :
7717 : 71 : if (GFC_DESCRIPTOR_TYPE_P (caf_type))
7718 : 28 : tmp = gfc_conv_descriptor_data_get (caf_decl);
7719 : : else
7720 : : {
7721 : 43 : gcc_assert (POINTER_TYPE_P (caf_type));
7722 : 43 : tmp = caf_decl;
7723 : : }
7724 : :
7725 : 142 : tmp2 = fsym->ts.type == BT_CLASS
7726 : 71 : ? gfc_class_data_get (parmse.expr) : parmse.expr;
7727 : 71 : if ((fsym->ts.type != BT_CLASS
7728 : 66 : && (fsym->as->type == AS_ASSUMED_SHAPE
7729 : 39 : || fsym->as->type == AS_ASSUMED_RANK))
7730 : 44 : || (fsym->ts.type == BT_CLASS
7731 : 5 : && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
7732 : 4 : || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
7733 : : {
7734 : 28 : if (fsym->ts.type == BT_CLASS)
7735 : 1 : gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
7736 : : else
7737 : : {
7738 : 27 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
7739 : 27 : tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
7740 : : }
7741 : 28 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
7742 : 28 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
7743 : : }
7744 : 43 : else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
7745 : 4 : tmp2 = gfc_conv_descriptor_data_get (tmp2);
7746 : : else
7747 : : {
7748 : 39 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
7749 : : }
7750 : :
7751 : 71 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
7752 : : gfc_array_index_type,
7753 : : fold_convert (gfc_array_index_type, tmp2),
7754 : : fold_convert (gfc_array_index_type, tmp));
7755 : 71 : offset = fold_build2_loc (input_location, PLUS_EXPR,
7756 : : gfc_array_index_type, offset, tmp);
7757 : :
7758 : 71 : vec_safe_push (stringargs, offset);
7759 : : }
7760 : :
7761 : 240465 : vec_safe_push (arglist, parmse.expr);
7762 : : }
7763 : :
7764 : 113329 : gfc_add_block_to_block (&se->pre, &dealloc_blk);
7765 : 113329 : gfc_add_block_to_block (&se->pre, &clobbers);
7766 : 113329 : gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
7767 : :
7768 : 113329 : if (comp)
7769 : 1701 : ts = comp->ts;
7770 : 111628 : else if (sym->ts.type == BT_CLASS)
7771 : 670 : ts = CLASS_DATA (sym)->ts;
7772 : : else
7773 : 110958 : ts = sym->ts;
7774 : :
7775 : 113329 : if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
7776 : 186 : se->string_length = build_int_cst (gfc_charlen_type_node, 1);
7777 : 113143 : else if (ts.type == BT_CHARACTER)
7778 : : {
7779 : 4431 : if (ts.u.cl->length == NULL)
7780 : : {
7781 : : /* Assumed character length results are not allowed by C418 of the 2003
7782 : : standard and are trapped in resolve.cc; except in the case of SPREAD
7783 : : (and other intrinsics?) and dummy functions. In the case of SPREAD,
7784 : : we take the character length of the first argument for the result.
7785 : : For dummies, we have to look through the formal argument list for
7786 : : this function and use the character length found there.
7787 : : Likewise, we handle the case of deferred-length character dummy
7788 : : arguments to intrinsics that determine the characteristics of
7789 : : the result, which cannot be deferred-length. */
7790 : 991 : if (expr->value.function.isym)
7791 : 674 : ts.deferred = false;
7792 : 991 : if (ts.deferred)
7793 : 312 : cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
7794 : 679 : else if (!sym->attr.dummy)
7795 : 674 : cl.backend_decl = (*stringargs)[0];
7796 : : else
7797 : : {
7798 : 5 : formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
7799 : 18 : for (; formal; formal = formal->next)
7800 : 8 : if (strcmp (formal->sym->name, sym->name) == 0)
7801 : 5 : cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
7802 : : }
7803 : 991 : len = cl.backend_decl;
7804 : : }
7805 : : else
7806 : : {
7807 : 3440 : tree tmp;
7808 : :
7809 : : /* Calculate the length of the returned string. */
7810 : 3440 : gfc_init_se (&parmse, NULL);
7811 : 3440 : if (need_interface_mapping)
7812 : 2795 : gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
7813 : : else
7814 : 645 : gfc_conv_expr (&parmse, ts.u.cl->length);
7815 : 3440 : gfc_add_block_to_block (&se->pre, &parmse.pre);
7816 : 3440 : gfc_add_block_to_block (&se->post, &parmse.post);
7817 : 3440 : tmp = parmse.expr;
7818 : : /* TODO: It would be better to have the charlens as
7819 : : gfc_charlen_type_node already when the interface is
7820 : : created instead of converting it here (see PR 84615). */
7821 : 3440 : tmp = fold_build2_loc (input_location, MAX_EXPR,
7822 : : gfc_charlen_type_node,
7823 : : fold_convert (gfc_charlen_type_node, tmp),
7824 : : build_zero_cst (gfc_charlen_type_node));
7825 : 3440 : cl.backend_decl = tmp;
7826 : : }
7827 : :
7828 : : /* Set up a charlen structure for it. */
7829 : 4431 : cl.next = NULL;
7830 : 4431 : cl.length = NULL;
7831 : 4431 : ts.u.cl = &cl;
7832 : :
7833 : 4431 : len = cl.backend_decl;
7834 : : }
7835 : :
7836 : 1701 : byref = (comp && (comp->attr.dimension
7837 : 1640 : || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
7838 : 113329 : || (!comp && gfc_return_by_reference (sym));
7839 : 14633 : if (byref)
7840 : : {
7841 : 14633 : if (se->direct_byref)
7842 : : {
7843 : : /* Sometimes, too much indirection can be applied; e.g. for
7844 : : function_result = array_valued_recursive_function. */
7845 : 4491 : if (TREE_TYPE (TREE_TYPE (se->expr))
7846 : 4491 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
7847 : 4509 : && GFC_DESCRIPTOR_TYPE_P
7848 : : (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
7849 : 18 : se->expr = build_fold_indirect_ref_loc (input_location,
7850 : : se->expr);
7851 : :
7852 : : /* If the lhs of an assignment x = f(..) is allocatable and
7853 : : f2003 is allowed, we must do the automatic reallocation.
7854 : : TODO - deal with intrinsics, without using a temporary. */
7855 : 4491 : if (flag_realloc_lhs
7856 : 4416 : && se->ss && se->ss->loop_chain
7857 : 152 : && se->ss->loop_chain->is_alloc_lhs
7858 : 152 : && !expr->value.function.isym
7859 : 152 : && sym->result->as != NULL)
7860 : : {
7861 : : /* Evaluate the bounds of the result, if known. */
7862 : 152 : gfc_set_loop_bounds_from_array_spec (&mapping, se,
7863 : : sym->result->as);
7864 : :
7865 : : /* Perform the automatic reallocation. */
7866 : 152 : tmp = gfc_alloc_allocatable_for_assignment (se->loop,
7867 : : expr, NULL);
7868 : 152 : gfc_add_expr_to_block (&se->pre, tmp);
7869 : :
7870 : : /* Pass the temporary as the first argument. */
7871 : 152 : result = info->descriptor;
7872 : : }
7873 : : else
7874 : 4339 : result = build_fold_indirect_ref_loc (input_location,
7875 : : se->expr);
7876 : 4491 : vec_safe_push (retargs, se->expr);
7877 : : }
7878 : 10142 : else if (comp && comp->attr.dimension)
7879 : : {
7880 : 59 : gcc_assert (se->loop && info);
7881 : :
7882 : : /* Set the type of the array. */
7883 : 59 : tmp = gfc_typenode_for_spec (&comp->ts);
7884 : 59 : gcc_assert (se->ss->dimen == se->loop->dimen);
7885 : :
7886 : : /* Evaluate the bounds of the result, if known. */
7887 : 59 : gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
7888 : :
7889 : : /* If the lhs of an assignment x = f(..) is allocatable and
7890 : : f2003 is allowed, we must not generate the function call
7891 : : here but should just send back the results of the mapping.
7892 : : This is signalled by the function ss being flagged. */
7893 : 59 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
7894 : : {
7895 : 0 : gfc_free_interface_mapping (&mapping);
7896 : 0 : return has_alternate_specifier;
7897 : : }
7898 : :
7899 : : /* Create a temporary to store the result. In case the function
7900 : : returns a pointer, the temporary will be a shallow copy and
7901 : : mustn't be deallocated. */
7902 : 59 : callee_alloc = comp->attr.allocatable || comp->attr.pointer;
7903 : 59 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
7904 : : tmp, NULL_TREE, false,
7905 : : !comp->attr.pointer, callee_alloc,
7906 : 59 : &se->ss->info->expr->where);
7907 : :
7908 : : /* Pass the temporary as the first argument. */
7909 : 59 : result = info->descriptor;
7910 : 59 : tmp = gfc_build_addr_expr (NULL_TREE, result);
7911 : 59 : vec_safe_push (retargs, tmp);
7912 : : }
7913 : 10016 : else if (!comp && sym->result->attr.dimension)
7914 : : {
7915 : 7377 : gcc_assert (se->loop && info);
7916 : :
7917 : : /* Set the type of the array. */
7918 : 7377 : tmp = gfc_typenode_for_spec (&ts);
7919 : 7377 : gcc_assert (se->ss->dimen == se->loop->dimen);
7920 : :
7921 : : /* Evaluate the bounds of the result, if known. */
7922 : 7377 : gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
7923 : :
7924 : : /* If the lhs of an assignment x = f(..) is allocatable and
7925 : : f2003 is allowed, we must not generate the function call
7926 : : here but should just send back the results of the mapping.
7927 : : This is signalled by the function ss being flagged. */
7928 : 7377 : if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
7929 : : {
7930 : 0 : gfc_free_interface_mapping (&mapping);
7931 : 0 : return has_alternate_specifier;
7932 : : }
7933 : :
7934 : : /* Create a temporary to store the result. In case the function
7935 : : returns a pointer, the temporary will be a shallow copy and
7936 : : mustn't be deallocated. */
7937 : 7377 : callee_alloc = sym->attr.allocatable || sym->attr.pointer;
7938 : 7377 : gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
7939 : : tmp, NULL_TREE, false,
7940 : : !sym->attr.pointer, callee_alloc,
7941 : 7377 : &se->ss->info->expr->where);
7942 : :
7943 : : /* Pass the temporary as the first argument. */
7944 : 7377 : result = info->descriptor;
7945 : 7377 : tmp = gfc_build_addr_expr (NULL_TREE, result);
7946 : 7377 : vec_safe_push (retargs, tmp);
7947 : : }
7948 : 2706 : else if (ts.type == BT_CHARACTER)
7949 : : {
7950 : : /* Pass the string length. */
7951 : 2640 : type = gfc_get_character_type (ts.kind, ts.u.cl);
7952 : 2640 : type = build_pointer_type (type);
7953 : :
7954 : : /* Emit a DECL_EXPR for the VLA type. */
7955 : 2640 : tmp = TREE_TYPE (type);
7956 : 2640 : if (TYPE_SIZE (tmp)
7957 : 2640 : && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
7958 : : {
7959 : 1589 : tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
7960 : 1589 : DECL_ARTIFICIAL (tmp) = 1;
7961 : 1589 : DECL_IGNORED_P (tmp) = 1;
7962 : 1589 : tmp = fold_build1_loc (input_location, DECL_EXPR,
7963 : 1589 : TREE_TYPE (tmp), tmp);
7964 : 1589 : gfc_add_expr_to_block (&se->pre, tmp);
7965 : : }
7966 : :
7967 : : /* Return an address to a char[0:len-1]* temporary for
7968 : : character pointers. */
7969 : 2640 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7970 : 67 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
7971 : : {
7972 : 361 : var = gfc_create_var (type, "pstr");
7973 : :
7974 : 361 : if ((!comp && sym->attr.allocatable)
7975 : 21 : || (comp && comp->attr.allocatable))
7976 : : {
7977 : 263 : gfc_add_modify (&se->pre, var,
7978 : 263 : fold_convert (TREE_TYPE (var),
7979 : : null_pointer_node));
7980 : 263 : tmp = gfc_call_free (var);
7981 : 263 : gfc_add_expr_to_block (&se->post, tmp);
7982 : : }
7983 : :
7984 : : /* Provide an address expression for the function arguments. */
7985 : 361 : var = gfc_build_addr_expr (NULL_TREE, var);
7986 : : }
7987 : : else
7988 : 2279 : var = gfc_conv_string_tmp (se, type, len);
7989 : :
7990 : 2640 : vec_safe_push (retargs, var);
7991 : : }
7992 : : else
7993 : : {
7994 : 66 : gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
7995 : :
7996 : 66 : type = gfc_get_complex_type (ts.kind);
7997 : 66 : var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
7998 : 66 : vec_safe_push (retargs, var);
7999 : : }
8000 : :
8001 : : /* Add the string length to the argument list. */
8002 : 14633 : if (ts.type == BT_CHARACTER && ts.deferred)
8003 : : {
8004 : 312 : tmp = len;
8005 : 312 : if (!VAR_P (tmp))
8006 : 0 : tmp = gfc_evaluate_now (len, &se->pre);
8007 : 312 : TREE_STATIC (tmp) = 1;
8008 : 312 : gfc_add_modify (&se->pre, tmp,
8009 : 312 : build_int_cst (TREE_TYPE (tmp), 0));
8010 : 312 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
8011 : 312 : vec_safe_push (retargs, tmp);
8012 : : }
8013 : 14321 : else if (ts.type == BT_CHARACTER)
8014 : 4119 : vec_safe_push (retargs, len);
8015 : : }
8016 : 113329 : gfc_free_interface_mapping (&mapping);
8017 : :
8018 : : /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
8019 : 213431 : arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
8020 : 137246 : + vec_safe_length (stringargs) + vec_safe_length (append_args));
8021 : 113329 : vec_safe_reserve (retargs, arglen);
8022 : :
8023 : : /* Add the return arguments. */
8024 : 113329 : vec_safe_splice (retargs, arglist);
8025 : :
8026 : : /* Add the hidden present status for optional+value to the arguments. */
8027 : 113329 : vec_safe_splice (retargs, optionalargs);
8028 : :
8029 : : /* Add the hidden string length parameters to the arguments. */
8030 : 113329 : vec_safe_splice (retargs, stringargs);
8031 : :
8032 : : /* We may want to append extra arguments here. This is used e.g. for
8033 : : calls to libgfortran_matmul_??, which need extra information. */
8034 : 113329 : vec_safe_splice (retargs, append_args);
8035 : :
8036 : 113329 : arglist = retargs;
8037 : :
8038 : : /* Generate the actual call. */
8039 : 113329 : if (base_object == NULL_TREE)
8040 : 113249 : conv_function_val (se, sym, expr, args);
8041 : : else
8042 : 80 : conv_base_obj_fcn_val (se, base_object, expr);
8043 : :
8044 : : /* If there are alternate return labels, function type should be
8045 : : integer. Can't modify the type in place though, since it can be shared
8046 : : with other functions. For dummy arguments, the typing is done to
8047 : : this result, even if it has to be repeated for each call. */
8048 : 113329 : if (has_alternate_specifier
8049 : 113329 : && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
8050 : : {
8051 : 7 : if (!sym->attr.dummy)
8052 : : {
8053 : 0 : TREE_TYPE (sym->backend_decl)
8054 : 0 : = build_function_type (integer_type_node,
8055 : 0 : TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
8056 : 0 : se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
8057 : : }
8058 : : else
8059 : 7 : TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
8060 : : }
8061 : :
8062 : 113329 : fntype = TREE_TYPE (TREE_TYPE (se->expr));
8063 : 113329 : se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
8064 : :
8065 : : /* Allocatable scalar function results must be freed and nullified
8066 : : after use. This necessitates the creation of a temporary to
8067 : : hold the result to prevent duplicate calls. */
8068 : 113329 : symbol_attribute attr = comp ? comp->attr : sym->attr;
8069 : 113329 : bool allocatable = attr.allocatable && !attr.dimension;
8070 : 113329 : gfc_symbol *der = comp ?
8071 : 1701 : comp->ts.type == BT_DERIVED ? comp->ts.u.derived : NULL
8072 : : :
8073 : 111628 : sym->ts.type == BT_DERIVED ? sym->ts.u.derived : NULL;
8074 : 2632 : bool finalizable = der != NULL && der->ns->proc_name
8075 : 5261 : && gfc_is_finalizable (der, NULL);
8076 : :
8077 : 113329 : if (!byref && finalizable)
8078 : 149 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8079 : :
8080 : 113329 : if (!byref && sym->ts.type != BT_CHARACTER
8081 : 98510 : && allocatable && !finalizable)
8082 : : {
8083 : 113 : tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
8084 : 113 : gfc_add_modify (&se->pre, tmp, se->expr);
8085 : 113 : se->expr = tmp;
8086 : 113 : tmp = gfc_call_free (tmp);
8087 : 113 : gfc_add_expr_to_block (&post, tmp);
8088 : 113 : gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
8089 : : }
8090 : :
8091 : : /* If we have a pointer function, but we don't want a pointer, e.g.
8092 : : something like
8093 : : x = f()
8094 : : where f is pointer valued, we have to dereference the result. */
8095 : 113329 : if (!se->want_pointer && !byref
8096 : 98113 : && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8097 : 1531 : || (comp && (comp->attr.pointer || comp->attr.allocatable))))
8098 : 343 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8099 : :
8100 : : /* f2c calling conventions require a scalar default real function to
8101 : : return a double precision result. Convert this back to default
8102 : : real. We only care about the cases that can happen in Fortran 77.
8103 : : */
8104 : 113329 : if (flag_f2c && sym->ts.type == BT_REAL
8105 : 102 : && sym->ts.kind == gfc_default_real_kind
8106 : : && !sym->attr.pointer
8107 : 78 : && !sym->attr.allocatable
8108 : 42 : && !sym->attr.always_explicit)
8109 : 42 : se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
8110 : :
8111 : : /* A pure function may still have side-effects - it may modify its
8112 : : parameters. */
8113 : 113329 : TREE_SIDE_EFFECTS (se->expr) = 1;
8114 : : #if 0
8115 : : if (!sym->attr.pure)
8116 : : TREE_SIDE_EFFECTS (se->expr) = 1;
8117 : : #endif
8118 : :
8119 : 113329 : if (byref)
8120 : : {
8121 : : /* Add the function call to the pre chain. There is no expression. */
8122 : 14633 : gfc_add_expr_to_block (&se->pre, se->expr);
8123 : 14633 : se->expr = NULL_TREE;
8124 : :
8125 : 14633 : if (!se->direct_byref)
8126 : : {
8127 : 10142 : if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
8128 : : {
8129 : 7436 : if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
8130 : : {
8131 : : /* Check the data pointer hasn't been modified. This would
8132 : : happen in a function returning a pointer. */
8133 : 247 : tmp = gfc_conv_descriptor_data_get (info->descriptor);
8134 : 247 : tmp = fold_build2_loc (input_location, NE_EXPR,
8135 : : logical_type_node,
8136 : : tmp, info->data);
8137 : 247 : gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
8138 : : gfc_msg_fault);
8139 : : }
8140 : 7436 : se->expr = info->descriptor;
8141 : : /* Bundle in the string length. */
8142 : 7436 : se->string_length = len;
8143 : :
8144 : 7436 : if (finalizable)
8145 : 6 : gfc_finalize_tree_expr (se, der, attr, expr->rank);
8146 : : }
8147 : 2706 : else if (ts.type == BT_CHARACTER)
8148 : : {
8149 : : /* Dereference for character pointer results. */
8150 : 2640 : if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
8151 : 67 : || (comp && (comp->attr.pointer || comp->attr.allocatable)))
8152 : 361 : se->expr = build_fold_indirect_ref_loc (input_location, var);
8153 : : else
8154 : 2279 : se->expr = var;
8155 : :
8156 : 2640 : se->string_length = len;
8157 : : }
8158 : : else
8159 : : {
8160 : 66 : gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
8161 : 66 : se->expr = build_fold_indirect_ref_loc (input_location, var);
8162 : : }
8163 : : }
8164 : : }
8165 : :
8166 : : /* Associate the rhs class object's meta-data with the result, when the
8167 : : result is a temporary. */
8168 : 100107 : if (args && args->expr && args->expr->ts.type == BT_CLASS
8169 : 4471 : && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
8170 : 113359 : && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
8171 : : {
8172 : 30 : gfc_se parmse;
8173 : 30 : gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
8174 : :
8175 : 30 : gfc_init_se (&parmse, NULL);
8176 : 30 : parmse.data_not_needed = 1;
8177 : 30 : gfc_conv_expr (&parmse, class_expr);
8178 : 30 : if (!DECL_LANG_SPECIFIC (result))
8179 : 30 : gfc_allocate_lang_decl (result);
8180 : 30 : GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
8181 : 30 : gfc_free_expr (class_expr);
8182 : : /* -fcheck= can add diagnostic code, which has to be placed before
8183 : : the call. */
8184 : 30 : if (parmse.pre.head != NULL)
8185 : 12 : gfc_add_expr_to_block (&se->pre, parmse.pre.head);
8186 : 30 : gcc_assert (parmse.post.head == NULL_TREE);
8187 : : }
8188 : :
8189 : : /* Follow the function call with the argument post block. */
8190 : 113329 : if (byref)
8191 : : {
8192 : 14633 : gfc_add_block_to_block (&se->pre, &post);
8193 : :
8194 : : /* Transformational functions of derived types with allocatable
8195 : : components must have the result allocatable components copied when the
8196 : : argument is actually given. */
8197 : 14633 : arg = expr->value.function.actual;
8198 : 14633 : if (result && arg && expr->rank
8199 : 11205 : && expr->value.function.isym
8200 : 9669 : && expr->value.function.isym->transformational
8201 : 9669 : && arg->expr
8202 : 9627 : && arg->expr->ts.type == BT_DERIVED
8203 : 190 : && arg->expr->ts.u.derived->attr.alloc_comp)
8204 : : {
8205 : 18 : tree tmp2;
8206 : : /* Copy the allocatable components. We have to use a
8207 : : temporary here to prevent source allocatable components
8208 : : from being corrupted. */
8209 : 18 : tmp2 = gfc_evaluate_now (result, &se->pre);
8210 : 18 : tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
8211 : : result, tmp2, expr->rank, 0);
8212 : 18 : gfc_add_expr_to_block (&se->pre, tmp);
8213 : 18 : tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
8214 : : expr->rank);
8215 : 18 : gfc_add_expr_to_block (&se->pre, tmp);
8216 : :
8217 : : /* Finally free the temporary's data field. */
8218 : 18 : tmp = gfc_conv_descriptor_data_get (tmp2);
8219 : 18 : tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
8220 : : NULL_TREE, NULL_TREE, true,
8221 : : NULL, GFC_CAF_COARRAY_NOCOARRAY);
8222 : 18 : gfc_add_expr_to_block (&se->pre, tmp);
8223 : : }
8224 : : }
8225 : : else
8226 : : {
8227 : : /* For a function with a class array result, save the result as
8228 : : a temporary, set the info fields needed by the scalarizer and
8229 : : call the finalization function of the temporary. Note that the
8230 : : nullification of allocatable components needed by the result
8231 : : is done in gfc_trans_assignment_1. */
8232 : 31116 : if (expr && ((gfc_is_class_array_function (expr)
8233 : 272 : && se->ss && se->ss->loop)
8234 : 30963 : || gfc_is_alloc_class_scalar_function (expr))
8235 : 433 : && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
8236 : 99129 : && expr->must_finalize)
8237 : : {
8238 : 227 : int n;
8239 : 227 : if (se->ss && se->ss->loop)
8240 : : {
8241 : 153 : gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
8242 : 153 : se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
8243 : 153 : tmp = gfc_class_data_get (se->expr);
8244 : 153 : info->descriptor = tmp;
8245 : 153 : info->data = gfc_conv_descriptor_data_get (tmp);
8246 : 153 : info->offset = gfc_conv_descriptor_offset_get (tmp);
8247 : 306 : for (n = 0; n < se->ss->loop->dimen; n++)
8248 : : {
8249 : 153 : tree dim = gfc_rank_cst[n];
8250 : 153 : se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
8251 : 153 : se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
8252 : : }
8253 : : }
8254 : : else
8255 : : {
8256 : : /* TODO Eliminate the doubling of temporaries. This
8257 : : one is necessary to ensure no memory leakage. */
8258 : 74 : se->expr = gfc_evaluate_now (se->expr, &se->pre);
8259 : : }
8260 : :
8261 : : /* Finalize the result, if necessary. */
8262 : 227 : attr = CLASS_DATA (expr->value.function.esym->result)->attr;
8263 : 227 : if (!((gfc_is_class_array_function (expr)
8264 : 74 : || gfc_is_alloc_class_scalar_function (expr))
8265 : 227 : && attr.pointer))
8266 : 196 : gfc_finalize_tree_expr (se, NULL, attr, expr->rank);
8267 : : }
8268 : 98696 : gfc_add_block_to_block (&se->post, &post);
8269 : : }
8270 : :
8271 : : return has_alternate_specifier;
8272 : : }
8273 : :
8274 : :
8275 : : /* Fill a character string with spaces. */
8276 : :
8277 : : static tree
8278 : 27404 : fill_with_spaces (tree start, tree type, tree size)
8279 : : {
8280 : 27404 : stmtblock_t block, loop;
8281 : 27404 : tree i, el, exit_label, cond, tmp;
8282 : :
8283 : : /* For a simple char type, we can call memset(). */
8284 : 27404 : if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
8285 : 45574 : return build_call_expr_loc (input_location,
8286 : : builtin_decl_explicit (BUILT_IN_MEMSET),
8287 : : 3, start,
8288 : : build_int_cst (gfc_get_int_type (gfc_c_int_kind),
8289 : 22787 : lang_hooks.to_target_charset (' ')),
8290 : : fold_convert (size_type_node, size));
8291 : :
8292 : : /* Otherwise, we use a loop:
8293 : : for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
8294 : : *el = (type) ' ';
8295 : : */
8296 : :
8297 : : /* Initialize variables. */
8298 : 4617 : gfc_init_block (&block);
8299 : 4617 : i = gfc_create_var (sizetype, "i");
8300 : 4617 : gfc_add_modify (&block, i, fold_convert (sizetype, size));
8301 : 4617 : el = gfc_create_var (build_pointer_type (type), "el");
8302 : 4617 : gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
8303 : 4617 : exit_label = gfc_build_label_decl (NULL_TREE);
8304 : 4617 : TREE_USED (exit_label) = 1;
8305 : :
8306 : :
8307 : : /* Loop body. */
8308 : 4617 : gfc_init_block (&loop);
8309 : :
8310 : : /* Exit condition. */
8311 : 4617 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
8312 : : build_zero_cst (sizetype));
8313 : 4617 : tmp = build1_v (GOTO_EXPR, exit_label);
8314 : 4617 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
8315 : : build_empty_stmt (input_location));
8316 : 4617 : gfc_add_expr_to_block (&loop, tmp);
8317 : :
8318 : : /* Assignment. */
8319 : 4617 : gfc_add_modify (&loop,
8320 : : fold_build1_loc (input_location, INDIRECT_REF, type, el),
8321 : 4617 : build_int_cst (type, lang_hooks.to_target_charset (' ')));
8322 : :
8323 : : /* Increment loop variables. */
8324 : 4617 : gfc_add_modify (&loop, i,
8325 : : fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
8326 : 4617 : TYPE_SIZE_UNIT (type)));
8327 : 4617 : gfc_add_modify (&loop, el,
8328 : : fold_build_pointer_plus_loc (input_location,
8329 : 4617 : el, TYPE_SIZE_UNIT (type)));
8330 : :
8331 : : /* Making the loop... actually loop! */
8332 : 4617 : tmp = gfc_finish_block (&loop);
8333 : 4617 : tmp = build1_v (LOOP_EXPR, tmp);
8334 : 4617 : gfc_add_expr_to_block (&block, tmp);
8335 : :
8336 : : /* The exit label. */
8337 : 4617 : tmp = build1_v (LABEL_EXPR, exit_label);
8338 : 4617 : gfc_add_expr_to_block (&block, tmp);
8339 : :
8340 : :
8341 : 4617 : return gfc_finish_block (&block);
8342 : : }
8343 : :
8344 : :
8345 : : /* Generate code to copy a string. */
8346 : :
8347 : : void
8348 : 32283 : gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
8349 : : int dkind, tree slength, tree src, int skind)
8350 : : {
8351 : 32283 : tree tmp, dlen, slen;
8352 : 32283 : tree dsc;
8353 : 32283 : tree ssc;
8354 : 32283 : tree cond;
8355 : 32283 : tree cond2;
8356 : 32283 : tree tmp2;
8357 : 32283 : tree tmp3;
8358 : 32283 : tree tmp4;
8359 : 32283 : tree chartype;
8360 : 32283 : stmtblock_t tempblock;
8361 : :
8362 : 32283 : gcc_assert (dkind == skind);
8363 : :
8364 : 32283 : if (slength != NULL_TREE)
8365 : : {
8366 : 32283 : slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
8367 : 32283 : ssc = gfc_string_to_single_character (slen, src, skind);
8368 : : }
8369 : : else
8370 : : {
8371 : 0 : slen = build_one_cst (gfc_charlen_type_node);
8372 : 0 : ssc = src;
8373 : : }
8374 : :
8375 : 32283 : if (dlength != NULL_TREE)
8376 : : {
8377 : 32283 : dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
8378 : 32283 : dsc = gfc_string_to_single_character (dlen, dest, dkind);
8379 : : }
8380 : : else
8381 : : {
8382 : 0 : dlen = build_one_cst (gfc_charlen_type_node);
8383 : 0 : dsc = dest;
8384 : : }
8385 : :
8386 : : /* Assign directly if the types are compatible. */
8387 : 32283 : if (dsc != NULL_TREE && ssc != NULL_TREE
8388 : 32283 : && TREE_TYPE (dsc) == TREE_TYPE (ssc))
8389 : : {
8390 : 4879 : gfc_add_modify (block, dsc, ssc);
8391 : 4879 : return;
8392 : : }
8393 : :
8394 : : /* The string copy algorithm below generates code like
8395 : :
8396 : : if (destlen > 0)
8397 : : {
8398 : : if (srclen < destlen)
8399 : : {
8400 : : memmove (dest, src, srclen);
8401 : : // Pad with spaces.
8402 : : memset (&dest[srclen], ' ', destlen - srclen);
8403 : : }
8404 : : else
8405 : : {
8406 : : // Truncate if too long.
8407 : : memmove (dest, src, destlen);
8408 : : }
8409 : : }
8410 : : */
8411 : :
8412 : : /* Do nothing if the destination length is zero. */
8413 : 27404 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
8414 : 27404 : build_zero_cst (TREE_TYPE (dlen)));
8415 : :
8416 : : /* For non-default character kinds, we have to multiply the string
8417 : : length by the base type size. */
8418 : 27404 : chartype = gfc_get_char_type (dkind);
8419 : 27404 : slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
8420 : : slen,
8421 : 27404 : fold_convert (TREE_TYPE (slen),
8422 : : TYPE_SIZE_UNIT (chartype)));
8423 : 27404 : dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
8424 : : dlen,
8425 : 27404 : fold_convert (TREE_TYPE (dlen),
8426 : : TYPE_SIZE_UNIT (chartype)));
8427 : :
8428 : 27404 : if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
8429 : 27357 : dest = fold_convert (pvoid_type_node, dest);
8430 : : else
8431 : 47 : dest = gfc_build_addr_expr (pvoid_type_node, dest);
8432 : :
8433 : 27404 : if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
8434 : 27400 : src = fold_convert (pvoid_type_node, src);
8435 : : else
8436 : 4 : src = gfc_build_addr_expr (pvoid_type_node, src);
8437 : :
8438 : : /* Truncate string if source is too long. */
8439 : 27404 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
8440 : : dlen);
8441 : :
8442 : : /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */
8443 : 27404 : if (!CONSTANT_CLASS_P (cond2))
8444 : : {
8445 : 7983 : dest = gfc_evaluate_now (dest, block);
8446 : 7983 : src = gfc_evaluate_now (src, block);
8447 : : }
8448 : :
8449 : : /* Copy and pad with spaces. */
8450 : 27404 : tmp3 = build_call_expr_loc (input_location,
8451 : : builtin_decl_explicit (BUILT_IN_MEMMOVE),
8452 : : 3, dest, src,
8453 : : fold_convert (size_type_node, slen));
8454 : :
8455 : : /* Wstringop-overflow appears at -O3 even though this warning is not
8456 : : explicitly available in fortran nor can it be switched off. If the
8457 : : source length is a constant, its negative appears as a very large
8458 : : positive number and triggers the warning in BUILTIN_MEMSET. Fixing
8459 : : the result of the MINUS_EXPR suppresses this spurious warning. */
8460 : 27404 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
8461 : 27404 : TREE_TYPE(dlen), dlen, slen);
8462 : 27404 : if (slength && TREE_CONSTANT (slength))
8463 : 24402 : tmp = gfc_evaluate_now (tmp, block);
8464 : :
8465 : 27404 : tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
8466 : 27404 : tmp4 = fill_with_spaces (tmp4, chartype, tmp);
8467 : :
8468 : 27404 : gfc_init_block (&tempblock);
8469 : 27404 : gfc_add_expr_to_block (&tempblock, tmp3);
8470 : 27404 : gfc_add_expr_to_block (&tempblock, tmp4);
8471 : 27404 : tmp3 = gfc_finish_block (&tempblock);
8472 : :
8473 : : /* The truncated memmove if the slen >= dlen. */
8474 : 27404 : tmp2 = build_call_expr_loc (input_location,
8475 : : builtin_decl_explicit (BUILT_IN_MEMMOVE),
8476 : : 3, dest, src,
8477 : : fold_convert (size_type_node, dlen));
8478 : :
8479 : : /* The whole copy_string function is there. */
8480 : 27404 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
8481 : : tmp3, tmp2);
8482 : 27404 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
8483 : : build_empty_stmt (input_location));
8484 : 27404 : gfc_add_expr_to_block (block, tmp);
8485 : : }
8486 : :
8487 : :
8488 : : /* Translate a statement function.
8489 : : The value of a statement function reference is obtained by evaluating the
8490 : : expression using the values of the actual arguments for the values of the
8491 : : corresponding dummy arguments. */
8492 : :
8493 : : static void
8494 : 249 : gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
8495 : : {
8496 : 249 : gfc_symbol *sym;
8497 : 249 : gfc_symbol *fsym;
8498 : 249 : gfc_formal_arglist *fargs;
8499 : 249 : gfc_actual_arglist *args;
8500 : 249 : gfc_se lse;
8501 : 249 : gfc_se rse;
8502 : 249 : gfc_saved_var *saved_vars;
8503 : 249 : tree *temp_vars;
8504 : 249 : tree type;
8505 : 249 : tree tmp;
8506 : 249 : int n;
8507 : :
8508 : 249 : sym = expr->symtree->n.sym;
8509 : 249 : args = expr->value.function.actual;
8510 : 249 : gfc_init_se (&lse, NULL);
8511 : 249 : gfc_init_se (&rse, NULL);
8512 : :
8513 : 249 : n = 0;
8514 : 669 : for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
8515 : 420 : n++;
8516 : 249 : saved_vars = XCNEWVEC (gfc_saved_var, n);
8517 : 249 : temp_vars = XCNEWVEC (tree, n);
8518 : :
8519 : 669 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8520 : 420 : fargs = fargs->next, n++)
8521 : : {
8522 : : /* Each dummy shall be specified, explicitly or implicitly, to be
8523 : : scalar. */
8524 : 420 : gcc_assert (fargs->sym->attr.dimension == 0);
8525 : 420 : fsym = fargs->sym;
8526 : :
8527 : 420 : if (fsym->ts.type == BT_CHARACTER)
8528 : : {
8529 : : /* Copy string arguments. */
8530 : 47 : tree arglen;
8531 : :
8532 : 47 : gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
8533 : : && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
8534 : :
8535 : : /* Create a temporary to hold the value. */
8536 : 47 : if (fsym->ts.u.cl->backend_decl == NULL_TREE)
8537 : 1 : fsym->ts.u.cl->backend_decl
8538 : 1 : = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
8539 : :
8540 : 47 : type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
8541 : 47 : temp_vars[n] = gfc_create_var (type, fsym->name);
8542 : :
8543 : 47 : arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
8544 : :
8545 : 47 : gfc_conv_expr (&rse, args->expr);
8546 : 47 : gfc_conv_string_parameter (&rse);
8547 : 47 : gfc_add_block_to_block (&se->pre, &lse.pre);
8548 : 47 : gfc_add_block_to_block (&se->pre, &rse.pre);
8549 : :
8550 : 47 : gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
8551 : : rse.string_length, rse.expr, fsym->ts.kind);
8552 : 47 : gfc_add_block_to_block (&se->pre, &lse.post);
8553 : 47 : gfc_add_block_to_block (&se->pre, &rse.post);
8554 : : }
8555 : : else
8556 : : {
8557 : : /* For everything else, just evaluate the expression. */
8558 : :
8559 : : /* Create a temporary to hold the value. */
8560 : 373 : type = gfc_typenode_for_spec (&fsym->ts);
8561 : 373 : temp_vars[n] = gfc_create_var (type, fsym->name);
8562 : :
8563 : 373 : gfc_conv_expr (&lse, args->expr);
8564 : :
8565 : 373 : gfc_add_block_to_block (&se->pre, &lse.pre);
8566 : 373 : gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
8567 : 373 : gfc_add_block_to_block (&se->pre, &lse.post);
8568 : : }
8569 : :
8570 : 420 : args = args->next;
8571 : : }
8572 : :
8573 : : /* Use the temporary variables in place of the real ones. */
8574 : 669 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8575 : 420 : fargs = fargs->next, n++)
8576 : 420 : gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
8577 : :
8578 : 249 : gfc_conv_expr (se, sym->value);
8579 : :
8580 : 249 : if (sym->ts.type == BT_CHARACTER)
8581 : : {
8582 : 55 : gfc_conv_const_charlen (sym->ts.u.cl);
8583 : :
8584 : : /* Force the expression to the correct length. */
8585 : 55 : if (!INTEGER_CST_P (se->string_length)
8586 : 101 : || tree_int_cst_lt (se->string_length,
8587 : 46 : sym->ts.u.cl->backend_decl))
8588 : : {
8589 : 31 : type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
8590 : 31 : tmp = gfc_create_var (type, sym->name);
8591 : 31 : tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
8592 : 31 : gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
8593 : : sym->ts.kind, se->string_length, se->expr,
8594 : : sym->ts.kind);
8595 : 31 : se->expr = tmp;
8596 : : }
8597 : 55 : se->string_length = sym->ts.u.cl->backend_decl;
8598 : : }
8599 : :
8600 : : /* Restore the original variables. */
8601 : 669 : for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
8602 : 420 : fargs = fargs->next, n++)
8603 : 420 : gfc_restore_sym (fargs->sym, &saved_vars[n]);
8604 : 249 : free (temp_vars);
8605 : 249 : free (saved_vars);
8606 : 249 : }
8607 : :
8608 : :
8609 : : /* Translate a function expression. */
8610 : :
8611 : : static void
8612 : 258689 : gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
8613 : : {
8614 : 258689 : gfc_symbol *sym;
8615 : :
8616 : 258689 : if (expr->value.function.isym)
8617 : : {
8618 : 212098 : gfc_conv_intrinsic_function (se, expr);
8619 : 212098 : return;
8620 : : }
8621 : :
8622 : : /* expr.value.function.esym is the resolved (specific) function symbol for
8623 : : most functions. However this isn't set for dummy procedures. */
8624 : 46591 : sym = expr->value.function.esym;
8625 : 46591 : if (!sym)
8626 : 1366 : sym = expr->symtree->n.sym;
8627 : :
8628 : : /* The IEEE_ARITHMETIC functions are caught here. */
8629 : 46591 : if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
8630 : 13807 : if (gfc_conv_ieee_arithmetic_function (se, expr))
8631 : : return;
8632 : :
8633 : : /* We distinguish statement functions from general functions to improve
8634 : : runtime performance. */
8635 : 34206 : if (sym->attr.proc == PROC_ST_FUNCTION)
8636 : : {
8637 : 249 : gfc_conv_statement_function (se, expr);
8638 : 249 : return;
8639 : : }
8640 : :
8641 : 33957 : gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
8642 : : NULL);
8643 : : }
8644 : :
8645 : :
8646 : : /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
8647 : :
8648 : : static bool
8649 : 32254 : is_zero_initializer_p (gfc_expr * expr)
8650 : : {
8651 : 32254 : if (expr->expr_type != EXPR_CONSTANT)
8652 : : return false;
8653 : :
8654 : : /* We ignore constants with prescribed memory representations for now. */
8655 : 10762 : if (expr->representation.string)
8656 : : return false;
8657 : :
8658 : 10744 : switch (expr->ts.type)
8659 : : {
8660 : 4786 : case BT_INTEGER:
8661 : 4786 : return mpz_cmp_si (expr->value.integer, 0) == 0;
8662 : :
8663 : 4830 : case BT_REAL:
8664 : 4830 : return mpfr_zero_p (expr->value.real)
8665 : 4830 : && MPFR_SIGN (expr->value.real) >= 0;
8666 : :
8667 : 792 : case BT_LOGICAL:
8668 : 792 : return expr->value.logical == 0;
8669 : :
8670 : 220 : case BT_COMPLEX:
8671 : 220 : return mpfr_zero_p (mpc_realref (expr->value.complex))
8672 : 129 : && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
8673 : 129 : && mpfr_zero_p (mpc_imagref (expr->value.complex))
8674 : 337 : && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
8675 : :
8676 : : default:
8677 : : break;
8678 : : }
8679 : : return false;
8680 : : }
8681 : :
8682 : :
8683 : : static void
8684 : 29754 : gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
8685 : : {
8686 : 29754 : gfc_ss *ss;
8687 : :
8688 : 29754 : ss = se->ss;
8689 : 29754 : gcc_assert (ss != NULL && ss != gfc_ss_terminator);
8690 : 29754 : gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
8691 : :
8692 : 29754 : gfc_conv_tmp_array_ref (se);
8693 : 29754 : }
8694 : :
8695 : :
8696 : : /* Build a static initializer. EXPR is the expression for the initial value.
8697 : : The other parameters describe the variable of the component being
8698 : : initialized. EXPR may be null. */
8699 : :
8700 : : tree
8701 : 120210 : gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
8702 : : bool array, bool pointer, bool procptr)
8703 : : {
8704 : 120210 : gfc_se se;
8705 : :
8706 : 120210 : if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
8707 : 39295 : && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
8708 : 39295 : && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
8709 : 57 : return build_constructor (type, NULL);
8710 : :
8711 : 120153 : if (!(expr || pointer || procptr))
8712 : : return NULL_TREE;
8713 : :
8714 : : /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
8715 : : (these are the only two iso_c_binding derived types that can be
8716 : : used as initialization expressions). If so, we need to modify
8717 : : the 'expr' to be that for a (void *). */
8718 : 112350 : if (expr != NULL && expr->ts.type == BT_DERIVED
8719 : 35245 : && expr->ts.is_iso_c && expr->ts.u.derived)
8720 : : {
8721 : 125 : if (TREE_CODE (type) == ARRAY_TYPE)
8722 : 4 : return build_constructor (type, NULL);
8723 : 121 : else if (POINTER_TYPE_P (type))
8724 : 121 : return build_int_cst (type, 0);
8725 : : else
8726 : 0 : gcc_unreachable ();
8727 : : }
8728 : :
8729 : 112225 : if (array && !procptr)
8730 : : {
8731 : 7359 : tree ctor;
8732 : : /* Arrays need special handling. */
8733 : 7359 : if (pointer)
8734 : 580 : ctor = gfc_build_null_descriptor (type);
8735 : : /* Special case assigning an array to zero. */
8736 : 6779 : else if (is_zero_initializer_p (expr))
8737 : 197 : ctor = build_constructor (type, NULL);
8738 : : else
8739 : 6582 : ctor = gfc_conv_array_initializer (type, expr);
8740 : 7359 : TREE_STATIC (ctor) = 1;
8741 : 7359 : return ctor;
8742 : : }
8743 : 104866 : else if (pointer || procptr)
8744 : : {
8745 : 51556 : if (ts->type == BT_CLASS && !procptr)
8746 : : {
8747 : 1525 : gfc_init_se (&se, NULL);
8748 : 1525 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
8749 : 1525 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
8750 : 1525 : TREE_STATIC (se.expr) = 1;
8751 : 1525 : return se.expr;
8752 : : }
8753 : 50031 : else if (!expr || expr->expr_type == EXPR_NULL)
8754 : 27034 : return fold_convert (type, null_pointer_node);
8755 : : else
8756 : : {
8757 : 22997 : gfc_init_se (&se, NULL);
8758 : 22997 : se.want_pointer = 1;
8759 : 22997 : gfc_conv_expr (&se, expr);
8760 : 22997 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
8761 : : return se.expr;
8762 : : }
8763 : : }
8764 : : else
8765 : : {
8766 : 53310 : switch (ts->type)
8767 : : {
8768 : 16425 : case_bt_struct:
8769 : 16425 : case BT_CLASS:
8770 : 16425 : gfc_init_se (&se, NULL);
8771 : 16425 : if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
8772 : 677 : gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
8773 : : else
8774 : 15748 : gfc_conv_structure (&se, expr, 1);
8775 : 16425 : gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
8776 : 16425 : TREE_STATIC (se.expr) = 1;
8777 : 16425 : return se.expr;
8778 : :
8779 : 2486 : case BT_CHARACTER:
8780 : 2486 : if (expr->expr_type == EXPR_CONSTANT)
8781 : : {
8782 : 2485 : tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
8783 : 2485 : TREE_STATIC (ctor) = 1;
8784 : 2485 : return ctor;
8785 : : }
8786 : :
8787 : : /* Fallthrough. */
8788 : 34400 : default:
8789 : 34400 : gfc_init_se (&se, NULL);
8790 : 34400 : gfc_conv_constant (&se, expr);
8791 : 34400 : gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
8792 : : return se.expr;
8793 : : }
8794 : : }
8795 : : }
8796 : :
8797 : : static tree
8798 : 862 : gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
8799 : : {
8800 : 862 : gfc_se rse;
8801 : 862 : gfc_se lse;
8802 : 862 : gfc_ss *rss;
8803 : 862 : gfc_ss *lss;
8804 : 862 : gfc_array_info *lss_array;
8805 : 862 : stmtblock_t body;
8806 : 862 : stmtblock_t block;
8807 : 862 : gfc_loopinfo loop;
8808 : 862 : int n;
8809 : 862 : tree tmp;
8810 : :
8811 : 862 : gfc_start_block (&block);
8812 : :
8813 : : /* Initialize the scalarizer. */
8814 : 862 : gfc_init_loopinfo (&loop);
8815 : :
8816 : 862 : gfc_init_se (&lse, NULL);
8817 : 862 : gfc_init_se (&rse, NULL);
8818 : :
8819 : : /* Walk the rhs. */
8820 : 862 : rss = gfc_walk_expr (expr);
8821 : 862 : if (rss == gfc_ss_terminator)
8822 : : /* The rhs is scalar. Add a ss for the expression. */
8823 : 159 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
8824 : :
8825 : : /* Create a SS for the destination. */
8826 : 862 : lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
8827 : : GFC_SS_COMPONENT);
8828 : 862 : lss_array = &lss->info->data.array;
8829 : 862 : lss_array->shape = gfc_get_shape (cm->as->rank);
8830 : 862 : lss_array->descriptor = dest;
8831 : 862 : lss_array->data = gfc_conv_array_data (dest);
8832 : 862 : lss_array->offset = gfc_conv_array_offset (dest);
8833 : 1786 : for (n = 0; n < cm->as->rank; n++)
8834 : : {
8835 : 924 : lss_array->start[n] = gfc_conv_array_lbound (dest, n);
8836 : 924 : lss_array->stride[n] = gfc_index_one_node;
8837 : :
8838 : 924 : mpz_init (lss_array->shape[n]);
8839 : 924 : mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
8840 : 924 : cm->as->lower[n]->value.integer);
8841 : 924 : mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
8842 : : }
8843 : :
8844 : : /* Associate the SS with the loop. */
8845 : 862 : gfc_add_ss_to_loop (&loop, lss);
8846 : 862 : gfc_add_ss_to_loop (&loop, rss);
8847 : :
8848 : : /* Calculate the bounds of the scalarization. */
8849 : 862 : gfc_conv_ss_startstride (&loop);
8850 : :
8851 : : /* Setup the scalarizing loops. */
8852 : 862 : gfc_conv_loop_setup (&loop, &expr->where);
8853 : :
8854 : : /* Setup the gfc_se structures. */
8855 : 862 : gfc_copy_loopinfo_to_se (&lse, &loop);
8856 : 862 : gfc_copy_loopinfo_to_se (&rse, &loop);
8857 : :
8858 : 862 : rse.ss = rss;
8859 : 862 : gfc_mark_ss_chain_used (rss, 1);
8860 : 862 : lse.ss = lss;
8861 : 862 : gfc_mark_ss_chain_used (lss, 1);
8862 : :
8863 : : /* Start the scalarized loop body. */
8864 : 862 : gfc_start_scalarized_body (&loop, &body);
8865 : :
8866 : 862 : gfc_conv_tmp_array_ref (&lse);
8867 : 862 : if (cm->ts.type == BT_CHARACTER)
8868 : 170 : lse.string_length = cm->ts.u.cl->backend_decl;
8869 : :
8870 : 862 : gfc_conv_expr (&rse, expr);
8871 : :
8872 : 862 : tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
8873 : 862 : gfc_add_expr_to_block (&body, tmp);
8874 : :
8875 : 862 : gcc_assert (rse.ss == gfc_ss_terminator);
8876 : :
8877 : : /* Generate the copying loops. */
8878 : 862 : gfc_trans_scalarizing_loops (&loop, &body);
8879 : :
8880 : : /* Wrap the whole thing up. */
8881 : 862 : gfc_add_block_to_block (&block, &loop.pre);
8882 : 862 : gfc_add_block_to_block (&block, &loop.post);
8883 : :
8884 : 862 : gcc_assert (lss_array->shape != NULL);
8885 : 862 : gfc_free_shape (&lss_array->shape, cm->as->rank);
8886 : 862 : gfc_cleanup_loop (&loop);
8887 : :
8888 : 862 : return gfc_finish_block (&block);
8889 : : }
8890 : :
8891 : :
8892 : : static tree
8893 : 996 : gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
8894 : : gfc_expr * expr)
8895 : : {
8896 : 996 : gfc_se se;
8897 : 996 : stmtblock_t block;
8898 : 996 : tree offset;
8899 : 996 : int n;
8900 : 996 : tree tmp;
8901 : 996 : tree tmp2;
8902 : 996 : gfc_array_spec *as;
8903 : 996 : gfc_expr *arg = NULL;
8904 : :
8905 : 996 : gfc_start_block (&block);
8906 : 996 : gfc_init_se (&se, NULL);
8907 : :
8908 : : /* Get the descriptor for the expressions. */
8909 : 996 : se.want_pointer = 0;
8910 : 996 : gfc_conv_expr_descriptor (&se, expr);
8911 : 996 : gfc_add_block_to_block (&block, &se.pre);
8912 : 996 : gfc_add_modify (&block, dest, se.expr);
8913 : 996 : if (cm->ts.type == BT_CHARACTER
8914 : 996 : && gfc_deferred_strlen (cm, &tmp))
8915 : : {
8916 : 30 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
8917 : 30 : TREE_TYPE (tmp),
8918 : 30 : TREE_OPERAND (dest, 0),
8919 : : tmp, NULL_TREE);
8920 : 30 : gfc_add_modify (&block, tmp,
8921 : 30 : fold_convert (TREE_TYPE (tmp),
8922 : : se.string_length));
8923 : 30 : cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node,
8924 : : "slen");
8925 : 30 : gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length);
8926 : : }
8927 : :
8928 : : /* Deal with arrays of derived types with allocatable components. */
8929 : 996 : if (gfc_bt_struct (cm->ts.type)
8930 : 168 : && cm->ts.u.derived->attr.alloc_comp)
8931 : : // TODO: Fix caf_mode
8932 : 114 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
8933 : : se.expr, dest,
8934 : 114 : cm->as->rank, 0);
8935 : 882 : else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
8936 : 30 : && CLASS_DATA(cm)->attr.allocatable)
8937 : : {
8938 : 30 : if (cm->ts.u.derived->attr.alloc_comp)
8939 : : // TODO: Fix caf_mode
8940 : 0 : tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
8941 : : se.expr, dest,
8942 : : expr->rank, 0);
8943 : : else
8944 : : {
8945 : 30 : tmp = TREE_TYPE (dest);
8946 : 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
8947 : : tmp, expr->rank, NULL_TREE);
8948 : : }
8949 : : }
8950 : 852 : else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8951 : 30 : tmp = gfc_duplicate_allocatable (dest, se.expr,
8952 : : gfc_typenode_for_spec (&cm->ts),
8953 : 30 : cm->as->rank, NULL_TREE);
8954 : : else
8955 : 822 : tmp = gfc_duplicate_allocatable (dest, se.expr,
8956 : 822 : TREE_TYPE(cm->backend_decl),
8957 : 822 : cm->as->rank, NULL_TREE);
8958 : :
8959 : :
8960 : 996 : gfc_add_expr_to_block (&block, tmp);
8961 : 996 : gfc_add_block_to_block (&block, &se.post);
8962 : :
8963 : 996 : if (expr->expr_type != EXPR_VARIABLE)
8964 : 876 : gfc_conv_descriptor_data_set (&block, se.expr,
8965 : : null_pointer_node);
8966 : :
8967 : : /* We need to know if the argument of a conversion function is a
8968 : : variable, so that the correct lower bound can be used. */
8969 : 996 : if (expr->expr_type == EXPR_FUNCTION
8970 : 60 : && expr->value.function.isym
8971 : 48 : && expr->value.function.isym->conversion
8972 : 48 : && expr->value.function.actual->expr
8973 : 48 : && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
8974 : 48 : arg = expr->value.function.actual->expr;
8975 : :
8976 : : /* Obtain the array spec of full array references. */
8977 : 48 : if (arg)
8978 : 48 : as = gfc_get_full_arrayspec_from_expr (arg);
8979 : : else
8980 : 948 : as = gfc_get_full_arrayspec_from_expr (expr);
8981 : :
8982 : : /* Shift the lbound and ubound of temporaries to being unity,
8983 : : rather than zero, based. Always calculate the offset. */
8984 : 996 : offset = gfc_conv_descriptor_offset_get (dest);
8985 : 996 : gfc_add_modify (&block, offset, gfc_index_zero_node);
8986 : 996 : tmp2 =gfc_create_var (gfc_array_index_type, NULL);
8987 : :
8988 : 2058 : for (n = 0; n < expr->rank; n++)
8989 : : {
8990 : 1062 : tree span;
8991 : 1062 : tree lbound;
8992 : :
8993 : : /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
8994 : : TODO It looks as if gfc_conv_expr_descriptor should return
8995 : : the correct bounds and that the following should not be
8996 : : necessary. This would simplify gfc_conv_intrinsic_bound
8997 : : as well. */
8998 : 1062 : if (as && as->lower[n])
8999 : : {
9000 : 54 : gfc_se lbse;
9001 : 54 : gfc_init_se (&lbse, NULL);
9002 : 54 : gfc_conv_expr (&lbse, as->lower[n]);
9003 : 54 : gfc_add_block_to_block (&block, &lbse.pre);
9004 : 54 : lbound = gfc_evaluate_now (lbse.expr, &block);
9005 : 54 : }
9006 : 1008 : else if (as && arg)
9007 : : {
9008 : 66 : tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
9009 : 66 : lbound = gfc_conv_descriptor_lbound_get (tmp,
9010 : : gfc_rank_cst[n]);
9011 : : }
9012 : 942 : else if (as)
9013 : 72 : lbound = gfc_conv_descriptor_lbound_get (dest,
9014 : : gfc_rank_cst[n]);
9015 : : else
9016 : 870 : lbound = gfc_index_one_node;
9017 : :
9018 : 1062 : lbound = fold_convert (gfc_array_index_type, lbound);
9019 : :
9020 : : /* Shift the bounds and set the offset accordingly. */
9021 : 1062 : tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
9022 : 1062 : span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9023 : : tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
9024 : 1062 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
9025 : : span, lbound);
9026 : 1062 : gfc_conv_descriptor_ubound_set (&block, dest,
9027 : : gfc_rank_cst[n], tmp);
9028 : 1062 : gfc_conv_descriptor_lbound_set (&block, dest,
9029 : : gfc_rank_cst[n], lbound);
9030 : :
9031 : 1062 : tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9032 : : gfc_conv_descriptor_lbound_get (dest,
9033 : : gfc_rank_cst[n]),
9034 : : gfc_conv_descriptor_stride_get (dest,
9035 : : gfc_rank_cst[n]));
9036 : 1062 : gfc_add_modify (&block, tmp2, tmp);
9037 : 1062 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
9038 : : offset, tmp2);
9039 : 1062 : gfc_conv_descriptor_offset_set (&block, dest, tmp);
9040 : : }
9041 : :
9042 : 996 : if (arg)
9043 : : {
9044 : : /* If a conversion expression has a null data pointer
9045 : : argument, nullify the allocatable component. */
9046 : 48 : tree non_null_expr;
9047 : 48 : tree null_expr;
9048 : :
9049 : 48 : if (arg->symtree->n.sym->attr.allocatable
9050 : 48 : || arg->symtree->n.sym->attr.pointer)
9051 : : {
9052 : 48 : non_null_expr = gfc_finish_block (&block);
9053 : 48 : gfc_start_block (&block);
9054 : 48 : gfc_conv_descriptor_data_set (&block, dest,
9055 : : null_pointer_node);
9056 : 48 : null_expr = gfc_finish_block (&block);
9057 : 48 : tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
9058 : 48 : tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
9059 : 48 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
9060 : 48 : return build3_v (COND_EXPR, tmp,
9061 : : null_expr, non_null_expr);
9062 : : }
9063 : : }
9064 : :
9065 : 948 : return gfc_finish_block (&block);
9066 : : }
9067 : :
9068 : :
9069 : : /* Allocate or reallocate scalar component, as necessary. */
9070 : :
9071 : : static void
9072 : 280 : alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
9073 : : gfc_component *cm, gfc_expr *expr2,
9074 : : tree slen)
9075 : : {
9076 : 280 : tree tmp;
9077 : 280 : tree ptr;
9078 : 280 : tree size;
9079 : 280 : tree size_in_bytes;
9080 : 280 : tree lhs_cl_size = NULL_TREE;
9081 : 280 : gfc_se se;
9082 : :
9083 : 280 : if (!comp)
9084 : 0 : return;
9085 : :
9086 : 280 : if (!expr2 || expr2->rank)
9087 : : return;
9088 : :
9089 : 280 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9090 : :
9091 : 280 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9092 : : {
9093 : 124 : gcc_assert (expr2->ts.type == BT_CHARACTER);
9094 : 124 : size = expr2->ts.u.cl->backend_decl;
9095 : 124 : if (!size || !VAR_P (size))
9096 : 124 : size = gfc_create_var (TREE_TYPE (slen), "slen");
9097 : 124 : gfc_add_modify (block, size, slen);
9098 : :
9099 : 124 : gfc_deferred_strlen (cm, &tmp);
9100 : 124 : lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
9101 : : gfc_charlen_type_node,
9102 : 124 : TREE_OPERAND (comp, 0),
9103 : : tmp, NULL_TREE);
9104 : :
9105 : 124 : tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
9106 : 124 : tmp = TYPE_SIZE_UNIT (tmp);
9107 : 248 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9108 : 124 : TREE_TYPE (tmp), tmp,
9109 : 124 : fold_convert (TREE_TYPE (tmp), size));
9110 : : }
9111 : 156 : else if (cm->ts.type == BT_CLASS)
9112 : : {
9113 : 78 : if (expr2->ts.type != BT_CLASS)
9114 : : {
9115 : 78 : if (expr2->ts.type == BT_CHARACTER)
9116 : : {
9117 : 18 : gfc_init_se (&se, NULL);
9118 : 18 : gfc_conv_expr (&se, expr2);
9119 : 18 : size = build_int_cst (gfc_charlen_type_node, expr2->ts.kind);
9120 : 18 : size = fold_build2_loc (input_location, MULT_EXPR,
9121 : : gfc_charlen_type_node,
9122 : : se.string_length, size);
9123 : 18 : size = fold_convert (size_type_node, size);
9124 : : }
9125 : : else
9126 : : {
9127 : 60 : if (expr2->ts.type == BT_DERIVED)
9128 : 48 : tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
9129 : : else
9130 : 12 : tmp = gfc_typenode_for_spec (&expr2->ts);
9131 : 60 : size = TYPE_SIZE_UNIT (tmp);
9132 : : }
9133 : : }
9134 : : else
9135 : : {
9136 : 0 : gfc_expr *e2vtab;
9137 : 0 : e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
9138 : 0 : gfc_add_vptr_component (e2vtab);
9139 : 0 : gfc_add_size_component (e2vtab);
9140 : 0 : gfc_init_se (&se, NULL);
9141 : 0 : gfc_conv_expr (&se, e2vtab);
9142 : 0 : gfc_add_block_to_block (block, &se.pre);
9143 : 0 : size = fold_convert (size_type_node, se.expr);
9144 : 0 : gfc_free_expr (e2vtab);
9145 : : }
9146 : : size_in_bytes = size;
9147 : : }
9148 : : else
9149 : : {
9150 : : /* Otherwise use the length in bytes of the rhs. */
9151 : 78 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
9152 : 78 : size_in_bytes = size;
9153 : : }
9154 : :
9155 : 280 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9156 : : size_in_bytes, size_one_node);
9157 : :
9158 : 280 : if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
9159 : : {
9160 : 0 : tmp = build_call_expr_loc (input_location,
9161 : : builtin_decl_explicit (BUILT_IN_CALLOC),
9162 : : 2, build_one_cst (size_type_node),
9163 : : size_in_bytes);
9164 : 0 : tmp = fold_convert (TREE_TYPE (comp), tmp);
9165 : 0 : gfc_add_modify (block, comp, tmp);
9166 : : }
9167 : : else
9168 : : {
9169 : 280 : tmp = build_call_expr_loc (input_location,
9170 : : builtin_decl_explicit (BUILT_IN_MALLOC),
9171 : : 1, size_in_bytes);
9172 : 280 : if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
9173 : 78 : ptr = gfc_class_data_get (comp);
9174 : : else
9175 : : ptr = comp;
9176 : 280 : tmp = fold_convert (TREE_TYPE (ptr), tmp);
9177 : 280 : gfc_add_modify (block, ptr, tmp);
9178 : : }
9179 : :
9180 : 280 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9181 : : /* Update the lhs character length. */
9182 : 124 : gfc_add_modify (block, lhs_cl_size,
9183 : 124 : fold_convert (TREE_TYPE (lhs_cl_size), size));
9184 : : }
9185 : :
9186 : :
9187 : : /* Assign a single component of a derived type constructor. */
9188 : :
9189 : : static tree
9190 : 22828 : gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
9191 : : gfc_expr * expr, bool init)
9192 : : {
9193 : 22828 : gfc_se se;
9194 : 22828 : gfc_se lse;
9195 : 22828 : stmtblock_t block;
9196 : 22828 : tree tmp;
9197 : 22828 : tree vtab;
9198 : :
9199 : 22828 : gfc_start_block (&block);
9200 : :
9201 : 22828 : if (cm->attr.pointer || cm->attr.proc_pointer)
9202 : : {
9203 : : /* Only care about pointers here, not about allocatables. */
9204 : 2235 : gfc_init_se (&se, NULL);
9205 : : /* Pointer component. */
9206 : 2235 : if ((cm->attr.dimension || cm->attr.codimension)
9207 : 557 : && !cm->attr.proc_pointer)
9208 : : {
9209 : : /* Array pointer. */
9210 : 542 : if (expr->expr_type == EXPR_NULL)
9211 : 536 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9212 : : else
9213 : : {
9214 : 6 : se.direct_byref = 1;
9215 : 6 : se.expr = dest;
9216 : 6 : gfc_conv_expr_descriptor (&se, expr);
9217 : 6 : gfc_add_block_to_block (&block, &se.pre);
9218 : 6 : gfc_add_block_to_block (&block, &se.post);
9219 : : }
9220 : : }
9221 : : else
9222 : : {
9223 : : /* Scalar pointers. */
9224 : 1693 : se.want_pointer = 1;
9225 : 1693 : gfc_conv_expr (&se, expr);
9226 : 1693 : gfc_add_block_to_block (&block, &se.pre);
9227 : :
9228 : 1693 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
9229 : 842 : && expr->symtree->n.sym->attr.dummy)
9230 : 12 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
9231 : :
9232 : 1693 : gfc_add_modify (&block, dest,
9233 : 1693 : fold_convert (TREE_TYPE (dest), se.expr));
9234 : 1693 : gfc_add_block_to_block (&block, &se.post);
9235 : : }
9236 : : }
9237 : 20593 : else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
9238 : : {
9239 : : /* NULL initialization for CLASS components. */
9240 : 751 : tmp = gfc_trans_structure_assign (dest,
9241 : : gfc_class_initializer (&cm->ts, expr),
9242 : : false);
9243 : 751 : gfc_add_expr_to_block (&block, tmp);
9244 : : }
9245 : 19842 : else if ((cm->attr.dimension || cm->attr.codimension)
9246 : 3666 : && !cm->attr.proc_pointer)
9247 : : {
9248 : 3666 : if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
9249 : 1838 : gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
9250 : 1828 : else if (cm->attr.allocatable || cm->attr.pdt_array)
9251 : : {
9252 : 966 : tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
9253 : 966 : gfc_add_expr_to_block (&block, tmp);
9254 : : }
9255 : : else
9256 : : {
9257 : 862 : tmp = gfc_trans_subarray_assign (dest, cm, expr);
9258 : 862 : gfc_add_expr_to_block (&block, tmp);
9259 : : }
9260 : : }
9261 : 16176 : else if (cm->ts.type == BT_CLASS
9262 : 114 : && CLASS_DATA (cm)->attr.dimension
9263 : 114 : && CLASS_DATA (cm)->attr.allocatable
9264 : 30 : && expr->ts.type == BT_DERIVED)
9265 : : {
9266 : 30 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
9267 : 30 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
9268 : 30 : tmp = gfc_class_vptr_get (dest);
9269 : 30 : gfc_add_modify (&block, tmp,
9270 : 30 : fold_convert (TREE_TYPE (tmp), vtab));
9271 : 30 : tmp = gfc_class_data_get (dest);
9272 : 30 : tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
9273 : 30 : gfc_add_expr_to_block (&block, tmp);
9274 : : }
9275 : 16146 : else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
9276 : : {
9277 : : /* NULL initialization for allocatable components. */
9278 : 66 : gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
9279 : : null_pointer_node));
9280 : : }
9281 : 11380 : else if (init && (cm->attr.allocatable
9282 : 11178 : || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
9283 : 84 : && expr->ts.type != BT_CLASS)))
9284 : : {
9285 : 280 : tree size;
9286 : :
9287 : 280 : gfc_init_se (&se, NULL);
9288 : 280 : gfc_conv_expr (&se, expr);
9289 : :
9290 : : /* The remainder of these instructions follow the if (cm->attr.pointer)
9291 : : if (!cm->attr.dimension) part above. */
9292 : 280 : gfc_add_block_to_block (&block, &se.pre);
9293 : : /* Take care about non-array allocatable components here. The alloc_*
9294 : : routine below is motivated by the alloc_scalar_allocatable_for_
9295 : : assignment() routine, but with the realloc portions removed and
9296 : : different input. */
9297 : 280 : alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
9298 : : se.string_length);
9299 : :
9300 : 280 : if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
9301 : 107 : && expr->symtree->n.sym->attr.dummy)
9302 : 0 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
9303 : :
9304 : 280 : if (cm->ts.type == BT_CLASS)
9305 : : {
9306 : 78 : tmp = gfc_class_data_get (dest);
9307 : 78 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
9308 : 78 : vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
9309 : 78 : vtab = gfc_build_addr_expr (NULL_TREE, vtab);
9310 : 78 : gfc_add_modify (&block, gfc_class_vptr_get (dest),
9311 : 78 : fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
9312 : : }
9313 : : else
9314 : 202 : tmp = build_fold_indirect_ref_loc (input_location, dest);
9315 : :
9316 : : /* For deferred strings insert a memcpy. */
9317 : 280 : if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
9318 : : {
9319 : 124 : gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
9320 : 124 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length
9321 : : ? se.string_length
9322 : 0 : : expr->ts.u.cl->backend_decl);
9323 : 124 : tmp = gfc_build_memcpy_call (tmp, se.expr, size);
9324 : 124 : gfc_add_expr_to_block (&block, tmp);
9325 : : }
9326 : 156 : else if (cm->ts.type == BT_CLASS)
9327 : : {
9328 : : /* Fix the expression for memcpy. */
9329 : 78 : if (expr->expr_type != EXPR_VARIABLE)
9330 : 48 : se.expr = gfc_evaluate_now (se.expr, &block);
9331 : :
9332 : 78 : if (expr->ts.type == BT_CHARACTER)
9333 : : {
9334 : 18 : size = build_int_cst (gfc_charlen_type_node, expr->ts.kind);
9335 : 18 : size = fold_build2_loc (input_location, MULT_EXPR,
9336 : : gfc_charlen_type_node,
9337 : : se.string_length, size);
9338 : 18 : size = fold_convert (size_type_node, size);
9339 : : }
9340 : : else
9341 : 60 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts));
9342 : :
9343 : : /* Now copy the expression to the constructor component _data. */
9344 : 78 : gfc_add_expr_to_block (&block,
9345 : : gfc_build_memcpy_call (tmp, se.expr, size));
9346 : :
9347 : : /* Fill the unlimited polymorphic _len field. */
9348 : 78 : if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER)
9349 : : {
9350 : 18 : tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp));
9351 : 18 : gfc_add_modify (&block, tmp,
9352 : 18 : fold_convert (TREE_TYPE (tmp),
9353 : : se.string_length));
9354 : : }
9355 : : }
9356 : : else
9357 : 78 : gfc_add_modify (&block, tmp,
9358 : 78 : fold_convert (TREE_TYPE (tmp), se.expr));
9359 : 280 : gfc_add_block_to_block (&block, &se.post);
9360 : 280 : }
9361 : 15800 : else if (expr->ts.type == BT_UNION)
9362 : : {
9363 : 13 : tree tmp;
9364 : 13 : gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
9365 : : /* We mark that the entire union should be initialized with a contrived
9366 : : EXPR_NULL expression at the beginning. */
9367 : 13 : if (c != NULL && c->n.component == NULL
9368 : 7 : && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
9369 : : {
9370 : 6 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
9371 : 6 : dest, build_constructor (TREE_TYPE (dest), NULL));
9372 : 6 : gfc_add_expr_to_block (&block, tmp);
9373 : 6 : c = gfc_constructor_next (c);
9374 : : }
9375 : : /* The following constructor expression, if any, represents a specific
9376 : : map intializer, as given by the user. */
9377 : 13 : if (c != NULL && c->expr != NULL)
9378 : : {
9379 : 6 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
9380 : 6 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
9381 : 6 : gfc_add_expr_to_block (&block, tmp);
9382 : : }
9383 : : }
9384 : 15787 : else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
9385 : : {
9386 : 2190 : if (expr->expr_type != EXPR_STRUCTURE)
9387 : : {
9388 : 329 : tree dealloc = NULL_TREE;
9389 : 329 : gfc_init_se (&se, NULL);
9390 : 329 : gfc_conv_expr (&se, expr);
9391 : 329 : gfc_add_block_to_block (&block, &se.pre);
9392 : : /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
9393 : : expression in a temporary variable and deallocate the allocatable
9394 : : components. Then we can the copy the expression to the result. */
9395 : 329 : if (cm->ts.u.derived->attr.alloc_comp
9396 : 231 : && expr->expr_type != EXPR_VARIABLE)
9397 : : {
9398 : 201 : se.expr = gfc_evaluate_now (se.expr, &block);
9399 : 201 : dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
9400 : : expr->rank);
9401 : : }
9402 : 329 : gfc_add_modify (&block, dest,
9403 : 329 : fold_convert (TREE_TYPE (dest), se.expr));
9404 : 329 : if (cm->ts.u.derived->attr.alloc_comp
9405 : 231 : && expr->expr_type != EXPR_NULL)
9406 : : {
9407 : : // TODO: Fix caf_mode
9408 : 48 : tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
9409 : : dest, expr->rank, 0);
9410 : 48 : gfc_add_expr_to_block (&block, tmp);
9411 : 48 : if (dealloc != NULL_TREE)
9412 : 18 : gfc_add_expr_to_block (&block, dealloc);
9413 : : }
9414 : 329 : gfc_add_block_to_block (&block, &se.post);
9415 : : }
9416 : : else
9417 : : {
9418 : : /* Nested constructors. */
9419 : 1861 : tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
9420 : 1861 : gfc_add_expr_to_block (&block, tmp);
9421 : : }
9422 : : }
9423 : 13597 : else if (gfc_deferred_strlen (cm, &tmp))
9424 : : {
9425 : 67 : tree strlen;
9426 : 67 : strlen = tmp;
9427 : 67 : gcc_assert (strlen);
9428 : 67 : strlen = fold_build3_loc (input_location, COMPONENT_REF,
9429 : 67 : TREE_TYPE (strlen),
9430 : 67 : TREE_OPERAND (dest, 0),
9431 : : strlen, NULL_TREE);
9432 : :
9433 : 67 : if (expr->expr_type == EXPR_NULL)
9434 : : {
9435 : 55 : tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
9436 : 55 : gfc_add_modify (&block, dest, tmp);
9437 : 55 : tmp = build_int_cst (TREE_TYPE (strlen), 0);
9438 : 55 : gfc_add_modify (&block, strlen, tmp);
9439 : : }
9440 : : else
9441 : : {
9442 : 12 : tree size;
9443 : 12 : gfc_init_se (&se, NULL);
9444 : 12 : gfc_conv_expr (&se, expr);
9445 : 12 : size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
9446 : 12 : tmp = build_call_expr_loc (input_location,
9447 : : builtin_decl_explicit (BUILT_IN_MALLOC),
9448 : : 1, size);
9449 : 12 : gfc_add_modify (&block, dest,
9450 : 12 : fold_convert (TREE_TYPE (dest), tmp));
9451 : 12 : gfc_add_modify (&block, strlen,
9452 : 12 : fold_convert (TREE_TYPE (strlen), se.string_length));
9453 : 12 : tmp = gfc_build_memcpy_call (dest, se.expr, size);
9454 : 12 : gfc_add_expr_to_block (&block, tmp);
9455 : : }
9456 : : }
9457 : 13530 : else if (!cm->attr.artificial)
9458 : : {
9459 : : /* Scalar component (excluding deferred parameters). */
9460 : 13463 : gfc_init_se (&se, NULL);
9461 : 13463 : gfc_init_se (&lse, NULL);
9462 : :
9463 : 13463 : gfc_conv_expr (&se, expr);
9464 : 13463 : if (cm->ts.type == BT_CHARACTER)
9465 : 1038 : lse.string_length = cm->ts.u.cl->backend_decl;
9466 : 13463 : lse.expr = dest;
9467 : 13463 : tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
9468 : 13463 : gfc_add_expr_to_block (&block, tmp);
9469 : : }
9470 : 22828 : return gfc_finish_block (&block);
9471 : : }
9472 : :
9473 : : /* Assign a derived type constructor to a variable. */
9474 : :
9475 : : tree
9476 : 16289 : gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
9477 : : {
9478 : 16289 : gfc_constructor *c;
9479 : 16289 : gfc_component *cm;
9480 : 16289 : stmtblock_t block;
9481 : 16289 : tree field;
9482 : 16289 : tree tmp;
9483 : 16289 : gfc_se se;
9484 : :
9485 : 16289 : gfc_start_block (&block);
9486 : :
9487 : 16289 : if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
9488 : 158 : && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
9489 : 9 : || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
9490 : : {
9491 : 158 : gfc_se lse;
9492 : :
9493 : 158 : gfc_init_se (&se, NULL);
9494 : 158 : gfc_init_se (&lse, NULL);
9495 : 158 : gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
9496 : 158 : lse.expr = dest;
9497 : 158 : gfc_add_modify (&block, lse.expr,
9498 : 158 : fold_convert (TREE_TYPE (lse.expr), se.expr));
9499 : :
9500 : 158 : return gfc_finish_block (&block);
9501 : : }
9502 : :
9503 : : /* Make sure that the derived type has been completely built. */
9504 : 16131 : if (!expr->ts.u.derived->backend_decl
9505 : 16131 : || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
9506 : : {
9507 : 220 : tmp = gfc_typenode_for_spec (&expr->ts);
9508 : 220 : gcc_assert (tmp);
9509 : : }
9510 : :
9511 : 16131 : cm = expr->ts.u.derived->components;
9512 : :
9513 : :
9514 : 16131 : if (coarray)
9515 : 107 : gfc_init_se (&se, NULL);
9516 : :
9517 : 16131 : for (c = gfc_constructor_first (expr->value.constructor);
9518 : 41780 : c; c = gfc_constructor_next (c), cm = cm->next)
9519 : : {
9520 : : /* Skip absent members in default initializers. */
9521 : 25649 : if (!c->expr && !cm->attr.allocatable)
9522 : 2821 : continue;
9523 : :
9524 : : /* Register the component with the caf-lib before it is initialized.
9525 : : Register only allocatable components, that are not coarray'ed
9526 : : components (%comp[*]). Only register when the constructor is not the
9527 : : null-expression. */
9528 : 22828 : if (coarray && !cm->attr.codimension
9529 : 186 : && (cm->attr.allocatable || cm->attr.pointer)
9530 : 177 : && (!c->expr || c->expr->expr_type == EXPR_NULL))
9531 : : {
9532 : 177 : tree token, desc, size;
9533 : 354 : bool is_array = cm->ts.type == BT_CLASS
9534 : 177 : ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
9535 : :
9536 : 177 : field = cm->backend_decl;
9537 : 177 : field = fold_build3_loc (input_location, COMPONENT_REF,
9538 : 177 : TREE_TYPE (field), dest, field, NULL_TREE);
9539 : 177 : if (cm->ts.type == BT_CLASS)
9540 : 0 : field = gfc_class_data_get (field);
9541 : :
9542 : 177 : token = is_array ? gfc_conv_descriptor_token (field)
9543 : 58 : : fold_build3_loc (input_location, COMPONENT_REF,
9544 : 58 : TREE_TYPE (cm->caf_token), dest,
9545 : : cm->caf_token, NULL_TREE);
9546 : :
9547 : 177 : if (is_array)
9548 : : {
9549 : : /* The _caf_register routine looks at the rank of the array
9550 : : descriptor to decide whether the data registered is an array
9551 : : or not. */
9552 : 119 : int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
9553 : 119 : : cm->as->rank;
9554 : : /* When the rank is not known just set a positive rank, which
9555 : : suffices to recognize the data as array. */
9556 : 119 : if (rank < 0)
9557 : 0 : rank = 1;
9558 : 119 : size = build_zero_cst (size_type_node);
9559 : 119 : desc = field;
9560 : 119 : gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
9561 : : build_int_cst (signed_char_type_node, rank));
9562 : : }
9563 : : else
9564 : : {
9565 : 58 : desc = gfc_conv_scalar_to_descriptor (&se, field,
9566 : 58 : cm->ts.type == BT_CLASS
9567 : 58 : ? CLASS_DATA (cm)->attr
9568 : : : cm->attr);
9569 : 58 : size = TYPE_SIZE_UNIT (TREE_TYPE (field));
9570 : : }
9571 : 177 : gfc_add_block_to_block (&block, &se.pre);
9572 : 177 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
9573 : : 7, size, build_int_cst (
9574 : : integer_type_node,
9575 : 177 : GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
9576 : : gfc_build_addr_expr (pvoid_type_node,
9577 : : token),
9578 : : gfc_build_addr_expr (NULL_TREE, desc),
9579 : : null_pointer_node, null_pointer_node,
9580 : : integer_zero_node);
9581 : 177 : gfc_add_expr_to_block (&block, tmp);
9582 : : }
9583 : 22828 : field = cm->backend_decl;
9584 : 22828 : gcc_assert(field);
9585 : 22828 : tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
9586 : : dest, field, NULL_TREE);
9587 : 22828 : if (!c->expr)
9588 : : {
9589 : 0 : gfc_expr *e = gfc_get_null_expr (NULL);
9590 : 0 : tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
9591 : 0 : gfc_free_expr (e);
9592 : : }
9593 : : else
9594 : 22828 : tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
9595 : 22828 : gfc_add_expr_to_block (&block, tmp);
9596 : : }
9597 : 16131 : return gfc_finish_block (&block);
9598 : : }
9599 : :
9600 : : static void
9601 : 21 : gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v,
9602 : : gfc_component *un, gfc_expr *init)
9603 : : {
9604 : 21 : gfc_constructor *ctor;
9605 : :
9606 : 21 : if (un->ts.type != BT_UNION || un == NULL || init == NULL)
9607 : : return;
9608 : :
9609 : 21 : ctor = gfc_constructor_first (init->value.constructor);
9610 : :
9611 : 21 : if (ctor == NULL || ctor->expr == NULL)
9612 : : return;
9613 : :
9614 : 21 : gcc_assert (init->expr_type == EXPR_STRUCTURE);
9615 : :
9616 : : /* If we have an 'initialize all' constructor, do it first. */
9617 : 21 : if (ctor->expr->expr_type == EXPR_NULL)
9618 : : {
9619 : 9 : tree union_type = TREE_TYPE (un->backend_decl);
9620 : 9 : tree val = build_constructor (union_type, NULL);
9621 : 9 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
9622 : 9 : ctor = gfc_constructor_next (ctor);
9623 : : }
9624 : :
9625 : : /* Add the map initializer on top. */
9626 : 21 : if (ctor != NULL && ctor->expr != NULL)
9627 : : {
9628 : 12 : gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
9629 : 12 : tree val = gfc_conv_initializer (ctor->expr, &un->ts,
9630 : 12 : TREE_TYPE (un->backend_decl),
9631 : 12 : un->attr.dimension, un->attr.pointer,
9632 : 12 : un->attr.proc_pointer);
9633 : 12 : CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
9634 : : }
9635 : : }
9636 : :
9637 : : /* Build an expression for a constructor. If init is nonzero then
9638 : : this is part of a static variable initializer. */
9639 : :
9640 : : void
9641 : 33100 : gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
9642 : : {
9643 : 33100 : gfc_constructor *c;
9644 : 33100 : gfc_component *cm;
9645 : 33100 : tree val;
9646 : 33100 : tree type;
9647 : 33100 : tree tmp;
9648 : 33100 : vec<constructor_elt, va_gc> *v = NULL;
9649 : :
9650 : 33100 : gcc_assert (se->ss == NULL);
9651 : 33100 : gcc_assert (expr->expr_type == EXPR_STRUCTURE);
9652 : 33100 : type = gfc_typenode_for_spec (&expr->ts);
9653 : :
9654 : 33100 : if (!init)
9655 : : {
9656 : : /* Create a temporary variable and fill it in. */
9657 : 13286 : se->expr = gfc_create_var (type, expr->ts.u.derived->name);
9658 : : /* The symtree in expr is NULL, if the code to generate is for
9659 : : initializing the static members only. */
9660 : 26572 : tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
9661 : 13286 : se->want_coarray);
9662 : 13286 : gfc_add_expr_to_block (&se->pre, tmp);
9663 : 13286 : return;
9664 : : }
9665 : :
9666 : 19814 : cm = expr->ts.u.derived->components;
9667 : :
9668 : 19814 : for (c = gfc_constructor_first (expr->value.constructor);
9669 : 104150 : c && cm; c = gfc_constructor_next (c), cm = cm->next)
9670 : : {
9671 : : /* Skip absent members in default initializers and allocatable
9672 : : components. Although the latter have a default initializer
9673 : : of EXPR_NULL,... by default, the static nullify is not needed
9674 : : since this is done every time we come into scope. */
9675 : 84336 : if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
9676 : 7086 : continue;
9677 : :
9678 : 77250 : if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
9679 : 44764 : && strcmp (cm->name, "_extends") == 0
9680 : 1159 : && cm->initializer->symtree)
9681 : : {
9682 : 1159 : tree vtab;
9683 : 1159 : gfc_symbol *vtabs;
9684 : 1159 : vtabs = cm->initializer->symtree->n.sym;
9685 : 1159 : vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
9686 : 1159 : vtab = unshare_expr_without_location (vtab);
9687 : 1159 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
9688 : 1159 : }
9689 : 76091 : else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
9690 : : {
9691 : 8510 : val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
9692 : 8510 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
9693 : : fold_convert (TREE_TYPE (cm->backend_decl),
9694 : : val));
9695 : 8510 : }
9696 : 67581 : else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
9697 : 318 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
9698 : : fold_convert (TREE_TYPE (cm->backend_decl),
9699 : 318 : integer_zero_node));
9700 : 67263 : else if (cm->ts.type == BT_UNION)
9701 : 21 : gfc_conv_union_initializer (v, cm, c->expr);
9702 : : else
9703 : : {
9704 : 67242 : val = gfc_conv_initializer (c->expr, &cm->ts,
9705 : 67242 : TREE_TYPE (cm->backend_decl),
9706 : : cm->attr.dimension, cm->attr.pointer,
9707 : 67242 : cm->attr.proc_pointer);
9708 : 67242 : val = unshare_expr_without_location (val);
9709 : :
9710 : : /* Append it to the constructor list. */
9711 : 151578 : CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
9712 : : }
9713 : : }
9714 : :
9715 : 19814 : se->expr = build_constructor (type, v);
9716 : 19814 : if (init)
9717 : 19814 : TREE_CONSTANT (se->expr) = 1;
9718 : : }
9719 : :
9720 : :
9721 : : /* Translate a substring expression. */
9722 : :
9723 : : static void
9724 : 273 : gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
9725 : : {
9726 : 273 : gfc_ref *ref;
9727 : :
9728 : 273 : ref = expr->ref;
9729 : :
9730 : 273 : gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
9731 : :
9732 : 546 : se->expr = gfc_build_wide_string_const (expr->ts.kind,
9733 : 273 : expr->value.character.length,
9734 : 273 : expr->value.character.string);
9735 : :
9736 : 273 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
9737 : 273 : TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
9738 : :
9739 : 273 : if (ref)
9740 : 273 : gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
9741 : 273 : }
9742 : :
9743 : :
9744 : : /* Entry point for expression translation. Evaluates a scalar quantity.
9745 : : EXPR is the expression to be translated, and SE is the state structure if
9746 : : called from within the scalarized. */
9747 : :
9748 : : void
9749 : 2809711 : gfc_conv_expr (gfc_se * se, gfc_expr * expr)
9750 : : {
9751 : 2809711 : gfc_ss *ss;
9752 : :
9753 : 2809711 : ss = se->ss;
9754 : 2809711 : if (ss && ss->info->expr == expr
9755 : 184729 : && (ss->info->type == GFC_SS_SCALAR
9756 : : || ss->info->type == GFC_SS_REFERENCE))
9757 : : {
9758 : 31714 : gfc_ss_info *ss_info;
9759 : :
9760 : 31714 : ss_info = ss->info;
9761 : : /* Substitute a scalar expression evaluated outside the scalarization
9762 : : loop. */
9763 : 31714 : se->expr = ss_info->data.scalar.value;
9764 : 31714 : if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
9765 : 768 : se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
9766 : :
9767 : 31714 : se->string_length = ss_info->string_length;
9768 : 31714 : gfc_advance_se_ss_chain (se);
9769 : 31714 : return;
9770 : : }
9771 : :
9772 : : /* We need to convert the expressions for the iso_c_binding derived types.
9773 : : C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
9774 : : null_pointer_node. C_PTR and C_FUNPTR are converted to match the
9775 : : typespec for the C_PTR and C_FUNPTR symbols, which has already been
9776 : : updated to be an integer with a kind equal to the size of a (void *). */
9777 : 2777997 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
9778 : 14597 : && expr->ts.u.derived->attr.is_bind_c)
9779 : : {
9780 : 13800 : if (expr->expr_type == EXPR_VARIABLE
9781 : 9690 : && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
9782 : 9690 : || expr->symtree->n.sym->intmod_sym_id
9783 : : == ISOCBINDING_NULL_FUNPTR))
9784 : : {
9785 : : /* Set expr_type to EXPR_NULL, which will result in
9786 : : null_pointer_node being used below. */
9787 : 0 : expr->expr_type = EXPR_NULL;
9788 : : }
9789 : : else
9790 : : {
9791 : : /* Update the type/kind of the expression to be what the new
9792 : : type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
9793 : 13800 : expr->ts.type = BT_INTEGER;
9794 : 13800 : expr->ts.f90_type = BT_VOID;
9795 : 13800 : expr->ts.kind = gfc_index_integer_kind;
9796 : : }
9797 : : }
9798 : :
9799 : 2777997 : gfc_fix_class_refs (expr);
9800 : :
9801 : 2777997 : switch (expr->expr_type)
9802 : : {
9803 : 348088 : case EXPR_OP:
9804 : 348088 : gfc_conv_expr_op (se, expr);
9805 : 348088 : break;
9806 : :
9807 : 254286 : case EXPR_FUNCTION:
9808 : 254286 : gfc_conv_function_expr (se, expr);
9809 : 254286 : break;
9810 : :
9811 : 952675 : case EXPR_CONSTANT:
9812 : 952675 : gfc_conv_constant (se, expr);
9813 : 952675 : break;
9814 : :
9815 : 1176392 : case EXPR_VARIABLE:
9816 : 1176392 : gfc_conv_variable (se, expr);
9817 : 1176392 : break;
9818 : :
9819 : 3243 : case EXPR_NULL:
9820 : 3243 : se->expr = null_pointer_node;
9821 : 3243 : break;
9822 : :
9823 : 273 : case EXPR_SUBSTRING:
9824 : 273 : gfc_conv_substring_expr (se, expr);
9825 : 273 : break;
9826 : :
9827 : 13286 : case EXPR_STRUCTURE:
9828 : 13286 : gfc_conv_structure (se, expr, 0);
9829 : : /* F2008 4.5.6.3 para 5: If an executable construct references a
9830 : : structure constructor or array constructor, the entity created by
9831 : : the constructor is finalized after execution of the innermost
9832 : : executable construct containing the reference. This, in fact,
9833 : : was later deleted by the Combined Techical Corrigenda 1 TO 4 for
9834 : : fortran 2008 (f08/0011). */
9835 : 13286 : if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
9836 : 13286 : && !(gfc_option.allow_std & GFC_STD_GNU)
9837 : 115 : && expr->must_finalize
9838 : 13298 : && gfc_may_be_finalized (expr->ts))
9839 : : {
9840 : 12 : gfc_warning (0, "The structure constructor at %C has been"
9841 : : " finalized. This feature was removed by f08/0011."
9842 : : " Use -std=f2018 or -std=gnu to eliminate the"
9843 : : " finalization.");
9844 : 12 : symbol_attribute attr;
9845 : 12 : attr.allocatable = attr.pointer = 0;
9846 : 12 : gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
9847 : 12 : gfc_add_block_to_block (&se->post, &se->finalblock);
9848 : : }
9849 : : break;
9850 : :
9851 : 29754 : case EXPR_ARRAY:
9852 : 29754 : gfc_conv_array_constructor_expr (se, expr);
9853 : 29754 : gfc_add_block_to_block (&se->post, &se->finalblock);
9854 : 29754 : break;
9855 : :
9856 : 0 : default:
9857 : 0 : gcc_unreachable ();
9858 : 2809711 : break;
9859 : : }
9860 : : }
9861 : :
9862 : : /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
9863 : : of an assignment. */
9864 : : void
9865 : 308083 : gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
9866 : : {
9867 : 308083 : gfc_conv_expr (se, expr);
9868 : : /* All numeric lvalues should have empty post chains. If not we need to
9869 : : figure out a way of rewriting an lvalue so that it has no post chain. */
9870 : 308083 : gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
9871 : 308083 : }
9872 : :
9873 : : /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
9874 : : numeric expressions. Used for scalar values where inserting cleanup code
9875 : : is inconvenient. */
9876 : : void
9877 : 815462 : gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
9878 : : {
9879 : 815462 : tree val;
9880 : :
9881 : 815462 : gcc_assert (expr->ts.type != BT_CHARACTER);
9882 : 815462 : gfc_conv_expr (se, expr);
9883 : 815462 : if (se->post.head)
9884 : : {
9885 : 2376 : val = gfc_create_var (TREE_TYPE (se->expr), NULL);
9886 : 2376 : gfc_add_modify (&se->pre, val, se->expr);
9887 : 2376 : se->expr = val;
9888 : 2376 : gfc_add_block_to_block (&se->pre, &se->post);
9889 : : }
9890 : 815462 : }
9891 : :
9892 : : /* Helper to translate an expression and convert it to a particular type. */
9893 : : void
9894 : 260819 : gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
9895 : : {
9896 : 260819 : gfc_conv_expr_val (se, expr);
9897 : 260819 : se->expr = convert (type, se->expr);
9898 : 260819 : }
9899 : :
9900 : :
9901 : : /* Converts an expression so that it can be passed by reference. Scalar
9902 : : values only. */
9903 : :
9904 : : void
9905 : 210204 : gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
9906 : : {
9907 : 210204 : gfc_ss *ss;
9908 : 210204 : tree var;
9909 : :
9910 : 210204 : ss = se->ss;
9911 : 210204 : if (ss && ss->info->expr == expr
9912 : 6585 : && ss->info->type == GFC_SS_REFERENCE)
9913 : : {
9914 : : /* Returns a reference to the scalar evaluated outside the loop
9915 : : for this case. */
9916 : 810 : gfc_conv_expr (se, expr);
9917 : :
9918 : 810 : if (expr->ts.type == BT_CHARACTER
9919 : 114 : && expr->expr_type != EXPR_FUNCTION)
9920 : 102 : gfc_conv_string_parameter (se);
9921 : : else
9922 : 708 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9923 : :
9924 : 810 : return;
9925 : : }
9926 : :
9927 : 209394 : if (expr->ts.type == BT_CHARACTER)
9928 : : {
9929 : 47959 : gfc_conv_expr (se, expr);
9930 : 47959 : gfc_conv_string_parameter (se);
9931 : 47959 : return;
9932 : : }
9933 : :
9934 : 161435 : if (expr->expr_type == EXPR_VARIABLE)
9935 : : {
9936 : 63573 : se->want_pointer = 1;
9937 : 63573 : gfc_conv_expr (se, expr);
9938 : 63573 : if (se->post.head)
9939 : : {
9940 : 0 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9941 : 0 : gfc_add_modify (&se->pre, var, se->expr);
9942 : 0 : gfc_add_block_to_block (&se->pre, &se->post);
9943 : 0 : se->expr = var;
9944 : : }
9945 : 63573 : return;
9946 : : }
9947 : :
9948 : 97862 : if (expr->expr_type == EXPR_FUNCTION
9949 : 12158 : && ((expr->value.function.esym
9950 : 1902 : && expr->value.function.esym->result
9951 : : && expr->value.function.esym->result->attr.pointer
9952 : 1901 : && !expr->value.function.esym->result->attr.dimension)
9953 : 12088 : || (!expr->value.function.esym && !expr->ref
9954 : 10151 : && expr->symtree->n.sym->attr.pointer
9955 : 10151 : && !expr->symtree->n.sym->attr.dimension)))
9956 : : {
9957 : 70 : se->want_pointer = 1;
9958 : 70 : gfc_conv_expr (se, expr);
9959 : 70 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9960 : 70 : gfc_add_modify (&se->pre, var, se->expr);
9961 : 70 : se->expr = var;
9962 : 70 : return;
9963 : : }
9964 : :
9965 : 97792 : gfc_conv_expr (se, expr);
9966 : :
9967 : : /* Create a temporary var to hold the value. */
9968 : 97792 : if (TREE_CONSTANT (se->expr))
9969 : : {
9970 : : tree tmp = se->expr;
9971 : 77706 : STRIP_TYPE_NOPS (tmp);
9972 : 77706 : var = build_decl (input_location,
9973 : 77706 : CONST_DECL, NULL, TREE_TYPE (tmp));
9974 : 77706 : DECL_INITIAL (var) = tmp;
9975 : 77706 : TREE_STATIC (var) = 1;
9976 : 77706 : pushdecl (var);
9977 : : }
9978 : : else
9979 : : {
9980 : 20086 : var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9981 : 20086 : gfc_add_modify (&se->pre, var, se->expr);
9982 : : }
9983 : :
9984 : 97792 : if (!expr->must_finalize)
9985 : 97719 : gfc_add_block_to_block (&se->pre, &se->post);
9986 : :
9987 : : /* Take the address of that value. */
9988 : 97792 : se->expr = gfc_build_addr_expr (NULL_TREE, var);
9989 : : }
9990 : :
9991 : :
9992 : : /* Get the _len component for an unlimited polymorphic expression. */
9993 : :
9994 : : static tree
9995 : 1298 : trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
9996 : : {
9997 : 1298 : gfc_se se;
9998 : 1298 : gfc_ref *ref = expr->ref;
9999 : :
10000 : 1298 : gfc_init_se (&se, NULL);
10001 : 2644 : while (ref && ref->next)
10002 : : ref = ref->next;
10003 : 1298 : gfc_add_len_component (expr);
10004 : 1298 : gfc_conv_expr (&se, expr);
10005 : 1298 : gfc_add_block_to_block (block, &se.pre);
10006 : 1298 : gcc_assert (se.post.head == NULL_TREE);
10007 : 1298 : if (ref)
10008 : : {
10009 : 183 : gfc_free_ref_list (ref->next);
10010 : 183 : ref->next = NULL;
10011 : : }
10012 : : else
10013 : : {
10014 : 1115 : gfc_free_ref_list (expr->ref);
10015 : 1115 : expr->ref = NULL;
10016 : : }
10017 : 1298 : return se.expr;
10018 : : }
10019 : :
10020 : :
10021 : : /* Assign _vptr and _len components as appropriate. BLOCK should be a
10022 : : statement-list outside of the scalarizer-loop. When code is generated, that
10023 : : depends on the scalarized expression, it is added to RSE.PRE.
10024 : : Returns le's _vptr tree and when set the len expressions in to_lenp and
10025 : : from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
10026 : : expression. */
10027 : :
10028 : : static tree
10029 : 3909 : trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
10030 : : gfc_expr * re, gfc_se *rse,
10031 : : tree * to_lenp, tree * from_lenp,
10032 : : tree * from_vptrp)
10033 : : {
10034 : 3909 : gfc_se se;
10035 : 3909 : gfc_expr * vptr_expr;
10036 : 3909 : tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
10037 : 3909 : bool set_vptr = false, temp_rhs = false;
10038 : 3909 : stmtblock_t *pre = block;
10039 : 3909 : tree class_expr = NULL_TREE;
10040 : 3909 : tree from_vptr = NULL_TREE;
10041 : :
10042 : : /* Create a temporary for complicated expressions. */
10043 : 3909 : if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
10044 : 1023 : && rse->expr != NULL_TREE)
10045 : : {
10046 : 1023 : if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10047 : 13 : class_expr = gfc_get_class_from_expr (rse->expr);
10048 : :
10049 : 1023 : if (rse->loop)
10050 : 207 : pre = &rse->loop->pre;
10051 : : else
10052 : 816 : pre = &rse->pre;
10053 : :
10054 : 1023 : if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
10055 : : {
10056 : 13 : tmp = TREE_OPERAND (rse->expr, 0);
10057 : 13 : tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
10058 : 13 : gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
10059 : : }
10060 : : else
10061 : : {
10062 : 1010 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
10063 : 1010 : gfc_add_modify (&rse->pre, tmp, rse->expr);
10064 : : }
10065 : :
10066 : 1023 : rse->expr = tmp;
10067 : 1023 : temp_rhs = true;
10068 : : }
10069 : :
10070 : : /* Get the _vptr for the left-hand side expression. */
10071 : 3909 : gfc_init_se (&se, NULL);
10072 : 3909 : vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
10073 : 3909 : if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
10074 : : {
10075 : : /* Care about _len for unlimited polymorphic entities. */
10076 : 3891 : if (UNLIMITED_POLY (vptr_expr)
10077 : 3226 : || (vptr_expr->ts.type == BT_DERIVED
10078 : 2307 : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10079 : 1099 : to_len = trans_get_upoly_len (block, vptr_expr);
10080 : 3891 : gfc_add_vptr_component (vptr_expr);
10081 : 3891 : set_vptr = true;
10082 : : }
10083 : : else
10084 : 18 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10085 : 3909 : se.want_pointer = 1;
10086 : 3909 : gfc_conv_expr (&se, vptr_expr);
10087 : 3909 : gfc_free_expr (vptr_expr);
10088 : 3909 : gfc_add_block_to_block (block, &se.pre);
10089 : 3909 : gcc_assert (se.post.head == NULL_TREE);
10090 : 3909 : lhs_vptr = se.expr;
10091 : 3909 : STRIP_NOPS (lhs_vptr);
10092 : :
10093 : : /* Set the _vptr only when the left-hand side of the assignment is a
10094 : : class-object. */
10095 : 3909 : if (set_vptr)
10096 : : {
10097 : : /* Get the vptr from the rhs expression only, when it is variable.
10098 : : Functions are expected to be assigned to a temporary beforehand. */
10099 : 2768 : vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
10100 : 4523 : ? gfc_find_and_cut_at_last_class_ref (re)
10101 : : : NULL;
10102 : 632 : if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
10103 : : {
10104 : 632 : if (to_len != NULL_TREE)
10105 : : {
10106 : : /* Get the _len information from the rhs. */
10107 : 212 : if (UNLIMITED_POLY (vptr_expr)
10108 : : || (vptr_expr->ts.type == BT_DERIVED
10109 : : && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
10110 : 199 : from_len = trans_get_upoly_len (block, vptr_expr);
10111 : : }
10112 : 632 : gfc_add_vptr_component (vptr_expr);
10113 : : }
10114 : : else
10115 : : {
10116 : 3259 : if (re->expr_type == EXPR_VARIABLE
10117 : 2136 : && DECL_P (re->symtree->n.sym->backend_decl)
10118 : 2136 : && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
10119 : 764 : && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
10120 : 3319 : && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
10121 : : re->symtree->n.sym->backend_decl))))
10122 : : {
10123 : 42 : vptr_expr = NULL;
10124 : 42 : se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
10125 : : re->symtree->n.sym->backend_decl));
10126 : 42 : if (to_len)
10127 : 0 : from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
10128 : : re->symtree->n.sym->backend_decl));
10129 : : }
10130 : 3217 : else if (temp_rhs && re->ts.type == BT_CLASS)
10131 : : {
10132 : 159 : vptr_expr = NULL;
10133 : 159 : if (class_expr)
10134 : : tmp = class_expr;
10135 : 146 : else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
10136 : 0 : tmp = gfc_get_class_from_expr (rse->expr);
10137 : : else
10138 : : tmp = rse->expr;
10139 : :
10140 : 159 : se.expr = gfc_class_vptr_get (tmp);
10141 : 159 : from_vptr = se.expr;
10142 : 159 : if (UNLIMITED_POLY (re))
10143 : 37 : from_len = gfc_class_len_get (tmp);
10144 : :
10145 : : }
10146 : 3058 : else if (re->expr_type != EXPR_NULL)
10147 : : /* Only when rhs is non-NULL use its declared type for vptr
10148 : : initialisation. */
10149 : 2946 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
10150 : : else
10151 : : /* When the rhs is NULL use the vtab of lhs' declared type. */
10152 : 112 : vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
10153 : : }
10154 : :
10155 : 3891 : if (vptr_expr)
10156 : : {
10157 : 3690 : gfc_init_se (&se, NULL);
10158 : 3690 : se.want_pointer = 1;
10159 : 3690 : gfc_conv_expr (&se, vptr_expr);
10160 : 3690 : gfc_free_expr (vptr_expr);
10161 : 3690 : gfc_add_block_to_block (block, &se.pre);
10162 : 3690 : gcc_assert (se.post.head == NULL_TREE);
10163 : 3690 : from_vptr = se.expr;
10164 : : }
10165 : 3891 : gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
10166 : : se.expr));
10167 : :
10168 : 3891 : if (to_len != NULL_TREE)
10169 : : {
10170 : : /* The _len component needs to be set. Figure how to get the
10171 : : value of the right-hand side. */
10172 : 1099 : if (from_len == NULL_TREE)
10173 : : {
10174 : 863 : if (rse->string_length != NULL_TREE)
10175 : : from_len = rse->string_length;
10176 : 503 : else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
10177 : : {
10178 : 0 : gfc_init_se (&se, NULL);
10179 : 0 : gfc_conv_expr (&se, re->ts.u.cl->length);
10180 : 0 : gfc_add_block_to_block (block, &se.pre);
10181 : 0 : gcc_assert (se.post.head == NULL_TREE);
10182 : 0 : from_len = gfc_evaluate_now (se.expr, block);
10183 : : }
10184 : : else
10185 : 503 : from_len = build_zero_cst (gfc_charlen_type_node);
10186 : : }
10187 : 1099 : gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
10188 : : from_len));
10189 : : }
10190 : : }
10191 : :
10192 : : /* Return the _len and _vptr trees only, when requested. */
10193 : 3909 : if (to_lenp)
10194 : 2865 : *to_lenp = to_len;
10195 : 3909 : if (from_lenp)
10196 : 2865 : *from_lenp = from_len;
10197 : 3909 : if (from_vptrp)
10198 : 2865 : *from_vptrp = from_vptr;
10199 : 3909 : return lhs_vptr;
10200 : : }
10201 : :
10202 : :
10203 : : /* Assign tokens for pointer components. */
10204 : :
10205 : : static void
10206 : 4 : trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
10207 : : gfc_expr *expr2)
10208 : : {
10209 : 4 : symbol_attribute lhs_attr, rhs_attr;
10210 : 4 : tree tmp, lhs_tok, rhs_tok;
10211 : : /* Flag to indicated component refs on the rhs. */
10212 : 4 : bool rhs_cr;
10213 : :
10214 : 4 : lhs_attr = gfc_caf_attr (expr1);
10215 : 4 : if (expr2->expr_type != EXPR_NULL)
10216 : : {
10217 : 3 : rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
10218 : 3 : if (lhs_attr.codimension && rhs_attr.codimension)
10219 : : {
10220 : 2 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
10221 : 2 : lhs_tok = build_fold_indirect_ref (lhs_tok);
10222 : :
10223 : 2 : if (rhs_cr)
10224 : 0 : rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
10225 : : else
10226 : : {
10227 : 2 : tree caf_decl;
10228 : 2 : caf_decl = gfc_get_tree_for_caf_expr (expr2);
10229 : 2 : gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
10230 : : NULL_TREE, NULL);
10231 : : }
10232 : 2 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10233 : : lhs_tok,
10234 : 2 : fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
10235 : 2 : gfc_prepend_expr_to_block (&lse->post, tmp);
10236 : : }
10237 : : }
10238 : 1 : else if (lhs_attr.codimension)
10239 : : {
10240 : 1 : lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
10241 : 1 : lhs_tok = build_fold_indirect_ref (lhs_tok);
10242 : 1 : tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
10243 : : lhs_tok, null_pointer_node);
10244 : 1 : gfc_prepend_expr_to_block (&lse->post, tmp);
10245 : : }
10246 : 4 : }
10247 : :
10248 : :
10249 : : /* Do everything that is needed for a CLASS function expr2. */
10250 : :
10251 : : static tree
10252 : 18 : trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
10253 : : gfc_expr *expr1, gfc_expr *expr2)
10254 : : {
10255 : 18 : tree expr1_vptr = NULL_TREE;
10256 : 18 : tree tmp;
10257 : :
10258 : 18 : gfc_conv_function_expr (rse, expr2);
10259 : 18 : rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
10260 : :
10261 : 18 : if (expr1->ts.type != BT_CLASS)
10262 : 12 : rse->expr = gfc_class_data_get (rse->expr);
10263 : : else
10264 : : {
10265 : 6 : expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
10266 : : expr2, rse,
10267 : : NULL, NULL, NULL);
10268 : 6 : gfc_add_block_to_block (block, &rse->pre);
10269 : 6 : tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
10270 : 6 : gfc_add_modify (&lse->pre, tmp, rse->expr);
10271 : :
10272 : 12 : gfc_add_modify (&lse->pre, expr1_vptr,
10273 : 6 : fold_convert (TREE_TYPE (expr1_vptr),
10274 : : gfc_class_vptr_get (tmp)));
10275 : 6 : rse->expr = gfc_class_data_get (tmp);
10276 : : }
10277 : :
10278 : 18 : return expr1_vptr;
10279 : : }
10280 : :
10281 : :
10282 : : tree
10283 : 8873 : gfc_trans_pointer_assign (gfc_code * code)
10284 : : {
10285 : 8873 : return gfc_trans_pointer_assignment (code->expr1, code->expr2);
10286 : : }
10287 : :
10288 : :
10289 : : /* Generate code for a pointer assignment. */
10290 : :
10291 : : tree
10292 : 8874 : gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
10293 : : {
10294 : 8874 : gfc_se lse;
10295 : 8874 : gfc_se rse;
10296 : 8874 : stmtblock_t block;
10297 : 8874 : tree desc;
10298 : 8874 : tree tmp;
10299 : 8874 : tree expr1_vptr = NULL_TREE;
10300 : 8874 : bool scalar, non_proc_ptr_assign;
10301 : 8874 : gfc_ss *ss;
10302 : :
10303 : 8874 : gfc_start_block (&block);
10304 : :
10305 : 8874 : gfc_init_se (&lse, NULL);
10306 : :
10307 : : /* Usually testing whether this is not a proc pointer assignment. */
10308 : 8874 : non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
10309 : 1152 : && expr2->expr_type == EXPR_VARIABLE
10310 : 925 : && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
10311 : :
10312 : : /* Check whether the expression is a scalar or not; we cannot use
10313 : : expr1->rank as it can be nonzero for proc pointers. */
10314 : 8874 : ss = gfc_walk_expr (expr1);
10315 : 8874 : scalar = ss == gfc_ss_terminator;
10316 : 8874 : if (!scalar)
10317 : 3777 : gfc_free_ss_chain (ss);
10318 : :
10319 : 8874 : if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
10320 : 84 : && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
10321 : : {
10322 : 66 : gfc_add_data_component (expr2);
10323 : : /* The following is required as gfc_add_data_component doesn't
10324 : : update ts.type if there is a trailing REF_ARRAY. */
10325 : 66 : expr2->ts.type = BT_DERIVED;
10326 : : }
10327 : :
10328 : 8874 : if (scalar)
10329 : : {
10330 : : /* Scalar pointers. */
10331 : 5097 : lse.want_pointer = 1;
10332 : 5097 : gfc_conv_expr (&lse, expr1);
10333 : 5097 : gfc_init_se (&rse, NULL);
10334 : 5097 : rse.want_pointer = 1;
10335 : 5097 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
10336 : 6 : trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
10337 : : else
10338 : 5091 : gfc_conv_expr (&rse, expr2);
10339 : :
10340 : 5097 : if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
10341 : : {
10342 : 725 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
10343 : : NULL, NULL);
10344 : 725 : lse.expr = gfc_class_data_get (lse.expr);
10345 : : }
10346 : :
10347 : 5097 : if (expr1->symtree->n.sym->attr.proc_pointer
10348 : 5097 : && expr1->symtree->n.sym->attr.dummy)
10349 : 49 : lse.expr = build_fold_indirect_ref_loc (input_location,
10350 : : lse.expr);
10351 : :
10352 : 5097 : if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
10353 : 3952 : && expr2->symtree->n.sym->attr.dummy)
10354 : 19 : rse.expr = build_fold_indirect_ref_loc (input_location,
10355 : : rse.expr);
10356 : :
10357 : 5097 : gfc_add_block_to_block (&block, &lse.pre);
10358 : 5097 : gfc_add_block_to_block (&block, &rse.pre);
10359 : :
10360 : : /* Check character lengths if character expression. The test is only
10361 : : really added if -fbounds-check is enabled. Exclude deferred
10362 : : character length lefthand sides. */
10363 : 706 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
10364 : 532 : && !expr1->ts.deferred
10365 : 300 : && !expr1->symtree->n.sym->attr.proc_pointer
10366 : 5390 : && !gfc_is_proc_ptr_comp (expr1))
10367 : : {
10368 : 274 : gcc_assert (expr2->ts.type == BT_CHARACTER);
10369 : 274 : gcc_assert (lse.string_length && rse.string_length);
10370 : 274 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
10371 : : lse.string_length, rse.string_length,
10372 : : &block);
10373 : : }
10374 : :
10375 : : /* The assignment to an deferred character length sets the string
10376 : : length to that of the rhs. */
10377 : 5097 : if (expr1->ts.deferred)
10378 : : {
10379 : 347 : if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
10380 : 230 : gfc_add_modify (&block, lse.string_length,
10381 : 230 : fold_convert (TREE_TYPE (lse.string_length),
10382 : : rse.string_length));
10383 : 117 : else if (lse.string_length != NULL)
10384 : 115 : gfc_add_modify (&block, lse.string_length,
10385 : 115 : build_zero_cst (TREE_TYPE (lse.string_length)));
10386 : : }
10387 : :
10388 : 5097 : gfc_add_modify (&block, lse.expr,
10389 : 5097 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
10390 : :
10391 : : /* Also set the tokens for pointer components in derived typed
10392 : : coarrays. */
10393 : 5097 : if (flag_coarray == GFC_FCOARRAY_LIB)
10394 : 4 : trans_caf_token_assign (&lse, &rse, expr1, expr2);
10395 : :
10396 : 5097 : gfc_add_block_to_block (&block, &rse.post);
10397 : 5097 : gfc_add_block_to_block (&block, &lse.post);
10398 : : }
10399 : : else
10400 : : {
10401 : 3777 : gfc_ref* remap;
10402 : 3777 : bool rank_remap;
10403 : 3777 : tree strlen_lhs;
10404 : 3777 : tree strlen_rhs = NULL_TREE;
10405 : :
10406 : : /* Array pointer. Find the last reference on the LHS and if it is an
10407 : : array section ref, we're dealing with bounds remapping. In this case,
10408 : : set it to AR_FULL so that gfc_conv_expr_descriptor does
10409 : : not see it and process the bounds remapping afterwards explicitly. */
10410 : 11810 : for (remap = expr1->ref; remap; remap = remap->next)
10411 : 4527 : if (!remap->next && remap->type == REF_ARRAY
10412 : 3777 : && remap->u.ar.type == AR_SECTION)
10413 : : break;
10414 : 3777 : rank_remap = (remap && remap->u.ar.end[0]);
10415 : :
10416 : 271 : if (remap && expr2->expr_type == EXPR_NULL)
10417 : : {
10418 : 2 : gfc_error ("If bounds remapping is specified at %L, "
10419 : : "the pointer target shall not be NULL", &expr1->where);
10420 : 2 : return NULL_TREE;
10421 : : }
10422 : :
10423 : 3775 : gfc_init_se (&lse, NULL);
10424 : 3775 : if (remap)
10425 : 269 : lse.descriptor_only = 1;
10426 : 3775 : gfc_conv_expr_descriptor (&lse, expr1);
10427 : 3775 : strlen_lhs = lse.string_length;
10428 : 3775 : desc = lse.expr;
10429 : :
10430 : 3775 : if (expr2->expr_type == EXPR_NULL)
10431 : : {
10432 : : /* Just set the data pointer to null. */
10433 : 665 : gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
10434 : : }
10435 : 3110 : else if (rank_remap)
10436 : : {
10437 : : /* If we are rank-remapping, just get the RHS's descriptor and
10438 : : process this later on. */
10439 : 146 : gfc_init_se (&rse, NULL);
10440 : 146 : rse.direct_byref = 1;
10441 : 146 : rse.byref_noassign = 1;
10442 : :
10443 : 146 : if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
10444 : 12 : expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
10445 : : expr1, expr2);
10446 : 134 : else if (expr2->expr_type == EXPR_FUNCTION)
10447 : : {
10448 : : tree bound[GFC_MAX_DIMENSIONS];
10449 : : int i;
10450 : :
10451 : 26 : for (i = 0; i < expr2->rank; i++)
10452 : 13 : bound[i] = NULL_TREE;
10453 : 13 : tmp = gfc_typenode_for_spec (&expr2->ts);
10454 : 13 : tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
10455 : : bound, bound, 0,
10456 : : GFC_ARRAY_POINTER_CONT, false);
10457 : 13 : tmp = gfc_create_var (tmp, "ptrtemp");
10458 : 13 : rse.descriptor_only = 0;
10459 : 13 : rse.expr = tmp;
10460 : 13 : rse.direct_byref = 1;
10461 : 13 : gfc_conv_expr_descriptor (&rse, expr2);
10462 : 13 : strlen_rhs = rse.string_length;
10463 : 13 : rse.expr = tmp;
10464 : : }
10465 : : else
10466 : : {
10467 : 121 : gfc_conv_expr_descriptor (&rse, expr2);
10468 : 121 : strlen_rhs = rse.string_length;
10469 : 121 : if (expr1->ts.type == BT_CLASS)
10470 : 12 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
10471 : : expr2, &rse,
10472 : : NULL, NULL,
10473 : : NULL);
10474 : : }
10475 : : }
10476 : 2964 : else if (expr2->expr_type == EXPR_VARIABLE)
10477 : : {
10478 : : /* Assign directly to the LHS's descriptor. */
10479 : 2839 : lse.descriptor_only = 0;
10480 : 2839 : lse.direct_byref = 1;
10481 : 2839 : gfc_conv_expr_descriptor (&lse, expr2);
10482 : 2839 : strlen_rhs = lse.string_length;
10483 : 2839 : gfc_init_se (&rse, NULL);
10484 : :
10485 : 2839 : if (expr1->ts.type == BT_CLASS)
10486 : : {
10487 : 288 : rse.expr = NULL_TREE;
10488 : 288 : rse.string_length = strlen_rhs;
10489 : 288 : trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
10490 : : NULL, NULL, NULL);
10491 : : }
10492 : :
10493 : 2839 : if (remap == NULL)
10494 : : {
10495 : : /* If the target is not a whole array, use the target array
10496 : : reference for remap. */
10497 : 5834 : for (remap = expr2->ref; remap; remap = remap->next)
10498 : 3213 : if (remap->type == REF_ARRAY
10499 : 2764 : && remap->u.ar.type == AR_FULL
10500 : 2108 : && remap->next)
10501 : : break;
10502 : : }
10503 : : }
10504 : 125 : else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
10505 : : {
10506 : 19 : gfc_init_se (&rse, NULL);
10507 : 19 : rse.want_pointer = 1;
10508 : 19 : gfc_conv_function_expr (&rse, expr2);
10509 : 19 : if (expr1->ts.type != BT_CLASS)
10510 : : {
10511 : 6 : rse.expr = gfc_class_data_get (rse.expr);
10512 : 6 : gfc_add_modify (&lse.pre, desc, rse.expr);
10513 : : /* Set the lhs span. */
10514 : 6 : tmp = TREE_TYPE (rse.expr);
10515 : 6 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
10516 : 6 : tmp = fold_convert (gfc_array_index_type, tmp);
10517 : 6 : gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
10518 : : }
10519 : : else
10520 : : {
10521 : 13 : expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
10522 : : expr2, &rse, NULL,
10523 : : NULL, NULL);
10524 : 13 : gfc_add_block_to_block (&block, &rse.pre);
10525 : 13 : tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
10526 : 13 : gfc_add_modify (&lse.pre, tmp, rse.expr);
10527 : :
10528 : 26 : gfc_add_modify (&lse.pre, expr1_vptr,
10529 : 13 : fold_convert (TREE_TYPE (expr1_vptr),
10530 : : gfc_class_vptr_get (tmp)));
10531 : 13 : rse.expr = gfc_class_data_get (tmp);
10532 : 13 : gfc_add_modify (&lse.pre, desc, rse.expr);
10533 : : }
10534 : : }
10535 : : else
10536 : : {
10537 : : /* Assign to a temporary descriptor and then copy that
10538 : : temporary to the pointer. */
10539 : 106 : tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
10540 : 106 : lse.descriptor_only = 0;
10541 : 106 : lse.expr = tmp;
10542 : 106 : lse.direct_byref = 1;
10543 : 106 : gfc_conv_expr_descriptor (&lse, expr2);
10544 : 106 : strlen_rhs = lse.string_length;
10545 : 106 : gfc_add_modify (&lse.pre, desc, tmp);
10546 : : }
10547 : :
10548 : 3775 : if (expr1->ts.type == BT_CHARACTER
10549 : 572 : && expr1->ts.deferred)
10550 : : {
10551 : 326 : gfc_symbol *psym = expr1->symtree->n.sym;
10552 : 326 : tmp = NULL_TREE;
10553 : 326 : if (psym->ts.type == BT_CHARACTER
10554 : 325 : && psym->ts.u.cl->backend_decl)
10555 : 325 : tmp = psym->ts.u.cl->backend_decl;
10556 : 1 : else if (expr1->ts.u.cl->backend_decl
10557 : 1 : && VAR_P (expr1->ts.u.cl->backend_decl))
10558 : 0 : tmp = expr1->ts.u.cl->backend_decl;
10559 : 1 : else if (TREE_CODE (lse.expr) == COMPONENT_REF)
10560 : : {
10561 : 1 : gfc_ref *ref = expr1->ref;
10562 : 3 : for (;ref; ref = ref->next)
10563 : : {
10564 : 2 : if (ref->type == REF_COMPONENT
10565 : 1 : && ref->u.c.component->ts.type == BT_CHARACTER
10566 : 3 : && gfc_deferred_strlen (ref->u.c.component, &tmp))
10567 : 1 : tmp = fold_build3_loc (input_location, COMPONENT_REF,
10568 : 1 : TREE_TYPE (tmp),
10569 : 1 : TREE_OPERAND (lse.expr, 0),
10570 : : tmp, NULL_TREE);
10571 : : }
10572 : : }
10573 : :
10574 : 326 : gcc_assert (tmp);
10575 : :
10576 : 326 : if (expr2->expr_type != EXPR_NULL)
10577 : 314 : gfc_add_modify (&block, tmp,
10578 : 314 : fold_convert (TREE_TYPE (tmp), strlen_rhs));
10579 : : else
10580 : 12 : gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
10581 : : }
10582 : :
10583 : 3775 : gfc_add_block_to_block (&block, &lse.pre);
10584 : 3775 : if (rank_remap)
10585 : 146 : gfc_add_block_to_block (&block, &rse.pre);
10586 : :
10587 : : /* If we do bounds remapping, update LHS descriptor accordingly. */
10588 : 3775 : if (remap)
10589 : : {
10590 : 364 : int dim;
10591 : 364 : gcc_assert (remap->u.ar.dimen == expr1->rank);
10592 : :
10593 : 364 : if (rank_remap)
10594 : : {
10595 : : /* Do rank remapping. We already have the RHS's descriptor
10596 : : converted in rse and now have to build the correct LHS
10597 : : descriptor for it. */
10598 : :
10599 : 146 : tree dtype, data, span;
10600 : 146 : tree offs, stride;
10601 : 146 : tree lbound, ubound;
10602 : :
10603 : : /* Set dtype. */
10604 : 146 : dtype = gfc_conv_descriptor_dtype (desc);
10605 : 146 : tmp = gfc_get_dtype (TREE_TYPE (desc));
10606 : 146 : gfc_add_modify (&block, dtype, tmp);
10607 : :
10608 : : /* Copy data pointer. */
10609 : 146 : data = gfc_conv_descriptor_data_get (rse.expr);
10610 : 146 : gfc_conv_descriptor_data_set (&block, desc, data);
10611 : :
10612 : : /* Copy the span. */
10613 : 146 : if (VAR_P (rse.expr)
10614 : 146 : && GFC_DECL_PTR_ARRAY_P (rse.expr))
10615 : 12 : span = gfc_conv_descriptor_span_get (rse.expr);
10616 : : else
10617 : : {
10618 : 134 : tmp = TREE_TYPE (rse.expr);
10619 : 134 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
10620 : 134 : span = fold_convert (gfc_array_index_type, tmp);
10621 : : }
10622 : 146 : gfc_conv_descriptor_span_set (&block, desc, span);
10623 : :
10624 : : /* Copy offset but adjust it such that it would correspond
10625 : : to a lbound of zero. */
10626 : 146 : offs = gfc_conv_descriptor_offset_get (rse.expr);
10627 : 456 : for (dim = 0; dim < expr2->rank; ++dim)
10628 : : {
10629 : 164 : stride = gfc_conv_descriptor_stride_get (rse.expr,
10630 : : gfc_rank_cst[dim]);
10631 : 164 : lbound = gfc_conv_descriptor_lbound_get (rse.expr,
10632 : : gfc_rank_cst[dim]);
10633 : 164 : tmp = fold_build2_loc (input_location, MULT_EXPR,
10634 : : gfc_array_index_type, stride, lbound);
10635 : 164 : offs = fold_build2_loc (input_location, PLUS_EXPR,
10636 : : gfc_array_index_type, offs, tmp);
10637 : : }
10638 : 146 : gfc_conv_descriptor_offset_set (&block, desc, offs);
10639 : :
10640 : : /* Set the bounds as declared for the LHS and calculate strides as
10641 : : well as another offset update accordingly. */
10642 : 146 : stride = gfc_conv_descriptor_stride_get (rse.expr,
10643 : : gfc_rank_cst[0]);
10644 : 371 : for (dim = 0; dim < expr1->rank; ++dim)
10645 : : {
10646 : 225 : gfc_se lower_se;
10647 : 225 : gfc_se upper_se;
10648 : :
10649 : 225 : gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
10650 : :
10651 : : /* Convert declared bounds. */
10652 : 225 : gfc_init_se (&lower_se, NULL);
10653 : 225 : gfc_init_se (&upper_se, NULL);
10654 : 225 : gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
10655 : 225 : gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
10656 : :
10657 : 225 : gfc_add_block_to_block (&block, &lower_se.pre);
10658 : 225 : gfc_add_block_to_block (&block, &upper_se.pre);
10659 : :
10660 : 225 : lbound = fold_convert (gfc_array_index_type, lower_se.expr);
10661 : 225 : ubound = fold_convert (gfc_array_index_type, upper_se.expr);
10662 : :
10663 : 225 : lbound = gfc_evaluate_now (lbound, &block);
10664 : 225 : ubound = gfc_evaluate_now (ubound, &block);
10665 : :
10666 : 225 : gfc_add_block_to_block (&block, &lower_se.post);
10667 : 225 : gfc_add_block_to_block (&block, &upper_se.post);
10668 : :
10669 : : /* Set bounds in descriptor. */
10670 : 225 : gfc_conv_descriptor_lbound_set (&block, desc,
10671 : : gfc_rank_cst[dim], lbound);
10672 : 225 : gfc_conv_descriptor_ubound_set (&block, desc,
10673 : : gfc_rank_cst[dim], ubound);
10674 : :
10675 : : /* Set stride. */
10676 : 225 : stride = gfc_evaluate_now (stride, &block);
10677 : 225 : gfc_conv_descriptor_stride_set (&block, desc,
10678 : : gfc_rank_cst[dim], stride);
10679 : :
10680 : : /* Update offset. */
10681 : 225 : offs = gfc_conv_descriptor_offset_get (desc);
10682 : 225 : tmp = fold_build2_loc (input_location, MULT_EXPR,
10683 : : gfc_array_index_type, lbound, stride);
10684 : 225 : offs = fold_build2_loc (input_location, MINUS_EXPR,
10685 : : gfc_array_index_type, offs, tmp);
10686 : 225 : offs = gfc_evaluate_now (offs, &block);
10687 : 225 : gfc_conv_descriptor_offset_set (&block, desc, offs);
10688 : :
10689 : : /* Update stride. */
10690 : 225 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
10691 : 225 : stride = fold_build2_loc (input_location, MULT_EXPR,
10692 : : gfc_array_index_type, stride, tmp);
10693 : : }
10694 : : }
10695 : : else
10696 : : {
10697 : : /* Bounds remapping. Just shift the lower bounds. */
10698 : :
10699 : 218 : gcc_assert (expr1->rank == expr2->rank);
10700 : :
10701 : 544 : for (dim = 0; dim < remap->u.ar.dimen; ++dim)
10702 : : {
10703 : 326 : gfc_se lbound_se;
10704 : :
10705 : 326 : gcc_assert (!remap->u.ar.end[dim]);
10706 : 326 : gfc_init_se (&lbound_se, NULL);
10707 : 326 : if (remap->u.ar.start[dim])
10708 : : {
10709 : 225 : gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
10710 : 225 : gfc_add_block_to_block (&block, &lbound_se.pre);
10711 : : }
10712 : : else
10713 : : /* This remap arises from a target that is not a whole
10714 : : array. The start expressions will be NULL but we need
10715 : : the lbounds to be one. */
10716 : 101 : lbound_se.expr = gfc_index_one_node;
10717 : 326 : gfc_conv_shift_descriptor_lbound (&block, desc,
10718 : : dim, lbound_se.expr);
10719 : 326 : gfc_add_block_to_block (&block, &lbound_se.post);
10720 : : }
10721 : : }
10722 : : }
10723 : :
10724 : : /* If rank remapping was done, check with -fcheck=bounds that
10725 : : the target is at least as large as the pointer. */
10726 : 3775 : if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
10727 : : {
10728 : 54 : tree lsize, rsize;
10729 : 54 : tree fault;
10730 : 54 : const char* msg;
10731 : :
10732 : 54 : lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
10733 : 54 : rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
10734 : :
10735 : 54 : lsize = gfc_evaluate_now (lsize, &block);
10736 : 54 : rsize = gfc_evaluate_now (rsize, &block);
10737 : 54 : fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
10738 : : rsize, lsize);
10739 : :
10740 : 54 : msg = _("Target of rank remapping is too small (%ld < %ld)");
10741 : 54 : gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
10742 : : msg, rsize, lsize);
10743 : : }
10744 : :
10745 : : /* Check string lengths if applicable. The check is only really added
10746 : : to the output code if -fbounds-check is enabled. */
10747 : 3775 : if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
10748 : : {
10749 : 506 : gcc_assert (expr2->ts.type == BT_CHARACTER);
10750 : 506 : gcc_assert (strlen_lhs && strlen_rhs);
10751 : 506 : gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
10752 : : strlen_lhs, strlen_rhs, &block);
10753 : : }
10754 : :
10755 : 3775 : gfc_add_block_to_block (&block, &lse.post);
10756 : 3775 : if (rank_remap)
10757 : 146 : gfc_add_block_to_block (&block, &rse.post);
10758 : : }
10759 : :
10760 : 8872 : return gfc_finish_block (&block);
10761 : : }
10762 : :
10763 : :
10764 : : /* Makes sure se is suitable for passing as a function string parameter. */
10765 : : /* TODO: Need to check all callers of this function. It may be abused. */
10766 : :
10767 : : void
10768 : 226147 : gfc_conv_string_parameter (gfc_se * se)
10769 : : {
10770 : 226147 : tree type;
10771 : :
10772 : 226147 : if (TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE
10773 : 226147 : && integer_onep (se->string_length))
10774 : : {
10775 : 667 : se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
10776 : 667 : return;
10777 : : }
10778 : :
10779 : 225480 : if (TREE_CODE (se->expr) == STRING_CST)
10780 : : {
10781 : 96117 : type = TREE_TYPE (TREE_TYPE (se->expr));
10782 : 96117 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
10783 : 96117 : return;
10784 : : }
10785 : :
10786 : 129363 : if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
10787 : 48705 : || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
10788 : 129459 : && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
10789 : : {
10790 : 80754 : type = TREE_TYPE (se->expr);
10791 : 80754 : if (TREE_CODE (se->expr) != INDIRECT_REF)
10792 : 76222 : se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
10793 : : else
10794 : : {
10795 : 4532 : if (TREE_CODE (type) == ARRAY_TYPE)
10796 : 4532 : type = TREE_TYPE (type);
10797 : 4532 : type = gfc_get_character_type_len_for_eltype (type,
10798 : : se->string_length);
10799 : 4532 : type = build_pointer_type (type);
10800 : 4532 : se->expr = gfc_build_addr_expr (type, se->expr);
10801 : : }
10802 : : }
10803 : :
10804 : 129363 : gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
10805 : : }
10806 : :
10807 : :
10808 : : /* Generate code for assignment of scalar variables. Includes character
10809 : : strings and derived types with allocatable components.
10810 : : If you know that the LHS has no allocations, set dealloc to false.
10811 : :
10812 : : DEEP_COPY has no effect if the typespec TS is not a derived type with
10813 : : allocatable components. Otherwise, if it is set, an explicit copy of each
10814 : : allocatable component is made. This is necessary as a simple copy of the
10815 : : whole object would copy array descriptors as is, so that the lhs's
10816 : : allocatable components would point to the rhs's after the assignment.
10817 : : Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
10818 : : necessary if the rhs is a non-pointer function, as the allocatable components
10819 : : are not accessible by other means than the function's result after the
10820 : : function has returned. It is even more subtle when temporaries are involved,
10821 : : as the two following examples show:
10822 : : 1. When we evaluate an array constructor, a temporary is created. Thus
10823 : : there is theoretically no alias possible. However, no deep copy is
10824 : : made for this temporary, so that if the constructor is made of one or
10825 : : more variable with allocatable components, those components still point
10826 : : to the variable's: DEEP_COPY should be set for the assignment from the
10827 : : temporary to the lhs in that case.
10828 : : 2. When assigning a scalar to an array, we evaluate the scalar value out
10829 : : of the loop, store it into a temporary variable, and assign from that.
10830 : : In that case, deep copying when assigning to the temporary would be a
10831 : : waste of resources; however deep copies should happen when assigning from
10832 : : the temporary to each array element: again DEEP_COPY should be set for
10833 : : the assignment from the temporary to the lhs. */
10834 : :
10835 : : tree
10836 : 214277 : gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
10837 : : bool deep_copy, bool dealloc, bool in_coarray)
10838 : : {
10839 : 214277 : stmtblock_t block;
10840 : 214277 : tree tmp;
10841 : 214277 : tree cond;
10842 : :
10843 : 214277 : gfc_init_block (&block);
10844 : :
10845 : 214277 : if (ts.type == BT_CHARACTER)
10846 : : {
10847 : 30255 : tree rlen = NULL;
10848 : 30255 : tree llen = NULL;
10849 : :
10850 : 30255 : if (lse->string_length != NULL_TREE)
10851 : : {
10852 : 30255 : gfc_conv_string_parameter (lse);
10853 : 30255 : gfc_add_block_to_block (&block, &lse->pre);
10854 : 30255 : llen = lse->string_length;
10855 : : }
10856 : :
10857 : 30255 : if (rse->string_length != NULL_TREE)
10858 : : {
10859 : 30255 : gfc_conv_string_parameter (rse);
10860 : 30255 : gfc_add_block_to_block (&block, &rse->pre);
10861 : 30255 : rlen = rse->string_length;
10862 : : }
10863 : :
10864 : 30255 : gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
10865 : : rse->expr, ts.kind);
10866 : : }
10867 : 184022 : else if (gfc_bt_struct (ts.type)
10868 : 15233 : && (ts.u.derived->attr.alloc_comp
10869 : 10578 : || (deep_copy && ts.u.derived->attr.pdt_type)))
10870 : : {
10871 : 4726 : tree tmp_var = NULL_TREE;
10872 : 4726 : cond = NULL_TREE;
10873 : :
10874 : : /* Are the rhs and the lhs the same? */
10875 : 4726 : if (deep_copy)
10876 : : {
10877 : 2907 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10878 : : gfc_build_addr_expr (NULL_TREE, lse->expr),
10879 : : gfc_build_addr_expr (NULL_TREE, rse->expr));
10880 : 2907 : cond = gfc_evaluate_now (cond, &lse->pre);
10881 : : }
10882 : :
10883 : : /* Deallocate the lhs allocated components as long as it is not
10884 : : the same as the rhs. This must be done following the assignment
10885 : : to prevent deallocating data that could be used in the rhs
10886 : : expression. */
10887 : 4726 : if (dealloc)
10888 : : {
10889 : 1400 : tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
10890 : 1400 : tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
10891 : 1400 : 0, gfc_may_be_finalized (ts));
10892 : 1400 : if (deep_copy)
10893 : 561 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10894 : : tmp);
10895 : 1400 : gfc_add_expr_to_block (&lse->post, tmp);
10896 : : }
10897 : :
10898 : 4726 : gfc_add_block_to_block (&block, &rse->pre);
10899 : 4726 : gfc_add_block_to_block (&block, &lse->finalblock);
10900 : 4726 : gfc_add_block_to_block (&block, &lse->pre);
10901 : :
10902 : 4726 : gfc_add_modify (&block, lse->expr,
10903 : 4726 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
10904 : :
10905 : : /* Restore pointer address of coarray components. */
10906 : 4726 : if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
10907 : : {
10908 : 4 : tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
10909 : 4 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10910 : : tmp);
10911 : 4 : gfc_add_expr_to_block (&block, tmp);
10912 : : }
10913 : :
10914 : : /* Do a deep copy if the rhs is a variable, if it is not the
10915 : : same as the lhs. */
10916 : 4726 : if (deep_copy)
10917 : : {
10918 : 2907 : int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10919 : : | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
10920 : 2907 : tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
10921 : : caf_mode);
10922 : 2907 : tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10923 : : tmp);
10924 : 2907 : gfc_add_expr_to_block (&block, tmp);
10925 : : }
10926 : : }
10927 : 179296 : else if (gfc_bt_struct (ts.type))
10928 : : {
10929 : 10507 : gfc_add_block_to_block (&block, &rse->pre);
10930 : 10507 : gfc_add_block_to_block (&block, &lse->finalblock);
10931 : 10507 : gfc_add_block_to_block (&block, &lse->pre);
10932 : 10507 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
10933 : 10507 : TREE_TYPE (lse->expr), rse->expr);
10934 : 10507 : gfc_add_modify (&block, lse->expr, tmp);
10935 : : }
10936 : : /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
10937 : 168789 : else if (ts.type == BT_CLASS)
10938 : : {
10939 : 642 : gfc_add_block_to_block (&block, &lse->pre);
10940 : 642 : gfc_add_block_to_block (&block, &rse->pre);
10941 : 642 : gfc_add_block_to_block (&block, &lse->finalblock);
10942 : :
10943 : 642 : if (!trans_scalar_class_assign (&block, lse, rse))
10944 : : {
10945 : : /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
10946 : : for the lhs which ensures that class data rhs cast as a string assigns
10947 : : correctly. */
10948 : 526 : tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
10949 : 526 : TREE_TYPE (rse->expr), lse->expr);
10950 : 526 : gfc_add_modify (&block, tmp, rse->expr);
10951 : : }
10952 : : }
10953 : 168147 : else if (ts.type != BT_CLASS)
10954 : : {
10955 : 168147 : gfc_add_block_to_block (&block, &lse->pre);
10956 : 168147 : gfc_add_block_to_block (&block, &rse->pre);
10957 : :
10958 : 168147 : gfc_add_modify (&block, lse->expr,
10959 : 168147 : fold_convert (TREE_TYPE (lse->expr), rse->expr));
10960 : : }
10961 : :
10962 : 214277 : gfc_add_block_to_block (&block, &lse->post);
10963 : 214277 : gfc_add_block_to_block (&block, &rse->post);
10964 : :
10965 : 214277 : return gfc_finish_block (&block);
10966 : : }
10967 : :
10968 : :
10969 : : /* There are quite a lot of restrictions on the optimisation in using an
10970 : : array function assign without a temporary. */
10971 : :
10972 : : static bool
10973 : 7736 : arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
10974 : : {
10975 : 7736 : gfc_ref * ref;
10976 : 7736 : bool seen_array_ref;
10977 : 7736 : bool c = false;
10978 : 7736 : gfc_symbol *sym = expr1->symtree->n.sym;
10979 : :
10980 : : /* Play it safe with class functions assigned to a derived type. */
10981 : 7736 : if (gfc_is_class_array_function (expr2)
10982 : 7736 : && expr1->ts.type == BT_DERIVED)
10983 : : return true;
10984 : :
10985 : : /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
10986 : 7712 : if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
10987 : : return true;
10988 : :
10989 : : /* Elemental functions are scalarized so that they don't need a
10990 : : temporary in gfc_trans_assignment_1, so return a true. Otherwise,
10991 : : they would need special treatment in gfc_trans_arrayfunc_assign. */
10992 : 5833 : if (expr2->value.function.esym != NULL
10993 : 1440 : && expr2->value.function.esym->attr.elemental)
10994 : : return true;
10995 : :
10996 : : /* Need a temporary if rhs is not FULL or a contiguous section. */
10997 : 5495 : if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
10998 : : return true;
10999 : :
11000 : : /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
11001 : 5291 : if (gfc_ref_needs_temporary_p (expr1->ref))
11002 : : return true;
11003 : :
11004 : : /* Functions returning pointers or allocatables need temporaries. */
11005 : 5279 : if (gfc_expr_attr (expr2).pointer
11006 : 5279 : || gfc_expr_attr (expr2).allocatable)
11007 : 297 : return true;
11008 : :
11009 : : /* Character array functions need temporaries unless the
11010 : : character lengths are the same. */
11011 : 4982 : if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
11012 : : {
11013 : 542 : if (expr1->ts.u.cl->length == NULL
11014 : 500 : || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11015 : : return true;
11016 : :
11017 : 486 : if (expr2->ts.u.cl->length == NULL
11018 : 486 : || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11019 : : return true;
11020 : :
11021 : 474 : if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
11022 : 474 : expr2->ts.u.cl->length->value.integer) != 0)
11023 : : return true;
11024 : : }
11025 : :
11026 : : /* Check that no LHS component references appear during an array
11027 : : reference. This is needed because we do not have the means to
11028 : : span any arbitrary stride with an array descriptor. This check
11029 : : is not needed for the rhs because the function result has to be
11030 : : a complete type. */
11031 : 4908 : seen_array_ref = false;
11032 : 9816 : for (ref = expr1->ref; ref; ref = ref->next)
11033 : : {
11034 : 4915 : if (ref->type == REF_ARRAY)
11035 : : seen_array_ref= true;
11036 : 7 : else if (ref->type == REF_COMPONENT && seen_array_ref)
11037 : : return true;
11038 : : }
11039 : :
11040 : : /* Check for a dependency. */
11041 : 4901 : if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
11042 : : expr2->value.function.esym,
11043 : : expr2->value.function.actual,
11044 : : NOT_ELEMENTAL))
11045 : : return true;
11046 : :
11047 : : /* If we have reached here with an intrinsic function, we do not
11048 : : need a temporary except in the particular case that reallocation
11049 : : on assignment is active and the lhs is allocatable and a target,
11050 : : or a pointer which may be a subref pointer. FIXME: The last
11051 : : condition can go away when we use span in the intrinsics
11052 : : directly.*/
11053 : 4484 : if (expr2->value.function.isym)
11054 : 3712 : return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
11055 : 7511 : || (sym->attr.pointer && sym->attr.subref_array_pointer);
11056 : :
11057 : : /* If the LHS is a dummy, we need a temporary if it is not
11058 : : INTENT(OUT). */
11059 : 697 : if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
11060 : : return true;
11061 : :
11062 : : /* If the lhs has been host_associated, is in common, a pointer or is
11063 : : a target and the function is not using a RESULT variable, aliasing
11064 : : can occur and a temporary is needed. */
11065 : 691 : if ((sym->attr.host_assoc
11066 : : || sym->attr.in_common
11067 : 691 : || sym->attr.pointer
11068 : 625 : || sym->attr.cray_pointee
11069 : 625 : || sym->attr.target)
11070 : 66 : && expr2->symtree != NULL
11071 : 66 : && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
11072 : : return true;
11073 : :
11074 : : /* A PURE function can unconditionally be called without a temporary. */
11075 : 649 : if (expr2->value.function.esym != NULL
11076 : 624 : && expr2->value.function.esym->attr.pure)
11077 : : return false;
11078 : :
11079 : : /* Implicit_pure functions are those which could legally be declared
11080 : : to be PURE. */
11081 : 621 : if (expr2->value.function.esym != NULL
11082 : 596 : && expr2->value.function.esym->attr.implicit_pure)
11083 : : return false;
11084 : :
11085 : 378 : if (!sym->attr.use_assoc
11086 : : && !sym->attr.in_common
11087 : : && !sym->attr.pointer
11088 : 378 : && !sym->attr.target
11089 : 372 : && !sym->attr.cray_pointee
11090 : 372 : && expr2->value.function.esym)
11091 : : {
11092 : : /* A temporary is not needed if the function is not contained and
11093 : : the variable is local or host associated and not a pointer or
11094 : : a target. */
11095 : 347 : if (!expr2->value.function.esym->attr.contained)
11096 : : return false;
11097 : :
11098 : : /* A temporary is not needed if the lhs has never been host
11099 : : associated and the procedure is contained. */
11100 : 122 : else if (!sym->attr.host_assoc)
11101 : : return false;
11102 : :
11103 : : /* A temporary is not needed if the variable is local and not
11104 : : a pointer, a target or a result. */
11105 : 6 : if (sym->ns->parent
11106 : 0 : && expr2->value.function.esym->ns == sym->ns->parent)
11107 : : return false;
11108 : : }
11109 : :
11110 : : /* Default to temporary use. */
11111 : : return true;
11112 : : }
11113 : :
11114 : :
11115 : : /* Provide the loop info so that the lhs descriptor can be built for
11116 : : reallocatable assignments from extrinsic function calls. */
11117 : :
11118 : : static void
11119 : 152 : realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
11120 : : gfc_loopinfo *loop)
11121 : : {
11122 : : /* Signal that the function call should not be made by
11123 : : gfc_conv_loop_setup. */
11124 : 152 : se->ss->is_alloc_lhs = 1;
11125 : 152 : gfc_init_loopinfo (loop);
11126 : 152 : gfc_add_ss_to_loop (loop, *ss);
11127 : 152 : gfc_add_ss_to_loop (loop, se->ss);
11128 : 152 : gfc_conv_ss_startstride (loop);
11129 : 152 : gfc_conv_loop_setup (loop, where);
11130 : 152 : gfc_copy_loopinfo_to_se (se, loop);
11131 : 152 : gfc_add_block_to_block (&se->pre, &loop->pre);
11132 : 152 : gfc_add_block_to_block (&se->pre, &loop->post);
11133 : 152 : se->ss->is_alloc_lhs = 0;
11134 : 152 : }
11135 : :
11136 : :
11137 : : /* For assignment to a reallocatable lhs from intrinsic functions,
11138 : : replace the se.expr (ie. the result) with a temporary descriptor.
11139 : : Null the data field so that the library allocates space for the
11140 : : result. Free the data of the original descriptor after the function,
11141 : : in case it appears in an argument expression and transfer the
11142 : : result to the original descriptor. */
11143 : :
11144 : : static void
11145 : 1072 : fcncall_realloc_result (gfc_se *se, int rank)
11146 : : {
11147 : 1072 : tree desc;
11148 : 1072 : tree res_desc;
11149 : 1072 : tree tmp;
11150 : 1072 : tree offset;
11151 : 1072 : tree zero_cond;
11152 : 1072 : tree not_same_shape;
11153 : 1072 : stmtblock_t shape_block;
11154 : 1072 : int n;
11155 : :
11156 : : /* Use the allocation done by the library. Substitute the lhs
11157 : : descriptor with a copy, whose data field is nulled.*/
11158 : 1072 : desc = build_fold_indirect_ref_loc (input_location, se->expr);
11159 : 1072 : if (POINTER_TYPE_P (TREE_TYPE (desc)))
11160 : 9 : desc = build_fold_indirect_ref_loc (input_location, desc);
11161 : :
11162 : : /* Unallocated, the descriptor does not have a dtype. */
11163 : 1072 : tmp = gfc_conv_descriptor_dtype (desc);
11164 : 1072 : gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
11165 : :
11166 : 1072 : res_desc = gfc_evaluate_now (desc, &se->pre);
11167 : 1072 : gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
11168 : 1072 : se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
11169 : :
11170 : : /* Free the lhs after the function call and copy the result data to
11171 : : the lhs descriptor. */
11172 : 1072 : tmp = gfc_conv_descriptor_data_get (desc);
11173 : 1072 : zero_cond = fold_build2_loc (input_location, EQ_EXPR,
11174 : : logical_type_node, tmp,
11175 : 1072 : build_int_cst (TREE_TYPE (tmp), 0));
11176 : 1072 : zero_cond = gfc_evaluate_now (zero_cond, &se->post);
11177 : 1072 : tmp = gfc_call_free (tmp);
11178 : 1072 : gfc_add_expr_to_block (&se->post, tmp);
11179 : :
11180 : 1072 : tmp = gfc_conv_descriptor_data_get (res_desc);
11181 : 1072 : gfc_conv_descriptor_data_set (&se->post, desc, tmp);
11182 : :
11183 : : /* Check that the shapes are the same between lhs and expression.
11184 : : The evaluation of the shape is done in 'shape_block' to avoid
11185 : : unitialized warnings from the lhs bounds. */
11186 : 1072 : not_same_shape = boolean_false_node;
11187 : 1072 : gfc_start_block (&shape_block);
11188 : 3828 : for (n = 0 ; n < rank; n++)
11189 : : {
11190 : 2756 : tree tmp1;
11191 : 2756 : tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11192 : 2756 : tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
11193 : 2756 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11194 : : gfc_array_index_type, tmp, tmp1);
11195 : 2756 : tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
11196 : 2756 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
11197 : : gfc_array_index_type, tmp, tmp1);
11198 : 2756 : tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
11199 : 2756 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11200 : : gfc_array_index_type, tmp, tmp1);
11201 : 2756 : tmp = fold_build2_loc (input_location, NE_EXPR,
11202 : : logical_type_node, tmp,
11203 : : gfc_index_zero_node);
11204 : 2756 : tmp = gfc_evaluate_now (tmp, &shape_block);
11205 : 2756 : if (n == 0)
11206 : : not_same_shape = tmp;
11207 : : else
11208 : 1684 : not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
11209 : : logical_type_node, tmp,
11210 : : not_same_shape);
11211 : : }
11212 : :
11213 : : /* 'zero_cond' being true is equal to lhs not being allocated or the
11214 : : shapes being different. */
11215 : 1072 : tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
11216 : : zero_cond, not_same_shape);
11217 : 1072 : gfc_add_modify (&shape_block, zero_cond, tmp);
11218 : 1072 : tmp = gfc_finish_block (&shape_block);
11219 : 1072 : tmp = build3_v (COND_EXPR, zero_cond,
11220 : : build_empty_stmt (input_location), tmp);
11221 : 1072 : gfc_add_expr_to_block (&se->post, tmp);
11222 : :
11223 : : /* Now reset the bounds returned from the function call to bounds based
11224 : : on the lhs lbounds, except where the lhs is not allocated or the shapes
11225 : : of 'variable and 'expr' are different. Set the offset accordingly. */
11226 : 1072 : offset = gfc_index_zero_node;
11227 : 3828 : for (n = 0 ; n < rank; n++)
11228 : : {
11229 : 2756 : tree lbound;
11230 : :
11231 : 2756 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
11232 : 2756 : lbound = fold_build3_loc (input_location, COND_EXPR,
11233 : : gfc_array_index_type, zero_cond,
11234 : : gfc_index_one_node, lbound);
11235 : 2756 : lbound = gfc_evaluate_now (lbound, &se->post);
11236 : :
11237 : 2756 : tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
11238 : 2756 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
11239 : : gfc_array_index_type, tmp, lbound);
11240 : 2756 : gfc_conv_descriptor_lbound_set (&se->post, desc,
11241 : : gfc_rank_cst[n], lbound);
11242 : 2756 : gfc_conv_descriptor_ubound_set (&se->post, desc,
11243 : : gfc_rank_cst[n], tmp);
11244 : :
11245 : : /* Set stride and accumulate the offset. */
11246 : 2756 : tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
11247 : 2756 : gfc_conv_descriptor_stride_set (&se->post, desc,
11248 : : gfc_rank_cst[n], tmp);
11249 : 2756 : tmp = fold_build2_loc (input_location, MULT_EXPR,
11250 : : gfc_array_index_type, lbound, tmp);
11251 : 2756 : offset = fold_build2_loc (input_location, MINUS_EXPR,
11252 : : gfc_array_index_type, offset, tmp);
11253 : 2756 : offset = gfc_evaluate_now (offset, &se->post);
11254 : : }
11255 : :
11256 : 1072 : gfc_conv_descriptor_offset_set (&se->post, desc, offset);
11257 : 1072 : }
11258 : :
11259 : :
11260 : :
11261 : : /* Try to translate array(:) = func (...), where func is a transformational
11262 : : array function, without using a temporary. Returns NULL if this isn't the
11263 : : case. */
11264 : :
11265 : : static tree
11266 : 7736 : gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
11267 : : {
11268 : 7736 : gfc_se se;
11269 : 7736 : gfc_ss *ss = NULL;
11270 : 7736 : gfc_component *comp = NULL;
11271 : 7736 : gfc_loopinfo loop;
11272 : 7736 : tree tmp;
11273 : 7736 : tree lhs;
11274 : 7736 : gfc_se final_se;
11275 : 7736 : gfc_symbol *sym = expr1->symtree->n.sym;
11276 : 7736 : bool finalizable = gfc_may_be_finalized (expr1->ts);
11277 : :
11278 : 7736 : if (arrayfunc_assign_needs_temporary (expr1, expr2))
11279 : : return NULL;
11280 : :
11281 : : /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
11282 : : functions. */
11283 : 4366 : comp = gfc_get_proc_ptr_comp (expr2);
11284 : :
11285 : 4366 : if (!(expr2->value.function.isym
11286 : 612 : || (comp && comp->attr.dimension)
11287 : 612 : || (!comp && gfc_return_by_reference (expr2->value.function.esym)
11288 : 612 : && expr2->value.function.esym->result->attr.dimension)))
11289 : 0 : return NULL;
11290 : :
11291 : 4366 : gfc_init_se (&se, NULL);
11292 : 4366 : gfc_start_block (&se.pre);
11293 : 4366 : se.want_pointer = 1;
11294 : :
11295 : : /* First the lhs must be finalized, if necessary. We use a copy of the symbol
11296 : : backend decl, stash the original away for the finalization so that the
11297 : : value used is that before the assignment. This is necessary because
11298 : : evaluation of the rhs expression using direct by reference can change
11299 : : the value. However, the standard mandates that the finalization must occur
11300 : : after evaluation of the rhs. */
11301 : 4366 : gfc_init_se (&final_se, NULL);
11302 : :
11303 : 4366 : if (finalizable)
11304 : : {
11305 : 21 : tmp = sym->backend_decl;
11306 : 21 : lhs = sym->backend_decl;
11307 : 21 : if (INDIRECT_REF_P (tmp))
11308 : 0 : tmp = TREE_OPERAND (tmp, 0);
11309 : 21 : sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs");
11310 : 21 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
11311 : 21 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
11312 : : {
11313 : 0 : tmp = gfc_copy_alloc_comp (expr1->ts.u.derived, tmp, sym->backend_decl,
11314 : : expr1->rank, 0);
11315 : 0 : gfc_add_expr_to_block (&final_se.pre, tmp);
11316 : : }
11317 : : }
11318 : :
11319 : 21 : if (finalizable && gfc_assignment_finalizer_call (&final_se, expr1, false))
11320 : : {
11321 : 21 : gfc_add_block_to_block (&se.pre, &final_se.pre);
11322 : 21 : gfc_add_block_to_block (&se.post, &final_se.finalblock);
11323 : : }
11324 : :
11325 : 4366 : if (finalizable)
11326 : 21 : sym->backend_decl = lhs;
11327 : :
11328 : 4366 : gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
11329 : :
11330 : 4366 : if (expr1->ts.type == BT_DERIVED
11331 : 131 : && expr1->ts.u.derived->attr.alloc_comp)
11332 : : {
11333 : 20 : tmp = build_fold_indirect_ref_loc (input_location, se.expr);
11334 : 20 : tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, tmp,
11335 : : expr1->rank);
11336 : 20 : gfc_add_expr_to_block (&se.pre, tmp);
11337 : : }
11338 : :
11339 : 4366 : se.direct_byref = 1;
11340 : 4366 : se.ss = gfc_walk_expr (expr2);
11341 : 4366 : gcc_assert (se.ss != gfc_ss_terminator);
11342 : :
11343 : : /* Since this is a direct by reference call, references to the lhs can be
11344 : : used for finalization of the function result just as long as the blocks
11345 : : from final_se are added at the right time. */
11346 : 4366 : gfc_init_se (&final_se, NULL);
11347 : 4366 : if (finalizable && expr2->value.function.esym)
11348 : : {
11349 : 20 : final_se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
11350 : 20 : gfc_finalize_tree_expr (&final_se, expr2->ts.u.derived,
11351 : 20 : expr2->value.function.esym->attr,
11352 : : expr2->rank);
11353 : : }
11354 : :
11355 : : /* Reallocate on assignment needs the loopinfo for extrinsic functions.
11356 : : This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
11357 : : Clearly, this cannot be done for an allocatable function result, since
11358 : : the shape of the result is unknown and, in any case, the function must
11359 : : correctly take care of the reallocation internally. For intrinsic
11360 : : calls, the array data is freed and the library takes care of allocation.
11361 : : TODO: Add logic of trans-array.cc: gfc_alloc_allocatable_for_assignment
11362 : : to the library. */
11363 : 4366 : if (flag_realloc_lhs
11364 : 4291 : && gfc_is_reallocatable_lhs (expr1)
11365 : 5590 : && !gfc_expr_attr (expr1).codimension
11366 : 1224 : && !gfc_is_coindexed (expr1)
11367 : 5590 : && !(expr2->value.function.esym
11368 : 152 : && expr2->value.function.esym->result->attr.allocatable))
11369 : : {
11370 : 1224 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
11371 : :
11372 : 1224 : if (!expr2->value.function.isym)
11373 : : {
11374 : 152 : ss = gfc_walk_expr (expr1);
11375 : 152 : gcc_assert (ss != gfc_ss_terminator);
11376 : :
11377 : 152 : realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
11378 : 152 : ss->is_alloc_lhs = 1;
11379 : : }
11380 : : else
11381 : 1072 : fcncall_realloc_result (&se, expr1->rank);
11382 : : }
11383 : :
11384 : 4366 : gfc_conv_function_expr (&se, expr2);
11385 : :
11386 : : /* Fix the result. */
11387 : 4366 : gfc_add_block_to_block (&se.pre, &se.post);
11388 : 4366 : if (finalizable)
11389 : 21 : gfc_add_block_to_block (&se.pre, &final_se.pre);
11390 : :
11391 : : /* Do the finalization, including final calls from function arguments. */
11392 : 21 : if (finalizable)
11393 : : {
11394 : 21 : gfc_add_block_to_block (&se.pre, &final_se.post);
11395 : 21 : gfc_add_block_to_block (&se.pre, &se.finalblock);
11396 : 21 : gfc_add_block_to_block (&se.pre, &final_se.finalblock);
11397 : : }
11398 : :
11399 : 4366 : if (ss)
11400 : 152 : gfc_cleanup_loop (&loop);
11401 : : else
11402 : 4214 : gfc_free_ss_chain (se.ss);
11403 : :
11404 : 4366 : return gfc_finish_block (&se.pre);
11405 : : }
11406 : :
11407 : :
11408 : : /* Try to efficiently translate array(:) = 0. Return NULL if this
11409 : : can't be done. */
11410 : :
11411 : : static tree
11412 : 3701 : gfc_trans_zero_assign (gfc_expr * expr)
11413 : : {
11414 : 3701 : tree dest, len, type;
11415 : 3701 : tree tmp;
11416 : 3701 : gfc_symbol *sym;
11417 : :
11418 : 3701 : sym = expr->symtree->n.sym;
11419 : 3701 : dest = gfc_get_symbol_decl (sym);
11420 : :
11421 : 3701 : type = TREE_TYPE (dest);
11422 : 3701 : if (POINTER_TYPE_P (type))
11423 : 230 : type = TREE_TYPE (type);
11424 : 3701 : if (!GFC_ARRAY_TYPE_P (type))
11425 : : return NULL_TREE;
11426 : :
11427 : : /* Determine the length of the array. */
11428 : 2506 : len = GFC_TYPE_ARRAY_SIZE (type);
11429 : 2506 : if (!len || TREE_CODE (len) != INTEGER_CST)
11430 : : return NULL_TREE;
11431 : :
11432 : 2340 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
11433 : 2340 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
11434 : : fold_convert (gfc_array_index_type, tmp));
11435 : :
11436 : : /* If we are zeroing a local array avoid taking its address by emitting
11437 : : a = {} instead. */
11438 : 2340 : if (!POINTER_TYPE_P (TREE_TYPE (dest)))
11439 : 2299 : return build2_loc (input_location, MODIFY_EXPR, void_type_node,
11440 : 2299 : dest, build_constructor (TREE_TYPE (dest),
11441 : 2299 : NULL));
11442 : :
11443 : : /* Convert arguments to the correct types. */
11444 : 41 : dest = fold_convert (pvoid_type_node, dest);
11445 : 41 : len = fold_convert (size_type_node, len);
11446 : :
11447 : : /* Construct call to __builtin_memset. */
11448 : 41 : tmp = build_call_expr_loc (input_location,
11449 : : builtin_decl_explicit (BUILT_IN_MEMSET),
11450 : : 3, dest, integer_zero_node, len);
11451 : 41 : return fold_convert (void_type_node, tmp);
11452 : : }
11453 : :
11454 : :
11455 : : /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
11456 : : that constructs the call to __builtin_memcpy. */
11457 : :
11458 : : tree
11459 : 5862 : gfc_build_memcpy_call (tree dst, tree src, tree len)
11460 : : {
11461 : 5862 : tree tmp;
11462 : :
11463 : : /* Convert arguments to the correct types. */
11464 : 5862 : if (!POINTER_TYPE_P (TREE_TYPE (dst)))
11465 : 5630 : dst = gfc_build_addr_expr (pvoid_type_node, dst);
11466 : : else
11467 : 232 : dst = fold_convert (pvoid_type_node, dst);
11468 : :
11469 : 5862 : if (!POINTER_TYPE_P (TREE_TYPE (src)))
11470 : 5560 : src = gfc_build_addr_expr (pvoid_type_node, src);
11471 : : else
11472 : 302 : src = fold_convert (pvoid_type_node, src);
11473 : :
11474 : 5862 : len = fold_convert (size_type_node, len);
11475 : :
11476 : : /* Construct call to __builtin_memcpy. */
11477 : 5862 : tmp = build_call_expr_loc (input_location,
11478 : : builtin_decl_explicit (BUILT_IN_MEMCPY),
11479 : : 3, dst, src, len);
11480 : 5862 : return fold_convert (void_type_node, tmp);
11481 : : }
11482 : :
11483 : :
11484 : : /* Try to efficiently translate dst(:) = src(:). Return NULL if this
11485 : : can't be done. EXPR1 is the destination/lhs and EXPR2 is the
11486 : : source/rhs, both are gfc_full_array_ref_p which have been checked for
11487 : : dependencies. */
11488 : :
11489 : : static tree
11490 : 1732 : gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
11491 : : {
11492 : 1732 : tree dst, dlen, dtype;
11493 : 1732 : tree src, slen, stype;
11494 : 1732 : tree tmp;
11495 : :
11496 : 1732 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
11497 : 1732 : src = gfc_get_symbol_decl (expr2->symtree->n.sym);
11498 : :
11499 : 1732 : dtype = TREE_TYPE (dst);
11500 : 1732 : if (POINTER_TYPE_P (dtype))
11501 : 183 : dtype = TREE_TYPE (dtype);
11502 : 1732 : stype = TREE_TYPE (src);
11503 : 1732 : if (POINTER_TYPE_P (stype))
11504 : 218 : stype = TREE_TYPE (stype);
11505 : :
11506 : 1732 : if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
11507 : : return NULL_TREE;
11508 : :
11509 : : /* Determine the lengths of the arrays. */
11510 : 949 : dlen = GFC_TYPE_ARRAY_SIZE (dtype);
11511 : 949 : if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
11512 : : return NULL_TREE;
11513 : 867 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
11514 : 867 : dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
11515 : : dlen, fold_convert (gfc_array_index_type, tmp));
11516 : :
11517 : 867 : slen = GFC_TYPE_ARRAY_SIZE (stype);
11518 : 867 : if (!slen || TREE_CODE (slen) != INTEGER_CST)
11519 : : return NULL_TREE;
11520 : 861 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
11521 : 861 : slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
11522 : : slen, fold_convert (gfc_array_index_type, tmp));
11523 : :
11524 : : /* Sanity check that they are the same. This should always be
11525 : : the case, as we should already have checked for conformance. */
11526 : 861 : if (!tree_int_cst_equal (slen, dlen))
11527 : : return NULL_TREE;
11528 : :
11529 : 861 : return gfc_build_memcpy_call (dst, src, dlen);
11530 : : }
11531 : :
11532 : :
11533 : : /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
11534 : : this can't be done. EXPR1 is the destination/lhs for which
11535 : : gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
11536 : :
11537 : : static tree
11538 : 7826 : gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
11539 : : {
11540 : 7826 : unsigned HOST_WIDE_INT nelem;
11541 : 7826 : tree dst, dtype;
11542 : 7826 : tree src, stype;
11543 : 7826 : tree len;
11544 : 7826 : tree tmp;
11545 : :
11546 : 7826 : nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
11547 : 7826 : if (nelem == 0)
11548 : : return NULL_TREE;
11549 : :
11550 : 5212 : dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
11551 : 5212 : dtype = TREE_TYPE (dst);
11552 : 5212 : if (POINTER_TYPE_P (dtype))
11553 : 245 : dtype = TREE_TYPE (dtype);
11554 : 5212 : if (!GFC_ARRAY_TYPE_P (dtype))
11555 : : return NULL_TREE;
11556 : :
11557 : : /* Determine the lengths of the array. */
11558 : 4600 : len = GFC_TYPE_ARRAY_SIZE (dtype);
11559 : 4600 : if (!len || TREE_CODE (len) != INTEGER_CST)
11560 : : return NULL_TREE;
11561 : :
11562 : : /* Confirm that the constructor is the same size. */
11563 : 4508 : if (compare_tree_int (len, nelem) != 0)
11564 : : return NULL_TREE;
11565 : :
11566 : 4508 : tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
11567 : 4508 : len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
11568 : : fold_convert (gfc_array_index_type, tmp));
11569 : :
11570 : 4508 : stype = gfc_typenode_for_spec (&expr2->ts);
11571 : 4508 : src = gfc_build_constant_array_constructor (expr2, stype);
11572 : :
11573 : 4508 : return gfc_build_memcpy_call (dst, src, len);
11574 : : }
11575 : :
11576 : :
11577 : : /* Tells whether the expression is to be treated as a variable reference. */
11578 : :
11579 : : bool
11580 : 195297 : gfc_expr_is_variable (gfc_expr *expr)
11581 : : {
11582 : 195557 : gfc_expr *arg;
11583 : 195557 : gfc_component *comp;
11584 : 195557 : gfc_symbol *func_ifc;
11585 : :
11586 : 195557 : if (expr->expr_type == EXPR_VARIABLE)
11587 : : return true;
11588 : :
11589 : 164945 : arg = gfc_get_noncopying_intrinsic_argument (expr);
11590 : 164945 : if (arg)
11591 : : {
11592 : 260 : gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
11593 : : return gfc_expr_is_variable (arg);
11594 : : }
11595 : :
11596 : : /* A data-pointer-returning function should be considered as a variable
11597 : : too. */
11598 : 164685 : if (expr->expr_type == EXPR_FUNCTION
11599 : 28411 : && expr->ref == NULL)
11600 : : {
11601 : 28063 : if (expr->value.function.isym != NULL)
11602 : : return false;
11603 : :
11604 : 8207 : if (expr->value.function.esym != NULL)
11605 : : {
11606 : 8198 : func_ifc = expr->value.function.esym;
11607 : 8198 : goto found_ifc;
11608 : : }
11609 : 9 : gcc_assert (expr->symtree);
11610 : 9 : func_ifc = expr->symtree->n.sym;
11611 : 9 : goto found_ifc;
11612 : : }
11613 : :
11614 : 136622 : comp = gfc_get_proc_ptr_comp (expr);
11615 : 136622 : if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
11616 : 348 : && comp)
11617 : : {
11618 : 246 : func_ifc = comp->ts.interface;
11619 : 246 : goto found_ifc;
11620 : : }
11621 : :
11622 : 136376 : if (expr->expr_type == EXPR_COMPCALL)
11623 : : {
11624 : 0 : gcc_assert (!expr->value.compcall.tbp->is_generic);
11625 : 0 : func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
11626 : 0 : goto found_ifc;
11627 : : }
11628 : :
11629 : : return false;
11630 : :
11631 : 8453 : found_ifc:
11632 : 8453 : gcc_assert (func_ifc->attr.function
11633 : : && func_ifc->result != NULL);
11634 : 8453 : return func_ifc->result->attr.pointer;
11635 : : }
11636 : :
11637 : :
11638 : : /* Is the lhs OK for automatic reallocation? */
11639 : :
11640 : : static bool
11641 : 155343 : is_scalar_reallocatable_lhs (gfc_expr *expr)
11642 : : {
11643 : 155343 : gfc_ref * ref;
11644 : :
11645 : : /* An allocatable variable with no reference. */
11646 : 155343 : if (expr->symtree->n.sym->attr.allocatable
11647 : 6279 : && !expr->ref)
11648 : : return true;
11649 : :
11650 : : /* All that can be left are allocatable components. However, we do
11651 : : not check for allocatable components here because the expression
11652 : : could be an allocatable component of a pointer component. */
11653 : 152888 : if (expr->symtree->n.sym->ts.type != BT_DERIVED
11654 : 134121 : && expr->symtree->n.sym->ts.type != BT_CLASS)
11655 : : return false;
11656 : :
11657 : : /* Find an allocatable component ref last. */
11658 : 33423 : for (ref = expr->ref; ref; ref = ref->next)
11659 : 13662 : if (ref->type == REF_COMPONENT
11660 : 10279 : && !ref->next
11661 : 8019 : && ref->u.c.component->attr.allocatable)
11662 : : return true;
11663 : :
11664 : : return false;
11665 : : }
11666 : :
11667 : :
11668 : : /* Allocate or reallocate scalar lhs, as necessary. */
11669 : :
11670 : : static void
11671 : 2986 : alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
11672 : : tree string_length,
11673 : : gfc_expr *expr1,
11674 : : gfc_expr *expr2)
11675 : :
11676 : : {
11677 : 2986 : tree cond;
11678 : 2986 : tree tmp;
11679 : 2986 : tree size;
11680 : 2986 : tree size_in_bytes;
11681 : 2986 : tree jump_label1;
11682 : 2986 : tree jump_label2;
11683 : 2986 : gfc_se lse;
11684 : 2986 : gfc_ref *ref;
11685 : :
11686 : 2986 : if (!expr1 || expr1->rank)
11687 : 0 : return;
11688 : :
11689 : 2986 : if (!expr2 || expr2->rank)
11690 : : return;
11691 : :
11692 : 3865 : for (ref = expr1->ref; ref; ref = ref->next)
11693 : 879 : if (ref->type == REF_SUBSTRING)
11694 : : return;
11695 : :
11696 : 2986 : realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
11697 : :
11698 : : /* Since this is a scalar lhs, we can afford to do this. That is,
11699 : : there is no risk of side effects being repeated. */
11700 : 2986 : gfc_init_se (&lse, NULL);
11701 : 2986 : lse.want_pointer = 1;
11702 : 2986 : gfc_conv_expr (&lse, expr1);
11703 : :
11704 : 2986 : jump_label1 = gfc_build_label_decl (NULL_TREE);
11705 : 2986 : jump_label2 = gfc_build_label_decl (NULL_TREE);
11706 : :
11707 : : /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
11708 : 2986 : tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
11709 : 2986 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
11710 : : lse.expr, tmp);
11711 : 2986 : tmp = build3_v (COND_EXPR, cond,
11712 : : build1_v (GOTO_EXPR, jump_label1),
11713 : : build_empty_stmt (input_location));
11714 : 2986 : gfc_add_expr_to_block (block, tmp);
11715 : :
11716 : 2986 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11717 : : {
11718 : : /* Use the rhs string length and the lhs element size. Note that 'size' is
11719 : : used below for the string-length comparison, only. */
11720 : 1234 : size = string_length;
11721 : 1234 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
11722 : 2468 : size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
11723 : 1234 : TREE_TYPE (tmp), tmp,
11724 : 1234 : fold_convert (TREE_TYPE (tmp), size));
11725 : : }
11726 : : else
11727 : : {
11728 : : /* Otherwise use the length in bytes of the rhs. */
11729 : 1752 : size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
11730 : 1752 : size_in_bytes = size;
11731 : : }
11732 : :
11733 : 2986 : size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
11734 : : size_in_bytes, size_one_node);
11735 : :
11736 : 2986 : if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
11737 : : {
11738 : 30 : tree caf_decl, token;
11739 : 30 : gfc_se caf_se;
11740 : 30 : symbol_attribute attr;
11741 : :
11742 : 30 : gfc_clear_attr (&attr);
11743 : 30 : gfc_init_se (&caf_se, NULL);
11744 : :
11745 : 30 : caf_decl = gfc_get_tree_for_caf_expr (expr1);
11746 : 30 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
11747 : : NULL);
11748 : 30 : gfc_add_block_to_block (block, &caf_se.pre);
11749 : 30 : gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
11750 : : gfc_build_addr_expr (NULL_TREE, token),
11751 : : NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
11752 : : expr1, 1);
11753 : : }
11754 : 2956 : else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
11755 : : {
11756 : 24 : tmp = build_call_expr_loc (input_location,
11757 : : builtin_decl_explicit (BUILT_IN_CALLOC),
11758 : : 2, build_one_cst (size_type_node),
11759 : : size_in_bytes);
11760 : 24 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11761 : 24 : gfc_add_modify (block, lse.expr, tmp);
11762 : : }
11763 : : else
11764 : : {
11765 : 2932 : tmp = build_call_expr_loc (input_location,
11766 : : builtin_decl_explicit (BUILT_IN_MALLOC),
11767 : : 1, size_in_bytes);
11768 : 2932 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11769 : 2932 : gfc_add_modify (block, lse.expr, tmp);
11770 : : }
11771 : :
11772 : 2986 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11773 : : {
11774 : : /* Deferred characters need checking for lhs and rhs string
11775 : : length. Other deferred parameter variables will have to
11776 : : come here too. */
11777 : 1234 : tmp = build1_v (GOTO_EXPR, jump_label2);
11778 : 1234 : gfc_add_expr_to_block (block, tmp);
11779 : : }
11780 : 2986 : tmp = build1_v (LABEL_EXPR, jump_label1);
11781 : 2986 : gfc_add_expr_to_block (block, tmp);
11782 : :
11783 : : /* For a deferred length character, reallocate if lengths of lhs and
11784 : : rhs are different. */
11785 : 2986 : if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
11786 : : {
11787 : 1234 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11788 : : lse.string_length,
11789 : 1234 : fold_convert (TREE_TYPE (lse.string_length),
11790 : : size));
11791 : : /* Jump past the realloc if the lengths are the same. */
11792 : 1234 : tmp = build3_v (COND_EXPR, cond,
11793 : : build1_v (GOTO_EXPR, jump_label2),
11794 : : build_empty_stmt (input_location));
11795 : 1234 : gfc_add_expr_to_block (block, tmp);
11796 : 1234 : tmp = build_call_expr_loc (input_location,
11797 : : builtin_decl_explicit (BUILT_IN_REALLOC),
11798 : : 2, fold_convert (pvoid_type_node, lse.expr),
11799 : : size_in_bytes);
11800 : 1234 : tree omp_cond = NULL_TREE;
11801 : 1234 : if (flag_openmp_allocators)
11802 : : {
11803 : 1 : tree omp_tmp;
11804 : 1 : omp_cond = gfc_omp_call_is_alloc (lse.expr);
11805 : 1 : omp_cond = gfc_evaluate_now (omp_cond, block);
11806 : :
11807 : 1 : omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC);
11808 : 1 : omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4,
11809 : : fold_convert (pvoid_type_node,
11810 : : lse.expr), size_in_bytes,
11811 : : build_zero_cst (ptr_type_node),
11812 : : build_zero_cst (ptr_type_node));
11813 : 1 : tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
11814 : : omp_cond, omp_tmp, tmp);
11815 : : }
11816 : 1234 : tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
11817 : 1234 : gfc_add_modify (block, lse.expr, tmp);
11818 : 1234 : if (omp_cond)
11819 : 1 : gfc_add_expr_to_block (block,
11820 : : build3_loc (input_location, COND_EXPR,
11821 : : void_type_node, omp_cond,
11822 : : gfc_omp_call_add_alloc (lse.expr),
11823 : : build_empty_stmt (input_location)));
11824 : 1234 : tmp = build1_v (LABEL_EXPR, jump_label2);
11825 : 1234 : gfc_add_expr_to_block (block, tmp);
11826 : :
11827 : : /* Update the lhs character length. */
11828 : 1234 : size = string_length;
11829 : 1234 : gfc_add_modify (block, lse.string_length,
11830 : 1234 : fold_convert (TREE_TYPE (lse.string_length), size));
11831 : : }
11832 : : }
11833 : :
11834 : : /* Check for assignments of the type
11835 : :
11836 : : a = a + 4
11837 : :
11838 : : to make sure we do not check for reallocation unneccessarily. */
11839 : :
11840 : :
11841 : : static bool
11842 : 3623 : is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
11843 : : {
11844 : 3912 : gfc_actual_arglist *a;
11845 : 3912 : gfc_expr *e1, *e2;
11846 : :
11847 : 3912 : switch (expr2->expr_type)
11848 : : {
11849 : 1204 : case EXPR_VARIABLE:
11850 : 1204 : return gfc_dep_compare_expr (expr1, expr2) == 0;
11851 : :
11852 : 843 : case EXPR_FUNCTION:
11853 : 843 : if (expr2->value.function.esym
11854 : 238 : && expr2->value.function.esym->attr.elemental)
11855 : : {
11856 : 51 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
11857 : : {
11858 : 50 : e1 = a->expr;
11859 : 50 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
11860 : : return false;
11861 : : }
11862 : : return true;
11863 : : }
11864 : 805 : else if (expr2->value.function.isym
11865 : 591 : && expr2->value.function.isym->elemental)
11866 : : {
11867 : 324 : for (a = expr2->value.function.actual; a != NULL; a = a->next)
11868 : : {
11869 : 314 : e1 = a->expr;
11870 : 314 : if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
11871 : : return false;
11872 : : }
11873 : : return true;
11874 : : }
11875 : :
11876 : : break;
11877 : :
11878 : 483 : case EXPR_OP:
11879 : 483 : switch (expr2->value.op.op)
11880 : : {
11881 : 32 : case INTRINSIC_NOT:
11882 : 32 : case INTRINSIC_UPLUS:
11883 : 32 : case INTRINSIC_UMINUS:
11884 : 32 : case INTRINSIC_PARENTHESES:
11885 : 32 : return is_runtime_conformable (expr1, expr2->value.op.op1);
11886 : :
11887 : 426 : case INTRINSIC_PLUS:
11888 : 426 : case INTRINSIC_MINUS:
11889 : 426 : case INTRINSIC_TIMES:
11890 : 426 : case INTRINSIC_DIVIDE:
11891 : 426 : case INTRINSIC_POWER:
11892 : 426 : case INTRINSIC_AND:
11893 : 426 : case INTRINSIC_OR:
11894 : 426 : case INTRINSIC_EQV:
11895 : 426 : case INTRINSIC_NEQV:
11896 : 426 : case INTRINSIC_EQ:
11897 : 426 : case INTRINSIC_NE:
11898 : 426 : case INTRINSIC_GT:
11899 : 426 : case INTRINSIC_GE:
11900 : 426 : case INTRINSIC_LT:
11901 : 426 : case INTRINSIC_LE:
11902 : 426 : case INTRINSIC_EQ_OS:
11903 : 426 : case INTRINSIC_NE_OS:
11904 : 426 : case INTRINSIC_GT_OS:
11905 : 426 : case INTRINSIC_GE_OS:
11906 : 426 : case INTRINSIC_LT_OS:
11907 : 426 : case INTRINSIC_LE_OS:
11908 : :
11909 : 426 : e1 = expr2->value.op.op1;
11910 : 426 : e2 = expr2->value.op.op2;
11911 : :
11912 : 426 : if (e1->rank == 0 && e2->rank > 0)
11913 : : return is_runtime_conformable (expr1, e2);
11914 : 380 : else if (e1->rank > 0 && e2->rank == 0)
11915 : : return is_runtime_conformable (expr1, e1);
11916 : 169 : else if (e1->rank > 0 && e2->rank > 0)
11917 : 169 : return is_runtime_conformable (expr1, e1)
11918 : 169 : && is_runtime_conformable (expr1, e2);
11919 : : break;
11920 : :
11921 : : default:
11922 : : break;
11923 : :
11924 : : }
11925 : :
11926 : : break;
11927 : :
11928 : : default:
11929 : : break;
11930 : : }
11931 : : return false;
11932 : : }
11933 : :
11934 : :
11935 : : static tree
11936 : 2865 : trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
11937 : : gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
11938 : : bool class_realloc)
11939 : : {
11940 : 2865 : tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
11941 : 2865 : vec<tree, va_gc> *args = NULL;
11942 : 2865 : bool final_expr;
11943 : :
11944 : 2865 : final_expr = gfc_assignment_finalizer_call (lse, lhs, false);
11945 : 2865 : if (final_expr)
11946 : : {
11947 : 272 : if (rse->loop)
11948 : 75 : gfc_prepend_expr_to_block (&rse->loop->pre,
11949 : : gfc_finish_block (&lse->finalblock));
11950 : : else
11951 : 197 : gfc_add_block_to_block (block, &lse->finalblock);
11952 : : }
11953 : :
11954 : : /* Store the old vptr so that dynamic types can be compared for
11955 : : reallocation to occur or not. */
11956 : 2865 : if (class_realloc)
11957 : : {
11958 : 209 : tmp = lse->expr;
11959 : 209 : if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
11960 : 18 : tmp = gfc_get_class_from_expr (tmp);
11961 : : }
11962 : :
11963 : 2865 : vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
11964 : : &from_len, &rhs_vptr);
11965 : 2865 : if (rhs_vptr == NULL_TREE)
11966 : 60 : rhs_vptr = vptr;
11967 : :
11968 : : /* Generate (re)allocation of the lhs. */
11969 : 2865 : if (class_realloc)
11970 : : {
11971 : 209 : stmtblock_t alloc, re_alloc;
11972 : 209 : tree class_han, re, size;
11973 : :
11974 : 209 : if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
11975 : 191 : old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
11976 : : else
11977 : 18 : old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
11978 : :
11979 : 209 : size = gfc_vptr_size_get (rhs_vptr);
11980 : 209 : tmp = lse->expr;
11981 : 209 : class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
11982 : 209 : ? gfc_class_data_get (tmp) : tmp;
11983 : :
11984 : 209 : if (!POINTER_TYPE_P (TREE_TYPE (class_han)))
11985 : 18 : class_han = gfc_build_addr_expr (NULL_TREE, class_han);
11986 : :
11987 : : /* Allocate block. */
11988 : 209 : gfc_init_block (&alloc);
11989 : 209 : gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
11990 : :
11991 : : /* Reallocate if dynamic types are different. */
11992 : 209 : gfc_init_block (&re_alloc);
11993 : 209 : tmp = fold_convert (pvoid_type_node, class_han);
11994 : 209 : re = build_call_expr_loc (input_location,
11995 : : builtin_decl_explicit (BUILT_IN_REALLOC), 2,
11996 : : tmp, size);
11997 : 209 : re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
11998 : : re);
11999 : 209 : tmp = fold_build2_loc (input_location, NE_EXPR,
12000 : : logical_type_node, rhs_vptr, old_vptr);
12001 : 209 : re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
12002 : : tmp, re, build_empty_stmt (input_location));
12003 : 209 : gfc_add_expr_to_block (&re_alloc, re);
12004 : :
12005 : 209 : tree realloc_expr = lhs->ts.type == BT_CLASS ?
12006 : 191 : gfc_finish_block (&re_alloc) :
12007 : 18 : build_empty_stmt (input_location);
12008 : :
12009 : : /* Allocate if _data is NULL, reallocate otherwise. */
12010 : 209 : tmp = fold_build2_loc (input_location, EQ_EXPR,
12011 : : logical_type_node, class_han,
12012 : 209 : build_int_cst (prvoid_type_node, 0));
12013 : 209 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
12014 : : gfc_unlikely (tmp,
12015 : : PRED_FORTRAN_FAIL_ALLOC),
12016 : : gfc_finish_block (&alloc),
12017 : : realloc_expr);
12018 : 209 : gfc_add_expr_to_block (&lse->pre, tmp);
12019 : : }
12020 : :
12021 : 2865 : fcn = gfc_vptr_copy_get (vptr);
12022 : :
12023 : 2865 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
12024 : 2865 : ? gfc_class_data_get (rse->expr) : rse->expr;
12025 : 2865 : if (use_vptr_copy)
12026 : : {
12027 : 4880 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
12028 : 392 : || INDIRECT_REF_P (tmp)
12029 : 313 : || (rhs->ts.type == BT_DERIVED
12030 : 0 : && rhs->ts.u.derived->attr.unlimited_polymorphic
12031 : : && !rhs->ts.u.derived->attr.pointer
12032 : 0 : && !rhs->ts.u.derived->attr.allocatable)
12033 : 2946 : || (UNLIMITED_POLY (rhs)
12034 : : && !CLASS_DATA (rhs)->attr.pointer
12035 : 97 : && !CLASS_DATA (rhs)->attr.allocatable))
12036 : 2320 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
12037 : : else
12038 : 313 : vec_safe_push (args, tmp);
12039 : 2633 : tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
12040 : 2633 : ? gfc_class_data_get (lse->expr) : lse->expr;
12041 : 4772 : if (!POINTER_TYPE_P (TREE_TYPE (tmp))
12042 : 494 : || INDIRECT_REF_P (tmp)
12043 : 191 : || (lhs->ts.type == BT_DERIVED
12044 : 0 : && lhs->ts.u.derived->attr.unlimited_polymorphic
12045 : : && !lhs->ts.u.derived->attr.pointer
12046 : 0 : && !lhs->ts.u.derived->attr.allocatable)
12047 : 2824 : || (UNLIMITED_POLY (lhs)
12048 : : && !CLASS_DATA (lhs)->attr.pointer
12049 : 52 : && !CLASS_DATA (lhs)->attr.allocatable))
12050 : 2442 : vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
12051 : : else
12052 : 191 : vec_safe_push (args, tmp);
12053 : :
12054 : 2633 : stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
12055 : :
12056 : 2633 : if (to_len != NULL_TREE && !integer_zerop (from_len))
12057 : : {
12058 : 247 : tree extcopy;
12059 : 247 : vec_safe_push (args, from_len);
12060 : 247 : vec_safe_push (args, to_len);
12061 : 247 : extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
12062 : :
12063 : 247 : tmp = fold_build2_loc (input_location, GT_EXPR,
12064 : : logical_type_node, from_len,
12065 : 247 : build_zero_cst (TREE_TYPE (from_len)));
12066 : 247 : return fold_build3_loc (input_location, COND_EXPR,
12067 : : void_type_node, tmp,
12068 : 247 : extcopy, stdcopy);
12069 : : }
12070 : : else
12071 : 2386 : return stdcopy;
12072 : : }
12073 : : else
12074 : : {
12075 : 232 : tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
12076 : 232 : ? gfc_class_data_get (lse->expr) : lse->expr;
12077 : 232 : stmtblock_t tblock;
12078 : 232 : gfc_init_block (&tblock);
12079 : 232 : if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
12080 : 0 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
12081 : 232 : if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
12082 : 0 : rhst = gfc_build_addr_expr (NULL_TREE, rhst);
12083 : : /* When coming from a ptr_copy lhs and rhs are swapped. */
12084 : 232 : gfc_add_modify_loc (input_location, &tblock, rhst,
12085 : 232 : fold_convert (TREE_TYPE (rhst), tmp));
12086 : 232 : return gfc_finish_block (&tblock);
12087 : : }
12088 : : }
12089 : :
12090 : :
12091 : : /* Subroutine of gfc_trans_assignment that actually scalarizes the
12092 : : assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
12093 : : init_flag indicates initialization expressions and dealloc that no
12094 : : deallocate prior assignment is needed (if in doubt, set true).
12095 : : When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
12096 : : routine instead of a pointer assignment. Alias resolution is only done,
12097 : : when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
12098 : : where it is known, that newly allocated memory on the lhs can never be
12099 : : an alias of the rhs. */
12100 : :
12101 : : static tree
12102 : 191173 : gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
12103 : : bool dealloc, bool use_vptr_copy, bool may_alias)
12104 : : {
12105 : 191173 : gfc_se lse;
12106 : 191173 : gfc_se rse;
12107 : 191173 : gfc_ss *lss;
12108 : 191173 : gfc_ss *lss_section;
12109 : 191173 : gfc_ss *rss;
12110 : 191173 : gfc_loopinfo loop;
12111 : 191173 : tree tmp;
12112 : 191173 : stmtblock_t block;
12113 : 191173 : stmtblock_t body;
12114 : 191173 : bool final_expr;
12115 : 191173 : bool l_is_temp;
12116 : 191173 : bool scalar_to_array;
12117 : 191173 : tree string_length;
12118 : 191173 : int n;
12119 : 191173 : bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
12120 : 191173 : symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
12121 : 191173 : bool is_poly_assign;
12122 : 191173 : bool realloc_flag;
12123 : :
12124 : : /* Assignment of the form lhs = rhs. */
12125 : 191173 : gfc_start_block (&block);
12126 : :
12127 : 191173 : gfc_init_se (&lse, NULL);
12128 : 191173 : gfc_init_se (&rse, NULL);
12129 : :
12130 : : /* Walk the lhs. */
12131 : 191173 : lss = gfc_walk_expr (expr1);
12132 : 191173 : if (gfc_is_reallocatable_lhs (expr1))
12133 : : {
12134 : 7830 : lss->no_bounds_check = 1;
12135 : 7830 : if (!(expr2->expr_type == EXPR_FUNCTION
12136 : 665 : && expr2->value.function.isym != NULL
12137 : 407 : && !(expr2->value.function.isym->elemental
12138 : : || expr2->value.function.isym->conversion)))
12139 : 7708 : lss->is_alloc_lhs = 1;
12140 : : }
12141 : : else
12142 : 183343 : lss->no_bounds_check = expr1->no_bounds_check;
12143 : :
12144 : 191173 : rss = NULL;
12145 : :
12146 : 191173 : if (expr2->expr_type != EXPR_VARIABLE
12147 : 191173 : && expr2->expr_type != EXPR_CONSTANT
12148 : 191173 : && (expr2->ts.type == BT_CLASS || gfc_may_be_finalized (expr2->ts)))
12149 : : {
12150 : 508 : expr2->must_finalize = 1;
12151 : : /* F2008 4.5.6.3 para 5: If an executable construct references a
12152 : : structure constructor or array constructor, the entity created by
12153 : : the constructor is finalized after execution of the innermost
12154 : : executable construct containing the reference.
12155 : : These finalizations were later deleted by the Combined Techical
12156 : : Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */
12157 : 508 : if (gfc_notification_std (GFC_STD_F2018_DEL)
12158 : 508 : && (expr2->expr_type == EXPR_STRUCTURE
12159 : 465 : || expr2->expr_type == EXPR_ARRAY))
12160 : 160 : expr2->must_finalize = 0;
12161 : : }
12162 : :
12163 : :
12164 : : /* Checking whether a class assignment is desired is quite complicated and
12165 : : needed at two locations, so do it once only before the information is
12166 : : needed. */
12167 : 191173 : lhs_attr = gfc_expr_attr (expr1);
12168 : :
12169 : 177370 : is_poly_assign = (use_vptr_copy || lhs_attr.pointer
12170 : 174367 : || (lhs_attr.allocatable && !lhs_attr.dimension))
12171 : 19939 : && (expr1->ts.type == BT_CLASS
12172 : 19356 : || gfc_is_class_array_ref (expr1, NULL)
12173 : 18274 : || gfc_is_class_scalar_expr (expr1)
12174 : 17049 : || gfc_is_class_array_ref (expr2, NULL)
12175 : 17049 : || gfc_is_class_scalar_expr (expr2))
12176 : 194081 : && lhs_attr.flavor != FL_PROCEDURE;
12177 : :
12178 : 382346 : realloc_flag = flag_realloc_lhs
12179 : 185756 : && gfc_is_reallocatable_lhs (expr1)
12180 : 4794 : && expr2->rank
12181 : 194168 : && !is_runtime_conformable (expr1, expr2);
12182 : :
12183 : : /* Only analyze the expressions for coarray properties, when in coarray-lib
12184 : : mode. Avoid false-positive uninitialized diagnostics with initializing
12185 : : the codimension flag unconditionally. */
12186 : 191173 : lhs_caf_attr.codimension = false;
12187 : 191173 : rhs_caf_attr.codimension = false;
12188 : 191173 : if (flag_coarray == GFC_FCOARRAY_LIB)
12189 : : {
12190 : 2202 : lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
12191 : 2202 : rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
12192 : : }
12193 : :
12194 : 191173 : if (lss != gfc_ss_terminator)
12195 : : {
12196 : : /* The assignment needs scalarization. */
12197 : : lss_section = lss;
12198 : :
12199 : : /* Find a non-scalar SS from the lhs. */
12200 : : while (lss_section != gfc_ss_terminator
12201 : 33352 : && lss_section->info->type != GFC_SS_SECTION)
12202 : 0 : lss_section = lss_section->next;
12203 : :
12204 : 33352 : gcc_assert (lss_section != gfc_ss_terminator);
12205 : :
12206 : : /* Initialize the scalarizer. */
12207 : 33352 : gfc_init_loopinfo (&loop);
12208 : :
12209 : : /* Walk the rhs. */
12210 : 33352 : rss = gfc_walk_expr (expr2);
12211 : 33352 : if (rss == gfc_ss_terminator)
12212 : : /* The rhs is scalar. Add a ss for the expression. */
12213 : 14469 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
12214 : : /* When doing a class assign, then the handle to the rhs needs to be a
12215 : : pointer to allow for polymorphism. */
12216 : 33352 : if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
12217 : 460 : rss->info->type = GFC_SS_REFERENCE;
12218 : :
12219 : 33352 : rss->no_bounds_check = expr2->no_bounds_check;
12220 : : /* Associate the SS with the loop. */
12221 : 33352 : gfc_add_ss_to_loop (&loop, lss);
12222 : 33352 : gfc_add_ss_to_loop (&loop, rss);
12223 : :
12224 : : /* Calculate the bounds of the scalarization. */
12225 : 33352 : gfc_conv_ss_startstride (&loop);
12226 : : /* Enable loop reversal. */
12227 : 566984 : for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
12228 : 500280 : loop.reverse[n] = GFC_ENABLE_REVERSE;
12229 : : /* Resolve any data dependencies in the statement. */
12230 : 33352 : if (may_alias)
12231 : 31288 : gfc_conv_resolve_dependencies (&loop, lss, rss);
12232 : : /* Setup the scalarizing loops. */
12233 : 33352 : gfc_conv_loop_setup (&loop, &expr2->where);
12234 : :
12235 : : /* Setup the gfc_se structures. */
12236 : 33352 : gfc_copy_loopinfo_to_se (&lse, &loop);
12237 : 33352 : gfc_copy_loopinfo_to_se (&rse, &loop);
12238 : :
12239 : 33352 : rse.ss = rss;
12240 : 33352 : gfc_mark_ss_chain_used (rss, 1);
12241 : 33352 : if (loop.temp_ss == NULL)
12242 : : {
12243 : 32556 : lse.ss = lss;
12244 : 32556 : gfc_mark_ss_chain_used (lss, 1);
12245 : : }
12246 : : else
12247 : : {
12248 : 796 : lse.ss = loop.temp_ss;
12249 : 796 : gfc_mark_ss_chain_used (lss, 3);
12250 : 796 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
12251 : : }
12252 : :
12253 : : /* Allow the scalarizer to workshare array assignments. */
12254 : 33352 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
12255 : : == OMPWS_WORKSHARE_FLAG
12256 : 85 : && loop.temp_ss == NULL)
12257 : : {
12258 : 73 : maybe_workshare = true;
12259 : 73 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
12260 : : }
12261 : :
12262 : : /* Start the scalarized loop body. */
12263 : 33352 : gfc_start_scalarized_body (&loop, &body);
12264 : : }
12265 : : else
12266 : 157821 : gfc_init_block (&body);
12267 : :
12268 : 191173 : l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
12269 : :
12270 : : /* Translate the expression. */
12271 : 2202 : rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
12272 : 191399 : && lhs_caf_attr.codimension;
12273 : 191173 : gfc_conv_expr (&rse, expr2);
12274 : :
12275 : : /* Deal with the case of a scalar class function assigned to a derived type. */
12276 : 191173 : if (gfc_is_alloc_class_scalar_function (expr2)
12277 : 191173 : && expr1->ts.type == BT_DERIVED)
12278 : : {
12279 : 60 : rse.expr = gfc_class_data_get (rse.expr);
12280 : 60 : rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
12281 : : }
12282 : :
12283 : : /* Stabilize a string length for temporaries. */
12284 : 191173 : if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
12285 : 22635 : && !(VAR_P (rse.string_length)
12286 : : || TREE_CODE (rse.string_length) == PARM_DECL
12287 : : || INDIRECT_REF_P (rse.string_length)))
12288 : 21972 : string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
12289 : 169201 : else if (expr2->ts.type == BT_CHARACTER)
12290 : : {
12291 : 3297 : if (expr1->ts.deferred
12292 : 5156 : && gfc_expr_attr (expr1).allocatable
12293 : 5222 : && gfc_check_dependency (expr1, expr2, true))
12294 : 66 : rse.string_length =
12295 : 66 : gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
12296 : 3297 : string_length = rse.string_length;
12297 : : }
12298 : : else
12299 : : string_length = NULL_TREE;
12300 : :
12301 : 191173 : if (l_is_temp)
12302 : : {
12303 : 796 : gfc_conv_tmp_array_ref (&lse);
12304 : 796 : if (expr2->ts.type == BT_CHARACTER)
12305 : 93 : lse.string_length = string_length;
12306 : : }
12307 : : else
12308 : : {
12309 : 190377 : gfc_conv_expr (&lse, expr1);
12310 : 190377 : if (gfc_option.rtcheck & GFC_RTCHECK_MEM
12311 : 6185 : && !init_flag
12312 : 190389 : && gfc_expr_attr (expr1).allocatable
12313 : 54 : && expr1->rank
12314 : 190431 : && !expr2->rank)
12315 : : {
12316 : 42 : tree cond;
12317 : 42 : const char* msg;
12318 : :
12319 : 84 : tmp = INDIRECT_REF_P (lse.expr)
12320 : 42 : ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
12321 : 42 : STRIP_NOPS (tmp);
12322 : :
12323 : : /* We should only get array references here. */
12324 : 42 : gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
12325 : : || TREE_CODE (tmp) == ARRAY_REF);
12326 : :
12327 : : /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
12328 : : or the array itself(ARRAY_REF). */
12329 : 42 : tmp = TREE_OPERAND (tmp, 0);
12330 : :
12331 : : /* Provide the address of the array. */
12332 : 42 : if (TREE_CODE (lse.expr) == ARRAY_REF)
12333 : 24 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
12334 : :
12335 : 42 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
12336 : 42 : tmp, build_int_cst (TREE_TYPE (tmp), 0));
12337 : 42 : msg = _("Assignment of scalar to unallocated array");
12338 : 42 : gfc_trans_runtime_check (true, false, cond, &loop.pre,
12339 : : &expr1->where, msg);
12340 : : }
12341 : :
12342 : : /* Deallocate the lhs parameterized components if required. */
12343 : 190377 : if (dealloc && expr2->expr_type == EXPR_FUNCTION
12344 : 28118 : && !expr1->symtree->n.sym->attr.associate_var)
12345 : : {
12346 : 28035 : if (expr1->ts.type == BT_DERIVED
12347 : 1818 : && expr1->ts.u.derived
12348 : 1818 : && expr1->ts.u.derived->attr.pdt_type)
12349 : : {
12350 : 12 : tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
12351 : : expr1->rank);
12352 : 12 : gfc_add_expr_to_block (&lse.pre, tmp);
12353 : : }
12354 : 28023 : else if (expr1->ts.type == BT_CLASS
12355 : 229 : && CLASS_DATA (expr1)->ts.u.derived
12356 : 229 : && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
12357 : : {
12358 : 0 : tmp = gfc_class_data_get (lse.expr);
12359 : 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
12360 : : tmp, expr1->rank);
12361 : 0 : gfc_add_expr_to_block (&lse.pre, tmp);
12362 : : }
12363 : : }
12364 : : }
12365 : :
12366 : : /* Assignments of scalar derived types with allocatable components
12367 : : to arrays must be done with a deep copy and the rhs temporary
12368 : : must have its components deallocated afterwards. */
12369 : 382346 : scalar_to_array = (expr2->ts.type == BT_DERIVED
12370 : 15783 : && expr2->ts.u.derived->attr.alloc_comp
12371 : 4801 : && !gfc_expr_is_variable (expr2)
12372 : 193643 : && expr1->rank && !expr2->rank);
12373 : 382346 : scalar_to_array |= (expr1->ts.type == BT_DERIVED
12374 : 16067 : && expr1->rank
12375 : 2951 : && expr1->ts.u.derived->attr.alloc_comp
12376 : 192165 : && gfc_is_alloc_class_scalar_function (expr2));
12377 : 191173 : if (scalar_to_array && dealloc)
12378 : : {
12379 : 24 : tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
12380 : 24 : gfc_prepend_expr_to_block (&loop.post, tmp);
12381 : : }
12382 : :
12383 : : /* When assigning a character function result to a deferred-length variable,
12384 : : the function call must happen before the (re)allocation of the lhs -
12385 : : otherwise the character length of the result is not known.
12386 : : NOTE 1: This relies on having the exact dependence of the length type
12387 : : parameter available to the caller; gfortran saves it in the .mod files.
12388 : : NOTE 2: Vector array references generate an index temporary that must
12389 : : not go outside the loop. Otherwise, variables should not generate
12390 : : a pre block.
12391 : : NOTE 3: The concatenation operation generates a temporary pointer,
12392 : : whose allocation must go to the innermost loop.
12393 : : NOTE 4: Elemental functions may generate a temporary, too. */
12394 : 191173 : if (flag_realloc_lhs
12395 : 185756 : && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
12396 : 2198 : && !(lss != gfc_ss_terminator
12397 : 537 : && rss != gfc_ss_terminator
12398 : 537 : && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
12399 : 418 : || (expr2->expr_type == EXPR_FUNCTION
12400 : 88 : && expr2->value.function.esym != NULL
12401 : 26 : && expr2->value.function.esym->attr.elemental)
12402 : 405 : || (expr2->expr_type == EXPR_FUNCTION
12403 : 75 : && expr2->value.function.isym != NULL
12404 : 62 : && expr2->value.function.isym->elemental)
12405 : 385 : || (expr2->expr_type == EXPR_OP
12406 : 31 : && expr2->value.op.op == INTRINSIC_CONCAT))))
12407 : 2021 : gfc_add_block_to_block (&block, &rse.pre);
12408 : :
12409 : : /* Nullify the allocatable components corresponding to those of the lhs
12410 : : derived type, so that the finalization of the function result does not
12411 : : affect the lhs of the assignment. Prepend is used to ensure that the
12412 : : nullification occurs before the call to the finalizer. In the case of
12413 : : a scalar to array assignment, this is done in gfc_trans_scalar_assign
12414 : : as part of the deep copy. */
12415 : 190644 : if (!scalar_to_array && expr1->ts.type == BT_DERIVED
12416 : 206711 : && (gfc_is_class_array_function (expr2)
12417 : 15514 : || gfc_is_alloc_class_scalar_function (expr2)))
12418 : : {
12419 : 78 : tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
12420 : 78 : gfc_prepend_expr_to_block (&rse.post, tmp);
12421 : 78 : if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
12422 : 0 : gfc_add_block_to_block (&loop.post, &rse.post);
12423 : : }
12424 : :
12425 : 191173 : tmp = NULL_TREE;
12426 : :
12427 : 191173 : if (is_poly_assign)
12428 : : {
12429 : 2865 : tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
12430 : 2865 : use_vptr_copy || (lhs_attr.allocatable
12431 : 441 : && !lhs_attr.dimension),
12432 : 2772 : !realloc_flag && flag_realloc_lhs
12433 : 3306 : && !lhs_attr.pointer);
12434 : 2865 : if (expr2->expr_type == EXPR_FUNCTION
12435 : 170 : && expr2->ts.type == BT_DERIVED
12436 : 30 : && expr2->ts.u.derived->attr.alloc_comp)
12437 : : {
12438 : 18 : tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
12439 : : rse.expr, expr2->rank);
12440 : 18 : if (lss == gfc_ss_terminator)
12441 : 18 : gfc_add_expr_to_block (&rse.post, tmp2);
12442 : : else
12443 : 0 : gfc_add_expr_to_block (&loop.post, tmp2);
12444 : : }
12445 : :
12446 : 2865 : expr1->must_finalize = 0;
12447 : : }
12448 : 188308 : else if (flag_coarray == GFC_FCOARRAY_LIB
12449 : 2190 : && lhs_caf_attr.codimension && rhs_caf_attr.codimension
12450 : 26 : && ((lhs_caf_attr.allocatable && lhs_refs_comp)
12451 : 20 : || (rhs_caf_attr.allocatable && rhs_refs_comp)))
12452 : : {
12453 : : /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
12454 : : allocatable component, because those need to be accessed via the
12455 : : caf-runtime. No need to check for coindexes here, because resolve
12456 : : has rewritten those already. */
12457 : 6 : gfc_code code;
12458 : 6 : gfc_actual_arglist a1, a2;
12459 : : /* Clear the structures to prevent accessing garbage. */
12460 : 6 : memset (&code, '\0', sizeof (gfc_code));
12461 : 6 : memset (&a1, '\0', sizeof (gfc_actual_arglist));
12462 : 6 : memset (&a2, '\0', sizeof (gfc_actual_arglist));
12463 : 6 : a1.expr = expr1;
12464 : 6 : a1.next = &a2;
12465 : 6 : a2.expr = expr2;
12466 : 6 : a2.next = NULL;
12467 : 6 : code.ext.actual = &a1;
12468 : 6 : code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
12469 : 6 : tmp = gfc_conv_intrinsic_subroutine (&code);
12470 : 6 : }
12471 : 188302 : else if (!is_poly_assign && expr2->must_finalize
12472 : 281 : && expr1->ts.type == BT_CLASS
12473 : 84 : && expr2->ts.type == BT_CLASS)
12474 : : {
12475 : : /* This case comes about when the scalarizer provides array element
12476 : : references. Use the vptr copy function, since this does a deep
12477 : : copy of allocatable components, without which the finalizer call
12478 : : will deallocate the components. */
12479 : 78 : tmp = gfc_get_vptr_from_expr (rse.expr);
12480 : 78 : if (tmp != NULL_TREE)
12481 : : {
12482 : 72 : tree fcn = gfc_vptr_copy_get (tmp);
12483 : 72 : if (POINTER_TYPE_P (TREE_TYPE (fcn)))
12484 : 72 : fcn = build_fold_indirect_ref_loc (input_location, fcn);
12485 : 72 : tmp = build_call_expr_loc (input_location,
12486 : : fcn, 2,
12487 : : gfc_build_addr_expr (NULL, rse.expr),
12488 : : gfc_build_addr_expr (NULL, lse.expr));
12489 : : }
12490 : : }
12491 : :
12492 : : /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
12493 : : after evaluation of the rhs and before reallocation. */
12494 : 191173 : final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
12495 : 191173 : if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
12496 : 139 : && expr2->symtree->n.sym->attr.artificial))
12497 : : {
12498 : 442 : if (lss == gfc_ss_terminator)
12499 : : {
12500 : 152 : gfc_add_block_to_block (&block, &rse.pre);
12501 : 152 : gfc_add_block_to_block (&block, &lse.finalblock);
12502 : : }
12503 : : else
12504 : : {
12505 : 290 : gfc_add_block_to_block (&body, &rse.pre);
12506 : 290 : gfc_add_block_to_block (&loop.code[expr1->rank - 1],
12507 : : &lse.finalblock);
12508 : : }
12509 : : }
12510 : : else
12511 : 190731 : gfc_add_block_to_block (&body, &rse.pre);
12512 : :
12513 : : /* If nothing else works, do it the old fashioned way! */
12514 : 191173 : if (tmp == NULL_TREE)
12515 : 188230 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
12516 : 188230 : gfc_expr_is_variable (expr2)
12517 : 161956 : || scalar_to_array
12518 : 349741 : || expr2->expr_type == EXPR_ARRAY,
12519 : 188230 : !(l_is_temp || init_flag) && dealloc,
12520 : 188230 : expr1->symtree->n.sym->attr.codimension);
12521 : :
12522 : :
12523 : : /* Add the lse pre block to the body */
12524 : 191173 : gfc_add_block_to_block (&body, &lse.pre);
12525 : 191173 : gfc_add_expr_to_block (&body, tmp);
12526 : :
12527 : : /* Add the post blocks to the body. Scalar finalization must appear before
12528 : : the post block in case any dellocations are done. */
12529 : 191173 : if (rse.finalblock.head
12530 : 191173 : && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
12531 : 14 : && gfc_expr_attr (expr2).elemental)))
12532 : : {
12533 : 110 : gfc_add_block_to_block (&body, &rse.finalblock);
12534 : 110 : gfc_add_block_to_block (&body, &rse.post);
12535 : : }
12536 : : else
12537 : 191063 : gfc_add_block_to_block (&body, &rse.post);
12538 : :
12539 : 191173 : gfc_add_block_to_block (&body, &lse.post);
12540 : :
12541 : 191173 : if (lss == gfc_ss_terminator)
12542 : : {
12543 : : /* F2003: Add the code for reallocation on assignment. */
12544 : 155343 : if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
12545 : 160825 : && !is_poly_assign)
12546 : 2986 : alloc_scalar_allocatable_for_assignment (&block, string_length,
12547 : : expr1, expr2);
12548 : :
12549 : : /* Use the scalar assignment as is. */
12550 : 157821 : gfc_add_block_to_block (&block, &body);
12551 : : }
12552 : : else
12553 : : {
12554 : 33352 : gcc_assert (lse.ss == gfc_ss_terminator
12555 : : && rse.ss == gfc_ss_terminator);
12556 : :
12557 : 33352 : if (l_is_temp)
12558 : : {
12559 : 796 : gfc_trans_scalarized_loop_boundary (&loop, &body);
12560 : :
12561 : : /* We need to copy the temporary to the actual lhs. */
12562 : 796 : gfc_init_se (&lse, NULL);
12563 : 796 : gfc_init_se (&rse, NULL);
12564 : 796 : gfc_copy_loopinfo_to_se (&lse, &loop);
12565 : 796 : gfc_copy_loopinfo_to_se (&rse, &loop);
12566 : :
12567 : 796 : rse.ss = loop.temp_ss;
12568 : 796 : lse.ss = lss;
12569 : :
12570 : 796 : gfc_conv_tmp_array_ref (&rse);
12571 : 796 : gfc_conv_expr (&lse, expr1);
12572 : :
12573 : 796 : gcc_assert (lse.ss == gfc_ss_terminator
12574 : : && rse.ss == gfc_ss_terminator);
12575 : :
12576 : 796 : if (expr2->ts.type == BT_CHARACTER)
12577 : 93 : rse.string_length = string_length;
12578 : :
12579 : 796 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
12580 : : false, dealloc);
12581 : 796 : gfc_add_expr_to_block (&body, tmp);
12582 : : }
12583 : :
12584 : : /* F2003: Allocate or reallocate lhs of allocatable array. */
12585 : 33352 : if (realloc_flag)
12586 : : {
12587 : 2812 : realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
12588 : 2812 : ompws_flags &= ~OMPWS_SCALARIZER_WS;
12589 : 2812 : tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
12590 : 2812 : if (tmp != NULL_TREE)
12591 : 2812 : gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
12592 : : }
12593 : :
12594 : 33352 : if (maybe_workshare)
12595 : 73 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
12596 : :
12597 : : /* Generate the copying loops. */
12598 : 33352 : gfc_trans_scalarizing_loops (&loop, &body);
12599 : :
12600 : : /* Wrap the whole thing up. */
12601 : 33352 : gfc_add_block_to_block (&block, &loop.pre);
12602 : 33352 : gfc_add_block_to_block (&block, &loop.post);
12603 : :
12604 : 33352 : gfc_cleanup_loop (&loop);
12605 : : }
12606 : :
12607 : 191173 : return gfc_finish_block (&block);
12608 : : }
12609 : :
12610 : :
12611 : : /* Check whether EXPR is a copyable array. */
12612 : :
12613 : : static bool
12614 : 614240 : copyable_array_p (gfc_expr * expr)
12615 : : {
12616 : 614240 : if (expr->expr_type != EXPR_VARIABLE)
12617 : : return false;
12618 : :
12619 : : /* First check it's an array. */
12620 : 594051 : if (expr->rank < 1 || !expr->ref || expr->ref->next)
12621 : : return false;
12622 : :
12623 : 119390 : if (!gfc_full_array_ref_p (expr->ref, NULL))
12624 : : return false;
12625 : :
12626 : : /* Next check that it's of a simple enough type. */
12627 : 94530 : switch (expr->ts.type)
12628 : : {
12629 : : case BT_INTEGER:
12630 : : case BT_REAL:
12631 : : case BT_COMPLEX:
12632 : : case BT_LOGICAL:
12633 : : return true;
12634 : :
12635 : : case BT_CHARACTER:
12636 : : return false;
12637 : :
12638 : 4974 : case_bt_struct:
12639 : 4974 : return !expr->ts.u.derived->attr.alloc_comp;
12640 : :
12641 : : default:
12642 : : break;
12643 : : }
12644 : :
12645 : : return false;
12646 : : }
12647 : :
12648 : : /* Translate an assignment. */
12649 : :
12650 : : tree
12651 : 203248 : gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
12652 : : bool dealloc, bool use_vptr_copy, bool may_alias)
12653 : : {
12654 : 203248 : tree tmp;
12655 : :
12656 : : /* Special case a single function returning an array. */
12657 : 203248 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
12658 : : {
12659 : 7736 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
12660 : 7736 : if (tmp)
12661 : : return tmp;
12662 : : }
12663 : :
12664 : : /* Special case assigning an array to zero. */
12665 : 198882 : if (copyable_array_p (expr1)
12666 : 198882 : && is_zero_initializer_p (expr2))
12667 : : {
12668 : 3701 : tmp = gfc_trans_zero_assign (expr1);
12669 : 3701 : if (tmp)
12670 : : return tmp;
12671 : : }
12672 : :
12673 : : /* Special case copying one array to another. */
12674 : 196542 : if (copyable_array_p (expr1)
12675 : 23135 : && copyable_array_p (expr2)
12676 : 1815 : && gfc_compare_types (&expr1->ts, &expr2->ts)
12677 : 198357 : && !gfc_check_dependency (expr1, expr2, 0))
12678 : : {
12679 : 1732 : tmp = gfc_trans_array_copy (expr1, expr2);
12680 : 1732 : if (tmp)
12681 : : return tmp;
12682 : : }
12683 : :
12684 : : /* Special case initializing an array from a constant array constructor. */
12685 : 195681 : if (copyable_array_p (expr1)
12686 : 22274 : && expr2->expr_type == EXPR_ARRAY
12687 : 203507 : && gfc_compare_types (&expr1->ts, &expr2->ts))
12688 : : {
12689 : 7826 : tmp = gfc_trans_array_constructor_copy (expr1, expr2);
12690 : 7826 : if (tmp)
12691 : : return tmp;
12692 : : }
12693 : :
12694 : 191173 : if (UNLIMITED_POLY (expr1) && expr1->rank)
12695 : 191173 : use_vptr_copy = true;
12696 : :
12697 : : /* Fallback to the scalarizer to generate explicit loops. */
12698 : 191173 : return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
12699 : 191173 : use_vptr_copy, may_alias);
12700 : : }
12701 : :
12702 : : tree
12703 : 10489 : gfc_trans_init_assign (gfc_code * code)
12704 : : {
12705 : 10489 : return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
12706 : : }
12707 : :
12708 : : tree
12709 : 185264 : gfc_trans_assign (gfc_code * code)
12710 : : {
12711 : 185264 : return gfc_trans_assignment (code->expr1, code->expr2, false, true);
12712 : : }
12713 : :
12714 : : /* Generate a simple loop for internal use of the form
12715 : : for (var = begin; var <cond> end; var += step)
12716 : : body; */
12717 : : void
12718 : 12072 : gfc_simple_for_loop (stmtblock_t *block, tree var, tree begin, tree end,
12719 : : enum tree_code cond, tree step, tree body)
12720 : : {
12721 : 12072 : tree tmp;
12722 : :
12723 : : /* var = begin. */
12724 : 12072 : gfc_add_modify (block, var, begin);
12725 : :
12726 : : /* Loop: for (var = begin; var <cond> end; var += step). */
12727 : 12072 : tree label_loop = gfc_build_label_decl (NULL_TREE);
12728 : 12072 : tree label_cond = gfc_build_label_decl (NULL_TREE);
12729 : 12072 : TREE_USED (label_loop) = 1;
12730 : 12072 : TREE_USED (label_cond) = 1;
12731 : :
12732 : 12072 : gfc_add_expr_to_block (block, build1_v (GOTO_EXPR, label_cond));
12733 : 12072 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_loop));
12734 : :
12735 : : /* Loop body. */
12736 : 12072 : gfc_add_expr_to_block (block, body);
12737 : :
12738 : : /* End of loop body. */
12739 : 12072 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, step);
12740 : 12072 : gfc_add_modify (block, var, tmp);
12741 : 12072 : gfc_add_expr_to_block (block, build1_v (LABEL_EXPR, label_cond));
12742 : 12072 : tmp = fold_build2_loc (input_location, cond, boolean_type_node, var, end);
12743 : 12072 : tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
12744 : : build_empty_stmt (input_location));
12745 : 12072 : gfc_add_expr_to_block (block, tmp);
12746 : 12072 : }
|
