1 /* Expression translation
2 Copyright (C) 2002-2021 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.c-- 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
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
46 arrays. */
47
48 static tree
get_scalar_to_descriptor_type(tree scalar,symbol_attribute attr)49 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
50 {
51 enum gfc_array_kind akind;
52
53 if (attr.pointer)
54 akind = GFC_ARRAY_POINTER_CONT;
55 else if (attr.allocatable)
56 akind = GFC_ARRAY_ALLOCATABLE;
57 else
58 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
59
60 if (POINTER_TYPE_P (TREE_TYPE (scalar)))
61 scalar = TREE_TYPE (scalar);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
63 akind, !(attr.pointer || attr.target));
64 }
65
66 tree
gfc_conv_scalar_to_descriptor(gfc_se * se,tree scalar,symbol_attribute attr)67 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
68 {
69 tree desc, type, etype;
70
71 type = get_scalar_to_descriptor_type (scalar, attr);
72 etype = TREE_TYPE (scalar);
73 desc = gfc_create_var (type, "desc");
74 DECL_ARTIFICIAL (desc) = 1;
75
76 if (CONSTANT_CLASS_P (scalar))
77 {
78 tree tmp;
79 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
80 gfc_add_modify (&se->pre, tmp, scalar);
81 scalar = tmp;
82 }
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
84 scalar = gfc_build_addr_expr (NULL_TREE, scalar);
85 else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
86 etype = TREE_TYPE (etype);
87 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
88 gfc_get_dtype_rank_type (0, etype));
89 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
90
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
94 gfc_add_modify (&se->post, scalar,
95 fold_convert (TREE_TYPE (scalar),
96 gfc_conv_descriptor_data_get (desc)));
97 return desc;
98 }
99
100
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
103
104 tree
gfc_get_ultimate_alloc_ptr_comps_caf_token(gfc_se * outerse,gfc_expr * expr)105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
106 {
107 gfc_symbol *sym = expr->symtree->n.sym;
108 bool is_coarray = sym->attr.codimension;
109 gfc_expr *caf_expr = gfc_copy_expr (expr);
110 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
111
112 while (ref)
113 {
114 if (ref->type == REF_COMPONENT
115 && (ref->u.c.component->attr.allocatable
116 || ref->u.c.component->attr.pointer)
117 && (is_coarray || ref->u.c.component->attr.codimension))
118 last_caf_ref = ref;
119 ref = ref->next;
120 }
121
122 if (last_caf_ref == NULL)
123 return NULL_TREE;
124
125 tree comp = last_caf_ref->u.c.component->caf_token, caf;
126 gfc_se se;
127 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
128 if (comp == NULL_TREE && comp_ref)
129 return NULL_TREE;
130 gfc_init_se (&se, outerse);
131 gfc_free_ref_list (last_caf_ref->next);
132 last_caf_ref->next = NULL;
133 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
134 se.want_pointer = comp_ref;
135 gfc_conv_expr (&se, caf_expr);
136 gfc_add_block_to_block (&outerse->pre, &se.pre);
137
138 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
139 se.expr = TREE_OPERAND (se.expr, 0);
140 gfc_free_expr (caf_expr);
141
142 if (comp_ref)
143 caf = fold_build3_loc (input_location, COMPONENT_REF,
144 TREE_TYPE (comp), se.expr, comp, NULL_TREE);
145 else
146 caf = gfc_conv_descriptor_token (se.expr);
147 return gfc_build_addr_expr (NULL_TREE, caf);
148 }
149
150
151 /* This is the seed for an eventual trans-class.c
152
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
165
166
167 tree
gfc_class_set_static_fields(tree decl,tree vptr,tree data)168 gfc_class_set_static_fields (tree decl, tree vptr, tree data)
169 {
170 tree tmp;
171 tree field;
172 vec<constructor_elt, va_gc> *init = NULL;
173
174 field = TYPE_FIELDS (TREE_TYPE (decl));
175 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
176 CONSTRUCTOR_APPEND_ELT (init, tmp, data);
177
178 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
179 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
180
181 return build_constructor (TREE_TYPE (decl), init);
182 }
183
184
185 tree
gfc_class_data_get(tree decl)186 gfc_class_data_get (tree decl)
187 {
188 tree data;
189 if (POINTER_TYPE_P (TREE_TYPE (decl)))
190 decl = build_fold_indirect_ref_loc (input_location, decl);
191 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
192 CLASS_DATA_FIELD);
193 return fold_build3_loc (input_location, COMPONENT_REF,
194 TREE_TYPE (data), decl, data,
195 NULL_TREE);
196 }
197
198
199 tree
gfc_class_vptr_get(tree decl)200 gfc_class_vptr_get (tree decl)
201 {
202 tree vptr;
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl))
207 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
208 if (POINTER_TYPE_P (TREE_TYPE (decl)))
209 decl = build_fold_indirect_ref_loc (input_location, decl);
210 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
211 CLASS_VPTR_FIELD);
212 return fold_build3_loc (input_location, COMPONENT_REF,
213 TREE_TYPE (vptr), decl, vptr,
214 NULL_TREE);
215 }
216
217
218 tree
gfc_class_len_get(tree decl)219 gfc_class_len_get (tree decl)
220 {
221 tree len;
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl))
226 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
227 if (POINTER_TYPE_P (TREE_TYPE (decl)))
228 decl = build_fold_indirect_ref_loc (input_location, decl);
229 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
230 CLASS_LEN_FIELD);
231 return fold_build3_loc (input_location, COMPONENT_REF,
232 TREE_TYPE (len), decl, len,
233 NULL_TREE);
234 }
235
236
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
239
240 tree
gfc_class_len_or_zero_get(tree decl)241 gfc_class_len_or_zero_get (tree decl)
242 {
243 tree len;
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl))
248 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
249 if (POINTER_TYPE_P (TREE_TYPE (decl)))
250 decl = build_fold_indirect_ref_loc (input_location, decl);
251 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
252 CLASS_LEN_FIELD);
253 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
254 TREE_TYPE (len), decl, len,
255 NULL_TREE)
256 : build_zero_cst (gfc_charlen_type_node);
257 }
258
259
260 tree
gfc_resize_class_size_with_len(stmtblock_t * block,tree class_expr,tree size)261 gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
262 {
263 tree tmp;
264 tree tmp2;
265 tree type;
266
267 tmp = gfc_class_len_or_zero_get (class_expr);
268
269 /* Include the len value in the element size if present. */
270 if (!integer_zerop (tmp))
271 {
272 type = TREE_TYPE (size);
273 if (block)
274 {
275 size = gfc_evaluate_now (size, block);
276 tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
277 }
278 tmp2 = fold_build2_loc (input_location, MULT_EXPR,
279 type, size, tmp);
280 tmp = fold_build2_loc (input_location, GT_EXPR,
281 logical_type_node, tmp,
282 build_zero_cst (type));
283 size = fold_build3_loc (input_location, COND_EXPR,
284 type, tmp, tmp2, size);
285 }
286 else
287 return size;
288
289 if (block)
290 size = gfc_evaluate_now (size, block);
291
292 return size;
293 }
294
295
296 /* Get the specified FIELD from the VPTR. */
297
298 static tree
vptr_field_get(tree vptr,int fieldno)299 vptr_field_get (tree vptr, int fieldno)
300 {
301 tree field;
302 vptr = build_fold_indirect_ref_loc (input_location, vptr);
303 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
304 fieldno);
305 field = fold_build3_loc (input_location, COMPONENT_REF,
306 TREE_TYPE (field), vptr, field,
307 NULL_TREE);
308 gcc_assert (field);
309 return field;
310 }
311
312
313 /* Get the field from the class' vptr. */
314
315 static tree
class_vtab_field_get(tree decl,int fieldno)316 class_vtab_field_get (tree decl, int fieldno)
317 {
318 tree vptr;
319 vptr = gfc_class_vptr_get (decl);
320 return vptr_field_get (vptr, fieldno);
321 }
322
323
324 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
325 unison. */
326 #define VTAB_GET_FIELD_GEN(name, field) tree \
327 gfc_class_vtab_## name ##_get (tree cl) \
328 { \
329 return class_vtab_field_get (cl, field); \
330 } \
331 \
332 tree \
333 gfc_vptr_## name ##_get (tree vptr) \
334 { \
335 return vptr_field_get (vptr, field); \
336 }
337
VTAB_GET_FIELD_GEN(hash,VTABLE_HASH_FIELD)338 VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
339 VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
340 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
341 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
342 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
343 VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
344
345
346 /* The size field is returned as an array index type. Therefore treat
347 it and only it specially. */
348
349 tree
350 gfc_class_vtab_size_get (tree cl)
351 {
352 tree size;
353 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
354 /* Always return size as an array index type. */
355 size = fold_convert (gfc_array_index_type, size);
356 gcc_assert (size);
357 return size;
358 }
359
360 tree
gfc_vptr_size_get(tree vptr)361 gfc_vptr_size_get (tree vptr)
362 {
363 tree size;
364 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
365 /* Always return size as an array index type. */
366 size = fold_convert (gfc_array_index_type, size);
367 gcc_assert (size);
368 return size;
369 }
370
371
372 #undef CLASS_DATA_FIELD
373 #undef CLASS_VPTR_FIELD
374 #undef CLASS_LEN_FIELD
375 #undef VTABLE_HASH_FIELD
376 #undef VTABLE_SIZE_FIELD
377 #undef VTABLE_EXTENDS_FIELD
378 #undef VTABLE_DEF_INIT_FIELD
379 #undef VTABLE_COPY_FIELD
380 #undef VTABLE_FINAL_FIELD
381
382
383 /* IF ts is null (default), search for the last _class ref in the chain
384 of references of the expression and cut the chain there. Although
385 this routine is similiar to class.c:gfc_add_component_ref (), there
386 is a significant difference: gfc_add_component_ref () concentrates
387 on an array ref that is the last ref in the chain and is oblivious
388 to the kind of refs following.
389 ELSE IF ts is non-null the cut is at the class entity or component
390 that is followed by an array reference, which is not an element.
391 These calls come from trans-array.c:build_class_array_ref, which
392 handles scalarized class array references.*/
393
394 gfc_expr *
gfc_find_and_cut_at_last_class_ref(gfc_expr * e,bool is_mold,gfc_typespec ** ts)395 gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
396 gfc_typespec **ts)
397 {
398 gfc_expr *base_expr;
399 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
400
401 /* Find the last class reference. */
402 class_ref = NULL;
403 array_ref = NULL;
404
405 if (ts)
406 {
407 if (e->symtree
408 && e->symtree->n.sym->ts.type == BT_CLASS)
409 *ts = &e->symtree->n.sym->ts;
410 else
411 *ts = NULL;
412 }
413
414 for (ref = e->ref; ref; ref = ref->next)
415 {
416 if (ts)
417 {
418 if (ref->type == REF_COMPONENT
419 && ref->u.c.component->ts.type == BT_CLASS
420 && ref->next && ref->next->type == REF_COMPONENT
421 && !strcmp (ref->next->u.c.component->name, "_data")
422 && ref->next->next
423 && ref->next->next->type == REF_ARRAY
424 && ref->next->next->u.ar.type != AR_ELEMENT)
425 {
426 *ts = &ref->u.c.component->ts;
427 class_ref = ref;
428 break;
429 }
430
431 if (ref->next == NULL)
432 break;
433 }
434 else
435 {
436 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
437 array_ref = ref;
438
439 if (ref->type == REF_COMPONENT
440 && ref->u.c.component->ts.type == BT_CLASS)
441 {
442 /* Component to the right of a part reference with nonzero
443 rank must not have the ALLOCATABLE attribute. If attempts
444 are made to reference such a component reference, an error
445 results followed by an ICE. */
446 if (array_ref
447 && CLASS_DATA (ref->u.c.component)->attr.allocatable)
448 return NULL;
449 class_ref = ref;
450 }
451 }
452 }
453
454 if (ts && *ts == NULL)
455 return NULL;
456
457 /* Remove and store all subsequent references after the
458 CLASS reference. */
459 if (class_ref)
460 {
461 tail = class_ref->next;
462 class_ref->next = NULL;
463 }
464 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
465 {
466 tail = e->ref;
467 e->ref = NULL;
468 }
469
470 if (is_mold)
471 base_expr = gfc_expr_to_initialize (e);
472 else
473 base_expr = gfc_copy_expr (e);
474
475 /* Restore the original tail expression. */
476 if (class_ref)
477 {
478 gfc_free_ref_list (class_ref->next);
479 class_ref->next = tail;
480 }
481 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
482 {
483 gfc_free_ref_list (e->ref);
484 e->ref = tail;
485 }
486 return base_expr;
487 }
488
489
490 /* Reset the vptr to the declared type, e.g. after deallocation. */
491
492 void
gfc_reset_vptr(stmtblock_t * block,gfc_expr * e)493 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
494 {
495 gfc_symbol *vtab;
496 tree vptr;
497 tree vtable;
498 gfc_se se;
499
500 /* Evaluate the expression and obtain the vptr from it. */
501 gfc_init_se (&se, NULL);
502 if (e->rank)
503 gfc_conv_expr_descriptor (&se, e);
504 else
505 gfc_conv_expr (&se, e);
506 gfc_add_block_to_block (block, &se.pre);
507 vptr = gfc_get_vptr_from_expr (se.expr);
508
509 /* If a vptr is not found, we can do nothing more. */
510 if (vptr == NULL_TREE)
511 return;
512
513 if (UNLIMITED_POLY (e))
514 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
515 else
516 {
517 /* Return the vptr to the address of the declared type. */
518 vtab = gfc_find_derived_vtab (e->ts.u.derived);
519 vtable = vtab->backend_decl;
520 if (vtable == NULL_TREE)
521 vtable = gfc_get_symbol_decl (vtab);
522 vtable = gfc_build_addr_expr (NULL, vtable);
523 vtable = fold_convert (TREE_TYPE (vptr), vtable);
524 gfc_add_modify (block, vptr, vtable);
525 }
526 }
527
528
529 /* Reset the len for unlimited polymorphic objects. */
530
531 void
gfc_reset_len(stmtblock_t * block,gfc_expr * expr)532 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
533 {
534 gfc_expr *e;
535 gfc_se se_len;
536 e = gfc_find_and_cut_at_last_class_ref (expr);
537 if (e == NULL)
538 return;
539 gfc_add_len_component (e);
540 gfc_init_se (&se_len, NULL);
541 gfc_conv_expr (&se_len, e);
542 gfc_add_modify (block, se_len.expr,
543 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
544 gfc_free_expr (e);
545 }
546
547
548 /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
549 reference is found. Note that it is up to the caller to avoid using this
550 for expressions other than variables. */
551
552 tree
gfc_get_class_from_gfc_expr(gfc_expr * e)553 gfc_get_class_from_gfc_expr (gfc_expr *e)
554 {
555 gfc_expr *class_expr;
556 gfc_se cse;
557 class_expr = gfc_find_and_cut_at_last_class_ref (e);
558 if (class_expr == NULL)
559 return NULL_TREE;
560 gfc_init_se (&cse, NULL);
561 gfc_conv_expr (&cse, class_expr);
562 gfc_free_expr (class_expr);
563 return cse.expr;
564 }
565
566
567 /* Obtain the last class reference in an expression.
568 Return NULL_TREE if no class reference is found. */
569
570 tree
gfc_get_class_from_expr(tree expr)571 gfc_get_class_from_expr (tree expr)
572 {
573 tree tmp;
574 tree type;
575
576 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
577 {
578 if (CONSTANT_CLASS_P (tmp))
579 return NULL_TREE;
580
581 type = TREE_TYPE (tmp);
582 while (type)
583 {
584 if (GFC_CLASS_TYPE_P (type))
585 return tmp;
586 if (type != TYPE_CANONICAL (type))
587 type = TYPE_CANONICAL (type);
588 else
589 type = NULL_TREE;
590 }
591 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
592 break;
593 }
594
595 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
596 tmp = build_fold_indirect_ref_loc (input_location, tmp);
597
598 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
599 return tmp;
600
601 return NULL_TREE;
602 }
603
604
605 /* Obtain the vptr of the last class reference in an expression.
606 Return NULL_TREE if no class reference is found. */
607
608 tree
gfc_get_vptr_from_expr(tree expr)609 gfc_get_vptr_from_expr (tree expr)
610 {
611 tree tmp;
612
613 tmp = gfc_get_class_from_expr (expr);
614
615 if (tmp != NULL_TREE)
616 return gfc_class_vptr_get (tmp);
617
618 return NULL_TREE;
619 }
620
621
622 static void
class_array_data_assign(stmtblock_t * block,tree lhs_desc,tree rhs_desc,bool lhs_type)623 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
624 bool lhs_type)
625 {
626 tree tmp, tmp2, type;
627
628 gfc_conv_descriptor_data_set (block, lhs_desc,
629 gfc_conv_descriptor_data_get (rhs_desc));
630 gfc_conv_descriptor_offset_set (block, lhs_desc,
631 gfc_conv_descriptor_offset_get (rhs_desc));
632
633 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
634 gfc_conv_descriptor_dtype (rhs_desc));
635
636 /* Assign the dimension as range-ref. */
637 tmp = gfc_get_descriptor_dimension (lhs_desc);
638 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
639
640 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
641 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
642 gfc_index_zero_node, NULL_TREE, NULL_TREE);
643 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
644 gfc_index_zero_node, NULL_TREE, NULL_TREE);
645 gfc_add_modify (block, tmp, tmp2);
646 }
647
648
649 /* Takes a derived type expression and returns the address of a temporary
650 class object of the 'declared' type. If vptr is not NULL, this is
651 used for the temporary class object.
652 optional_alloc_ptr is false when the dummy is neither allocatable
653 nor a pointer; that's only relevant for the optional handling.
654 The optional argument 'derived_array' is used to preserve the parmse
655 expression for deallocation of allocatable components. Assumed rank
656 formal arguments made this necessary. */
657 void
gfc_conv_derived_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts,tree vptr,bool optional,bool optional_alloc_ptr,tree * derived_array)658 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
659 gfc_typespec class_ts, tree vptr, bool optional,
660 bool optional_alloc_ptr,
661 tree *derived_array)
662 {
663 gfc_symbol *vtab;
664 tree cond_optional = NULL_TREE;
665 gfc_ss *ss;
666 tree ctree;
667 tree var;
668 tree tmp;
669 int dim;
670
671 /* The derived type needs to be converted to a temporary
672 CLASS object. */
673 tmp = gfc_typenode_for_spec (&class_ts);
674 var = gfc_create_var (tmp, "class");
675
676 /* Set the vptr. */
677 ctree = gfc_class_vptr_get (var);
678
679 if (vptr != NULL_TREE)
680 {
681 /* Use the dynamic vptr. */
682 tmp = vptr;
683 }
684 else
685 {
686 /* In this case the vtab corresponds to the derived type and the
687 vptr must point to it. */
688 vtab = gfc_find_derived_vtab (e->ts.u.derived);
689 gcc_assert (vtab);
690 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
691 }
692 gfc_add_modify (&parmse->pre, ctree,
693 fold_convert (TREE_TYPE (ctree), tmp));
694
695 /* Now set the data field. */
696 ctree = gfc_class_data_get (var);
697
698 if (optional)
699 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
700
701 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
702 {
703 /* If there is a ready made pointer to a derived type, use it
704 rather than evaluating the expression again. */
705 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
706 gfc_add_modify (&parmse->pre, ctree, tmp);
707 }
708 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
709 {
710 /* For an array reference in an elemental procedure call we need
711 to retain the ss to provide the scalarized array reference. */
712 gfc_conv_expr_reference (parmse, e);
713 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
714 if (optional)
715 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
716 cond_optional, tmp,
717 fold_convert (TREE_TYPE (tmp), null_pointer_node));
718 gfc_add_modify (&parmse->pre, ctree, tmp);
719 }
720 else
721 {
722 ss = gfc_walk_expr (e);
723 if (ss == gfc_ss_terminator)
724 {
725 parmse->ss = NULL;
726 gfc_conv_expr_reference (parmse, e);
727
728 /* Scalar to an assumed-rank array. */
729 if (class_ts.u.derived->components->as)
730 {
731 tree type;
732 type = get_scalar_to_descriptor_type (parmse->expr,
733 gfc_expr_attr (e));
734 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
735 gfc_get_dtype (type));
736 if (optional)
737 parmse->expr = build3_loc (input_location, COND_EXPR,
738 TREE_TYPE (parmse->expr),
739 cond_optional, parmse->expr,
740 fold_convert (TREE_TYPE (parmse->expr),
741 null_pointer_node));
742 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
743 }
744 else
745 {
746 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
747 if (optional)
748 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
749 cond_optional, tmp,
750 fold_convert (TREE_TYPE (tmp),
751 null_pointer_node));
752 gfc_add_modify (&parmse->pre, ctree, tmp);
753 }
754 }
755 else
756 {
757 stmtblock_t block;
758 gfc_init_block (&block);
759 gfc_ref *ref;
760
761 parmse->ss = ss;
762 parmse->use_offset = 1;
763 gfc_conv_expr_descriptor (parmse, e);
764
765 /* Detect any array references with vector subscripts. */
766 for (ref = e->ref; ref; ref = ref->next)
767 if (ref->type == REF_ARRAY
768 && ref->u.ar.type != AR_ELEMENT
769 && ref->u.ar.type != AR_FULL)
770 {
771 for (dim = 0; dim < ref->u.ar.dimen; dim++)
772 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
773 break;
774 if (dim < ref->u.ar.dimen)
775 break;
776 }
777
778 /* Array references with vector subscripts and non-variable expressions
779 need be converted to a one-based descriptor. */
780 if (ref || e->expr_type != EXPR_VARIABLE)
781 {
782 for (dim = 0; dim < e->rank; ++dim)
783 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
784 gfc_index_one_node);
785 }
786
787 if (e->rank != class_ts.u.derived->components->as->rank)
788 {
789 gcc_assert (class_ts.u.derived->components->as->type
790 == AS_ASSUMED_RANK);
791 if (derived_array
792 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
793 {
794 *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
795 "array");
796 gfc_add_modify (&block, *derived_array , parmse->expr);
797 }
798 class_array_data_assign (&block, ctree, parmse->expr, false);
799 }
800 else
801 {
802 if (gfc_expr_attr (e).codimension)
803 parmse->expr = fold_build1_loc (input_location,
804 VIEW_CONVERT_EXPR,
805 TREE_TYPE (ctree),
806 parmse->expr);
807 gfc_add_modify (&block, ctree, parmse->expr);
808 }
809
810 if (optional)
811 {
812 tmp = gfc_finish_block (&block);
813
814 gfc_init_block (&block);
815 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
816 if (derived_array && *derived_array != NULL_TREE)
817 gfc_conv_descriptor_data_set (&block, *derived_array,
818 null_pointer_node);
819
820 tmp = build3_v (COND_EXPR, cond_optional, tmp,
821 gfc_finish_block (&block));
822 gfc_add_expr_to_block (&parmse->pre, tmp);
823 }
824 else
825 gfc_add_block_to_block (&parmse->pre, &block);
826 }
827 }
828
829 if (class_ts.u.derived->components->ts.type == BT_DERIVED
830 && class_ts.u.derived->components->ts.u.derived
831 ->attr.unlimited_polymorphic)
832 {
833 /* Take care about initializing the _len component correctly. */
834 ctree = gfc_class_len_get (var);
835 if (UNLIMITED_POLY (e))
836 {
837 gfc_expr *len;
838 gfc_se se;
839
840 len = gfc_find_and_cut_at_last_class_ref (e);
841 gfc_add_len_component (len);
842 gfc_init_se (&se, NULL);
843 gfc_conv_expr (&se, len);
844 if (optional)
845 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
846 cond_optional, se.expr,
847 fold_convert (TREE_TYPE (se.expr),
848 integer_zero_node));
849 else
850 tmp = se.expr;
851 gfc_free_expr (len);
852 }
853 else
854 tmp = integer_zero_node;
855 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
856 tmp));
857 }
858 /* Pass the address of the class object. */
859 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
860
861 if (optional && optional_alloc_ptr)
862 parmse->expr = build3_loc (input_location, COND_EXPR,
863 TREE_TYPE (parmse->expr),
864 cond_optional, parmse->expr,
865 fold_convert (TREE_TYPE (parmse->expr),
866 null_pointer_node));
867 }
868
869
870 /* Create a new class container, which is required as scalar coarrays
871 have an array descriptor while normal scalars haven't. Optionally,
872 NULL pointer checks are added if the argument is OPTIONAL. */
873
874 static void
class_scalar_coarray_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts,bool optional)875 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
876 gfc_typespec class_ts, bool optional)
877 {
878 tree var, ctree, tmp;
879 stmtblock_t block;
880 gfc_ref *ref;
881 gfc_ref *class_ref;
882
883 gfc_init_block (&block);
884
885 class_ref = NULL;
886 for (ref = e->ref; ref; ref = ref->next)
887 {
888 if (ref->type == REF_COMPONENT
889 && ref->u.c.component->ts.type == BT_CLASS)
890 class_ref = ref;
891 }
892
893 if (class_ref == NULL
894 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
895 tmp = e->symtree->n.sym->backend_decl;
896 else
897 {
898 /* Remove everything after the last class reference, convert the
899 expression and then recover its tailend once more. */
900 gfc_se tmpse;
901 ref = class_ref->next;
902 class_ref->next = NULL;
903 gfc_init_se (&tmpse, NULL);
904 gfc_conv_expr (&tmpse, e);
905 class_ref->next = ref;
906 tmp = tmpse.expr;
907 }
908
909 var = gfc_typenode_for_spec (&class_ts);
910 var = gfc_create_var (var, "class");
911
912 ctree = gfc_class_vptr_get (var);
913 gfc_add_modify (&block, ctree,
914 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
915
916 ctree = gfc_class_data_get (var);
917 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
918 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
919
920 /* Pass the address of the class object. */
921 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
922
923 if (optional)
924 {
925 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
926 tree tmp2;
927
928 tmp = gfc_finish_block (&block);
929
930 gfc_init_block (&block);
931 tmp2 = gfc_class_data_get (var);
932 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
933 null_pointer_node));
934 tmp2 = gfc_finish_block (&block);
935
936 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
937 cond, tmp, tmp2);
938 gfc_add_expr_to_block (&parmse->pre, tmp);
939 }
940 else
941 gfc_add_block_to_block (&parmse->pre, &block);
942 }
943
944
945 /* Takes an intrinsic type expression and returns the address of a temporary
946 class object of the 'declared' type. */
947 void
gfc_conv_intrinsic_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts)948 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
949 gfc_typespec class_ts)
950 {
951 gfc_symbol *vtab;
952 gfc_ss *ss;
953 tree ctree;
954 tree var;
955 tree tmp;
956 int dim;
957
958 /* The intrinsic type needs to be converted to a temporary
959 CLASS object. */
960 tmp = gfc_typenode_for_spec (&class_ts);
961 var = gfc_create_var (tmp, "class");
962
963 /* Set the vptr. */
964 ctree = gfc_class_vptr_get (var);
965
966 vtab = gfc_find_vtab (&e->ts);
967 gcc_assert (vtab);
968 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
969 gfc_add_modify (&parmse->pre, ctree,
970 fold_convert (TREE_TYPE (ctree), tmp));
971
972 /* Now set the data field. */
973 ctree = gfc_class_data_get (var);
974 if (parmse->ss && parmse->ss->info->useflags)
975 {
976 /* For an array reference in an elemental procedure call we need
977 to retain the ss to provide the scalarized array reference. */
978 gfc_conv_expr_reference (parmse, e);
979 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
980 gfc_add_modify (&parmse->pre, ctree, tmp);
981 }
982 else
983 {
984 ss = gfc_walk_expr (e);
985 if (ss == gfc_ss_terminator)
986 {
987 parmse->ss = NULL;
988 gfc_conv_expr_reference (parmse, e);
989 if (class_ts.u.derived->components->as
990 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
991 {
992 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
993 gfc_expr_attr (e));
994 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
995 TREE_TYPE (ctree), tmp);
996 }
997 else
998 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
999 gfc_add_modify (&parmse->pre, ctree, tmp);
1000 }
1001 else
1002 {
1003 parmse->ss = ss;
1004 parmse->use_offset = 1;
1005 gfc_conv_expr_descriptor (parmse, e);
1006
1007 /* Array references with vector subscripts and non-variable expressions
1008 need be converted to a one-based descriptor. */
1009 if (e->expr_type != EXPR_VARIABLE)
1010 {
1011 for (dim = 0; dim < e->rank; ++dim)
1012 gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
1013 dim, gfc_index_one_node);
1014 }
1015
1016 if (class_ts.u.derived->components->as->rank != e->rank)
1017 {
1018 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1019 TREE_TYPE (ctree), parmse->expr);
1020 gfc_add_modify (&parmse->pre, ctree, tmp);
1021 }
1022 else
1023 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
1024 }
1025 }
1026
1027 gcc_assert (class_ts.type == BT_CLASS);
1028 if (class_ts.u.derived->components->ts.type == BT_DERIVED
1029 && class_ts.u.derived->components->ts.u.derived
1030 ->attr.unlimited_polymorphic)
1031 {
1032 ctree = gfc_class_len_get (var);
1033 /* When the actual arg is a char array, then set the _len component of the
1034 unlimited polymorphic entity to the length of the string. */
1035 if (e->ts.type == BT_CHARACTER)
1036 {
1037 /* Start with parmse->string_length because this seems to be set to a
1038 correct value more often. */
1039 if (parmse->string_length)
1040 tmp = parmse->string_length;
1041 /* When the string_length is not yet set, then try the backend_decl of
1042 the cl. */
1043 else if (e->ts.u.cl->backend_decl)
1044 tmp = e->ts.u.cl->backend_decl;
1045 /* If both of the above approaches fail, then try to generate an
1046 expression from the input, which is only feasible currently, when the
1047 expression can be evaluated to a constant one. */
1048 else
1049 {
1050 /* Try to simplify the expression. */
1051 gfc_simplify_expr (e, 0);
1052 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
1053 {
1054 /* Amazingly all data is present to compute the length of a
1055 constant string, but the expression is not yet there. */
1056 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
1057 gfc_charlen_int_kind,
1058 &e->where);
1059 mpz_set_ui (e->ts.u.cl->length->value.integer,
1060 e->value.character.length);
1061 gfc_conv_const_charlen (e->ts.u.cl);
1062 e->ts.u.cl->resolved = 1;
1063 tmp = e->ts.u.cl->backend_decl;
1064 }
1065 else
1066 {
1067 gfc_error ("Cannot compute the length of the char array "
1068 "at %L.", &e->where);
1069 }
1070 }
1071 }
1072 else
1073 tmp = integer_zero_node;
1074
1075 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
1076 }
1077 else if (class_ts.type == BT_CLASS
1078 && class_ts.u.derived->components
1079 && class_ts.u.derived->components->ts.u
1080 .derived->attr.unlimited_polymorphic)
1081 {
1082 ctree = gfc_class_len_get (var);
1083 gfc_add_modify (&parmse->pre, ctree,
1084 fold_convert (TREE_TYPE (ctree),
1085 integer_zero_node));
1086 }
1087 /* Pass the address of the class object. */
1088 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1089 }
1090
1091
1092 /* Takes a scalarized class array expression and returns the
1093 address of a temporary scalar class object of the 'declared'
1094 type.
1095 OOP-TODO: This could be improved by adding code that branched on
1096 the dynamic type being the same as the declared type. In this case
1097 the original class expression can be passed directly.
1098 optional_alloc_ptr is false when the dummy is neither allocatable
1099 nor a pointer; that's relevant for the optional handling.
1100 Set copyback to true if class container's _data and _vtab pointers
1101 might get modified. */
1102
1103 void
gfc_conv_class_to_class(gfc_se * parmse,gfc_expr * e,gfc_typespec class_ts,bool elemental,bool copyback,bool optional,bool optional_alloc_ptr)1104 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
1105 bool elemental, bool copyback, bool optional,
1106 bool optional_alloc_ptr)
1107 {
1108 tree ctree;
1109 tree var;
1110 tree tmp;
1111 tree vptr;
1112 tree cond = NULL_TREE;
1113 tree slen = NULL_TREE;
1114 gfc_ref *ref;
1115 gfc_ref *class_ref;
1116 stmtblock_t block;
1117 bool full_array = false;
1118
1119 gfc_init_block (&block);
1120
1121 class_ref = NULL;
1122 for (ref = e->ref; ref; ref = ref->next)
1123 {
1124 if (ref->type == REF_COMPONENT
1125 && ref->u.c.component->ts.type == BT_CLASS)
1126 class_ref = ref;
1127
1128 if (ref->next == NULL)
1129 break;
1130 }
1131
1132 if ((ref == NULL || class_ref == ref)
1133 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1134 && (!class_ts.u.derived->components->as
1135 || class_ts.u.derived->components->as->rank != -1))
1136 return;
1137
1138 /* Test for FULL_ARRAY. */
1139 if (e->rank == 0 && gfc_expr_attr (e).codimension
1140 && gfc_expr_attr (e).dimension)
1141 full_array = true;
1142 else
1143 gfc_is_class_array_ref (e, &full_array);
1144
1145 /* The derived type needs to be converted to a temporary
1146 CLASS object. */
1147 tmp = gfc_typenode_for_spec (&class_ts);
1148 var = gfc_create_var (tmp, "class");
1149
1150 /* Set the data. */
1151 ctree = gfc_class_data_get (var);
1152 if (class_ts.u.derived->components->as
1153 && e->rank != class_ts.u.derived->components->as->rank)
1154 {
1155 if (e->rank == 0)
1156 {
1157 tree type = get_scalar_to_descriptor_type (parmse->expr,
1158 gfc_expr_attr (e));
1159 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1160 gfc_get_dtype (type));
1161
1162 tmp = gfc_class_data_get (parmse->expr);
1163 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1164 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1165
1166 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1167 }
1168 else
1169 class_array_data_assign (&block, ctree, parmse->expr, false);
1170 }
1171 else
1172 {
1173 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1174 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1175 TREE_TYPE (ctree), parmse->expr);
1176 gfc_add_modify (&block, ctree, parmse->expr);
1177 }
1178
1179 /* Return the data component, except in the case of scalarized array
1180 references, where nullification of the cannot occur and so there
1181 is no need. */
1182 if (!elemental && full_array && copyback)
1183 {
1184 if (class_ts.u.derived->components->as
1185 && e->rank != class_ts.u.derived->components->as->rank)
1186 {
1187 if (e->rank == 0)
1188 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1189 gfc_conv_descriptor_data_get (ctree));
1190 else
1191 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1192 }
1193 else
1194 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1195 }
1196
1197 /* Set the vptr. */
1198 ctree = gfc_class_vptr_get (var);
1199
1200 /* The vptr is the second field of the actual argument.
1201 First we have to find the corresponding class reference. */
1202
1203 tmp = NULL_TREE;
1204 if (gfc_is_class_array_function (e)
1205 && parmse->class_vptr != NULL_TREE)
1206 tmp = parmse->class_vptr;
1207 else if (class_ref == NULL
1208 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1209 {
1210 tmp = e->symtree->n.sym->backend_decl;
1211
1212 if (TREE_CODE (tmp) == FUNCTION_DECL)
1213 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1214
1215 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1216 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1217
1218 slen = build_zero_cst (size_type_node);
1219 }
1220 else
1221 {
1222 /* Remove everything after the last class reference, convert the
1223 expression and then recover its tailend once more. */
1224 gfc_se tmpse;
1225 ref = class_ref->next;
1226 class_ref->next = NULL;
1227 gfc_init_se (&tmpse, NULL);
1228 gfc_conv_expr (&tmpse, e);
1229 class_ref->next = ref;
1230 tmp = tmpse.expr;
1231 slen = tmpse.string_length;
1232 }
1233
1234 gcc_assert (tmp != NULL_TREE);
1235
1236 /* Dereference if needs be. */
1237 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1238 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1239
1240 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1241 vptr = gfc_class_vptr_get (tmp);
1242 else
1243 vptr = tmp;
1244
1245 gfc_add_modify (&block, ctree,
1246 fold_convert (TREE_TYPE (ctree), vptr));
1247
1248 /* Return the vptr component, except in the case of scalarized array
1249 references, where the dynamic type cannot change. */
1250 if (!elemental && full_array && copyback)
1251 gfc_add_modify (&parmse->post, vptr,
1252 fold_convert (TREE_TYPE (vptr), ctree));
1253
1254 /* For unlimited polymorphic objects also set the _len component. */
1255 if (class_ts.type == BT_CLASS
1256 && class_ts.u.derived->components
1257 && class_ts.u.derived->components->ts.u
1258 .derived->attr.unlimited_polymorphic)
1259 {
1260 ctree = gfc_class_len_get (var);
1261 if (UNLIMITED_POLY (e))
1262 tmp = gfc_class_len_get (tmp);
1263 else if (e->ts.type == BT_CHARACTER)
1264 {
1265 gcc_assert (slen != NULL_TREE);
1266 tmp = slen;
1267 }
1268 else
1269 tmp = build_zero_cst (size_type_node);
1270 gfc_add_modify (&parmse->pre, ctree,
1271 fold_convert (TREE_TYPE (ctree), tmp));
1272
1273 /* Return the len component, except in the case of scalarized array
1274 references, where the dynamic type cannot change. */
1275 if (!elemental && full_array && copyback
1276 && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1277 gfc_add_modify (&parmse->post, tmp,
1278 fold_convert (TREE_TYPE (tmp), ctree));
1279 }
1280
1281 if (optional)
1282 {
1283 tree tmp2;
1284
1285 cond = gfc_conv_expr_present (e->symtree->n.sym);
1286 /* parmse->pre may contain some preparatory instructions for the
1287 temporary array descriptor. Those may only be executed when the
1288 optional argument is set, therefore add parmse->pre's instructions
1289 to block, which is later guarded by an if (optional_arg_given). */
1290 gfc_add_block_to_block (&parmse->pre, &block);
1291 block.head = parmse->pre.head;
1292 parmse->pre.head = NULL_TREE;
1293 tmp = gfc_finish_block (&block);
1294
1295 if (optional_alloc_ptr)
1296 tmp2 = build_empty_stmt (input_location);
1297 else
1298 {
1299 gfc_init_block (&block);
1300
1301 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1302 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1303 null_pointer_node));
1304 tmp2 = gfc_finish_block (&block);
1305 }
1306
1307 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1308 cond, tmp, tmp2);
1309 gfc_add_expr_to_block (&parmse->pre, tmp);
1310 }
1311 else
1312 gfc_add_block_to_block (&parmse->pre, &block);
1313
1314 /* Pass the address of the class object. */
1315 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1316
1317 if (optional && optional_alloc_ptr)
1318 parmse->expr = build3_loc (input_location, COND_EXPR,
1319 TREE_TYPE (parmse->expr),
1320 cond, parmse->expr,
1321 fold_convert (TREE_TYPE (parmse->expr),
1322 null_pointer_node));
1323 }
1324
1325
1326 /* Given a class array declaration and an index, returns the address
1327 of the referenced element. */
1328
1329 tree
gfc_get_class_array_ref(tree index,tree class_decl,tree data_comp,bool unlimited)1330 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1331 bool unlimited)
1332 {
1333 tree data, size, tmp, ctmp, offset, ptr;
1334
1335 data = data_comp != NULL_TREE ? data_comp :
1336 gfc_class_data_get (class_decl);
1337 size = gfc_class_vtab_size_get (class_decl);
1338
1339 if (unlimited)
1340 {
1341 tmp = fold_convert (gfc_array_index_type,
1342 gfc_class_len_get (class_decl));
1343 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1344 gfc_array_index_type, size, tmp);
1345 tmp = fold_build2_loc (input_location, GT_EXPR,
1346 logical_type_node, tmp,
1347 build_zero_cst (TREE_TYPE (tmp)));
1348 size = fold_build3_loc (input_location, COND_EXPR,
1349 gfc_array_index_type, tmp, ctmp, size);
1350 }
1351
1352 offset = fold_build2_loc (input_location, MULT_EXPR,
1353 gfc_array_index_type,
1354 index, size);
1355
1356 data = gfc_conv_descriptor_data_get (data);
1357 ptr = fold_convert (pvoid_type_node, data);
1358 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1359 return fold_convert (TREE_TYPE (data), ptr);
1360 }
1361
1362
1363 /* Copies one class expression to another, assuming that if either
1364 'to' or 'from' are arrays they are packed. Should 'from' be
1365 NULL_TREE, the initialization expression for 'to' is used, assuming
1366 that the _vptr is set. */
1367
1368 tree
gfc_copy_class_to_class(tree from,tree to,tree nelems,bool unlimited)1369 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1370 {
1371 tree fcn;
1372 tree fcn_type;
1373 tree from_data;
1374 tree from_len;
1375 tree to_data;
1376 tree to_len;
1377 tree to_ref;
1378 tree from_ref;
1379 vec<tree, va_gc> *args;
1380 tree tmp;
1381 tree stdcopy;
1382 tree extcopy;
1383 tree index;
1384 bool is_from_desc = false, is_to_class = false;
1385
1386 args = NULL;
1387 /* To prevent warnings on uninitialized variables. */
1388 from_len = to_len = NULL_TREE;
1389
1390 if (from != NULL_TREE)
1391 fcn = gfc_class_vtab_copy_get (from);
1392 else
1393 fcn = gfc_class_vtab_copy_get (to);
1394
1395 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1396
1397 if (from != NULL_TREE)
1398 {
1399 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1400 if (is_from_desc)
1401 {
1402 from_data = from;
1403 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1404 }
1405 else
1406 {
1407 /* Check that from is a class. When the class is part of a coarray,
1408 then from is a common pointer and is to be used as is. */
1409 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1410 ? build_fold_indirect_ref (from) : from;
1411 from_data =
1412 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1413 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1414 ? gfc_class_data_get (from) : from;
1415 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1416 }
1417 }
1418 else
1419 from_data = gfc_class_vtab_def_init_get (to);
1420
1421 if (unlimited)
1422 {
1423 if (from != NULL_TREE && unlimited)
1424 from_len = gfc_class_len_or_zero_get (from);
1425 else
1426 from_len = build_zero_cst (size_type_node);
1427 }
1428
1429 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1430 {
1431 is_to_class = true;
1432 to_data = gfc_class_data_get (to);
1433 if (unlimited)
1434 to_len = gfc_class_len_get (to);
1435 }
1436 else
1437 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1438 to_data = to;
1439
1440 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1441 {
1442 stmtblock_t loopbody;
1443 stmtblock_t body;
1444 stmtblock_t ifbody;
1445 gfc_loopinfo loop;
1446 tree orig_nelems = nelems; /* Needed for bounds check. */
1447
1448 gfc_init_block (&body);
1449 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1450 gfc_array_index_type, nelems,
1451 gfc_index_one_node);
1452 nelems = gfc_evaluate_now (tmp, &body);
1453 index = gfc_create_var (gfc_array_index_type, "S");
1454
1455 if (is_from_desc)
1456 {
1457 from_ref = gfc_get_class_array_ref (index, from, from_data,
1458 unlimited);
1459 vec_safe_push (args, from_ref);
1460 }
1461 else
1462 vec_safe_push (args, from_data);
1463
1464 if (is_to_class)
1465 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1466 else
1467 {
1468 tmp = gfc_conv_array_data (to);
1469 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1470 to_ref = gfc_build_addr_expr (NULL_TREE,
1471 gfc_build_array_ref (tmp, index, to));
1472 }
1473 vec_safe_push (args, to_ref);
1474
1475 /* Add bounds check. */
1476 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1477 {
1478 char *msg;
1479 const char *name = "<<unknown>>";
1480 tree from_len;
1481
1482 if (DECL_P (to))
1483 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1484
1485 from_len = gfc_conv_descriptor_size (from_data, 1);
1486 tmp = fold_build2_loc (input_location, NE_EXPR,
1487 logical_type_node, from_len, orig_nelems);
1488 msg = xasprintf ("Array bound mismatch for dimension %d "
1489 "of array '%s' (%%ld/%%ld)",
1490 1, name);
1491
1492 gfc_trans_runtime_check (true, false, tmp, &body,
1493 &gfc_current_locus, msg,
1494 fold_convert (long_integer_type_node, orig_nelems),
1495 fold_convert (long_integer_type_node, from_len));
1496
1497 free (msg);
1498 }
1499
1500 tmp = build_call_vec (fcn_type, fcn, args);
1501
1502 /* Build the body of the loop. */
1503 gfc_init_block (&loopbody);
1504 gfc_add_expr_to_block (&loopbody, tmp);
1505
1506 /* Build the loop and return. */
1507 gfc_init_loopinfo (&loop);
1508 loop.dimen = 1;
1509 loop.from[0] = gfc_index_zero_node;
1510 loop.loopvar[0] = index;
1511 loop.to[0] = nelems;
1512 gfc_trans_scalarizing_loops (&loop, &loopbody);
1513 gfc_init_block (&ifbody);
1514 gfc_add_block_to_block (&ifbody, &loop.pre);
1515 stdcopy = gfc_finish_block (&ifbody);
1516 /* In initialization mode from_len is a constant zero. */
1517 if (unlimited && !integer_zerop (from_len))
1518 {
1519 vec_safe_push (args, from_len);
1520 vec_safe_push (args, to_len);
1521 tmp = build_call_vec (fcn_type, fcn, args);
1522 /* Build the body of the loop. */
1523 gfc_init_block (&loopbody);
1524 gfc_add_expr_to_block (&loopbody, tmp);
1525
1526 /* Build the loop and return. */
1527 gfc_init_loopinfo (&loop);
1528 loop.dimen = 1;
1529 loop.from[0] = gfc_index_zero_node;
1530 loop.loopvar[0] = index;
1531 loop.to[0] = nelems;
1532 gfc_trans_scalarizing_loops (&loop, &loopbody);
1533 gfc_init_block (&ifbody);
1534 gfc_add_block_to_block (&ifbody, &loop.pre);
1535 extcopy = gfc_finish_block (&ifbody);
1536
1537 tmp = fold_build2_loc (input_location, GT_EXPR,
1538 logical_type_node, from_len,
1539 build_zero_cst (TREE_TYPE (from_len)));
1540 tmp = fold_build3_loc (input_location, COND_EXPR,
1541 void_type_node, tmp, extcopy, stdcopy);
1542 gfc_add_expr_to_block (&body, tmp);
1543 tmp = gfc_finish_block (&body);
1544 }
1545 else
1546 {
1547 gfc_add_expr_to_block (&body, stdcopy);
1548 tmp = gfc_finish_block (&body);
1549 }
1550 gfc_cleanup_loop (&loop);
1551 }
1552 else
1553 {
1554 gcc_assert (!is_from_desc);
1555 vec_safe_push (args, from_data);
1556 vec_safe_push (args, to_data);
1557 stdcopy = build_call_vec (fcn_type, fcn, args);
1558
1559 /* In initialization mode from_len is a constant zero. */
1560 if (unlimited && !integer_zerop (from_len))
1561 {
1562 vec_safe_push (args, from_len);
1563 vec_safe_push (args, to_len);
1564 extcopy = build_call_vec (fcn_type, fcn, args);
1565 tmp = fold_build2_loc (input_location, GT_EXPR,
1566 logical_type_node, from_len,
1567 build_zero_cst (TREE_TYPE (from_len)));
1568 tmp = fold_build3_loc (input_location, COND_EXPR,
1569 void_type_node, tmp, extcopy, stdcopy);
1570 }
1571 else
1572 tmp = stdcopy;
1573 }
1574
1575 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1576 if (from == NULL_TREE)
1577 {
1578 tree cond;
1579 cond = fold_build2_loc (input_location, NE_EXPR,
1580 logical_type_node,
1581 from_data, null_pointer_node);
1582 tmp = fold_build3_loc (input_location, COND_EXPR,
1583 void_type_node, cond,
1584 tmp, build_empty_stmt (input_location));
1585 }
1586
1587 return tmp;
1588 }
1589
1590
1591 static tree
gfc_trans_class_array_init_assign(gfc_expr * rhs,gfc_expr * lhs,gfc_expr * obj)1592 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1593 {
1594 gfc_actual_arglist *actual;
1595 gfc_expr *ppc;
1596 gfc_code *ppc_code;
1597 tree res;
1598
1599 actual = gfc_get_actual_arglist ();
1600 actual->expr = gfc_copy_expr (rhs);
1601 actual->next = gfc_get_actual_arglist ();
1602 actual->next->expr = gfc_copy_expr (lhs);
1603 ppc = gfc_copy_expr (obj);
1604 gfc_add_vptr_component (ppc);
1605 gfc_add_component_ref (ppc, "_copy");
1606 ppc_code = gfc_get_code (EXEC_CALL);
1607 ppc_code->resolved_sym = ppc->symtree->n.sym;
1608 /* Although '_copy' is set to be elemental in class.c, it is
1609 not staying that way. Find out why, sometime.... */
1610 ppc_code->resolved_sym->attr.elemental = 1;
1611 ppc_code->ext.actual = actual;
1612 ppc_code->expr1 = ppc;
1613 /* Since '_copy' is elemental, the scalarizer will take care
1614 of arrays in gfc_trans_call. */
1615 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1616 gfc_free_statements (ppc_code);
1617
1618 if (UNLIMITED_POLY(obj))
1619 {
1620 /* Check if rhs is non-NULL. */
1621 gfc_se src;
1622 gfc_init_se (&src, NULL);
1623 gfc_conv_expr (&src, rhs);
1624 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1625 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1626 src.expr, fold_convert (TREE_TYPE (src.expr),
1627 null_pointer_node));
1628 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1629 build_empty_stmt (input_location));
1630 }
1631
1632 return res;
1633 }
1634
1635 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1636 A MEMCPY is needed to copy the full data from the default initializer
1637 of the dynamic type. */
1638
1639 tree
gfc_trans_class_init_assign(gfc_code * code)1640 gfc_trans_class_init_assign (gfc_code *code)
1641 {
1642 stmtblock_t block;
1643 tree tmp;
1644 gfc_se dst,src,memsz;
1645 gfc_expr *lhs, *rhs, *sz;
1646
1647 gfc_start_block (&block);
1648
1649 lhs = gfc_copy_expr (code->expr1);
1650
1651 rhs = gfc_copy_expr (code->expr1);
1652 gfc_add_vptr_component (rhs);
1653
1654 /* Make sure that the component backend_decls have been built, which
1655 will not have happened if the derived types concerned have not
1656 been referenced. */
1657 gfc_get_derived_type (rhs->ts.u.derived);
1658 gfc_add_def_init_component (rhs);
1659 /* The _def_init is always scalar. */
1660 rhs->rank = 0;
1661
1662 if (code->expr1->ts.type == BT_CLASS
1663 && CLASS_DATA (code->expr1)->attr.dimension)
1664 {
1665 gfc_array_spec *tmparr = gfc_get_array_spec ();
1666 *tmparr = *CLASS_DATA (code->expr1)->as;
1667 /* Adding the array ref to the class expression results in correct
1668 indexing to the dynamic type. */
1669 gfc_add_full_array_ref (lhs, tmparr);
1670 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1671 }
1672 else
1673 {
1674 /* Scalar initialization needs the _data component. */
1675 gfc_add_data_component (lhs);
1676 sz = gfc_copy_expr (code->expr1);
1677 gfc_add_vptr_component (sz);
1678 gfc_add_size_component (sz);
1679
1680 gfc_init_se (&dst, NULL);
1681 gfc_init_se (&src, NULL);
1682 gfc_init_se (&memsz, NULL);
1683 gfc_conv_expr (&dst, lhs);
1684 gfc_conv_expr (&src, rhs);
1685 gfc_conv_expr (&memsz, sz);
1686 gfc_add_block_to_block (&block, &src.pre);
1687 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1688
1689 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1690
1691 if (UNLIMITED_POLY(code->expr1))
1692 {
1693 /* Check if _def_init is non-NULL. */
1694 tree cond = fold_build2_loc (input_location, NE_EXPR,
1695 logical_type_node, src.expr,
1696 fold_convert (TREE_TYPE (src.expr),
1697 null_pointer_node));
1698 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1699 tmp, build_empty_stmt (input_location));
1700 }
1701 }
1702
1703 if (code->expr1->symtree->n.sym->attr.dummy
1704 && (code->expr1->symtree->n.sym->attr.optional
1705 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master))
1706 {
1707 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1708 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1709 present, tmp,
1710 build_empty_stmt (input_location));
1711 }
1712
1713 gfc_add_expr_to_block (&block, tmp);
1714
1715 return gfc_finish_block (&block);
1716 }
1717
1718
1719 /* Class valued elemental function calls or class array elements arriving
1720 in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
1721 is used to ensure that the rhs dynamic type is assigned to the lhs. */
1722
1723 static bool
trans_scalar_class_assign(stmtblock_t * block,gfc_se * lse,gfc_se * rse)1724 trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
1725 {
1726 tree fcn;
1727 tree rse_expr;
1728 tree class_data;
1729 tree tmp;
1730 tree zero;
1731 tree cond;
1732 tree final_cond;
1733 stmtblock_t inner_block;
1734 bool is_descriptor;
1735 bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
1736 bool not_lhs_array_type;
1737
1738 /* Temporaries arising from depencies in assignment get cast as a
1739 character type of the dynamic size of the rhs. Use the vptr copy
1740 for this case. */
1741 tmp = TREE_TYPE (lse->expr);
1742 not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
1743 && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
1744
1745 /* Use ordinary assignment if the rhs is not a call expression or
1746 the lhs is not a class entity or an array(ie. character) type. */
1747 if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
1748 && not_lhs_array_type)
1749 return false;
1750
1751 /* Ordinary assignment can be used if both sides are class expressions
1752 since the dynamic type is preserved by copying the vptr. This
1753 should only occur, where temporaries are involved. */
1754 if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
1755 && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
1756 return false;
1757
1758 /* Fix the class expression and the class data of the rhs. */
1759 if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
1760 || not_call_expr)
1761 {
1762 tmp = gfc_get_class_from_expr (rse->expr);
1763 if (tmp == NULL_TREE)
1764 return false;
1765 rse_expr = gfc_evaluate_now (tmp, block);
1766 }
1767 else
1768 rse_expr = gfc_evaluate_now (rse->expr, block);
1769
1770 class_data = gfc_class_data_get (rse_expr);
1771
1772 /* Check that the rhs data is not null. */
1773 is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
1774 if (is_descriptor)
1775 class_data = gfc_conv_descriptor_data_get (class_data);
1776 class_data = gfc_evaluate_now (class_data, block);
1777
1778 zero = build_int_cst (TREE_TYPE (class_data), 0);
1779 cond = fold_build2_loc (input_location, NE_EXPR,
1780 logical_type_node,
1781 class_data, zero);
1782
1783 /* Copy the rhs to the lhs. */
1784 fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
1785 fcn = build_fold_indirect_ref_loc (input_location, fcn);
1786 tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
1787 tmp = is_descriptor ? tmp : class_data;
1788 tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
1789 gfc_build_addr_expr (NULL, lse->expr));
1790 gfc_add_expr_to_block (block, tmp);
1791
1792 /* Only elemental function results need to be finalised and freed. */
1793 if (not_call_expr)
1794 return true;
1795
1796 /* Finalize the class data if needed. */
1797 gfc_init_block (&inner_block);
1798 fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
1799 zero = build_int_cst (TREE_TYPE (fcn), 0);
1800 final_cond = fold_build2_loc (input_location, NE_EXPR,
1801 logical_type_node, fcn, zero);
1802 fcn = build_fold_indirect_ref_loc (input_location, fcn);
1803 tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
1804 tmp = build3_v (COND_EXPR, final_cond,
1805 tmp, build_empty_stmt (input_location));
1806 gfc_add_expr_to_block (&inner_block, tmp);
1807
1808 /* Free the class data. */
1809 tmp = gfc_call_free (class_data);
1810 tmp = build3_v (COND_EXPR, cond, tmp,
1811 build_empty_stmt (input_location));
1812 gfc_add_expr_to_block (&inner_block, tmp);
1813
1814 /* Finish the inner block and subject it to the condition on the
1815 class data being non-zero. */
1816 tmp = gfc_finish_block (&inner_block);
1817 tmp = build3_v (COND_EXPR, cond, tmp,
1818 build_empty_stmt (input_location));
1819 gfc_add_expr_to_block (block, tmp);
1820
1821 return true;
1822 }
1823
1824 /* End of prototype trans-class.c */
1825
1826
1827 static void
realloc_lhs_warning(bt type,bool array,locus * where)1828 realloc_lhs_warning (bt type, bool array, locus *where)
1829 {
1830 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1831 gfc_warning (OPT_Wrealloc_lhs,
1832 "Code for reallocating the allocatable array at %L will "
1833 "be added", where);
1834 else if (warn_realloc_lhs_all)
1835 gfc_warning (OPT_Wrealloc_lhs_all,
1836 "Code for reallocating the allocatable variable at %L "
1837 "will be added", where);
1838 }
1839
1840
1841 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1842 gfc_expr *);
1843
1844 /* Copy the scalarization loop variables. */
1845
1846 static void
gfc_copy_se_loopvars(gfc_se * dest,gfc_se * src)1847 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1848 {
1849 dest->ss = src->ss;
1850 dest->loop = src->loop;
1851 }
1852
1853
1854 /* Initialize a simple expression holder.
1855
1856 Care must be taken when multiple se are created with the same parent.
1857 The child se must be kept in sync. The easiest way is to delay creation
1858 of a child se until after the previous se has been translated. */
1859
1860 void
gfc_init_se(gfc_se * se,gfc_se * parent)1861 gfc_init_se (gfc_se * se, gfc_se * parent)
1862 {
1863 memset (se, 0, sizeof (gfc_se));
1864 gfc_init_block (&se->pre);
1865 gfc_init_block (&se->post);
1866
1867 se->parent = parent;
1868
1869 if (parent)
1870 gfc_copy_se_loopvars (se, parent);
1871 }
1872
1873
1874 /* Advances to the next SS in the chain. Use this rather than setting
1875 se->ss = se->ss->next because all the parents needs to be kept in sync.
1876 See gfc_init_se. */
1877
1878 void
gfc_advance_se_ss_chain(gfc_se * se)1879 gfc_advance_se_ss_chain (gfc_se * se)
1880 {
1881 gfc_se *p;
1882 gfc_ss *ss;
1883
1884 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1885
1886 p = se;
1887 /* Walk down the parent chain. */
1888 while (p != NULL)
1889 {
1890 /* Simple consistency check. */
1891 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1892 || p->parent->ss->nested_ss == p->ss);
1893
1894 /* If we were in a nested loop, the next scalarized expression can be
1895 on the parent ss' next pointer. Thus we should not take the next
1896 pointer blindly, but rather go up one nest level as long as next
1897 is the end of chain. */
1898 ss = p->ss;
1899 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1900 ss = ss->parent;
1901
1902 p->ss = ss->next;
1903
1904 p = p->parent;
1905 }
1906 }
1907
1908
1909 /* Ensures the result of the expression as either a temporary variable
1910 or a constant so that it can be used repeatedly. */
1911
1912 void
gfc_make_safe_expr(gfc_se * se)1913 gfc_make_safe_expr (gfc_se * se)
1914 {
1915 tree var;
1916
1917 if (CONSTANT_CLASS_P (se->expr))
1918 return;
1919
1920 /* We need a temporary for this result. */
1921 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1922 gfc_add_modify (&se->pre, var, se->expr);
1923 se->expr = var;
1924 }
1925
1926
1927 /* Return an expression which determines if a dummy parameter is present.
1928 Also used for arguments to procedures with multiple entry points. */
1929
1930 tree
gfc_conv_expr_present(gfc_symbol * sym,bool use_saved_desc)1931 gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc)
1932 {
1933 tree decl, orig_decl, cond;
1934
1935 gcc_assert (sym->attr.dummy);
1936 orig_decl = decl = gfc_get_symbol_decl (sym);
1937
1938 /* Intrinsic scalars with VALUE attribute which are passed by value
1939 use a hidden argument to denote the present status. */
1940 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1941 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1942 && !sym->attr.dimension)
1943 {
1944 char name[GFC_MAX_SYMBOL_LEN + 2];
1945 tree tree_name;
1946
1947 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1948 name[0] = '_';
1949 strcpy (&name[1], sym->name);
1950 tree_name = get_identifier (name);
1951
1952 /* Walk function argument list to find hidden arg. */
1953 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1954 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1955 if (DECL_NAME (cond) == tree_name
1956 && DECL_ARTIFICIAL (cond))
1957 break;
1958
1959 gcc_assert (cond);
1960 return cond;
1961 }
1962
1963 /* Assumed-shape arrays use a local variable for the array data;
1964 the actual PARAM_DECL is in a saved decl. As the local variable
1965 is NULL, it can be checked instead, unless use_saved_desc is
1966 requested. */
1967
1968 if (use_saved_desc && TREE_CODE (decl) != PARM_DECL)
1969 {
1970 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1971 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1972 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1973 }
1974
1975 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1976 fold_convert (TREE_TYPE (decl), null_pointer_node));
1977
1978 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1979 as actual argument to denote absent dummies. For array descriptors,
1980 we thus also need to check the array descriptor. For BT_CLASS, it
1981 can also occur for scalars and F2003 due to type->class wrapping and
1982 class->class wrapping. Note further that BT_CLASS always uses an
1983 array descriptor for arrays, also for explicit-shape/assumed-size.
1984 For assumed-rank arrays, no local variable is generated, hence,
1985 the following also applies with !use_saved_desc. */
1986
1987 if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL)
1988 && !sym->attr.allocatable
1989 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1990 || (sym->ts.type == BT_CLASS
1991 && !CLASS_DATA (sym)->attr.allocatable
1992 && !CLASS_DATA (sym)->attr.class_pointer))
1993 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1994 || sym->ts.type == BT_CLASS))
1995 {
1996 tree tmp;
1997
1998 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1999 || sym->as->type == AS_ASSUMED_RANK
2000 || sym->attr.codimension))
2001 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
2002 {
2003 tmp = build_fold_indirect_ref_loc (input_location, decl);
2004 if (sym->ts.type == BT_CLASS)
2005 tmp = gfc_class_data_get (tmp);
2006 tmp = gfc_conv_array_data (tmp);
2007 }
2008 else if (sym->ts.type == BT_CLASS)
2009 tmp = gfc_class_data_get (decl);
2010 else
2011 tmp = NULL_TREE;
2012
2013 if (tmp != NULL_TREE)
2014 {
2015 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
2016 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2017 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2018 logical_type_node, cond, tmp);
2019 }
2020 }
2021
2022 return cond;
2023 }
2024
2025
2026 /* Converts a missing, dummy argument into a null or zero. */
2027
2028 void
gfc_conv_missing_dummy(gfc_se * se,gfc_expr * arg,gfc_typespec ts,int kind)2029 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
2030 {
2031 tree present;
2032 tree tmp;
2033
2034 present = gfc_conv_expr_present (arg->symtree->n.sym);
2035
2036 if (kind > 0)
2037 {
2038 /* Create a temporary and convert it to the correct type. */
2039 tmp = gfc_get_int_type (kind);
2040 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
2041 se->expr));
2042
2043 /* Test for a NULL value. */
2044 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
2045 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
2046 tmp = gfc_evaluate_now (tmp, &se->pre);
2047 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
2048 }
2049 else
2050 {
2051 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
2052 present, se->expr,
2053 build_zero_cst (TREE_TYPE (se->expr)));
2054 tmp = gfc_evaluate_now (tmp, &se->pre);
2055 se->expr = tmp;
2056 }
2057
2058 if (ts.type == BT_CHARACTER)
2059 {
2060 tmp = build_int_cst (gfc_charlen_type_node, 0);
2061 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
2062 present, se->string_length, tmp);
2063 tmp = gfc_evaluate_now (tmp, &se->pre);
2064 se->string_length = tmp;
2065 }
2066 return;
2067 }
2068
2069
2070 /* Get the character length of an expression, looking through gfc_refs
2071 if necessary. */
2072
2073 tree
gfc_get_expr_charlen(gfc_expr * e)2074 gfc_get_expr_charlen (gfc_expr *e)
2075 {
2076 gfc_ref *r;
2077 tree length;
2078 gfc_se se;
2079
2080 gcc_assert (e->expr_type == EXPR_VARIABLE
2081 && e->ts.type == BT_CHARACTER);
2082
2083 length = NULL; /* To silence compiler warning. */
2084
2085 if (is_subref_array (e) && e->ts.u.cl->length)
2086 {
2087 gfc_se tmpse;
2088 gfc_init_se (&tmpse, NULL);
2089 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
2090 e->ts.u.cl->backend_decl = tmpse.expr;
2091 return tmpse.expr;
2092 }
2093
2094 /* First candidate: if the variable is of type CHARACTER, the
2095 expression's length could be the length of the character
2096 variable. */
2097 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2098 length = e->symtree->n.sym->ts.u.cl->backend_decl;
2099
2100 /* Look through the reference chain for component references. */
2101 for (r = e->ref; r; r = r->next)
2102 {
2103 switch (r->type)
2104 {
2105 case REF_COMPONENT:
2106 if (r->u.c.component->ts.type == BT_CHARACTER)
2107 length = r->u.c.component->ts.u.cl->backend_decl;
2108 break;
2109
2110 case REF_ARRAY:
2111 /* Do nothing. */
2112 break;
2113
2114 case REF_SUBSTRING:
2115 gfc_init_se (&se, NULL);
2116 gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
2117 length = se.expr;
2118 gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
2119 length = fold_build2_loc (input_location, MINUS_EXPR,
2120 gfc_charlen_type_node,
2121 se.expr, length);
2122 length = fold_build2_loc (input_location, PLUS_EXPR,
2123 gfc_charlen_type_node, length,
2124 gfc_index_one_node);
2125 break;
2126
2127 default:
2128 gcc_unreachable ();
2129 break;
2130 }
2131 }
2132
2133 gcc_assert (length != NULL);
2134 return length;
2135 }
2136
2137
2138 /* Return for an expression the backend decl of the coarray. */
2139
2140 tree
gfc_get_tree_for_caf_expr(gfc_expr * expr)2141 gfc_get_tree_for_caf_expr (gfc_expr *expr)
2142 {
2143 tree caf_decl;
2144 bool found = false;
2145 gfc_ref *ref;
2146
2147 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
2148
2149 /* Not-implemented diagnostic. */
2150 if (expr->symtree->n.sym->ts.type == BT_CLASS
2151 && UNLIMITED_POLY (expr->symtree->n.sym)
2152 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2153 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
2154 "%L is not supported", &expr->where);
2155
2156 for (ref = expr->ref; ref; ref = ref->next)
2157 if (ref->type == REF_COMPONENT)
2158 {
2159 if (ref->u.c.component->ts.type == BT_CLASS
2160 && UNLIMITED_POLY (ref->u.c.component)
2161 && CLASS_DATA (ref->u.c.component)->attr.codimension)
2162 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
2163 "component at %L is not supported", &expr->where);
2164 }
2165
2166 /* Make sure the backend_decl is present before accessing it. */
2167 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
2168 ? gfc_get_symbol_decl (expr->symtree->n.sym)
2169 : expr->symtree->n.sym->backend_decl;
2170
2171 if (expr->symtree->n.sym->ts.type == BT_CLASS)
2172 {
2173 if (expr->ref && expr->ref->type == REF_ARRAY)
2174 {
2175 caf_decl = gfc_class_data_get (caf_decl);
2176 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2177 return caf_decl;
2178 }
2179 for (ref = expr->ref; ref; ref = ref->next)
2180 {
2181 if (ref->type == REF_COMPONENT
2182 && strcmp (ref->u.c.component->name, "_data") != 0)
2183 {
2184 caf_decl = gfc_class_data_get (caf_decl);
2185 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
2186 return caf_decl;
2187 break;
2188 }
2189 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
2190 break;
2191 }
2192 }
2193 if (expr->symtree->n.sym->attr.codimension)
2194 return caf_decl;
2195
2196 /* The following code assumes that the coarray is a component reachable via
2197 only scalar components/variables; the Fortran standard guarantees this. */
2198
2199 for (ref = expr->ref; ref; ref = ref->next)
2200 if (ref->type == REF_COMPONENT)
2201 {
2202 gfc_component *comp = ref->u.c.component;
2203
2204 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
2205 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2206 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
2207 TREE_TYPE (comp->backend_decl), caf_decl,
2208 comp->backend_decl, NULL_TREE);
2209 if (comp->ts.type == BT_CLASS)
2210 {
2211 caf_decl = gfc_class_data_get (caf_decl);
2212 if (CLASS_DATA (comp)->attr.codimension)
2213 {
2214 found = true;
2215 break;
2216 }
2217 }
2218 if (comp->attr.codimension)
2219 {
2220 found = true;
2221 break;
2222 }
2223 }
2224 gcc_assert (found && caf_decl);
2225 return caf_decl;
2226 }
2227
2228
2229 /* Obtain the Coarray token - and optionally also the offset. */
2230
2231 void
gfc_get_caf_token_offset(gfc_se * se,tree * token,tree * offset,tree caf_decl,tree se_expr,gfc_expr * expr)2232 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
2233 tree se_expr, gfc_expr *expr)
2234 {
2235 tree tmp;
2236
2237 /* Coarray token. */
2238 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2239 {
2240 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
2241 == GFC_ARRAY_ALLOCATABLE
2242 || expr->symtree->n.sym->attr.select_type_temporary);
2243 *token = gfc_conv_descriptor_token (caf_decl);
2244 }
2245 else if (DECL_LANG_SPECIFIC (caf_decl)
2246 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2247 *token = GFC_DECL_TOKEN (caf_decl);
2248 else
2249 {
2250 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2251 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2252 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2253 }
2254
2255 if (offset == NULL)
2256 return;
2257
2258 /* Offset between the coarray base address and the address wanted. */
2259 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2260 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2261 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2262 *offset = build_int_cst (gfc_array_index_type, 0);
2263 else if (DECL_LANG_SPECIFIC (caf_decl)
2264 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2265 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2266 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2267 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2268 else
2269 *offset = build_int_cst (gfc_array_index_type, 0);
2270
2271 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2272 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2273 {
2274 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2275 tmp = gfc_conv_descriptor_data_get (tmp);
2276 }
2277 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2278 tmp = gfc_conv_descriptor_data_get (se_expr);
2279 else
2280 {
2281 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2282 tmp = se_expr;
2283 }
2284
2285 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2286 *offset, fold_convert (gfc_array_index_type, tmp));
2287
2288 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2289 && expr->symtree->n.sym->attr.codimension
2290 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2291 {
2292 gfc_expr *base_expr = gfc_copy_expr (expr);
2293 gfc_ref *ref = base_expr->ref;
2294 gfc_se base_se;
2295
2296 // Iterate through the refs until the last one.
2297 while (ref->next)
2298 ref = ref->next;
2299
2300 if (ref->type == REF_ARRAY
2301 && ref->u.ar.type != AR_FULL)
2302 {
2303 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2304 int i;
2305 for (i = 0; i < ranksum; ++i)
2306 {
2307 ref->u.ar.start[i] = NULL;
2308 ref->u.ar.end[i] = NULL;
2309 }
2310 ref->u.ar.type = AR_FULL;
2311 }
2312 gfc_init_se (&base_se, NULL);
2313 if (gfc_caf_attr (base_expr).dimension)
2314 {
2315 gfc_conv_expr_descriptor (&base_se, base_expr);
2316 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2317 }
2318 else
2319 {
2320 gfc_conv_expr (&base_se, base_expr);
2321 tmp = base_se.expr;
2322 }
2323
2324 gfc_free_expr (base_expr);
2325 gfc_add_block_to_block (&se->pre, &base_se.pre);
2326 gfc_add_block_to_block (&se->post, &base_se.post);
2327 }
2328 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2329 tmp = gfc_conv_descriptor_data_get (caf_decl);
2330 else
2331 {
2332 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2333 tmp = caf_decl;
2334 }
2335
2336 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2337 fold_convert (gfc_array_index_type, *offset),
2338 fold_convert (gfc_array_index_type, tmp));
2339 }
2340
2341
2342 /* Convert the coindex of a coarray into an image index; the result is
2343 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2344 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2345
2346 tree
gfc_caf_get_image_index(stmtblock_t * block,gfc_expr * e,tree desc)2347 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2348 {
2349 gfc_ref *ref;
2350 tree lbound, ubound, extent, tmp, img_idx;
2351 gfc_se se;
2352 int i;
2353
2354 for (ref = e->ref; ref; ref = ref->next)
2355 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2356 break;
2357 gcc_assert (ref != NULL);
2358
2359 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2360 {
2361 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2362 integer_zero_node);
2363 }
2364
2365 img_idx = build_zero_cst (gfc_array_index_type);
2366 extent = build_one_cst (gfc_array_index_type);
2367 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2368 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2369 {
2370 gfc_init_se (&se, NULL);
2371 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2372 gfc_add_block_to_block (block, &se.pre);
2373 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2374 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2375 TREE_TYPE (lbound), se.expr, lbound);
2376 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2377 extent, tmp);
2378 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2379 TREE_TYPE (tmp), img_idx, tmp);
2380 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2381 {
2382 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2383 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2384 extent = fold_build2_loc (input_location, MULT_EXPR,
2385 TREE_TYPE (tmp), extent, tmp);
2386 }
2387 }
2388 else
2389 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2390 {
2391 gfc_init_se (&se, NULL);
2392 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2393 gfc_add_block_to_block (block, &se.pre);
2394 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2395 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2396 TREE_TYPE (lbound), se.expr, lbound);
2397 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2398 extent, tmp);
2399 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2400 img_idx, tmp);
2401 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2402 {
2403 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2404 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2405 TREE_TYPE (ubound), ubound, lbound);
2406 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2407 tmp, build_one_cst (TREE_TYPE (tmp)));
2408 extent = fold_build2_loc (input_location, MULT_EXPR,
2409 TREE_TYPE (tmp), extent, tmp);
2410 }
2411 }
2412 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2413 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2414 return fold_convert (integer_type_node, img_idx);
2415 }
2416
2417
2418 /* For each character array constructor subexpression without a ts.u.cl->length,
2419 replace it by its first element (if there aren't any elements, the length
2420 should already be set to zero). */
2421
2422 static void
flatten_array_ctors_without_strlen(gfc_expr * e)2423 flatten_array_ctors_without_strlen (gfc_expr* e)
2424 {
2425 gfc_actual_arglist* arg;
2426 gfc_constructor* c;
2427
2428 if (!e)
2429 return;
2430
2431 switch (e->expr_type)
2432 {
2433
2434 case EXPR_OP:
2435 flatten_array_ctors_without_strlen (e->value.op.op1);
2436 flatten_array_ctors_without_strlen (e->value.op.op2);
2437 break;
2438
2439 case EXPR_COMPCALL:
2440 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2441 gcc_unreachable ();
2442
2443 case EXPR_FUNCTION:
2444 for (arg = e->value.function.actual; arg; arg = arg->next)
2445 flatten_array_ctors_without_strlen (arg->expr);
2446 break;
2447
2448 case EXPR_ARRAY:
2449
2450 /* We've found what we're looking for. */
2451 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2452 {
2453 gfc_constructor *c;
2454 gfc_expr* new_expr;
2455
2456 gcc_assert (e->value.constructor);
2457
2458 c = gfc_constructor_first (e->value.constructor);
2459 new_expr = c->expr;
2460 c->expr = NULL;
2461
2462 flatten_array_ctors_without_strlen (new_expr);
2463 gfc_replace_expr (e, new_expr);
2464 break;
2465 }
2466
2467 /* Otherwise, fall through to handle constructor elements. */
2468 gcc_fallthrough ();
2469 case EXPR_STRUCTURE:
2470 for (c = gfc_constructor_first (e->value.constructor);
2471 c; c = gfc_constructor_next (c))
2472 flatten_array_ctors_without_strlen (c->expr);
2473 break;
2474
2475 default:
2476 break;
2477
2478 }
2479 }
2480
2481
2482 /* Generate code to initialize a string length variable. Returns the
2483 value. For array constructors, cl->length might be NULL and in this case,
2484 the first element of the constructor is needed. expr is the original
2485 expression so we can access it but can be NULL if this is not needed. */
2486
2487 void
gfc_conv_string_length(gfc_charlen * cl,gfc_expr * expr,stmtblock_t * pblock)2488 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2489 {
2490 gfc_se se;
2491
2492 gfc_init_se (&se, NULL);
2493
2494 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2495 return;
2496
2497 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2498 "flatten" array constructors by taking their first element; all elements
2499 should be the same length or a cl->length should be present. */
2500 if (!cl->length)
2501 {
2502 gfc_expr* expr_flat;
2503 if (!expr)
2504 return;
2505 expr_flat = gfc_copy_expr (expr);
2506 flatten_array_ctors_without_strlen (expr_flat);
2507 gfc_resolve_expr (expr_flat);
2508
2509 gfc_conv_expr (&se, expr_flat);
2510 gfc_add_block_to_block (pblock, &se.pre);
2511 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2512
2513 gfc_free_expr (expr_flat);
2514 return;
2515 }
2516
2517 /* Convert cl->length. */
2518
2519 gcc_assert (cl->length);
2520
2521 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2522 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2523 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2524 gfc_add_block_to_block (pblock, &se.pre);
2525
2526 if (cl->backend_decl && VAR_P (cl->backend_decl))
2527 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2528 else
2529 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2530 }
2531
2532
2533 static void
gfc_conv_substring(gfc_se * se,gfc_ref * ref,int kind,const char * name,locus * where)2534 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2535 const char *name, locus *where)
2536 {
2537 tree tmp;
2538 tree type;
2539 tree fault;
2540 gfc_se start;
2541 gfc_se end;
2542 char *msg;
2543 mpz_t length;
2544
2545 type = gfc_get_character_type (kind, ref->u.ss.length);
2546 type = build_pointer_type (type);
2547
2548 gfc_init_se (&start, se);
2549 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2550 gfc_add_block_to_block (&se->pre, &start.pre);
2551
2552 if (integer_onep (start.expr))
2553 gfc_conv_string_parameter (se);
2554 else
2555 {
2556 tmp = start.expr;
2557 STRIP_NOPS (tmp);
2558 /* Avoid multiple evaluation of substring start. */
2559 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2560 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2561
2562 /* Change the start of the string. */
2563 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2564 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2565 && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2566 tmp = se->expr;
2567 else
2568 tmp = build_fold_indirect_ref_loc (input_location,
2569 se->expr);
2570 /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
2571 if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
2572 {
2573 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2574 se->expr = gfc_build_addr_expr (type, tmp);
2575 }
2576 }
2577
2578 /* Length = end + 1 - start. */
2579 gfc_init_se (&end, se);
2580 if (ref->u.ss.end == NULL)
2581 end.expr = se->string_length;
2582 else
2583 {
2584 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2585 gfc_add_block_to_block (&se->pre, &end.pre);
2586 }
2587 tmp = end.expr;
2588 STRIP_NOPS (tmp);
2589 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2590 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2591
2592 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2593 {
2594 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2595 logical_type_node, start.expr,
2596 end.expr);
2597
2598 /* Check lower bound. */
2599 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2600 start.expr,
2601 build_one_cst (TREE_TYPE (start.expr)));
2602 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2603 logical_type_node, nonempty, fault);
2604 if (name)
2605 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2606 "is less than one", name);
2607 else
2608 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2609 "is less than one");
2610 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2611 fold_convert (long_integer_type_node,
2612 start.expr));
2613 free (msg);
2614
2615 /* Check upper bound. */
2616 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2617 end.expr, se->string_length);
2618 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2619 logical_type_node, nonempty, fault);
2620 if (name)
2621 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2622 "exceeds string length (%%ld)", name);
2623 else
2624 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2625 "exceeds string length (%%ld)");
2626 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2627 fold_convert (long_integer_type_node, end.expr),
2628 fold_convert (long_integer_type_node,
2629 se->string_length));
2630 free (msg);
2631 }
2632
2633 /* Try to calculate the length from the start and end expressions. */
2634 if (ref->u.ss.end
2635 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2636 {
2637 HOST_WIDE_INT i_len;
2638
2639 i_len = gfc_mpz_get_hwi (length) + 1;
2640 if (i_len < 0)
2641 i_len = 0;
2642
2643 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2644 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2645 }
2646 else
2647 {
2648 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2649 fold_convert (gfc_charlen_type_node, end.expr),
2650 fold_convert (gfc_charlen_type_node, start.expr));
2651 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2652 build_int_cst (gfc_charlen_type_node, 1), tmp);
2653 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2654 tmp, build_int_cst (gfc_charlen_type_node, 0));
2655 }
2656
2657 se->string_length = tmp;
2658 }
2659
2660
2661 /* Convert a derived type component reference. */
2662
2663 void
gfc_conv_component_ref(gfc_se * se,gfc_ref * ref)2664 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2665 {
2666 gfc_component *c;
2667 tree tmp;
2668 tree decl;
2669 tree field;
2670 tree context;
2671
2672 c = ref->u.c.component;
2673
2674 if (c->backend_decl == NULL_TREE
2675 && ref->u.c.sym != NULL)
2676 gfc_get_derived_type (ref->u.c.sym);
2677
2678 field = c->backend_decl;
2679 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2680 decl = se->expr;
2681 context = DECL_FIELD_CONTEXT (field);
2682
2683 /* Components can correspond to fields of different containing
2684 types, as components are created without context, whereas
2685 a concrete use of a component has the type of decl as context.
2686 So, if the type doesn't match, we search the corresponding
2687 FIELD_DECL in the parent type. To not waste too much time
2688 we cache this result in norestrict_decl.
2689 On the other hand, if the context is a UNION or a MAP (a
2690 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2691
2692 if (context != TREE_TYPE (decl)
2693 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2694 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2695 {
2696 tree f2 = c->norestrict_decl;
2697 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2698 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2699 if (TREE_CODE (f2) == FIELD_DECL
2700 && DECL_NAME (f2) == DECL_NAME (field))
2701 break;
2702 gcc_assert (f2);
2703 c->norestrict_decl = f2;
2704 field = f2;
2705 }
2706
2707 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2708 && strcmp ("_data", c->name) == 0)
2709 {
2710 /* Found a ref to the _data component. Store the associated ref to
2711 the vptr in se->class_vptr. */
2712 se->class_vptr = gfc_class_vptr_get (decl);
2713 }
2714 else
2715 se->class_vptr = NULL_TREE;
2716
2717 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2718 decl, field, NULL_TREE);
2719
2720 se->expr = tmp;
2721
2722 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2723 strlen () conditional below. */
2724 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2725 && !c->ts.deferred
2726 && !c->attr.pdt_string)
2727 {
2728 tmp = c->ts.u.cl->backend_decl;
2729 /* Components must always be constant length. */
2730 gcc_assert (tmp && INTEGER_CST_P (tmp));
2731 se->string_length = tmp;
2732 }
2733
2734 if (gfc_deferred_strlen (c, &field))
2735 {
2736 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2737 TREE_TYPE (field),
2738 decl, field, NULL_TREE);
2739 se->string_length = tmp;
2740 }
2741
2742 if (((c->attr.pointer || c->attr.allocatable)
2743 && (!c->attr.dimension && !c->attr.codimension)
2744 && c->ts.type != BT_CHARACTER)
2745 || c->attr.proc_pointer)
2746 se->expr = build_fold_indirect_ref_loc (input_location,
2747 se->expr);
2748 }
2749
2750
2751 /* This function deals with component references to components of the
2752 parent type for derived type extensions. */
2753 void
conv_parent_component_references(gfc_se * se,gfc_ref * ref)2754 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2755 {
2756 gfc_component *c;
2757 gfc_component *cmp;
2758 gfc_symbol *dt;
2759 gfc_ref parent;
2760
2761 dt = ref->u.c.sym;
2762 c = ref->u.c.component;
2763
2764 /* Return if the component is in the parent type. */
2765 for (cmp = dt->components; cmp; cmp = cmp->next)
2766 if (strcmp (c->name, cmp->name) == 0)
2767 return;
2768
2769 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2770 parent.type = REF_COMPONENT;
2771 parent.next = NULL;
2772 parent.u.c.sym = dt;
2773 parent.u.c.component = dt->components;
2774
2775 if (dt->backend_decl == NULL)
2776 gfc_get_derived_type (dt);
2777
2778 /* Build the reference and call self. */
2779 gfc_conv_component_ref (se, &parent);
2780 parent.u.c.sym = dt->components->ts.u.derived;
2781 parent.u.c.component = c;
2782 conv_parent_component_references (se, &parent);
2783 }
2784
2785
2786 static void
conv_inquiry(gfc_se * se,gfc_ref * ref,gfc_expr * expr,gfc_typespec * ts)2787 conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2788 {
2789 tree res = se->expr;
2790
2791 switch (ref->u.i)
2792 {
2793 case INQUIRY_RE:
2794 res = fold_build1_loc (input_location, REALPART_EXPR,
2795 TREE_TYPE (TREE_TYPE (res)), res);
2796 break;
2797
2798 case INQUIRY_IM:
2799 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2800 TREE_TYPE (TREE_TYPE (res)), res);
2801 break;
2802
2803 case INQUIRY_KIND:
2804 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2805 ts->kind);
2806 break;
2807
2808 case INQUIRY_LEN:
2809 res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2810 se->string_length);
2811 break;
2812
2813 default:
2814 gcc_unreachable ();
2815 }
2816 se->expr = res;
2817 }
2818
2819 /* Dereference VAR where needed if it is a pointer, reference, etc.
2820 according to Fortran semantics. */
2821
2822 tree
gfc_maybe_dereference_var(gfc_symbol * sym,tree var,bool descriptor_only_p,bool is_classarray)2823 gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
2824 bool is_classarray)
2825 {
2826 /* Characters are entirely different from other types, they are treated
2827 separately. */
2828 if (sym->ts.type == BT_CHARACTER)
2829 {
2830 /* Dereference character pointer dummy arguments
2831 or results. */
2832 if ((sym->attr.pointer || sym->attr.allocatable
2833 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2834 && (sym->attr.dummy
2835 || sym->attr.function
2836 || sym->attr.result))
2837 var = build_fold_indirect_ref_loc (input_location, var);
2838 }
2839 else if (!sym->attr.value)
2840 {
2841 /* Dereference temporaries for class array dummy arguments. */
2842 if (sym->attr.dummy && is_classarray
2843 && GFC_ARRAY_TYPE_P (TREE_TYPE (var)))
2844 {
2845 if (!descriptor_only_p)
2846 var = GFC_DECL_SAVED_DESCRIPTOR (var);
2847
2848 var = build_fold_indirect_ref_loc (input_location, var);
2849 }
2850
2851 /* Dereference non-character scalar dummy arguments. */
2852 if (sym->attr.dummy && !sym->attr.dimension
2853 && !(sym->attr.codimension && sym->attr.allocatable)
2854 && (sym->ts.type != BT_CLASS
2855 || (!CLASS_DATA (sym)->attr.dimension
2856 && !(CLASS_DATA (sym)->attr.codimension
2857 && CLASS_DATA (sym)->attr.allocatable))))
2858 var = build_fold_indirect_ref_loc (input_location, var);
2859
2860 /* Dereference scalar hidden result. */
2861 if (flag_f2c && sym->ts.type == BT_COMPLEX
2862 && (sym->attr.function || sym->attr.result)
2863 && !sym->attr.dimension && !sym->attr.pointer
2864 && !sym->attr.always_explicit)
2865 var = build_fold_indirect_ref_loc (input_location, var);
2866
2867 /* Dereference non-character, non-class pointer variables.
2868 These must be dummies, results, or scalars. */
2869 if (!is_classarray
2870 && (sym->attr.pointer || sym->attr.allocatable
2871 || gfc_is_associate_pointer (sym)
2872 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2873 && (sym->attr.dummy
2874 || sym->attr.function
2875 || sym->attr.result
2876 || (!sym->attr.dimension
2877 && (!sym->attr.codimension || !sym->attr.allocatable))))
2878 var = build_fold_indirect_ref_loc (input_location, var);
2879 /* Now treat the class array pointer variables accordingly. */
2880 else if (sym->ts.type == BT_CLASS
2881 && sym->attr.dummy
2882 && (CLASS_DATA (sym)->attr.dimension
2883 || CLASS_DATA (sym)->attr.codimension)
2884 && ((CLASS_DATA (sym)->as
2885 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2886 || CLASS_DATA (sym)->attr.allocatable
2887 || CLASS_DATA (sym)->attr.class_pointer))
2888 var = build_fold_indirect_ref_loc (input_location, var);
2889 /* And the case where a non-dummy, non-result, non-function,
2890 non-allotable and non-pointer classarray is present. This case was
2891 previously covered by the first if, but with introducing the
2892 condition !is_classarray there, that case has to be covered
2893 explicitly. */
2894 else if (sym->ts.type == BT_CLASS
2895 && !sym->attr.dummy
2896 && !sym->attr.function
2897 && !sym->attr.result
2898 && (CLASS_DATA (sym)->attr.dimension
2899 || CLASS_DATA (sym)->attr.codimension)
2900 && (sym->assoc
2901 || !CLASS_DATA (sym)->attr.allocatable)
2902 && !CLASS_DATA (sym)->attr.class_pointer)
2903 var = build_fold_indirect_ref_loc (input_location, var);
2904 }
2905
2906 return var;
2907 }
2908
2909 /* Return the contents of a variable. Also handles reference/pointer
2910 variables (all Fortran pointer references are implicit). */
2911
2912 static void
gfc_conv_variable(gfc_se * se,gfc_expr * expr)2913 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2914 {
2915 gfc_ss *ss;
2916 gfc_ref *ref;
2917 gfc_symbol *sym;
2918 tree parent_decl = NULL_TREE;
2919 int parent_flag;
2920 bool return_value;
2921 bool alternate_entry;
2922 bool entry_master;
2923 bool is_classarray;
2924 bool first_time = true;
2925
2926 sym = expr->symtree->n.sym;
2927 is_classarray = IS_CLASS_ARRAY (sym);
2928 ss = se->ss;
2929 if (ss != NULL)
2930 {
2931 gfc_ss_info *ss_info = ss->info;
2932
2933 /* Check that something hasn't gone horribly wrong. */
2934 gcc_assert (ss != gfc_ss_terminator);
2935 gcc_assert (ss_info->expr == expr);
2936
2937 /* A scalarized term. We already know the descriptor. */
2938 se->expr = ss_info->data.array.descriptor;
2939 se->string_length = ss_info->string_length;
2940 ref = ss_info->data.array.ref;
2941 if (ref)
2942 gcc_assert (ref->type == REF_ARRAY
2943 && ref->u.ar.type != AR_ELEMENT);
2944 else
2945 gfc_conv_tmp_array_ref (se);
2946 }
2947 else
2948 {
2949 tree se_expr = NULL_TREE;
2950
2951 se->expr = gfc_get_symbol_decl (sym);
2952
2953 /* Deal with references to a parent results or entries by storing
2954 the current_function_decl and moving to the parent_decl. */
2955 return_value = sym->attr.function && sym->result == sym;
2956 alternate_entry = sym->attr.function && sym->attr.entry
2957 && sym->result == sym;
2958 entry_master = sym->attr.result
2959 && sym->ns->proc_name->attr.entry_master
2960 && !gfc_return_by_reference (sym->ns->proc_name);
2961 if (current_function_decl)
2962 parent_decl = DECL_CONTEXT (current_function_decl);
2963
2964 if ((se->expr == parent_decl && return_value)
2965 || (sym->ns && sym->ns->proc_name
2966 && parent_decl
2967 && sym->ns->proc_name->backend_decl == parent_decl
2968 && (alternate_entry || entry_master)))
2969 parent_flag = 1;
2970 else
2971 parent_flag = 0;
2972
2973 /* Special case for assigning the return value of a function.
2974 Self recursive functions must have an explicit return value. */
2975 if (return_value && (se->expr == current_function_decl || parent_flag))
2976 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2977
2978 /* Similarly for alternate entry points. */
2979 else if (alternate_entry
2980 && (sym->ns->proc_name->backend_decl == current_function_decl
2981 || parent_flag))
2982 {
2983 gfc_entry_list *el = NULL;
2984
2985 for (el = sym->ns->entries; el; el = el->next)
2986 if (sym == el->sym)
2987 {
2988 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2989 break;
2990 }
2991 }
2992
2993 else if (entry_master
2994 && (sym->ns->proc_name->backend_decl == current_function_decl
2995 || parent_flag))
2996 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2997
2998 if (se_expr)
2999 se->expr = se_expr;
3000
3001 /* Procedure actual arguments. Look out for temporary variables
3002 with the same attributes as function values. */
3003 else if (!sym->attr.temporary
3004 && sym->attr.flavor == FL_PROCEDURE
3005 && se->expr != current_function_decl)
3006 {
3007 if (!sym->attr.dummy && !sym->attr.proc_pointer)
3008 {
3009 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
3010 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3011 }
3012 return;
3013 }
3014
3015 /* Dereference the expression, where needed. */
3016 se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
3017 is_classarray);
3018
3019 ref = expr->ref;
3020 }
3021
3022 /* For character variables, also get the length. */
3023 if (sym->ts.type == BT_CHARACTER)
3024 {
3025 /* If the character length of an entry isn't set, get the length from
3026 the master function instead. */
3027 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
3028 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
3029 else
3030 se->string_length = sym->ts.u.cl->backend_decl;
3031 gcc_assert (se->string_length);
3032 }
3033
3034 gfc_typespec *ts = &sym->ts;
3035 while (ref)
3036 {
3037 switch (ref->type)
3038 {
3039 case REF_ARRAY:
3040 /* Return the descriptor if that's what we want and this is an array
3041 section reference. */
3042 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
3043 return;
3044 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
3045 /* Return the descriptor for array pointers and allocations. */
3046 if (se->want_pointer
3047 && ref->next == NULL && (se->descriptor_only))
3048 return;
3049
3050 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
3051 /* Return a pointer to an element. */
3052 break;
3053
3054 case REF_COMPONENT:
3055 ts = &ref->u.c.component->ts;
3056 if (first_time && is_classarray && sym->attr.dummy
3057 && se->descriptor_only
3058 && !CLASS_DATA (sym)->attr.allocatable
3059 && !CLASS_DATA (sym)->attr.class_pointer
3060 && CLASS_DATA (sym)->as
3061 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
3062 && strcmp ("_data", ref->u.c.component->name) == 0)
3063 /* Skip the first ref of a _data component, because for class
3064 arrays that one is already done by introducing a temporary
3065 array descriptor. */
3066 break;
3067
3068 if (ref->u.c.sym->attr.extension)
3069 conv_parent_component_references (se, ref);
3070
3071 gfc_conv_component_ref (se, ref);
3072 if (!ref->next && ref->u.c.sym->attr.codimension
3073 && se->want_pointer && se->descriptor_only)
3074 return;
3075
3076 break;
3077
3078 case REF_SUBSTRING:
3079 gfc_conv_substring (se, ref, expr->ts.kind,
3080 expr->symtree->name, &expr->where);
3081 break;
3082
3083 case REF_INQUIRY:
3084 conv_inquiry (se, ref, expr, ts);
3085 break;
3086
3087 default:
3088 gcc_unreachable ();
3089 break;
3090 }
3091 first_time = false;
3092 ref = ref->next;
3093 }
3094 /* Pointer assignment, allocation or pass by reference. Arrays are handled
3095 separately. */
3096 if (se->want_pointer)
3097 {
3098 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
3099 gfc_conv_string_parameter (se);
3100 else
3101 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
3102 }
3103 }
3104
3105
3106 /* Unary ops are easy... Or they would be if ! was a valid op. */
3107
3108 static void
gfc_conv_unary_op(enum tree_code code,gfc_se * se,gfc_expr * expr)3109 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
3110 {
3111 gfc_se operand;
3112 tree type;
3113
3114 gcc_assert (expr->ts.type != BT_CHARACTER);
3115 /* Initialize the operand. */
3116 gfc_init_se (&operand, se);
3117 gfc_conv_expr_val (&operand, expr->value.op.op1);
3118 gfc_add_block_to_block (&se->pre, &operand.pre);
3119
3120 type = gfc_typenode_for_spec (&expr->ts);
3121
3122 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
3123 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
3124 All other unary operators have an equivalent GIMPLE unary operator. */
3125 if (code == TRUTH_NOT_EXPR)
3126 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
3127 build_int_cst (type, 0));
3128 else
3129 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
3130
3131 }
3132
3133 /* Expand power operator to optimal multiplications when a value is raised
3134 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
3135 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
3136 Programming", 3rd Edition, 1998. */
3137
3138 /* This code is mostly duplicated from expand_powi in the backend.
3139 We establish the "optimal power tree" lookup table with the defined size.
3140 The items in the table are the exponents used to calculate the index
3141 exponents. Any integer n less than the value can get an "addition chain",
3142 with the first node being one. */
3143 #define POWI_TABLE_SIZE 256
3144
3145 /* The table is from builtins.c. */
3146 static const unsigned char powi_table[POWI_TABLE_SIZE] =
3147 {
3148 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
3149 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
3150 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
3151 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
3152 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
3153 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
3154 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
3155 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
3156 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
3157 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
3158 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
3159 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
3160 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
3161 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
3162 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
3163 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
3164 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
3165 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
3166 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
3167 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
3168 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
3169 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
3170 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
3171 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
3172 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
3173 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
3174 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
3175 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
3176 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
3177 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
3178 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
3179 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
3180 };
3181
3182 /* If n is larger than lookup table's max index, we use the "window
3183 method". */
3184 #define POWI_WINDOW_SIZE 3
3185
3186 /* Recursive function to expand the power operator. The temporary
3187 values are put in tmpvar. The function returns tmpvar[1] ** n. */
3188 static tree
gfc_conv_powi(gfc_se * se,unsigned HOST_WIDE_INT n,tree * tmpvar)3189 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
3190 {
3191 tree op0;
3192 tree op1;
3193 tree tmp;
3194 int digit;
3195
3196 if (n < POWI_TABLE_SIZE)
3197 {
3198 if (tmpvar[n])
3199 return tmpvar[n];
3200
3201 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
3202 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
3203 }
3204 else if (n & 1)
3205 {
3206 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
3207 op0 = gfc_conv_powi (se, n - digit, tmpvar);
3208 op1 = gfc_conv_powi (se, digit, tmpvar);
3209 }
3210 else
3211 {
3212 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
3213 op1 = op0;
3214 }
3215
3216 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
3217 tmp = gfc_evaluate_now (tmp, &se->pre);
3218
3219 if (n < POWI_TABLE_SIZE)
3220 tmpvar[n] = tmp;
3221
3222 return tmp;
3223 }
3224
3225
3226 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
3227 return 1. Else return 0 and a call to runtime library functions
3228 will have to be built. */
3229 static int
gfc_conv_cst_int_power(gfc_se * se,tree lhs,tree rhs)3230 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
3231 {
3232 tree cond;
3233 tree tmp;
3234 tree type;
3235 tree vartmp[POWI_TABLE_SIZE];
3236 HOST_WIDE_INT m;
3237 unsigned HOST_WIDE_INT n;
3238 int sgn;
3239 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
3240
3241 /* If exponent is too large, we won't expand it anyway, so don't bother
3242 with large integer values. */
3243 if (!wi::fits_shwi_p (wrhs))
3244 return 0;
3245
3246 m = wrhs.to_shwi ();
3247 /* Use the wide_int's routine to reliably get the absolute value on all
3248 platforms. Then convert it to a HOST_WIDE_INT like above. */
3249 n = wi::abs (wrhs).to_shwi ();
3250
3251 type = TREE_TYPE (lhs);
3252 sgn = tree_int_cst_sgn (rhs);
3253
3254 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3255 || optimize_size) && (m > 2 || m < -1))
3256 return 0;
3257
3258 /* rhs == 0 */
3259 if (sgn == 0)
3260 {
3261 se->expr = gfc_build_const (type, integer_one_node);
3262 return 1;
3263 }
3264
3265 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3266 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3267 {
3268 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3269 lhs, build_int_cst (TREE_TYPE (lhs), -1));
3270 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3271 lhs, build_int_cst (TREE_TYPE (lhs), 1));
3272
3273 /* If rhs is even,
3274 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3275 if ((n & 1) == 0)
3276 {
3277 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3278 logical_type_node, tmp, cond);
3279 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3280 tmp, build_int_cst (type, 1),
3281 build_int_cst (type, 0));
3282 return 1;
3283 }
3284 /* If rhs is odd,
3285 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3286 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3287 build_int_cst (type, -1),
3288 build_int_cst (type, 0));
3289 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3290 cond, build_int_cst (type, 1), tmp);
3291 return 1;
3292 }
3293
3294 memset (vartmp, 0, sizeof (vartmp));
3295 vartmp[1] = lhs;
3296 if (sgn == -1)
3297 {
3298 tmp = gfc_build_const (type, integer_one_node);
3299 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3300 vartmp[1]);
3301 }
3302
3303 se->expr = gfc_conv_powi (se, n, vartmp);
3304
3305 return 1;
3306 }
3307
3308
3309 /* Power op (**). Constant integer exponent has special handling. */
3310
3311 static void
gfc_conv_power_op(gfc_se * se,gfc_expr * expr)3312 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3313 {
3314 tree gfc_int4_type_node;
3315 int kind;
3316 int ikind;
3317 int res_ikind_1, res_ikind_2;
3318 gfc_se lse;
3319 gfc_se rse;
3320 tree fndecl = NULL;
3321
3322 gfc_init_se (&lse, se);
3323 gfc_conv_expr_val (&lse, expr->value.op.op1);
3324 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3325 gfc_add_block_to_block (&se->pre, &lse.pre);
3326
3327 gfc_init_se (&rse, se);
3328 gfc_conv_expr_val (&rse, expr->value.op.op2);
3329 gfc_add_block_to_block (&se->pre, &rse.pre);
3330
3331 if (expr->value.op.op2->ts.type == BT_INTEGER
3332 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3333 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3334 return;
3335
3336 if (INTEGER_CST_P (lse.expr)
3337 && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3338 {
3339 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3340 HOST_WIDE_INT v, w;
3341 int kind, ikind, bit_size;
3342
3343 v = wlhs.to_shwi ();
3344 w = abs (v);
3345
3346 kind = expr->value.op.op1->ts.kind;
3347 ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3348 bit_size = gfc_integer_kinds[ikind].bit_size;
3349
3350 if (v == 1)
3351 {
3352 /* 1**something is always 1. */
3353 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3354 return;
3355 }
3356 else if (v == -1)
3357 {
3358 /* (-1)**n is 1 - ((n & 1) << 1) */
3359 tree type;
3360 tree tmp;
3361
3362 type = TREE_TYPE (lse.expr);
3363 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3364 rse.expr, build_int_cst (type, 1));
3365 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3366 tmp, build_int_cst (type, 1));
3367 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3368 build_int_cst (type, 1), tmp);
3369 se->expr = tmp;
3370 return;
3371 }
3372 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3373 {
3374 /* Here v is +/- 2**e. The further simplification uses
3375 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3376 1<<(4*n), etc., but we have to make sure to return zero
3377 if the number of bits is too large. */
3378 tree lshift;
3379 tree type;
3380 tree shift;
3381 tree ge;
3382 tree cond;
3383 tree num_bits;
3384 tree cond2;
3385 tree tmp1;
3386
3387 type = TREE_TYPE (lse.expr);
3388
3389 if (w == 2)
3390 shift = rse.expr;
3391 else if (w == 4)
3392 shift = fold_build2_loc (input_location, PLUS_EXPR,
3393 TREE_TYPE (rse.expr),
3394 rse.expr, rse.expr);
3395 else
3396 {
3397 /* use popcount for fast log2(w) */
3398 int e = wi::popcount (w-1);
3399 shift = fold_build2_loc (input_location, MULT_EXPR,
3400 TREE_TYPE (rse.expr),
3401 build_int_cst (TREE_TYPE (rse.expr), e),
3402 rse.expr);
3403 }
3404
3405 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3406 build_int_cst (type, 1), shift);
3407 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3408 rse.expr, build_int_cst (type, 0));
3409 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3410 build_int_cst (type, 0));
3411 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3412 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3413 rse.expr, num_bits);
3414 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3415 build_int_cst (type, 0), cond);
3416 if (v > 0)
3417 {
3418 se->expr = tmp1;
3419 }
3420 else
3421 {
3422 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3423 tree tmp2;
3424 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3425 rse.expr, build_int_cst (type, 1));
3426 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3427 tmp2, build_int_cst (type, 1));
3428 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3429 build_int_cst (type, 1), tmp2);
3430 se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3431 tmp1, tmp2);
3432 }
3433 return;
3434 }
3435 }
3436
3437 gfc_int4_type_node = gfc_get_int_type (4);
3438
3439 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3440 library routine. But in the end, we have to convert the result back
3441 if this case applies -- with res_ikind_K, we keep track whether operand K
3442 falls into this case. */
3443 res_ikind_1 = -1;
3444 res_ikind_2 = -1;
3445
3446 kind = expr->value.op.op1->ts.kind;
3447 switch (expr->value.op.op2->ts.type)
3448 {
3449 case BT_INTEGER:
3450 ikind = expr->value.op.op2->ts.kind;
3451 switch (ikind)
3452 {
3453 case 1:
3454 case 2:
3455 rse.expr = convert (gfc_int4_type_node, rse.expr);
3456 res_ikind_2 = ikind;
3457 /* Fall through. */
3458
3459 case 4:
3460 ikind = 0;
3461 break;
3462
3463 case 8:
3464 ikind = 1;
3465 break;
3466
3467 case 16:
3468 ikind = 2;
3469 break;
3470
3471 default:
3472 gcc_unreachable ();
3473 }
3474 switch (kind)
3475 {
3476 case 1:
3477 case 2:
3478 if (expr->value.op.op1->ts.type == BT_INTEGER)
3479 {
3480 lse.expr = convert (gfc_int4_type_node, lse.expr);
3481 res_ikind_1 = kind;
3482 }
3483 else
3484 gcc_unreachable ();
3485 /* Fall through. */
3486
3487 case 4:
3488 kind = 0;
3489 break;
3490
3491 case 8:
3492 kind = 1;
3493 break;
3494
3495 case 10:
3496 kind = 2;
3497 break;
3498
3499 case 16:
3500 kind = 3;
3501 break;
3502
3503 default:
3504 gcc_unreachable ();
3505 }
3506
3507 switch (expr->value.op.op1->ts.type)
3508 {
3509 case BT_INTEGER:
3510 if (kind == 3) /* Case 16 was not handled properly above. */
3511 kind = 2;
3512 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3513 break;
3514
3515 case BT_REAL:
3516 /* Use builtins for real ** int4. */
3517 if (ikind == 0)
3518 {
3519 switch (kind)
3520 {
3521 case 0:
3522 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3523 break;
3524
3525 case 1:
3526 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3527 break;
3528
3529 case 2:
3530 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3531 break;
3532
3533 case 3:
3534 /* Use the __builtin_powil() only if real(kind=16) is
3535 actually the C long double type. */
3536 if (!gfc_real16_is_float128)
3537 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3538 break;
3539
3540 default:
3541 gcc_unreachable ();
3542 }
3543 }
3544
3545 /* If we don't have a good builtin for this, go for the
3546 library function. */
3547 if (!fndecl)
3548 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3549 break;
3550
3551 case BT_COMPLEX:
3552 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3553 break;
3554
3555 default:
3556 gcc_unreachable ();
3557 }
3558 break;
3559
3560 case BT_REAL:
3561 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3562 break;
3563
3564 case BT_COMPLEX:
3565 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3566 break;
3567
3568 default:
3569 gcc_unreachable ();
3570 break;
3571 }
3572
3573 se->expr = build_call_expr_loc (input_location,
3574 fndecl, 2, lse.expr, rse.expr);
3575
3576 /* Convert the result back if it is of wrong integer kind. */
3577 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3578 {
3579 /* We want the maximum of both operand kinds as result. */
3580 if (res_ikind_1 < res_ikind_2)
3581 res_ikind_1 = res_ikind_2;
3582 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3583 }
3584 }
3585
3586
3587 /* Generate code to allocate a string temporary. */
3588
3589 tree
gfc_conv_string_tmp(gfc_se * se,tree type,tree len)3590 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3591 {
3592 tree var;
3593 tree tmp;
3594
3595 if (gfc_can_put_var_on_stack (len))
3596 {
3597 /* Create a temporary variable to hold the result. */
3598 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3599 TREE_TYPE (len), len,
3600 build_int_cst (TREE_TYPE (len), 1));
3601 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3602
3603 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3604 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3605 else
3606 tmp = build_array_type (TREE_TYPE (type), tmp);
3607
3608 var = gfc_create_var (tmp, "str");
3609 var = gfc_build_addr_expr (type, var);
3610 }
3611 else
3612 {
3613 /* Allocate a temporary to hold the result. */
3614 var = gfc_create_var (type, "pstr");
3615 gcc_assert (POINTER_TYPE_P (type));
3616 tmp = TREE_TYPE (type);
3617 if (TREE_CODE (tmp) == ARRAY_TYPE)
3618 tmp = TREE_TYPE (tmp);
3619 tmp = TYPE_SIZE_UNIT (tmp);
3620 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3621 fold_convert (size_type_node, len),
3622 fold_convert (size_type_node, tmp));
3623 tmp = gfc_call_malloc (&se->pre, type, tmp);
3624 gfc_add_modify (&se->pre, var, tmp);
3625
3626 /* Free the temporary afterwards. */
3627 tmp = gfc_call_free (var);
3628 gfc_add_expr_to_block (&se->post, tmp);
3629 }
3630
3631 return var;
3632 }
3633
3634
3635 /* Handle a string concatenation operation. A temporary will be allocated to
3636 hold the result. */
3637
3638 static void
gfc_conv_concat_op(gfc_se * se,gfc_expr * expr)3639 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3640 {
3641 gfc_se lse, rse;
3642 tree len, type, var, tmp, fndecl;
3643
3644 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3645 && expr->value.op.op2->ts.type == BT_CHARACTER);
3646 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3647
3648 gfc_init_se (&lse, se);
3649 gfc_conv_expr (&lse, expr->value.op.op1);
3650 gfc_conv_string_parameter (&lse);
3651 gfc_init_se (&rse, se);
3652 gfc_conv_expr (&rse, expr->value.op.op2);
3653 gfc_conv_string_parameter (&rse);
3654
3655 gfc_add_block_to_block (&se->pre, &lse.pre);
3656 gfc_add_block_to_block (&se->pre, &rse.pre);
3657
3658 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3659 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3660 if (len == NULL_TREE)
3661 {
3662 len = fold_build2_loc (input_location, PLUS_EXPR,
3663 gfc_charlen_type_node,
3664 fold_convert (gfc_charlen_type_node,
3665 lse.string_length),
3666 fold_convert (gfc_charlen_type_node,
3667 rse.string_length));
3668 }
3669
3670 type = build_pointer_type (type);
3671
3672 var = gfc_conv_string_tmp (se, type, len);
3673
3674 /* Do the actual concatenation. */
3675 if (expr->ts.kind == 1)
3676 fndecl = gfor_fndecl_concat_string;
3677 else if (expr->ts.kind == 4)
3678 fndecl = gfor_fndecl_concat_string_char4;
3679 else
3680 gcc_unreachable ();
3681
3682 tmp = build_call_expr_loc (input_location,
3683 fndecl, 6, len, var, lse.string_length, lse.expr,
3684 rse.string_length, rse.expr);
3685 gfc_add_expr_to_block (&se->pre, tmp);
3686
3687 /* Add the cleanup for the operands. */
3688 gfc_add_block_to_block (&se->pre, &rse.post);
3689 gfc_add_block_to_block (&se->pre, &lse.post);
3690
3691 se->expr = var;
3692 se->string_length = len;
3693 }
3694
3695 /* Translates an op expression. Common (binary) cases are handled by this
3696 function, others are passed on. Recursion is used in either case.
3697 We use the fact that (op1.ts == op2.ts) (except for the power
3698 operator **).
3699 Operators need no special handling for scalarized expressions as long as
3700 they call gfc_conv_simple_val to get their operands.
3701 Character strings get special handling. */
3702
3703 static void
gfc_conv_expr_op(gfc_se * se,gfc_expr * expr)3704 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3705 {
3706 enum tree_code code;
3707 gfc_se lse;
3708 gfc_se rse;
3709 tree tmp, type;
3710 int lop;
3711 int checkstring;
3712
3713 checkstring = 0;
3714 lop = 0;
3715 switch (expr->value.op.op)
3716 {
3717 case INTRINSIC_PARENTHESES:
3718 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3719 && flag_protect_parens)
3720 {
3721 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3722 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3723 return;
3724 }
3725
3726 /* Fallthrough. */
3727 case INTRINSIC_UPLUS:
3728 gfc_conv_expr (se, expr->value.op.op1);
3729 return;
3730
3731 case INTRINSIC_UMINUS:
3732 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3733 return;
3734
3735 case INTRINSIC_NOT:
3736 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3737 return;
3738
3739 case INTRINSIC_PLUS:
3740 code = PLUS_EXPR;
3741 break;
3742
3743 case INTRINSIC_MINUS:
3744 code = MINUS_EXPR;
3745 break;
3746
3747 case INTRINSIC_TIMES:
3748 code = MULT_EXPR;
3749 break;
3750
3751 case INTRINSIC_DIVIDE:
3752 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3753 an integer, we must round towards zero, so we use a
3754 TRUNC_DIV_EXPR. */
3755 if (expr->ts.type == BT_INTEGER)
3756 code = TRUNC_DIV_EXPR;
3757 else
3758 code = RDIV_EXPR;
3759 break;
3760
3761 case INTRINSIC_POWER:
3762 gfc_conv_power_op (se, expr);
3763 return;
3764
3765 case INTRINSIC_CONCAT:
3766 gfc_conv_concat_op (se, expr);
3767 return;
3768
3769 case INTRINSIC_AND:
3770 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3771 lop = 1;
3772 break;
3773
3774 case INTRINSIC_OR:
3775 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3776 lop = 1;
3777 break;
3778
3779 /* EQV and NEQV only work on logicals, but since we represent them
3780 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3781 case INTRINSIC_EQ:
3782 case INTRINSIC_EQ_OS:
3783 case INTRINSIC_EQV:
3784 code = EQ_EXPR;
3785 checkstring = 1;
3786 lop = 1;
3787 break;
3788
3789 case INTRINSIC_NE:
3790 case INTRINSIC_NE_OS:
3791 case INTRINSIC_NEQV:
3792 code = NE_EXPR;
3793 checkstring = 1;
3794 lop = 1;
3795 break;
3796
3797 case INTRINSIC_GT:
3798 case INTRINSIC_GT_OS:
3799 code = GT_EXPR;
3800 checkstring = 1;
3801 lop = 1;
3802 break;
3803
3804 case INTRINSIC_GE:
3805 case INTRINSIC_GE_OS:
3806 code = GE_EXPR;
3807 checkstring = 1;
3808 lop = 1;
3809 break;
3810
3811 case INTRINSIC_LT:
3812 case INTRINSIC_LT_OS:
3813 code = LT_EXPR;
3814 checkstring = 1;
3815 lop = 1;
3816 break;
3817
3818 case INTRINSIC_LE:
3819 case INTRINSIC_LE_OS:
3820 code = LE_EXPR;
3821 checkstring = 1;
3822 lop = 1;
3823 break;
3824
3825 case INTRINSIC_USER:
3826 case INTRINSIC_ASSIGN:
3827 /* These should be converted into function calls by the frontend. */
3828 gcc_unreachable ();
3829
3830 default:
3831 fatal_error (input_location, "Unknown intrinsic op");
3832 return;
3833 }
3834
3835 /* The only exception to this is **, which is handled separately anyway. */
3836 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3837
3838 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3839 checkstring = 0;
3840
3841 /* lhs */
3842 gfc_init_se (&lse, se);
3843 gfc_conv_expr (&lse, expr->value.op.op1);
3844 gfc_add_block_to_block (&se->pre, &lse.pre);
3845
3846 /* rhs */
3847 gfc_init_se (&rse, se);
3848 gfc_conv_expr (&rse, expr->value.op.op2);
3849 gfc_add_block_to_block (&se->pre, &rse.pre);
3850
3851 if (checkstring)
3852 {
3853 gfc_conv_string_parameter (&lse);
3854 gfc_conv_string_parameter (&rse);
3855
3856 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3857 rse.string_length, rse.expr,
3858 expr->value.op.op1->ts.kind,
3859 code);
3860 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3861 gfc_add_block_to_block (&lse.post, &rse.post);
3862 }
3863
3864 type = gfc_typenode_for_spec (&expr->ts);
3865
3866 if (lop)
3867 {
3868 /* The result of logical ops is always logical_type_node. */
3869 tmp = fold_build2_loc (input_location, code, logical_type_node,
3870 lse.expr, rse.expr);
3871 se->expr = convert (type, tmp);
3872 }
3873 else
3874 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3875
3876 /* Add the post blocks. */
3877 gfc_add_block_to_block (&se->post, &rse.post);
3878 gfc_add_block_to_block (&se->post, &lse.post);
3879 }
3880
3881 /* If a string's length is one, we convert it to a single character. */
3882
3883 tree
gfc_string_to_single_character(tree len,tree str,int kind)3884 gfc_string_to_single_character (tree len, tree str, int kind)
3885 {
3886
3887 if (len == NULL
3888 || !tree_fits_uhwi_p (len)
3889 || !POINTER_TYPE_P (TREE_TYPE (str)))
3890 return NULL_TREE;
3891
3892 if (TREE_INT_CST_LOW (len) == 1)
3893 {
3894 str = fold_convert (gfc_get_pchar_type (kind), str);
3895 return build_fold_indirect_ref_loc (input_location, str);
3896 }
3897
3898 if (kind == 1
3899 && TREE_CODE (str) == ADDR_EXPR
3900 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3901 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3902 && array_ref_low_bound (TREE_OPERAND (str, 0))
3903 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3904 && TREE_INT_CST_LOW (len) > 1
3905 && TREE_INT_CST_LOW (len)
3906 == (unsigned HOST_WIDE_INT)
3907 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3908 {
3909 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3910 ret = build_fold_indirect_ref_loc (input_location, ret);
3911 if (TREE_CODE (ret) == INTEGER_CST)
3912 {
3913 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3914 int i, length = TREE_STRING_LENGTH (string_cst);
3915 const char *ptr = TREE_STRING_POINTER (string_cst);
3916
3917 for (i = 1; i < length; i++)
3918 if (ptr[i] != ' ')
3919 return NULL_TREE;
3920
3921 return ret;
3922 }
3923 }
3924
3925 return NULL_TREE;
3926 }
3927
3928
3929 void
gfc_conv_scalar_char_value(gfc_symbol * sym,gfc_se * se,gfc_expr ** expr)3930 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3931 {
3932
3933 if (sym->backend_decl)
3934 {
3935 /* This becomes the nominal_type in
3936 function.c:assign_parm_find_data_types. */
3937 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3938 /* This becomes the passed_type in
3939 function.c:assign_parm_find_data_types. C promotes char to
3940 integer for argument passing. */
3941 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3942
3943 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3944 }
3945
3946 if (expr != NULL)
3947 {
3948 /* If we have a constant character expression, make it into an
3949 integer. */
3950 if ((*expr)->expr_type == EXPR_CONSTANT)
3951 {
3952 gfc_typespec ts;
3953 gfc_clear_ts (&ts);
3954
3955 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3956 (int)(*expr)->value.character.string[0]);
3957 if ((*expr)->ts.kind != gfc_c_int_kind)
3958 {
3959 /* The expr needs to be compatible with a C int. If the
3960 conversion fails, then the 2 causes an ICE. */
3961 ts.type = BT_INTEGER;
3962 ts.kind = gfc_c_int_kind;
3963 gfc_convert_type (*expr, &ts, 2);
3964 }
3965 }
3966 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3967 {
3968 if ((*expr)->ref == NULL)
3969 {
3970 se->expr = gfc_string_to_single_character
3971 (build_int_cst (integer_type_node, 1),
3972 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3973 gfc_get_symbol_decl
3974 ((*expr)->symtree->n.sym)),
3975 (*expr)->ts.kind);
3976 }
3977 else
3978 {
3979 gfc_conv_variable (se, *expr);
3980 se->expr = gfc_string_to_single_character
3981 (build_int_cst (integer_type_node, 1),
3982 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3983 se->expr),
3984 (*expr)->ts.kind);
3985 }
3986 }
3987 }
3988 }
3989
3990 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3991 if STR is a string literal, otherwise return -1. */
3992
3993 static int
gfc_optimize_len_trim(tree len,tree str,int kind)3994 gfc_optimize_len_trim (tree len, tree str, int kind)
3995 {
3996 if (kind == 1
3997 && TREE_CODE (str) == ADDR_EXPR
3998 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3999 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
4000 && array_ref_low_bound (TREE_OPERAND (str, 0))
4001 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
4002 && tree_fits_uhwi_p (len)
4003 && tree_to_uhwi (len) >= 1
4004 && tree_to_uhwi (len)
4005 == (unsigned HOST_WIDE_INT)
4006 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
4007 {
4008 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
4009 folded = build_fold_indirect_ref_loc (input_location, folded);
4010 if (TREE_CODE (folded) == INTEGER_CST)
4011 {
4012 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
4013 int length = TREE_STRING_LENGTH (string_cst);
4014 const char *ptr = TREE_STRING_POINTER (string_cst);
4015
4016 for (; length > 0; length--)
4017 if (ptr[length - 1] != ' ')
4018 break;
4019
4020 return length;
4021 }
4022 }
4023 return -1;
4024 }
4025
4026 /* Helper to build a call to memcmp. */
4027
4028 static tree
build_memcmp_call(tree s1,tree s2,tree n)4029 build_memcmp_call (tree s1, tree s2, tree n)
4030 {
4031 tree tmp;
4032
4033 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
4034 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
4035 else
4036 s1 = fold_convert (pvoid_type_node, s1);
4037
4038 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
4039 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
4040 else
4041 s2 = fold_convert (pvoid_type_node, s2);
4042
4043 n = fold_convert (size_type_node, n);
4044
4045 tmp = build_call_expr_loc (input_location,
4046 builtin_decl_explicit (BUILT_IN_MEMCMP),
4047 3, s1, s2, n);
4048
4049 return fold_convert (integer_type_node, tmp);
4050 }
4051
4052 /* Compare two strings. If they are all single characters, the result is the
4053 subtraction of them. Otherwise, we build a library call. */
4054
4055 tree
gfc_build_compare_string(tree len1,tree str1,tree len2,tree str2,int kind,enum tree_code code)4056 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
4057 enum tree_code code)
4058 {
4059 tree sc1;
4060 tree sc2;
4061 tree fndecl;
4062
4063 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
4064 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
4065
4066 sc1 = gfc_string_to_single_character (len1, str1, kind);
4067 sc2 = gfc_string_to_single_character (len2, str2, kind);
4068
4069 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
4070 {
4071 /* Deal with single character specially. */
4072 sc1 = fold_convert (integer_type_node, sc1);
4073 sc2 = fold_convert (integer_type_node, sc2);
4074 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4075 sc1, sc2);
4076 }
4077
4078 if ((code == EQ_EXPR || code == NE_EXPR)
4079 && optimize
4080 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
4081 {
4082 /* If one string is a string literal with LEN_TRIM longer
4083 than the length of the second string, the strings
4084 compare unequal. */
4085 int len = gfc_optimize_len_trim (len1, str1, kind);
4086 if (len > 0 && compare_tree_int (len2, len) < 0)
4087 return integer_one_node;
4088 len = gfc_optimize_len_trim (len2, str2, kind);
4089 if (len > 0 && compare_tree_int (len1, len) < 0)
4090 return integer_one_node;
4091 }
4092
4093 /* We can compare via memcpy if the strings are known to be equal
4094 in length and they are
4095 - kind=1
4096 - kind=4 and the comparison is for (in)equality. */
4097
4098 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
4099 && tree_int_cst_equal (len1, len2)
4100 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
4101 {
4102 tree tmp;
4103 tree chartype;
4104
4105 chartype = gfc_get_char_type (kind);
4106 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
4107 fold_convert (TREE_TYPE(len1),
4108 TYPE_SIZE_UNIT(chartype)),
4109 len1);
4110 return build_memcmp_call (str1, str2, tmp);
4111 }
4112
4113 /* Build a call for the comparison. */
4114 if (kind == 1)
4115 fndecl = gfor_fndecl_compare_string;
4116 else if (kind == 4)
4117 fndecl = gfor_fndecl_compare_string_char4;
4118 else
4119 gcc_unreachable ();
4120
4121 return build_call_expr_loc (input_location, fndecl, 4,
4122 len1, str1, len2, str2);
4123 }
4124
4125
4126 /* Return the backend_decl for a procedure pointer component. */
4127
4128 static tree
get_proc_ptr_comp(gfc_expr * e)4129 get_proc_ptr_comp (gfc_expr *e)
4130 {
4131 gfc_se comp_se;
4132 gfc_expr *e2;
4133 expr_t old_type;
4134
4135 gfc_init_se (&comp_se, NULL);
4136 e2 = gfc_copy_expr (e);
4137 /* We have to restore the expr type later so that gfc_free_expr frees
4138 the exact same thing that was allocated.
4139 TODO: This is ugly. */
4140 old_type = e2->expr_type;
4141 e2->expr_type = EXPR_VARIABLE;
4142 gfc_conv_expr (&comp_se, e2);
4143 e2->expr_type = old_type;
4144 gfc_free_expr (e2);
4145 return build_fold_addr_expr_loc (input_location, comp_se.expr);
4146 }
4147
4148
4149 /* Convert a typebound function reference from a class object. */
4150 static void
conv_base_obj_fcn_val(gfc_se * se,tree base_object,gfc_expr * expr)4151 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
4152 {
4153 gfc_ref *ref;
4154 tree var;
4155
4156 if (!VAR_P (base_object))
4157 {
4158 var = gfc_create_var (TREE_TYPE (base_object), NULL);
4159 gfc_add_modify (&se->pre, var, base_object);
4160 }
4161 se->expr = gfc_class_vptr_get (base_object);
4162 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
4163 ref = expr->ref;
4164 while (ref && ref->next)
4165 ref = ref->next;
4166 gcc_assert (ref && ref->type == REF_COMPONENT);
4167 if (ref->u.c.sym->attr.extension)
4168 conv_parent_component_references (se, ref);
4169 gfc_conv_component_ref (se, ref);
4170 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
4171 }
4172
4173
4174 static void
conv_function_val(gfc_se * se,gfc_symbol * sym,gfc_expr * expr,gfc_actual_arglist * actual_args)4175 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
4176 gfc_actual_arglist *actual_args)
4177 {
4178 tree tmp;
4179
4180 if (gfc_is_proc_ptr_comp (expr))
4181 tmp = get_proc_ptr_comp (expr);
4182 else if (sym->attr.dummy)
4183 {
4184 tmp = gfc_get_symbol_decl (sym);
4185 if (sym->attr.proc_pointer)
4186 tmp = build_fold_indirect_ref_loc (input_location,
4187 tmp);
4188 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
4189 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
4190 }
4191 else
4192 {
4193 if (!sym->backend_decl)
4194 sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
4195
4196 TREE_USED (sym->backend_decl) = 1;
4197
4198 tmp = sym->backend_decl;
4199
4200 if (sym->attr.cray_pointee)
4201 {
4202 /* TODO - make the cray pointee a pointer to a procedure,
4203 assign the pointer to it and use it for the call. This
4204 will do for now! */
4205 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
4206 gfc_get_symbol_decl (sym->cp_pointer));
4207 tmp = gfc_evaluate_now (tmp, &se->pre);
4208 }
4209
4210 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
4211 {
4212 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
4213 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
4214 }
4215 }
4216 se->expr = tmp;
4217 }
4218
4219
4220 /* Initialize MAPPING. */
4221
4222 void
gfc_init_interface_mapping(gfc_interface_mapping * mapping)4223 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
4224 {
4225 mapping->syms = NULL;
4226 mapping->charlens = NULL;
4227 }
4228
4229
4230 /* Free all memory held by MAPPING (but not MAPPING itself). */
4231
4232 void
gfc_free_interface_mapping(gfc_interface_mapping * mapping)4233 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
4234 {
4235 gfc_interface_sym_mapping *sym;
4236 gfc_interface_sym_mapping *nextsym;
4237 gfc_charlen *cl;
4238 gfc_charlen *nextcl;
4239
4240 for (sym = mapping->syms; sym; sym = nextsym)
4241 {
4242 nextsym = sym->next;
4243 sym->new_sym->n.sym->formal = NULL;
4244 gfc_free_symbol (sym->new_sym->n.sym);
4245 gfc_free_expr (sym->expr);
4246 free (sym->new_sym);
4247 free (sym);
4248 }
4249 for (cl = mapping->charlens; cl; cl = nextcl)
4250 {
4251 nextcl = cl->next;
4252 gfc_free_expr (cl->length);
4253 free (cl);
4254 }
4255 }
4256
4257
4258 /* Return a copy of gfc_charlen CL. Add the returned structure to
4259 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4260
4261 static gfc_charlen *
gfc_get_interface_mapping_charlen(gfc_interface_mapping * mapping,gfc_charlen * cl)4262 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4263 gfc_charlen * cl)
4264 {
4265 gfc_charlen *new_charlen;
4266
4267 new_charlen = gfc_get_charlen ();
4268 new_charlen->next = mapping->charlens;
4269 new_charlen->length = gfc_copy_expr (cl->length);
4270
4271 mapping->charlens = new_charlen;
4272 return new_charlen;
4273 }
4274
4275
4276 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4277 array variable that can be used as the actual argument for dummy
4278 argument SYM. Add any initialization code to BLOCK. PACKED is as
4279 for gfc_get_nodesc_array_type and DATA points to the first element
4280 in the passed array. */
4281
4282 static tree
gfc_get_interface_mapping_array(stmtblock_t * block,gfc_symbol * sym,gfc_packed packed,tree data)4283 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4284 gfc_packed packed, tree data)
4285 {
4286 tree type;
4287 tree var;
4288
4289 type = gfc_typenode_for_spec (&sym->ts);
4290 type = gfc_get_nodesc_array_type (type, sym->as, packed,
4291 !sym->attr.target && !sym->attr.pointer
4292 && !sym->attr.proc_pointer);
4293
4294 var = gfc_create_var (type, "ifm");
4295 gfc_add_modify (block, var, fold_convert (type, data));
4296
4297 return var;
4298 }
4299
4300
4301 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4302 and offset of descriptorless array type TYPE given that it has the same
4303 size as DESC. Add any set-up code to BLOCK. */
4304
4305 static void
gfc_set_interface_mapping_bounds(stmtblock_t * block,tree type,tree desc)4306 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4307 {
4308 int n;
4309 tree dim;
4310 tree offset;
4311 tree tmp;
4312
4313 offset = gfc_index_zero_node;
4314 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4315 {
4316 dim = gfc_rank_cst[n];
4317 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4318 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4319 {
4320 GFC_TYPE_ARRAY_LBOUND (type, n)
4321 = gfc_conv_descriptor_lbound_get (desc, dim);
4322 GFC_TYPE_ARRAY_UBOUND (type, n)
4323 = gfc_conv_descriptor_ubound_get (desc, dim);
4324 }
4325 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4326 {
4327 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4328 gfc_array_index_type,
4329 gfc_conv_descriptor_ubound_get (desc, dim),
4330 gfc_conv_descriptor_lbound_get (desc, dim));
4331 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4332 gfc_array_index_type,
4333 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4334 tmp = gfc_evaluate_now (tmp, block);
4335 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4336 }
4337 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4338 GFC_TYPE_ARRAY_LBOUND (type, n),
4339 GFC_TYPE_ARRAY_STRIDE (type, n));
4340 offset = fold_build2_loc (input_location, MINUS_EXPR,
4341 gfc_array_index_type, offset, tmp);
4342 }
4343 offset = gfc_evaluate_now (offset, block);
4344 GFC_TYPE_ARRAY_OFFSET (type) = offset;
4345 }
4346
4347
4348 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4349 in SE. The caller may still use se->expr and se->string_length after
4350 calling this function. */
4351
4352 void
gfc_add_interface_mapping(gfc_interface_mapping * mapping,gfc_symbol * sym,gfc_se * se,gfc_expr * expr)4353 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4354 gfc_symbol * sym, gfc_se * se,
4355 gfc_expr *expr)
4356 {
4357 gfc_interface_sym_mapping *sm;
4358 tree desc;
4359 tree tmp;
4360 tree value;
4361 gfc_symbol *new_sym;
4362 gfc_symtree *root;
4363 gfc_symtree *new_symtree;
4364
4365 /* Create a new symbol to represent the actual argument. */
4366 new_sym = gfc_new_symbol (sym->name, NULL);
4367 new_sym->ts = sym->ts;
4368 new_sym->as = gfc_copy_array_spec (sym->as);
4369 new_sym->attr.referenced = 1;
4370 new_sym->attr.dimension = sym->attr.dimension;
4371 new_sym->attr.contiguous = sym->attr.contiguous;
4372 new_sym->attr.codimension = sym->attr.codimension;
4373 new_sym->attr.pointer = sym->attr.pointer;
4374 new_sym->attr.allocatable = sym->attr.allocatable;
4375 new_sym->attr.flavor = sym->attr.flavor;
4376 new_sym->attr.function = sym->attr.function;
4377
4378 /* Ensure that the interface is available and that
4379 descriptors are passed for array actual arguments. */
4380 if (sym->attr.flavor == FL_PROCEDURE)
4381 {
4382 new_sym->formal = expr->symtree->n.sym->formal;
4383 new_sym->attr.always_explicit
4384 = expr->symtree->n.sym->attr.always_explicit;
4385 }
4386
4387 /* Create a fake symtree for it. */
4388 root = NULL;
4389 new_symtree = gfc_new_symtree (&root, sym->name);
4390 new_symtree->n.sym = new_sym;
4391 gcc_assert (new_symtree == root);
4392
4393 /* Create a dummy->actual mapping. */
4394 sm = XCNEW (gfc_interface_sym_mapping);
4395 sm->next = mapping->syms;
4396 sm->old = sym;
4397 sm->new_sym = new_symtree;
4398 sm->expr = gfc_copy_expr (expr);
4399 mapping->syms = sm;
4400
4401 /* Stabilize the argument's value. */
4402 if (!sym->attr.function && se)
4403 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4404
4405 if (sym->ts.type == BT_CHARACTER)
4406 {
4407 /* Create a copy of the dummy argument's length. */
4408 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4409 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4410
4411 /* If the length is specified as "*", record the length that
4412 the caller is passing. We should use the callee's length
4413 in all other cases. */
4414 if (!new_sym->ts.u.cl->length && se)
4415 {
4416 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4417 new_sym->ts.u.cl->backend_decl = se->string_length;
4418 }
4419 }
4420
4421 if (!se)
4422 return;
4423
4424 /* Use the passed value as-is if the argument is a function. */
4425 if (sym->attr.flavor == FL_PROCEDURE)
4426 value = se->expr;
4427
4428 /* If the argument is a pass-by-value scalar, use the value as is. */
4429 else if (!sym->attr.dimension && sym->attr.value)
4430 value = se->expr;
4431
4432 /* If the argument is either a string or a pointer to a string,
4433 convert it to a boundless character type. */
4434 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4435 {
4436 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4437 tmp = build_pointer_type (tmp);
4438 if (sym->attr.pointer)
4439 value = build_fold_indirect_ref_loc (input_location,
4440 se->expr);
4441 else
4442 value = se->expr;
4443 value = fold_convert (tmp, value);
4444 }
4445
4446 /* If the argument is a scalar, a pointer to an array or an allocatable,
4447 dereference it. */
4448 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4449 value = build_fold_indirect_ref_loc (input_location,
4450 se->expr);
4451
4452 /* For character(*), use the actual argument's descriptor. */
4453 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4454 value = build_fold_indirect_ref_loc (input_location,
4455 se->expr);
4456
4457 /* If the argument is an array descriptor, use it to determine
4458 information about the actual argument's shape. */
4459 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4460 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4461 {
4462 /* Get the actual argument's descriptor. */
4463 desc = build_fold_indirect_ref_loc (input_location,
4464 se->expr);
4465
4466 /* Create the replacement variable. */
4467 tmp = gfc_conv_descriptor_data_get (desc);
4468 value = gfc_get_interface_mapping_array (&se->pre, sym,
4469 PACKED_NO, tmp);
4470
4471 /* Use DESC to work out the upper bounds, strides and offset. */
4472 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4473 }
4474 else
4475 /* Otherwise we have a packed array. */
4476 value = gfc_get_interface_mapping_array (&se->pre, sym,
4477 PACKED_FULL, se->expr);
4478
4479 new_sym->backend_decl = value;
4480 }
4481
4482
4483 /* Called once all dummy argument mappings have been added to MAPPING,
4484 but before the mapping is used to evaluate expressions. Pre-evaluate
4485 the length of each argument, adding any initialization code to PRE and
4486 any finalization code to POST. */
4487
4488 void
gfc_finish_interface_mapping(gfc_interface_mapping * mapping,stmtblock_t * pre,stmtblock_t * post)4489 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4490 stmtblock_t * pre, stmtblock_t * post)
4491 {
4492 gfc_interface_sym_mapping *sym;
4493 gfc_expr *expr;
4494 gfc_se se;
4495
4496 for (sym = mapping->syms; sym; sym = sym->next)
4497 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4498 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4499 {
4500 expr = sym->new_sym->n.sym->ts.u.cl->length;
4501 gfc_apply_interface_mapping_to_expr (mapping, expr);
4502 gfc_init_se (&se, NULL);
4503 gfc_conv_expr (&se, expr);
4504 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4505 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4506 gfc_add_block_to_block (pre, &se.pre);
4507 gfc_add_block_to_block (post, &se.post);
4508
4509 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4510 }
4511 }
4512
4513
4514 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4515 constructor C. */
4516
4517 static void
gfc_apply_interface_mapping_to_cons(gfc_interface_mapping * mapping,gfc_constructor_base base)4518 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4519 gfc_constructor_base base)
4520 {
4521 gfc_constructor *c;
4522 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4523 {
4524 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4525 if (c->iterator)
4526 {
4527 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4528 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4529 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4530 }
4531 }
4532 }
4533
4534
4535 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4536 reference REF. */
4537
4538 static void
gfc_apply_interface_mapping_to_ref(gfc_interface_mapping * mapping,gfc_ref * ref)4539 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4540 gfc_ref * ref)
4541 {
4542 int n;
4543
4544 for (; ref; ref = ref->next)
4545 switch (ref->type)
4546 {
4547 case REF_ARRAY:
4548 for (n = 0; n < ref->u.ar.dimen; n++)
4549 {
4550 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4551 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4552 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4553 }
4554 break;
4555
4556 case REF_COMPONENT:
4557 case REF_INQUIRY:
4558 break;
4559
4560 case REF_SUBSTRING:
4561 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4562 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4563 break;
4564 }
4565 }
4566
4567
4568 /* Convert intrinsic function calls into result expressions. */
4569
4570 static bool
gfc_map_intrinsic_function(gfc_expr * expr,gfc_interface_mapping * mapping)4571 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4572 {
4573 gfc_symbol *sym;
4574 gfc_expr *new_expr;
4575 gfc_expr *arg1;
4576 gfc_expr *arg2;
4577 int d, dup;
4578
4579 arg1 = expr->value.function.actual->expr;
4580 if (expr->value.function.actual->next)
4581 arg2 = expr->value.function.actual->next->expr;
4582 else
4583 arg2 = NULL;
4584
4585 sym = arg1->symtree->n.sym;
4586
4587 if (sym->attr.dummy)
4588 return false;
4589
4590 new_expr = NULL;
4591
4592 switch (expr->value.function.isym->id)
4593 {
4594 case GFC_ISYM_LEN:
4595 /* TODO figure out why this condition is necessary. */
4596 if (sym->attr.function
4597 && (arg1->ts.u.cl->length == NULL
4598 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4599 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4600 return false;
4601
4602 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4603 break;
4604
4605 case GFC_ISYM_LEN_TRIM:
4606 new_expr = gfc_copy_expr (arg1);
4607 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4608
4609 if (!new_expr)
4610 return false;
4611
4612 gfc_replace_expr (arg1, new_expr);
4613 return true;
4614
4615 case GFC_ISYM_SIZE:
4616 if (!sym->as || sym->as->rank == 0)
4617 return false;
4618
4619 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4620 {
4621 dup = mpz_get_si (arg2->value.integer);
4622 d = dup - 1;
4623 }
4624 else
4625 {
4626 dup = sym->as->rank;
4627 d = 0;
4628 }
4629
4630 for (; d < dup; d++)
4631 {
4632 gfc_expr *tmp;
4633
4634 if (!sym->as->upper[d] || !sym->as->lower[d])
4635 {
4636 gfc_free_expr (new_expr);
4637 return false;
4638 }
4639
4640 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4641 gfc_get_int_expr (gfc_default_integer_kind,
4642 NULL, 1));
4643 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4644 if (new_expr)
4645 new_expr = gfc_multiply (new_expr, tmp);
4646 else
4647 new_expr = tmp;
4648 }
4649 break;
4650
4651 case GFC_ISYM_LBOUND:
4652 case GFC_ISYM_UBOUND:
4653 /* TODO These implementations of lbound and ubound do not limit if
4654 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4655
4656 if (!sym->as || sym->as->rank == 0)
4657 return false;
4658
4659 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4660 d = mpz_get_si (arg2->value.integer) - 1;
4661 else
4662 return false;
4663
4664 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4665 {
4666 if (sym->as->lower[d])
4667 new_expr = gfc_copy_expr (sym->as->lower[d]);
4668 }
4669 else
4670 {
4671 if (sym->as->upper[d])
4672 new_expr = gfc_copy_expr (sym->as->upper[d]);
4673 }
4674 break;
4675
4676 default:
4677 break;
4678 }
4679
4680 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4681 if (!new_expr)
4682 return false;
4683
4684 gfc_replace_expr (expr, new_expr);
4685 return true;
4686 }
4687
4688
4689 static void
gfc_map_fcn_formal_to_actual(gfc_expr * expr,gfc_expr * map_expr,gfc_interface_mapping * mapping)4690 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4691 gfc_interface_mapping * mapping)
4692 {
4693 gfc_formal_arglist *f;
4694 gfc_actual_arglist *actual;
4695
4696 actual = expr->value.function.actual;
4697 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4698
4699 for (; f && actual; f = f->next, actual = actual->next)
4700 {
4701 if (!actual->expr)
4702 continue;
4703
4704 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4705 }
4706
4707 if (map_expr->symtree->n.sym->attr.dimension)
4708 {
4709 int d;
4710 gfc_array_spec *as;
4711
4712 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4713
4714 for (d = 0; d < as->rank; d++)
4715 {
4716 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4717 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4718 }
4719
4720 expr->value.function.esym->as = as;
4721 }
4722
4723 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4724 {
4725 expr->value.function.esym->ts.u.cl->length
4726 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4727
4728 gfc_apply_interface_mapping_to_expr (mapping,
4729 expr->value.function.esym->ts.u.cl->length);
4730 }
4731 }
4732
4733
4734 /* EXPR is a copy of an expression that appeared in the interface
4735 associated with MAPPING. Walk it recursively looking for references to
4736 dummy arguments that MAPPING maps to actual arguments. Replace each such
4737 reference with a reference to the associated actual argument. */
4738
4739 static void
gfc_apply_interface_mapping_to_expr(gfc_interface_mapping * mapping,gfc_expr * expr)4740 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4741 gfc_expr * expr)
4742 {
4743 gfc_interface_sym_mapping *sym;
4744 gfc_actual_arglist *actual;
4745
4746 if (!expr)
4747 return;
4748
4749 /* Copying an expression does not copy its length, so do that here. */
4750 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4751 {
4752 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4753 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4754 }
4755
4756 /* Apply the mapping to any references. */
4757 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4758
4759 /* ...and to the expression's symbol, if it has one. */
4760 /* TODO Find out why the condition on expr->symtree had to be moved into
4761 the loop rather than being outside it, as originally. */
4762 for (sym = mapping->syms; sym; sym = sym->next)
4763 if (expr->symtree && sym->old == expr->symtree->n.sym)
4764 {
4765 if (sym->new_sym->n.sym->backend_decl)
4766 expr->symtree = sym->new_sym;
4767 else if (sym->expr)
4768 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4769 }
4770
4771 /* ...and to subexpressions in expr->value. */
4772 switch (expr->expr_type)
4773 {
4774 case EXPR_VARIABLE:
4775 case EXPR_CONSTANT:
4776 case EXPR_NULL:
4777 case EXPR_SUBSTRING:
4778 break;
4779
4780 case EXPR_OP:
4781 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4782 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4783 break;
4784
4785 case EXPR_FUNCTION:
4786 for (actual = expr->value.function.actual; actual; actual = actual->next)
4787 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4788
4789 if (expr->value.function.esym == NULL
4790 && expr->value.function.isym != NULL
4791 && expr->value.function.actual
4792 && expr->value.function.actual->expr
4793 && expr->value.function.actual->expr->symtree
4794 && gfc_map_intrinsic_function (expr, mapping))
4795 break;
4796
4797 for (sym = mapping->syms; sym; sym = sym->next)
4798 if (sym->old == expr->value.function.esym)
4799 {
4800 expr->value.function.esym = sym->new_sym->n.sym;
4801 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4802 expr->value.function.esym->result = sym->new_sym->n.sym;
4803 }
4804 break;
4805
4806 case EXPR_ARRAY:
4807 case EXPR_STRUCTURE:
4808 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4809 break;
4810
4811 case EXPR_COMPCALL:
4812 case EXPR_PPC:
4813 case EXPR_UNKNOWN:
4814 gcc_unreachable ();
4815 break;
4816 }
4817
4818 return;
4819 }
4820
4821
4822 /* Evaluate interface expression EXPR using MAPPING. Store the result
4823 in SE. */
4824
4825 void
gfc_apply_interface_mapping(gfc_interface_mapping * mapping,gfc_se * se,gfc_expr * expr)4826 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4827 gfc_se * se, gfc_expr * expr)
4828 {
4829 expr = gfc_copy_expr (expr);
4830 gfc_apply_interface_mapping_to_expr (mapping, expr);
4831 gfc_conv_expr (se, expr);
4832 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4833 gfc_free_expr (expr);
4834 }
4835
4836
4837 /* Returns a reference to a temporary array into which a component of
4838 an actual argument derived type array is copied and then returned
4839 after the function call. */
4840 void
gfc_conv_subref_array_arg(gfc_se * se,gfc_expr * expr,int g77,sym_intent intent,bool formal_ptr,const gfc_symbol * fsym,const char * proc_name,gfc_symbol * sym,bool check_contiguous)4841 gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
4842 sym_intent intent, bool formal_ptr,
4843 const gfc_symbol *fsym, const char *proc_name,
4844 gfc_symbol *sym, bool check_contiguous)
4845 {
4846 gfc_se lse;
4847 gfc_se rse;
4848 gfc_ss *lss;
4849 gfc_ss *rss;
4850 gfc_loopinfo loop;
4851 gfc_loopinfo loop2;
4852 gfc_array_info *info;
4853 tree offset;
4854 tree tmp_index;
4855 tree tmp;
4856 tree base_type;
4857 tree size;
4858 stmtblock_t body;
4859 int n;
4860 int dimen;
4861 gfc_se work_se;
4862 gfc_se *parmse;
4863 bool pass_optional;
4864
4865 pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
4866
4867 if (pass_optional || check_contiguous)
4868 {
4869 gfc_init_se (&work_se, NULL);
4870 parmse = &work_se;
4871 }
4872 else
4873 parmse = se;
4874
4875 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
4876 {
4877 /* We will create a temporary array, so let us warn. */
4878 char * msg;
4879
4880 if (fsym && proc_name)
4881 msg = xasprintf ("An array temporary was created for argument "
4882 "'%s' of procedure '%s'", fsym->name, proc_name);
4883 else
4884 msg = xasprintf ("An array temporary was created");
4885
4886 tmp = build_int_cst (logical_type_node, 1);
4887 gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
4888 &expr->where, msg);
4889 free (msg);
4890 }
4891
4892 gfc_init_se (&lse, NULL);
4893 gfc_init_se (&rse, NULL);
4894
4895 /* Walk the argument expression. */
4896 rss = gfc_walk_expr (expr);
4897
4898 gcc_assert (rss != gfc_ss_terminator);
4899
4900 /* Initialize the scalarizer. */
4901 gfc_init_loopinfo (&loop);
4902 gfc_add_ss_to_loop (&loop, rss);
4903
4904 /* Calculate the bounds of the scalarization. */
4905 gfc_conv_ss_startstride (&loop);
4906
4907 /* Build an ss for the temporary. */
4908 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4909 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4910
4911 base_type = gfc_typenode_for_spec (&expr->ts);
4912 if (GFC_ARRAY_TYPE_P (base_type)
4913 || GFC_DESCRIPTOR_TYPE_P (base_type))
4914 base_type = gfc_get_element_type (base_type);
4915
4916 if (expr->ts.type == BT_CLASS)
4917 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4918
4919 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4920 ? expr->ts.u.cl->backend_decl
4921 : NULL),
4922 loop.dimen);
4923
4924 parmse->string_length = loop.temp_ss->info->string_length;
4925
4926 /* Associate the SS with the loop. */
4927 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4928
4929 /* Setup the scalarizing loops. */
4930 gfc_conv_loop_setup (&loop, &expr->where);
4931
4932 /* Pass the temporary descriptor back to the caller. */
4933 info = &loop.temp_ss->info->data.array;
4934 parmse->expr = info->descriptor;
4935
4936 /* Setup the gfc_se structures. */
4937 gfc_copy_loopinfo_to_se (&lse, &loop);
4938 gfc_copy_loopinfo_to_se (&rse, &loop);
4939
4940 rse.ss = rss;
4941 lse.ss = loop.temp_ss;
4942 gfc_mark_ss_chain_used (rss, 1);
4943 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4944
4945 /* Start the scalarized loop body. */
4946 gfc_start_scalarized_body (&loop, &body);
4947
4948 /* Translate the expression. */
4949 gfc_conv_expr (&rse, expr);
4950
4951 /* Reset the offset for the function call since the loop
4952 is zero based on the data pointer. Note that the temp
4953 comes first in the loop chain since it is added second. */
4954 if (gfc_is_class_array_function (expr))
4955 {
4956 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4957 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4958 gfc_index_zero_node);
4959 }
4960
4961 gfc_conv_tmp_array_ref (&lse);
4962
4963 if (intent != INTENT_OUT)
4964 {
4965 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4966 gfc_add_expr_to_block (&body, tmp);
4967 gcc_assert (rse.ss == gfc_ss_terminator);
4968 gfc_trans_scalarizing_loops (&loop, &body);
4969 }
4970 else
4971 {
4972 /* Make sure that the temporary declaration survives by merging
4973 all the loop declarations into the current context. */
4974 for (n = 0; n < loop.dimen; n++)
4975 {
4976 gfc_merge_block_scope (&body);
4977 body = loop.code[loop.order[n]];
4978 }
4979 gfc_merge_block_scope (&body);
4980 }
4981
4982 /* Add the post block after the second loop, so that any
4983 freeing of allocated memory is done at the right time. */
4984 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4985
4986 /**********Copy the temporary back again.*********/
4987
4988 gfc_init_se (&lse, NULL);
4989 gfc_init_se (&rse, NULL);
4990
4991 /* Walk the argument expression. */
4992 lss = gfc_walk_expr (expr);
4993 rse.ss = loop.temp_ss;
4994 lse.ss = lss;
4995
4996 /* Initialize the scalarizer. */
4997 gfc_init_loopinfo (&loop2);
4998 gfc_add_ss_to_loop (&loop2, lss);
4999
5000 dimen = rse.ss->dimen;
5001
5002 /* Skip the write-out loop for this case. */
5003 if (gfc_is_class_array_function (expr))
5004 goto class_array_fcn;
5005
5006 /* Calculate the bounds of the scalarization. */
5007 gfc_conv_ss_startstride (&loop2);
5008
5009 /* Setup the scalarizing loops. */
5010 gfc_conv_loop_setup (&loop2, &expr->where);
5011
5012 gfc_copy_loopinfo_to_se (&lse, &loop2);
5013 gfc_copy_loopinfo_to_se (&rse, &loop2);
5014
5015 gfc_mark_ss_chain_used (lss, 1);
5016 gfc_mark_ss_chain_used (loop.temp_ss, 1);
5017
5018 /* Declare the variable to hold the temporary offset and start the
5019 scalarized loop body. */
5020 offset = gfc_create_var (gfc_array_index_type, NULL);
5021 gfc_start_scalarized_body (&loop2, &body);
5022
5023 /* Build the offsets for the temporary from the loop variables. The
5024 temporary array has lbounds of zero and strides of one in all
5025 dimensions, so this is very simple. The offset is only computed
5026 outside the innermost loop, so the overall transfer could be
5027 optimized further. */
5028 info = &rse.ss->info->data.array;
5029
5030 tmp_index = gfc_index_zero_node;
5031 for (n = dimen - 1; n > 0; n--)
5032 {
5033 tree tmp_str;
5034 tmp = rse.loop->loopvar[n];
5035 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5036 tmp, rse.loop->from[n]);
5037 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5038 tmp, tmp_index);
5039
5040 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
5041 gfc_array_index_type,
5042 rse.loop->to[n-1], rse.loop->from[n-1]);
5043 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
5044 gfc_array_index_type,
5045 tmp_str, gfc_index_one_node);
5046
5047 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
5048 gfc_array_index_type, tmp, tmp_str);
5049 }
5050
5051 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
5052 gfc_array_index_type,
5053 tmp_index, rse.loop->from[0]);
5054 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
5055
5056 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
5057 gfc_array_index_type,
5058 rse.loop->loopvar[0], offset);
5059
5060 /* Now use the offset for the reference. */
5061 tmp = build_fold_indirect_ref_loc (input_location,
5062 info->data);
5063 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
5064
5065 if (expr->ts.type == BT_CHARACTER)
5066 rse.string_length = expr->ts.u.cl->backend_decl;
5067
5068 gfc_conv_expr (&lse, expr);
5069
5070 gcc_assert (lse.ss == gfc_ss_terminator);
5071
5072 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
5073 gfc_add_expr_to_block (&body, tmp);
5074
5075 /* Generate the copying loops. */
5076 gfc_trans_scalarizing_loops (&loop2, &body);
5077
5078 /* Wrap the whole thing up by adding the second loop to the post-block
5079 and following it by the post-block of the first loop. In this way,
5080 if the temporary needs freeing, it is done after use! */
5081 if (intent != INTENT_IN)
5082 {
5083 gfc_add_block_to_block (&parmse->post, &loop2.pre);
5084 gfc_add_block_to_block (&parmse->post, &loop2.post);
5085 }
5086
5087 class_array_fcn:
5088
5089 gfc_add_block_to_block (&parmse->post, &loop.post);
5090
5091 gfc_cleanup_loop (&loop);
5092 gfc_cleanup_loop (&loop2);
5093
5094 /* Pass the string length to the argument expression. */
5095 if (expr->ts.type == BT_CHARACTER)
5096 parmse->string_length = expr->ts.u.cl->backend_decl;
5097
5098 /* Determine the offset for pointer formal arguments and set the
5099 lbounds to one. */
5100 if (formal_ptr)
5101 {
5102 size = gfc_index_one_node;
5103 offset = gfc_index_zero_node;
5104 for (n = 0; n < dimen; n++)
5105 {
5106 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
5107 gfc_rank_cst[n]);
5108 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5109 gfc_array_index_type, tmp,
5110 gfc_index_one_node);
5111 gfc_conv_descriptor_ubound_set (&parmse->pre,
5112 parmse->expr,
5113 gfc_rank_cst[n],
5114 tmp);
5115 gfc_conv_descriptor_lbound_set (&parmse->pre,
5116 parmse->expr,
5117 gfc_rank_cst[n],
5118 gfc_index_one_node);
5119 size = gfc_evaluate_now (size, &parmse->pre);
5120 offset = fold_build2_loc (input_location, MINUS_EXPR,
5121 gfc_array_index_type,
5122 offset, size);
5123 offset = gfc_evaluate_now (offset, &parmse->pre);
5124 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5125 gfc_array_index_type,
5126 rse.loop->to[n], rse.loop->from[n]);
5127 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5128 gfc_array_index_type,
5129 tmp, gfc_index_one_node);
5130 size = fold_build2_loc (input_location, MULT_EXPR,
5131 gfc_array_index_type, size, tmp);
5132 }
5133
5134 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
5135 offset);
5136 }
5137
5138 /* We want either the address for the data or the address of the descriptor,
5139 depending on the mode of passing array arguments. */
5140 if (g77)
5141 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
5142 else
5143 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5144
5145 /* Basically make this into
5146
5147 if (present)
5148 {
5149 if (contiguous)
5150 {
5151 pointer = a;
5152 }
5153 else
5154 {
5155 parmse->pre();
5156 pointer = parmse->expr;
5157 }
5158 }
5159 else
5160 pointer = NULL;
5161
5162 foo (pointer);
5163 if (present && !contiguous)
5164 se->post();
5165
5166 */
5167
5168 if (pass_optional || check_contiguous)
5169 {
5170 tree type;
5171 stmtblock_t else_block;
5172 tree pre_stmts, post_stmts;
5173 tree pointer;
5174 tree else_stmt;
5175 tree present_var = NULL_TREE;
5176 tree cont_var = NULL_TREE;
5177 tree post_cond;
5178
5179 type = TREE_TYPE (parmse->expr);
5180 pointer = gfc_create_var (type, "arg_ptr");
5181
5182 if (check_contiguous)
5183 {
5184 gfc_se cont_se, array_se;
5185 stmtblock_t if_block, else_block;
5186 tree if_stmt, else_stmt;
5187 mpz_t size;
5188 bool size_set;
5189
5190 cont_var = gfc_create_var (boolean_type_node, "contiguous");
5191
5192 /* If the size is known to be one at compile-time, set
5193 cont_var to true unconditionally. This may look
5194 inelegant, but we're only doing this during
5195 optimization, so the statements will be optimized away,
5196 and this saves complexity here. */
5197
5198 size_set = gfc_array_size (expr, &size);
5199 if (size_set && mpz_cmp_ui (size, 1) == 0)
5200 {
5201 gfc_add_modify (&se->pre, cont_var,
5202 build_one_cst (boolean_type_node));
5203 }
5204 else
5205 {
5206 /* cont_var = is_contiguous (expr); . */
5207 gfc_init_se (&cont_se, parmse);
5208 gfc_conv_is_contiguous_expr (&cont_se, expr);
5209 gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
5210 gfc_add_modify (&se->pre, cont_var, cont_se.expr);
5211 gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
5212 }
5213
5214 if (size_set)
5215 mpz_clear (size);
5216
5217 /* arrayse->expr = descriptor of a. */
5218 gfc_init_se (&array_se, se);
5219 gfc_conv_expr_descriptor (&array_se, expr);
5220 gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
5221 gfc_add_block_to_block (&se->pre, &(&array_se)->post);
5222
5223 /* if_stmt = { pointer = &a[0]; } . */
5224 gfc_init_block (&if_block);
5225 tmp = gfc_conv_array_data (array_se.expr);
5226 tmp = fold_convert (type, tmp);
5227 gfc_add_modify (&if_block, pointer, tmp);
5228 if_stmt = gfc_finish_block (&if_block);
5229
5230 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
5231 gfc_init_block (&else_block);
5232 gfc_add_block_to_block (&else_block, &parmse->pre);
5233 gfc_add_modify (&else_block, pointer, parmse->expr);
5234 else_stmt = gfc_finish_block (&else_block);
5235
5236 /* And put the above into an if statement. */
5237 pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5238 gfc_likely (cont_var,
5239 PRED_FORTRAN_CONTIGUOUS),
5240 if_stmt, else_stmt);
5241 }
5242 else
5243 {
5244 /* pointer = pramse->expr; . */
5245 gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5246 pre_stmts = gfc_finish_block (&parmse->pre);
5247 }
5248
5249 if (pass_optional)
5250 {
5251 present_var = gfc_create_var (boolean_type_node, "present");
5252
5253 /* present_var = present(sym); . */
5254 tmp = gfc_conv_expr_present (sym);
5255 tmp = fold_convert (boolean_type_node, tmp);
5256 gfc_add_modify (&se->pre, present_var, tmp);
5257
5258 /* else_stmt = { pointer = NULL; } . */
5259 gfc_init_block (&else_block);
5260 gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5261 else_stmt = gfc_finish_block (&else_block);
5262
5263 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5264 gfc_likely (present_var,
5265 PRED_FORTRAN_ABSENT_DUMMY),
5266 pre_stmts, else_stmt);
5267 gfc_add_expr_to_block (&se->pre, tmp);
5268 }
5269 else
5270 gfc_add_expr_to_block (&se->pre, pre_stmts);
5271
5272 post_stmts = gfc_finish_block (&parmse->post);
5273
5274 /* Put together the post stuff, plus the optional
5275 deallocation. */
5276 if (check_contiguous)
5277 {
5278 /* !cont_var. */
5279 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5280 cont_var,
5281 build_zero_cst (boolean_type_node));
5282 tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5283
5284 if (pass_optional)
5285 {
5286 tree present_likely = gfc_likely (present_var,
5287 PRED_FORTRAN_ABSENT_DUMMY);
5288 post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5289 boolean_type_node, present_likely,
5290 tmp);
5291 }
5292 else
5293 post_cond = tmp;
5294 }
5295 else
5296 {
5297 gcc_assert (pass_optional);
5298 post_cond = present_var;
5299 }
5300
5301 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5302 post_stmts, build_empty_stmt (input_location));
5303 gfc_add_expr_to_block (&se->post, tmp);
5304 se->expr = pointer;
5305 }
5306
5307 return;
5308 }
5309
5310
5311 /* Generate the code for argument list functions. */
5312
5313 static void
conv_arglist_function(gfc_se * se,gfc_expr * expr,const char * name)5314 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5315 {
5316 /* Pass by value for g77 %VAL(arg), pass the address
5317 indirectly for %LOC, else by reference. Thus %REF
5318 is a "do-nothing" and %LOC is the same as an F95
5319 pointer. */
5320 if (strcmp (name, "%VAL") == 0)
5321 gfc_conv_expr (se, expr);
5322 else if (strcmp (name, "%LOC") == 0)
5323 {
5324 gfc_conv_expr_reference (se, expr);
5325 se->expr = gfc_build_addr_expr (NULL, se->expr);
5326 }
5327 else if (strcmp (name, "%REF") == 0)
5328 gfc_conv_expr_reference (se, expr);
5329 else
5330 gfc_error ("Unknown argument list function at %L", &expr->where);
5331 }
5332
5333
5334 /* This function tells whether the middle-end representation of the expression
5335 E given as input may point to data otherwise accessible through a variable
5336 (sub-)reference.
5337 It is assumed that the only expressions that may alias are variables,
5338 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5339 may alias.
5340 This function is used to decide whether freeing an expression's allocatable
5341 components is safe or should be avoided.
5342
5343 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5344 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5345 is necessary because for array constructors, aliasing depends on how
5346 the array is used:
5347 - If E is an array constructor used as argument to an elemental procedure,
5348 the array, which is generated through shallow copy by the scalarizer,
5349 is used directly and can alias the expressions it was copied from.
5350 - If E is an array constructor used as argument to a non-elemental
5351 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5352 the array as in the previous case, but then that array is used
5353 to initialize a new descriptor through deep copy. There is no alias
5354 possible in that case.
5355 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5356 above. */
5357
5358 static bool
expr_may_alias_variables(gfc_expr * e,bool array_may_alias)5359 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5360 {
5361 gfc_constructor *c;
5362
5363 if (e->expr_type == EXPR_VARIABLE)
5364 return true;
5365 else if (e->expr_type == EXPR_FUNCTION)
5366 {
5367 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5368
5369 if (proc_ifc->result != NULL
5370 && ((proc_ifc->result->ts.type == BT_CLASS
5371 && proc_ifc->result->ts.u.derived->attr.is_class
5372 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
5373 || proc_ifc->result->attr.pointer))
5374 return true;
5375 else
5376 return false;
5377 }
5378 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
5379 return false;
5380
5381 for (c = gfc_constructor_first (e->value.constructor);
5382 c; c = gfc_constructor_next (c))
5383 if (c->expr
5384 && expr_may_alias_variables (c->expr, array_may_alias))
5385 return true;
5386
5387 return false;
5388 }
5389
5390
5391 /* A helper function to set the dtype for unallocated or unassociated
5392 entities. */
5393
5394 static void
set_dtype_for_unallocated(gfc_se * parmse,gfc_expr * e)5395 set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
5396 {
5397 tree tmp;
5398 tree desc;
5399 tree cond;
5400 tree type;
5401 stmtblock_t block;
5402
5403 /* TODO Figure out how to handle optional dummies. */
5404 if (e && e->expr_type == EXPR_VARIABLE
5405 && e->symtree->n.sym->attr.optional)
5406 return;
5407
5408 desc = parmse->expr;
5409 if (desc == NULL_TREE)
5410 return;
5411
5412 if (POINTER_TYPE_P (TREE_TYPE (desc)))
5413 desc = build_fold_indirect_ref_loc (input_location, desc);
5414
5415 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5416 return;
5417
5418 gfc_init_block (&block);
5419 tmp = gfc_conv_descriptor_data_get (desc);
5420 cond = fold_build2_loc (input_location, EQ_EXPR,
5421 logical_type_node, tmp,
5422 build_int_cst (TREE_TYPE (tmp), 0));
5423 tmp = gfc_conv_descriptor_dtype (desc);
5424 type = gfc_get_element_type (TREE_TYPE (desc));
5425 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5426 TREE_TYPE (tmp), tmp,
5427 gfc_get_dtype_rank_type (e->rank, type));
5428 gfc_add_expr_to_block (&block, tmp);
5429 cond = build3_v (COND_EXPR, cond,
5430 gfc_finish_block (&block),
5431 build_empty_stmt (input_location));
5432 gfc_add_expr_to_block (&parmse->pre, cond);
5433 }
5434
5435
5436
5437 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5438 ISO_Fortran_binding array descriptors. */
5439
5440 static void
gfc_conv_gfc_desc_to_cfi_desc(gfc_se * parmse,gfc_expr * e,gfc_symbol * fsym)5441 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
5442 {
5443 tree tmp;
5444 tree cfi_desc_ptr;
5445 tree gfc_desc_ptr;
5446 tree type;
5447 tree cond;
5448 tree desc_attr;
5449 int attribute;
5450 int cfi_attribute;
5451 symbol_attribute attr = gfc_expr_attr (e);
5452
5453 /* If this is a full array or a scalar, the allocatable and pointer
5454 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5455 attribute = 2;
5456 if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
5457 {
5458 if (attr.pointer)
5459 attribute = 0;
5460 else if (attr.allocatable)
5461 attribute = 1;
5462 }
5463
5464 /* If the formal argument is assumed shape and neither a pointer nor
5465 allocatable, it is unconditionally CFI_attribute_other. */
5466 if (fsym->as->type == AS_ASSUMED_SHAPE
5467 && !fsym->attr.pointer && !fsym->attr.allocatable)
5468 cfi_attribute = 2;
5469 else
5470 cfi_attribute = attribute;
5471
5472 if (e->rank != 0)
5473 {
5474 parmse->force_no_tmp = 1;
5475 if (fsym->attr.contiguous
5476 && !gfc_is_simply_contiguous (e, false, true))
5477 gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
5478 fsym->attr.pointer);
5479 else
5480 gfc_conv_expr_descriptor (parmse, e);
5481
5482 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5483 parmse->expr = build_fold_indirect_ref_loc (input_location,
5484 parmse->expr);
5485 bool is_artificial = (INDIRECT_REF_P (parmse->expr)
5486 ? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
5487 : DECL_ARTIFICIAL (parmse->expr));
5488
5489 /* Unallocated allocatable arrays and unassociated pointer arrays
5490 need their dtype setting if they are argument associated with
5491 assumed rank dummies. */
5492 if (fsym && fsym->as
5493 && (gfc_expr_attr (e).pointer
5494 || gfc_expr_attr (e).allocatable))
5495 set_dtype_for_unallocated (parmse, e);
5496
5497 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5498 the expression type is different from the descriptor type, then
5499 the offset must be found (eg. to a component ref or substring)
5500 and the dtype updated. Assumed type entities are only allowed
5501 to be dummies in Fortran. They therefore lack the decl specific
5502 appendiges and so must be treated differently from other fortran
5503 entities passed to CFI descriptors in the interface decl. */
5504 type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
5505 NULL_TREE;
5506
5507 if (type && is_artificial
5508 && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
5509 {
5510 /* Obtain the offset to the data. */
5511 gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
5512 gfc_index_zero_node, true, e);
5513
5514 /* Update the dtype. */
5515 gfc_add_modify (&parmse->pre,
5516 gfc_conv_descriptor_dtype (parmse->expr),
5517 gfc_get_dtype_rank_type (e->rank, type));
5518 }
5519 else if (type == NULL_TREE
5520 || (!is_subref_array (e) && !is_artificial))
5521 {
5522 /* Make sure that the span is set for expressions where it
5523 might not have been done already. */
5524 tmp = gfc_conv_descriptor_elem_len (parmse->expr);
5525 tmp = fold_convert (gfc_array_index_type, tmp);
5526 gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
5527 }
5528 }
5529 else
5530 {
5531 gfc_conv_expr (parmse, e);
5532
5533 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5534 parmse->expr = build_fold_indirect_ref_loc (input_location,
5535 parmse->expr);
5536
5537 parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
5538 parmse->expr, attr);
5539 }
5540
5541 /* Set the CFI attribute field through a temporary value for the
5542 gfc attribute. */
5543 desc_attr = gfc_conv_descriptor_attribute (parmse->expr);
5544 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5545 void_type_node, desc_attr,
5546 build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
5547 gfc_add_expr_to_block (&parmse->pre, tmp);
5548
5549 /* Now pass the gfc_descriptor by reference. */
5550 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5551
5552 /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
5553 that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
5554 gfc_desc_ptr = parmse->expr;
5555 cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
5556 gfc_add_modify (&parmse->pre, cfi_desc_ptr, null_pointer_node);
5557
5558 /* Allocate the CFI descriptor itself and fill the fields. */
5559 tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
5560 tmp = build_call_expr_loc (input_location,
5561 gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
5562 gfc_add_expr_to_block (&parmse->pre, tmp);
5563
5564 /* Now set the gfc descriptor attribute. */
5565 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5566 void_type_node, desc_attr,
5567 build_int_cst (TREE_TYPE (desc_attr), attribute));
5568 gfc_add_expr_to_block (&parmse->pre, tmp);
5569
5570 /* The CFI descriptor is passed to the bind_C procedure. */
5571 parmse->expr = cfi_desc_ptr;
5572
5573 /* Free the CFI descriptor. */
5574 tmp = gfc_call_free (cfi_desc_ptr);
5575 gfc_prepend_expr_to_block (&parmse->post, tmp);
5576
5577 /* Transfer values back to gfc descriptor. */
5578 tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5579 tmp = build_call_expr_loc (input_location,
5580 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
5581 gfc_prepend_expr_to_block (&parmse->post, tmp);
5582
5583 /* Deal with an optional dummy being passed to an optional formal arg
5584 by finishing the pre and post blocks and making their execution
5585 conditional on the dummy being present. */
5586 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5587 && e->symtree->n.sym->attr.optional)
5588 {
5589 cond = gfc_conv_expr_present (e->symtree->n.sym);
5590 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5591 cfi_desc_ptr,
5592 build_int_cst (pvoid_type_node, 0));
5593 tmp = build3_v (COND_EXPR, cond,
5594 gfc_finish_block (&parmse->pre), tmp);
5595 gfc_add_expr_to_block (&parmse->pre, tmp);
5596 tmp = build3_v (COND_EXPR, cond,
5597 gfc_finish_block (&parmse->post),
5598 build_empty_stmt (input_location));
5599 gfc_add_expr_to_block (&parmse->post, tmp);
5600 }
5601 }
5602
5603
5604 /* Generate code for a procedure call. Note can return se->post != NULL.
5605 If se->direct_byref is set then se->expr contains the return parameter.
5606 Return nonzero, if the call has alternate specifiers.
5607 'expr' is only needed for procedure pointer components. */
5608
5609 int
gfc_conv_procedure_call(gfc_se * se,gfc_symbol * sym,gfc_actual_arglist * args,gfc_expr * expr,vec<tree,va_gc> * append_args)5610 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
5611 gfc_actual_arglist * args, gfc_expr * expr,
5612 vec<tree, va_gc> *append_args)
5613 {
5614 gfc_interface_mapping mapping;
5615 vec<tree, va_gc> *arglist;
5616 vec<tree, va_gc> *retargs;
5617 tree tmp;
5618 tree fntype;
5619 gfc_se parmse;
5620 gfc_array_info *info;
5621 int byref;
5622 int parm_kind;
5623 tree type;
5624 tree var;
5625 tree len;
5626 tree base_object;
5627 vec<tree, va_gc> *stringargs;
5628 vec<tree, va_gc> *optionalargs;
5629 tree result = NULL;
5630 gfc_formal_arglist *formal;
5631 gfc_actual_arglist *arg;
5632 int has_alternate_specifier = 0;
5633 bool need_interface_mapping;
5634 bool callee_alloc;
5635 bool ulim_copy;
5636 gfc_typespec ts;
5637 gfc_charlen cl;
5638 gfc_expr *e;
5639 gfc_symbol *fsym;
5640 stmtblock_t post;
5641 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
5642 gfc_component *comp = NULL;
5643 int arglen;
5644 unsigned int argc;
5645
5646 arglist = NULL;
5647 retargs = NULL;
5648 stringargs = NULL;
5649 optionalargs = NULL;
5650 var = NULL_TREE;
5651 len = NULL_TREE;
5652 gfc_clear_ts (&ts);
5653
5654 comp = gfc_get_proc_ptr_comp (expr);
5655
5656 bool elemental_proc = (comp
5657 && comp->ts.interface
5658 && comp->ts.interface->attr.elemental)
5659 || (comp && comp->attr.elemental)
5660 || sym->attr.elemental;
5661
5662 if (se->ss != NULL)
5663 {
5664 if (!elemental_proc)
5665 {
5666 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
5667 if (se->ss->info->useflags)
5668 {
5669 gcc_assert ((!comp && gfc_return_by_reference (sym)
5670 && sym->result->attr.dimension)
5671 || (comp && comp->attr.dimension)
5672 || gfc_is_class_array_function (expr));
5673 gcc_assert (se->loop != NULL);
5674 /* Access the previously obtained result. */
5675 gfc_conv_tmp_array_ref (se);
5676 return 0;
5677 }
5678 }
5679 info = &se->ss->info->data.array;
5680 }
5681 else
5682 info = NULL;
5683
5684 gfc_init_block (&post);
5685 gfc_init_interface_mapping (&mapping);
5686 if (!comp)
5687 {
5688 formal = gfc_sym_get_dummy_args (sym);
5689 need_interface_mapping = sym->attr.dimension ||
5690 (sym->ts.type == BT_CHARACTER
5691 && sym->ts.u.cl->length
5692 && sym->ts.u.cl->length->expr_type
5693 != EXPR_CONSTANT);
5694 }
5695 else
5696 {
5697 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
5698 need_interface_mapping = comp->attr.dimension ||
5699 (comp->ts.type == BT_CHARACTER
5700 && comp->ts.u.cl->length
5701 && comp->ts.u.cl->length->expr_type
5702 != EXPR_CONSTANT);
5703 }
5704
5705 base_object = NULL_TREE;
5706 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5707 is the third and fourth argument to such a function call a value
5708 denoting the number of elements to copy (i.e., most of the time the
5709 length of a deferred length string). */
5710 ulim_copy = (formal == NULL)
5711 && UNLIMITED_POLY (sym)
5712 && comp && (strcmp ("_copy", comp->name) == 0);
5713
5714 /* Evaluate the arguments. */
5715 for (arg = args, argc = 0; arg != NULL;
5716 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
5717 {
5718 bool finalized = false;
5719 bool non_unity_length_string = false;
5720 tree derived_array = NULL_TREE;
5721
5722 e = arg->expr;
5723 fsym = formal ? formal->sym : NULL;
5724 parm_kind = MISSING;
5725
5726 if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
5727 && (!fsym->ts.u.cl->length
5728 || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5729 || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
5730 non_unity_length_string = true;
5731
5732 /* If the procedure requires an explicit interface, the actual
5733 argument is passed according to the corresponding formal
5734 argument. If the corresponding formal argument is a POINTER,
5735 ALLOCATABLE or assumed shape, we do not use g77's calling
5736 convention, and pass the address of the array descriptor
5737 instead. Otherwise we use g77's calling convention, in other words
5738 pass the array data pointer without descriptor. */
5739 bool nodesc_arg = fsym != NULL
5740 && !(fsym->attr.pointer || fsym->attr.allocatable)
5741 && fsym->as
5742 && fsym->as->type != AS_ASSUMED_SHAPE
5743 && fsym->as->type != AS_ASSUMED_RANK;
5744 if (comp)
5745 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
5746 else
5747 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
5748
5749 /* Class array expressions are sometimes coming completely unadorned
5750 with either arrayspec or _data component. Correct that here.
5751 OOP-TODO: Move this to the frontend. */
5752 if (e && e->expr_type == EXPR_VARIABLE
5753 && !e->ref
5754 && e->ts.type == BT_CLASS
5755 && (CLASS_DATA (e)->attr.codimension
5756 || CLASS_DATA (e)->attr.dimension))
5757 {
5758 gfc_typespec temp_ts = e->ts;
5759 gfc_add_class_array_ref (e);
5760 e->ts = temp_ts;
5761 }
5762
5763 if (e == NULL)
5764 {
5765 if (se->ignore_optional)
5766 {
5767 /* Some intrinsics have already been resolved to the correct
5768 parameters. */
5769 continue;
5770 }
5771 else if (arg->label)
5772 {
5773 has_alternate_specifier = 1;
5774 continue;
5775 }
5776 else
5777 {
5778 gfc_init_se (&parmse, NULL);
5779
5780 /* For scalar arguments with VALUE attribute which are passed by
5781 value, pass "0" and a hidden argument gives the optional
5782 status. */
5783 if (fsym && fsym->attr.optional && fsym->attr.value
5784 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
5785 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
5786 {
5787 parmse.expr = fold_convert (gfc_sym_type (fsym),
5788 integer_zero_node);
5789 vec_safe_push (optionalargs, boolean_false_node);
5790 }
5791 else
5792 {
5793 /* Pass a NULL pointer for an absent arg. */
5794 parmse.expr = null_pointer_node;
5795 if (arg->missing_arg_type == BT_CHARACTER)
5796 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5797 0);
5798 }
5799 }
5800 }
5801 else if (arg->expr->expr_type == EXPR_NULL
5802 && fsym && !fsym->attr.pointer
5803 && (fsym->ts.type != BT_CLASS
5804 || !CLASS_DATA (fsym)->attr.class_pointer))
5805 {
5806 /* Pass a NULL pointer to denote an absent arg. */
5807 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5808 && (fsym->ts.type != BT_CLASS
5809 || !CLASS_DATA (fsym)->attr.allocatable));
5810 gfc_init_se (&parmse, NULL);
5811 parmse.expr = null_pointer_node;
5812 if (arg->missing_arg_type == BT_CHARACTER)
5813 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5814 }
5815 else if (fsym && fsym->ts.type == BT_CLASS
5816 && e->ts.type == BT_DERIVED)
5817 {
5818 /* The derived type needs to be converted to a temporary
5819 CLASS object. */
5820 gfc_init_se (&parmse, se);
5821 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5822 fsym->attr.optional
5823 && e->expr_type == EXPR_VARIABLE
5824 && e->symtree->n.sym->attr.optional,
5825 CLASS_DATA (fsym)->attr.class_pointer
5826 || CLASS_DATA (fsym)->attr.allocatable,
5827 &derived_array);
5828 }
5829 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
5830 && e->ts.type != BT_PROCEDURE
5831 && (gfc_expr_attr (e).flavor != FL_PROCEDURE
5832 || gfc_expr_attr (e).proc != PROC_UNKNOWN))
5833 {
5834 /* The intrinsic type needs to be converted to a temporary
5835 CLASS object for the unlimited polymorphic formal. */
5836 gfc_find_vtab (&e->ts);
5837 gfc_init_se (&parmse, se);
5838 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5839
5840 }
5841 else if (se->ss && se->ss->info->useflags)
5842 {
5843 gfc_ss *ss;
5844
5845 ss = se->ss;
5846
5847 /* An elemental function inside a scalarized loop. */
5848 gfc_init_se (&parmse, se);
5849 parm_kind = ELEMENTAL;
5850
5851 /* When no fsym is present, ulim_copy is set and this is a third or
5852 fourth argument, use call-by-value instead of by reference to
5853 hand the length properties to the copy routine (i.e., most of the
5854 time this will be a call to a __copy_character_* routine where the
5855 third and fourth arguments are the lengths of a deferred length
5856 char array). */
5857 if ((fsym && fsym->attr.value)
5858 || (ulim_copy && (argc == 2 || argc == 3)))
5859 gfc_conv_expr (&parmse, e);
5860 else
5861 gfc_conv_expr_reference (&parmse, e);
5862
5863 if (e->ts.type == BT_CHARACTER && !e->rank
5864 && e->expr_type == EXPR_FUNCTION)
5865 parmse.expr = build_fold_indirect_ref_loc (input_location,
5866 parmse.expr);
5867
5868 if (fsym && fsym->ts.type == BT_DERIVED
5869 && gfc_is_class_container_ref (e))
5870 {
5871 parmse.expr = gfc_class_data_get (parmse.expr);
5872
5873 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5874 && e->symtree->n.sym->attr.optional)
5875 {
5876 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5877 parmse.expr = build3_loc (input_location, COND_EXPR,
5878 TREE_TYPE (parmse.expr),
5879 cond, parmse.expr,
5880 fold_convert (TREE_TYPE (parmse.expr),
5881 null_pointer_node));
5882 }
5883 }
5884
5885 /* If we are passing an absent array as optional dummy to an
5886 elemental procedure, make sure that we pass NULL when the data
5887 pointer is NULL. We need this extra conditional because of
5888 scalarization which passes arrays elements to the procedure,
5889 ignoring the fact that the array can be absent/unallocated/... */
5890 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5891 {
5892 tree descriptor_data;
5893
5894 descriptor_data = ss->info->data.array.data;
5895 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5896 descriptor_data,
5897 fold_convert (TREE_TYPE (descriptor_data),
5898 null_pointer_node));
5899 parmse.expr
5900 = fold_build3_loc (input_location, COND_EXPR,
5901 TREE_TYPE (parmse.expr),
5902 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5903 fold_convert (TREE_TYPE (parmse.expr),
5904 null_pointer_node),
5905 parmse.expr);
5906 }
5907
5908 /* The scalarizer does not repackage the reference to a class
5909 array - instead it returns a pointer to the data element. */
5910 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5911 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5912 fsym->attr.intent != INTENT_IN
5913 && (CLASS_DATA (fsym)->attr.class_pointer
5914 || CLASS_DATA (fsym)->attr.allocatable),
5915 fsym->attr.optional
5916 && e->expr_type == EXPR_VARIABLE
5917 && e->symtree->n.sym->attr.optional,
5918 CLASS_DATA (fsym)->attr.class_pointer
5919 || CLASS_DATA (fsym)->attr.allocatable);
5920 }
5921 else
5922 {
5923 bool scalar;
5924 gfc_ss *argss;
5925
5926 gfc_init_se (&parmse, NULL);
5927
5928 /* Check whether the expression is a scalar or not; we cannot use
5929 e->rank as it can be nonzero for functions arguments. */
5930 argss = gfc_walk_expr (e);
5931 scalar = argss == gfc_ss_terminator;
5932 if (!scalar)
5933 gfc_free_ss_chain (argss);
5934
5935 /* Special handling for passing scalar polymorphic coarrays;
5936 otherwise one passes "class->_data.data" instead of "&class". */
5937 if (e->rank == 0 && e->ts.type == BT_CLASS
5938 && fsym && fsym->ts.type == BT_CLASS
5939 && CLASS_DATA (fsym)->attr.codimension
5940 && !CLASS_DATA (fsym)->attr.dimension)
5941 {
5942 gfc_add_class_array_ref (e);
5943 parmse.want_coarray = 1;
5944 scalar = false;
5945 }
5946
5947 /* A scalar or transformational function. */
5948 if (scalar)
5949 {
5950 if (e->expr_type == EXPR_VARIABLE
5951 && e->symtree->n.sym->attr.cray_pointee
5952 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5953 {
5954 /* The Cray pointer needs to be converted to a pointer to
5955 a type given by the expression. */
5956 gfc_conv_expr (&parmse, e);
5957 type = build_pointer_type (TREE_TYPE (parmse.expr));
5958 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5959 parmse.expr = convert (type, tmp);
5960 }
5961
5962 else if (sym->attr.is_bind_c && e
5963 && (is_CFI_desc (fsym, NULL)
5964 || non_unity_length_string))
5965 /* Implement F2018, C.12.6.1: paragraph (2). */
5966 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5967
5968 else if (fsym && fsym->attr.value)
5969 {
5970 if (fsym->ts.type == BT_CHARACTER
5971 && fsym->ts.is_c_interop
5972 && fsym->ns->proc_name != NULL
5973 && fsym->ns->proc_name->attr.is_bind_c)
5974 {
5975 parmse.expr = NULL;
5976 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5977 if (parmse.expr == NULL)
5978 gfc_conv_expr (&parmse, e);
5979 }
5980 else
5981 {
5982 gfc_conv_expr (&parmse, e);
5983 if (fsym->attr.optional
5984 && fsym->ts.type != BT_CLASS
5985 && fsym->ts.type != BT_DERIVED)
5986 {
5987 if (e->expr_type != EXPR_VARIABLE
5988 || !e->symtree->n.sym->attr.optional
5989 || e->ref != NULL)
5990 vec_safe_push (optionalargs, boolean_true_node);
5991 else
5992 {
5993 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5994 if (!e->symtree->n.sym->attr.value)
5995 parmse.expr
5996 = fold_build3_loc (input_location, COND_EXPR,
5997 TREE_TYPE (parmse.expr),
5998 tmp, parmse.expr,
5999 fold_convert (TREE_TYPE (parmse.expr),
6000 integer_zero_node));
6001
6002 vec_safe_push (optionalargs,
6003 fold_convert (boolean_type_node,
6004 tmp));
6005 }
6006 }
6007 }
6008 }
6009
6010 else if (arg->name && arg->name[0] == '%')
6011 /* Argument list functions %VAL, %LOC and %REF are signalled
6012 through arg->name. */
6013 conv_arglist_function (&parmse, arg->expr, arg->name);
6014 else if ((e->expr_type == EXPR_FUNCTION)
6015 && ((e->value.function.esym
6016 && e->value.function.esym->result->attr.pointer)
6017 || (!e->value.function.esym
6018 && e->symtree->n.sym->attr.pointer))
6019 && fsym && fsym->attr.target)
6020 /* Make sure the function only gets called once. */
6021 gfc_conv_expr_reference (&parmse, e, false);
6022 else if (e->expr_type == EXPR_FUNCTION
6023 && e->symtree->n.sym->result
6024 && e->symtree->n.sym->result != e->symtree->n.sym
6025 && e->symtree->n.sym->result->attr.proc_pointer)
6026 {
6027 /* Functions returning procedure pointers. */
6028 gfc_conv_expr (&parmse, e);
6029 if (fsym && fsym->attr.proc_pointer)
6030 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6031 }
6032
6033 else
6034 {
6035 if (e->ts.type == BT_CLASS && fsym
6036 && fsym->ts.type == BT_CLASS
6037 && (!CLASS_DATA (fsym)->as
6038 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
6039 && CLASS_DATA (e)->attr.codimension)
6040 {
6041 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
6042 gcc_assert (!CLASS_DATA (fsym)->as);
6043 gfc_add_class_array_ref (e);
6044 parmse.want_coarray = 1;
6045 gfc_conv_expr_reference (&parmse, e);
6046 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
6047 fsym->attr.optional
6048 && e->expr_type == EXPR_VARIABLE);
6049 }
6050 else if (e->ts.type == BT_CLASS && fsym
6051 && fsym->ts.type == BT_CLASS
6052 && !CLASS_DATA (fsym)->as
6053 && !CLASS_DATA (e)->as
6054 && strcmp (fsym->ts.u.derived->name,
6055 e->ts.u.derived->name))
6056 {
6057 type = gfc_typenode_for_spec (&fsym->ts);
6058 var = gfc_create_var (type, fsym->name);
6059 gfc_conv_expr (&parmse, e);
6060 if (fsym->attr.optional
6061 && e->expr_type == EXPR_VARIABLE
6062 && e->symtree->n.sym->attr.optional)
6063 {
6064 stmtblock_t block;
6065 tree cond;
6066 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6067 cond = fold_build2_loc (input_location, NE_EXPR,
6068 logical_type_node, tmp,
6069 fold_convert (TREE_TYPE (tmp),
6070 null_pointer_node));
6071 gfc_start_block (&block);
6072 gfc_add_modify (&block, var,
6073 fold_build1_loc (input_location,
6074 VIEW_CONVERT_EXPR,
6075 type, parmse.expr));
6076 gfc_add_expr_to_block (&parmse.pre,
6077 fold_build3_loc (input_location,
6078 COND_EXPR, void_type_node,
6079 cond, gfc_finish_block (&block),
6080 build_empty_stmt (input_location)));
6081 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6082 parmse.expr = build3_loc (input_location, COND_EXPR,
6083 TREE_TYPE (parmse.expr),
6084 cond, parmse.expr,
6085 fold_convert (TREE_TYPE (parmse.expr),
6086 null_pointer_node));
6087 }
6088 else
6089 {
6090 /* Since the internal representation of unlimited
6091 polymorphic expressions includes an extra field
6092 that other class objects do not, a cast to the
6093 formal type does not work. */
6094 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
6095 {
6096 tree efield;
6097
6098 /* Set the _data field. */
6099 tmp = gfc_class_data_get (var);
6100 efield = fold_convert (TREE_TYPE (tmp),
6101 gfc_class_data_get (parmse.expr));
6102 gfc_add_modify (&parmse.pre, tmp, efield);
6103
6104 /* Set the _vptr field. */
6105 tmp = gfc_class_vptr_get (var);
6106 efield = fold_convert (TREE_TYPE (tmp),
6107 gfc_class_vptr_get (parmse.expr));
6108 gfc_add_modify (&parmse.pre, tmp, efield);
6109
6110 /* Set the _len field. */
6111 tmp = gfc_class_len_get (var);
6112 gfc_add_modify (&parmse.pre, tmp,
6113 build_int_cst (TREE_TYPE (tmp), 0));
6114 }
6115 else
6116 {
6117 tmp = fold_build1_loc (input_location,
6118 VIEW_CONVERT_EXPR,
6119 type, parmse.expr);
6120 gfc_add_modify (&parmse.pre, var, tmp);
6121 ;
6122 }
6123 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
6124 }
6125 }
6126 else
6127 {
6128 bool add_clobber;
6129 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
6130 && !fsym->attr.allocatable && !fsym->attr.pointer
6131 && e->symtree && e->symtree->n.sym
6132 && !e->symtree->n.sym->attr.dimension
6133 && !e->symtree->n.sym->attr.pointer
6134 && !e->symtree->n.sym->attr.allocatable
6135 /* See PR 41453. */
6136 && !e->symtree->n.sym->attr.dummy
6137 /* FIXME - PR 87395 and PR 41453 */
6138 && e->symtree->n.sym->attr.save == SAVE_NONE
6139 && !e->symtree->n.sym->attr.associate_var
6140 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
6141 && e->ts.type != BT_CLASS && !sym->attr.elemental;
6142
6143 gfc_conv_expr_reference (&parmse, e, add_clobber);
6144 }
6145 /* Catch base objects that are not variables. */
6146 if (e->ts.type == BT_CLASS
6147 && e->expr_type != EXPR_VARIABLE
6148 && expr && e == expr->base_expr)
6149 base_object = build_fold_indirect_ref_loc (input_location,
6150 parmse.expr);
6151
6152 /* A class array element needs converting back to be a
6153 class object, if the formal argument is a class object. */
6154 if (fsym && fsym->ts.type == BT_CLASS
6155 && e->ts.type == BT_CLASS
6156 && ((CLASS_DATA (fsym)->as
6157 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
6158 || CLASS_DATA (e)->attr.dimension))
6159 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
6160 fsym->attr.intent != INTENT_IN
6161 && (CLASS_DATA (fsym)->attr.class_pointer
6162 || CLASS_DATA (fsym)->attr.allocatable),
6163 fsym->attr.optional
6164 && e->expr_type == EXPR_VARIABLE
6165 && e->symtree->n.sym->attr.optional,
6166 CLASS_DATA (fsym)->attr.class_pointer
6167 || CLASS_DATA (fsym)->attr.allocatable);
6168
6169 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6170 allocated on entry, it must be deallocated. */
6171 if (fsym && fsym->attr.intent == INTENT_OUT
6172 && (fsym->attr.allocatable
6173 || (fsym->ts.type == BT_CLASS
6174 && CLASS_DATA (fsym)->attr.allocatable)))
6175 {
6176 stmtblock_t block;
6177 tree ptr;
6178
6179 gfc_init_block (&block);
6180 ptr = parmse.expr;
6181 if (e->ts.type == BT_CLASS)
6182 ptr = gfc_class_data_get (ptr);
6183
6184 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
6185 NULL_TREE, true,
6186 e, e->ts);
6187 gfc_add_expr_to_block (&block, tmp);
6188 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6189 void_type_node, ptr,
6190 null_pointer_node);
6191 gfc_add_expr_to_block (&block, tmp);
6192
6193 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
6194 {
6195 gfc_add_modify (&block, ptr,
6196 fold_convert (TREE_TYPE (ptr),
6197 null_pointer_node));
6198 gfc_add_expr_to_block (&block, tmp);
6199 }
6200 else if (fsym->ts.type == BT_CLASS)
6201 {
6202 gfc_symbol *vtab;
6203 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
6204 tmp = gfc_get_symbol_decl (vtab);
6205 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6206 ptr = gfc_class_vptr_get (parmse.expr);
6207 gfc_add_modify (&block, ptr,
6208 fold_convert (TREE_TYPE (ptr), tmp));
6209 gfc_add_expr_to_block (&block, tmp);
6210 }
6211
6212 if (fsym->attr.optional
6213 && e->expr_type == EXPR_VARIABLE
6214 && e->symtree->n.sym->attr.optional)
6215 {
6216 tmp = fold_build3_loc (input_location, COND_EXPR,
6217 void_type_node,
6218 gfc_conv_expr_present (e->symtree->n.sym),
6219 gfc_finish_block (&block),
6220 build_empty_stmt (input_location));
6221 }
6222 else
6223 tmp = gfc_finish_block (&block);
6224
6225 gfc_add_expr_to_block (&se->pre, tmp);
6226 }
6227
6228 if (fsym && (fsym->ts.type == BT_DERIVED
6229 || fsym->ts.type == BT_ASSUMED)
6230 && e->ts.type == BT_CLASS
6231 && !CLASS_DATA (e)->attr.dimension
6232 && !CLASS_DATA (e)->attr.codimension)
6233 {
6234 parmse.expr = gfc_class_data_get (parmse.expr);
6235 /* The result is a class temporary, whose _data component
6236 must be freed to avoid a memory leak. */
6237 if (e->expr_type == EXPR_FUNCTION
6238 && CLASS_DATA (e)->attr.allocatable)
6239 {
6240 tree zero;
6241
6242 gfc_expr *var;
6243
6244 /* Borrow the function symbol to make a call to
6245 gfc_add_finalizer_call and then restore it. */
6246 tmp = e->symtree->n.sym->backend_decl;
6247 e->symtree->n.sym->backend_decl
6248 = TREE_OPERAND (parmse.expr, 0);
6249 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
6250 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
6251 finalized = gfc_add_finalizer_call (&parmse.post,
6252 var);
6253 gfc_free_expr (var);
6254 e->symtree->n.sym->backend_decl = tmp;
6255 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
6256
6257 /* Then free the class _data. */
6258 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
6259 tmp = fold_build2_loc (input_location, NE_EXPR,
6260 logical_type_node,
6261 parmse.expr, zero);
6262 tmp = build3_v (COND_EXPR, tmp,
6263 gfc_call_free (parmse.expr),
6264 build_empty_stmt (input_location));
6265 gfc_add_expr_to_block (&parmse.post, tmp);
6266 gfc_add_modify (&parmse.post, parmse.expr, zero);
6267 }
6268 }
6269
6270 /* Wrap scalar variable in a descriptor. We need to convert
6271 the address of a pointer back to the pointer itself before,
6272 we can assign it to the data field. */
6273
6274 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
6275 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
6276 {
6277 tmp = parmse.expr;
6278 if (TREE_CODE (tmp) == ADDR_EXPR)
6279 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6280 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
6281 fsym->attr);
6282 parmse.expr = gfc_build_addr_expr (NULL_TREE,
6283 parmse.expr);
6284 }
6285 else if (fsym && e->expr_type != EXPR_NULL
6286 && ((fsym->attr.pointer
6287 && fsym->attr.flavor != FL_PROCEDURE)
6288 || (fsym->attr.proc_pointer
6289 && !(e->expr_type == EXPR_VARIABLE
6290 && e->symtree->n.sym->attr.dummy))
6291 || (fsym->attr.proc_pointer
6292 && e->expr_type == EXPR_VARIABLE
6293 && gfc_is_proc_ptr_comp (e))
6294 || (fsym->attr.allocatable
6295 && fsym->attr.flavor != FL_PROCEDURE)))
6296 {
6297 /* Scalar pointer dummy args require an extra level of
6298 indirection. The null pointer already contains
6299 this level of indirection. */
6300 parm_kind = SCALAR_POINTER;
6301 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6302 }
6303 }
6304 }
6305 else if (e->ts.type == BT_CLASS
6306 && fsym && fsym->ts.type == BT_CLASS
6307 && (CLASS_DATA (fsym)->attr.dimension
6308 || CLASS_DATA (fsym)->attr.codimension))
6309 {
6310 /* Pass a class array. */
6311 parmse.use_offset = 1;
6312 gfc_conv_expr_descriptor (&parmse, e);
6313
6314 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6315 allocated on entry, it must be deallocated. */
6316 if (fsym->attr.intent == INTENT_OUT
6317 && CLASS_DATA (fsym)->attr.allocatable)
6318 {
6319 stmtblock_t block;
6320 tree ptr;
6321
6322 gfc_init_block (&block);
6323 ptr = parmse.expr;
6324 ptr = gfc_class_data_get (ptr);
6325
6326 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
6327 NULL_TREE, NULL_TREE,
6328 NULL_TREE, true, e,
6329 GFC_CAF_COARRAY_NOCOARRAY);
6330 gfc_add_expr_to_block (&block, tmp);
6331 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6332 void_type_node, ptr,
6333 null_pointer_node);
6334 gfc_add_expr_to_block (&block, tmp);
6335 gfc_reset_vptr (&block, e);
6336
6337 if (fsym->attr.optional
6338 && e->expr_type == EXPR_VARIABLE
6339 && (!e->ref
6340 || (e->ref->type == REF_ARRAY
6341 && e->ref->u.ar.type != AR_FULL))
6342 && e->symtree->n.sym->attr.optional)
6343 {
6344 tmp = fold_build3_loc (input_location, COND_EXPR,
6345 void_type_node,
6346 gfc_conv_expr_present (e->symtree->n.sym),
6347 gfc_finish_block (&block),
6348 build_empty_stmt (input_location));
6349 }
6350 else
6351 tmp = gfc_finish_block (&block);
6352
6353 gfc_add_expr_to_block (&se->pre, tmp);
6354 }
6355
6356 /* The conversion does not repackage the reference to a class
6357 array - _data descriptor. */
6358 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
6359 fsym->attr.intent != INTENT_IN
6360 && (CLASS_DATA (fsym)->attr.class_pointer
6361 || CLASS_DATA (fsym)->attr.allocatable),
6362 fsym->attr.optional
6363 && e->expr_type == EXPR_VARIABLE
6364 && e->symtree->n.sym->attr.optional,
6365 CLASS_DATA (fsym)->attr.class_pointer
6366 || CLASS_DATA (fsym)->attr.allocatable);
6367 }
6368 else
6369 {
6370 /* If the argument is a function call that may not create
6371 a temporary for the result, we have to check that we
6372 can do it, i.e. that there is no alias between this
6373 argument and another one. */
6374 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
6375 {
6376 gfc_expr *iarg;
6377 sym_intent intent;
6378
6379 if (fsym != NULL)
6380 intent = fsym->attr.intent;
6381 else
6382 intent = INTENT_UNKNOWN;
6383
6384 if (gfc_check_fncall_dependency (e, intent, sym, args,
6385 NOT_ELEMENTAL))
6386 parmse.force_tmp = 1;
6387
6388 iarg = e->value.function.actual->expr;
6389
6390 /* Temporary needed if aliasing due to host association. */
6391 if (sym->attr.contained
6392 && !sym->attr.pure
6393 && !sym->attr.implicit_pure
6394 && !sym->attr.use_assoc
6395 && iarg->expr_type == EXPR_VARIABLE
6396 && sym->ns == iarg->symtree->n.sym->ns)
6397 parmse.force_tmp = 1;
6398
6399 /* Ditto within module. */
6400 if (sym->attr.use_assoc
6401 && !sym->attr.pure
6402 && !sym->attr.implicit_pure
6403 && iarg->expr_type == EXPR_VARIABLE
6404 && sym->module == iarg->symtree->n.sym->module)
6405 parmse.force_tmp = 1;
6406 }
6407
6408 if (sym->attr.is_bind_c && e
6409 && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
6410 /* Implement F2018, C.12.6.1: paragraph (2). */
6411 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
6412
6413 else if (e->expr_type == EXPR_VARIABLE
6414 && is_subref_array (e)
6415 && !(fsym && fsym->attr.pointer))
6416 /* The actual argument is a component reference to an
6417 array of derived types. In this case, the argument
6418 is converted to a temporary, which is passed and then
6419 written back after the procedure call. */
6420 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6421 fsym ? fsym->attr.intent : INTENT_INOUT,
6422 fsym && fsym->attr.pointer);
6423
6424 else if (gfc_is_class_array_ref (e, NULL)
6425 && fsym && fsym->ts.type == BT_DERIVED)
6426 /* The actual argument is a component reference to an
6427 array of derived types. In this case, the argument
6428 is converted to a temporary, which is passed and then
6429 written back after the procedure call.
6430 OOP-TODO: Insert code so that if the dynamic type is
6431 the same as the declared type, copy-in/copy-out does
6432 not occur. */
6433 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6434 fsym->attr.intent,
6435 fsym->attr.pointer);
6436
6437 else if (gfc_is_class_array_function (e)
6438 && fsym && fsym->ts.type == BT_DERIVED)
6439 /* See previous comment. For function actual argument,
6440 the write out is not needed so the intent is set as
6441 intent in. */
6442 {
6443 e->must_finalize = 1;
6444 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6445 INTENT_IN, fsym->attr.pointer);
6446 }
6447 else if (fsym && fsym->attr.contiguous
6448 && !gfc_is_simply_contiguous (e, false, true)
6449 && gfc_expr_is_variable (e))
6450 {
6451 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6452 fsym->attr.intent,
6453 fsym->attr.pointer);
6454 }
6455 else
6456 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
6457 sym->name, NULL);
6458
6459 /* Unallocated allocatable arrays and unassociated pointer arrays
6460 need their dtype setting if they are argument associated with
6461 assumed rank dummies, unless already assumed rank. */
6462 if (!sym->attr.is_bind_c && e && fsym && fsym->as
6463 && fsym->as->type == AS_ASSUMED_RANK
6464 && e->rank != -1)
6465 {
6466 if (gfc_expr_attr (e).pointer
6467 || gfc_expr_attr (e).allocatable)
6468 set_dtype_for_unallocated (&parmse, e);
6469 else if (e->expr_type == EXPR_VARIABLE
6470 && e->ref
6471 && e->ref->u.ar.type == AR_FULL
6472 && e->symtree->n.sym->attr.dummy
6473 && e->symtree->n.sym->as
6474 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6475 {
6476 tree minus_one;
6477 tmp = build_fold_indirect_ref_loc (input_location,
6478 parmse.expr);
6479 minus_one = build_int_cst (gfc_array_index_type, -1);
6480 gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
6481 gfc_rank_cst[e->rank - 1],
6482 minus_one);
6483 }
6484 }
6485
6486 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6487 allocated on entry, it must be deallocated. */
6488 if (fsym && fsym->attr.allocatable
6489 && fsym->attr.intent == INTENT_OUT)
6490 {
6491 if (fsym->ts.type == BT_DERIVED
6492 && fsym->ts.u.derived->attr.alloc_comp)
6493 {
6494 // deallocate the components first
6495 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
6496 parmse.expr, e->rank);
6497 if (tmp != NULL_TREE)
6498 gfc_add_expr_to_block (&se->pre, tmp);
6499 }
6500
6501 tmp = parmse.expr;
6502 /* With bind(C), the actual argument is replaced by a bind-C
6503 descriptor; in this case, the data component arrives here,
6504 which shall not be dereferenced, but still freed and
6505 nullified. */
6506 if (TREE_TYPE(tmp) != pvoid_type_node)
6507 tmp = build_fold_indirect_ref_loc (input_location,
6508 parmse.expr);
6509 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
6510 tmp = gfc_conv_descriptor_data_get (tmp);
6511 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6512 NULL_TREE, NULL_TREE, true,
6513 e,
6514 GFC_CAF_COARRAY_NOCOARRAY);
6515 if (fsym->attr.optional
6516 && e->expr_type == EXPR_VARIABLE
6517 && e->symtree->n.sym->attr.optional)
6518 tmp = fold_build3_loc (input_location, COND_EXPR,
6519 void_type_node,
6520 gfc_conv_expr_present (e->symtree->n.sym),
6521 tmp, build_empty_stmt (input_location));
6522 gfc_add_expr_to_block (&se->pre, tmp);
6523 }
6524 }
6525 }
6526
6527 /* The case with fsym->attr.optional is that of a user subroutine
6528 with an interface indicating an optional argument. When we call
6529 an intrinsic subroutine, however, fsym is NULL, but we might still
6530 have an optional argument, so we proceed to the substitution
6531 just in case. */
6532 if (e && (fsym == NULL || fsym->attr.optional))
6533 {
6534 /* If an optional argument is itself an optional dummy argument,
6535 check its presence and substitute a null if absent. This is
6536 only needed when passing an array to an elemental procedure
6537 as then array elements are accessed - or no NULL pointer is
6538 allowed and a "1" or "0" should be passed if not present.
6539 When passing a non-array-descriptor full array to a
6540 non-array-descriptor dummy, no check is needed. For
6541 array-descriptor actual to array-descriptor dummy, see
6542 PR 41911 for why a check has to be inserted.
6543 fsym == NULL is checked as intrinsics required the descriptor
6544 but do not always set fsym.
6545 Also, it is necessary to pass a NULL pointer to library routines
6546 which usually ignore optional arguments, so they can handle
6547 these themselves. */
6548 if (e->expr_type == EXPR_VARIABLE
6549 && e->symtree->n.sym->attr.optional
6550 && (((e->rank != 0 && elemental_proc)
6551 || e->representation.length || e->ts.type == BT_CHARACTER
6552 || (e->rank != 0
6553 && (fsym == NULL
6554 || (fsym->as
6555 && (fsym->as->type == AS_ASSUMED_SHAPE
6556 || fsym->as->type == AS_ASSUMED_RANK
6557 || fsym->as->type == AS_DEFERRED)))))
6558 || se->ignore_optional))
6559 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
6560 e->representation.length);
6561 }
6562
6563 if (fsym && e)
6564 {
6565 /* Obtain the character length of an assumed character length
6566 length procedure from the typespec. */
6567 if (fsym->ts.type == BT_CHARACTER
6568 && parmse.string_length == NULL_TREE
6569 && e->ts.type == BT_PROCEDURE
6570 && e->symtree->n.sym->ts.type == BT_CHARACTER
6571 && e->symtree->n.sym->ts.u.cl->length != NULL
6572 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6573 {
6574 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
6575 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
6576 }
6577 }
6578
6579 if (fsym && need_interface_mapping && e)
6580 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
6581
6582 gfc_add_block_to_block (&se->pre, &parmse.pre);
6583 gfc_add_block_to_block (&post, &parmse.post);
6584
6585 /* Allocated allocatable components of derived types must be
6586 deallocated for non-variable scalars, array arguments to elemental
6587 procedures, and array arguments with descriptor to non-elemental
6588 procedures. As bounds information for descriptorless arrays is no
6589 longer available here, they are dealt with in trans-array.c
6590 (gfc_conv_array_parameter). */
6591 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
6592 && e->ts.u.derived->attr.alloc_comp
6593 && (e->rank == 0 || elemental_proc || !nodesc_arg)
6594 && !expr_may_alias_variables (e, elemental_proc))
6595 {
6596 int parm_rank;
6597 /* It is known the e returns a structure type with at least one
6598 allocatable component. When e is a function, ensure that the
6599 function is called once only by using a temporary variable. */
6600 if (!DECL_P (parmse.expr))
6601 parmse.expr = gfc_evaluate_now_loc (input_location,
6602 parmse.expr, &se->pre);
6603
6604 if (fsym && fsym->attr.value)
6605 tmp = parmse.expr;
6606 else
6607 tmp = build_fold_indirect_ref_loc (input_location,
6608 parmse.expr);
6609
6610 parm_rank = e->rank;
6611 switch (parm_kind)
6612 {
6613 case (ELEMENTAL):
6614 case (SCALAR):
6615 parm_rank = 0;
6616 break;
6617
6618 case (SCALAR_POINTER):
6619 tmp = build_fold_indirect_ref_loc (input_location,
6620 tmp);
6621 break;
6622 }
6623
6624 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
6625 {
6626 /* The derived type is passed to gfc_deallocate_alloc_comp.
6627 Therefore, class actuals can be handled correctly but derived
6628 types passed to class formals need the _data component. */
6629 tmp = gfc_class_data_get (tmp);
6630 if (!CLASS_DATA (fsym)->attr.dimension)
6631 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6632 }
6633
6634 if (e->expr_type == EXPR_OP
6635 && e->value.op.op == INTRINSIC_PARENTHESES
6636 && e->value.op.op1->expr_type == EXPR_VARIABLE)
6637 {
6638 tree local_tmp;
6639 local_tmp = gfc_evaluate_now (tmp, &se->pre);
6640 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
6641 parm_rank, 0);
6642 gfc_add_expr_to_block (&se->post, local_tmp);
6643 }
6644
6645 if (!finalized && !e->must_finalize)
6646 {
6647 bool scalar_res_outside_loop;
6648 scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
6649 && parm_rank == 0
6650 && parmse.loop;
6651
6652 /* Scalars passed to an assumed rank argument are converted to
6653 a descriptor. Obtain the data field before deallocating any
6654 allocatable components. */
6655 if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
6656 tmp = gfc_conv_descriptor_data_get (tmp);
6657
6658 if (scalar_res_outside_loop)
6659 {
6660 /* Go through the ss chain to find the argument and use
6661 the stored value. */
6662 gfc_ss *tmp_ss = parmse.loop->ss;
6663 for (; tmp_ss; tmp_ss = tmp_ss->next)
6664 if (tmp_ss->info
6665 && tmp_ss->info->expr == e
6666 && tmp_ss->info->data.scalar.value != NULL_TREE)
6667 {
6668 tmp = tmp_ss->info->data.scalar.value;
6669 break;
6670 }
6671 }
6672
6673 STRIP_NOPS (tmp);
6674
6675 if (derived_array != NULL_TREE)
6676 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
6677 derived_array,
6678 parm_rank);
6679 else if ((e->ts.type == BT_CLASS
6680 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
6681 || e->ts.type == BT_DERIVED)
6682 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
6683 parm_rank);
6684 else if (e->ts.type == BT_CLASS)
6685 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
6686 tmp, parm_rank);
6687
6688 if (scalar_res_outside_loop)
6689 gfc_add_expr_to_block (&parmse.loop->post, tmp);
6690 else
6691 gfc_prepend_expr_to_block (&post, tmp);
6692 }
6693 }
6694
6695 /* Add argument checking of passing an unallocated/NULL actual to
6696 a nonallocatable/nonpointer dummy. */
6697
6698 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
6699 {
6700 symbol_attribute attr;
6701 char *msg;
6702 tree cond;
6703 tree tmp;
6704 symbol_attribute fsym_attr;
6705
6706 if (fsym)
6707 {
6708 if (fsym->ts.type == BT_CLASS)
6709 {
6710 fsym_attr = CLASS_DATA (fsym)->attr;
6711 fsym_attr.pointer = fsym_attr.class_pointer;
6712 }
6713 else
6714 fsym_attr = fsym->attr;
6715 }
6716
6717 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
6718 attr = gfc_expr_attr (e);
6719 else
6720 goto end_pointer_check;
6721
6722 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6723 allocatable to an optional dummy, cf. 12.5.2.12. */
6724 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
6725 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6726 goto end_pointer_check;
6727
6728 if (attr.optional)
6729 {
6730 /* If the actual argument is an optional pointer/allocatable and
6731 the formal argument takes an nonpointer optional value,
6732 it is invalid to pass a non-present argument on, even
6733 though there is no technical reason for this in gfortran.
6734 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6735 tree present, null_ptr, type;
6736
6737 if (attr.allocatable
6738 && (fsym == NULL || !fsym_attr.allocatable))
6739 msg = xasprintf ("Allocatable actual argument '%s' is not "
6740 "allocated or not present",
6741 e->symtree->n.sym->name);
6742 else if (attr.pointer
6743 && (fsym == NULL || !fsym_attr.pointer))
6744 msg = xasprintf ("Pointer actual argument '%s' is not "
6745 "associated or not present",
6746 e->symtree->n.sym->name);
6747 else if (attr.proc_pointer && !e->value.function.actual
6748 && (fsym == NULL || !fsym_attr.proc_pointer))
6749 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6750 "associated or not present",
6751 e->symtree->n.sym->name);
6752 else
6753 goto end_pointer_check;
6754
6755 present = gfc_conv_expr_present (e->symtree->n.sym);
6756 type = TREE_TYPE (present);
6757 present = fold_build2_loc (input_location, EQ_EXPR,
6758 logical_type_node, present,
6759 fold_convert (type,
6760 null_pointer_node));
6761 type = TREE_TYPE (parmse.expr);
6762 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
6763 logical_type_node, parmse.expr,
6764 fold_convert (type,
6765 null_pointer_node));
6766 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6767 logical_type_node, present, null_ptr);
6768 }
6769 else
6770 {
6771 if (attr.allocatable
6772 && (fsym == NULL || !fsym_attr.allocatable))
6773 msg = xasprintf ("Allocatable actual argument '%s' is not "
6774 "allocated", e->symtree->n.sym->name);
6775 else if (attr.pointer
6776 && (fsym == NULL || !fsym_attr.pointer))
6777 msg = xasprintf ("Pointer actual argument '%s' is not "
6778 "associated", e->symtree->n.sym->name);
6779 else if (attr.proc_pointer && !e->value.function.actual
6780 && (fsym == NULL || !fsym_attr.proc_pointer))
6781 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6782 "associated", e->symtree->n.sym->name);
6783 else
6784 goto end_pointer_check;
6785
6786 if (fsym && fsym->ts.type == BT_CLASS)
6787 {
6788 tmp = build_fold_indirect_ref_loc (input_location,
6789 parmse.expr);
6790 tmp = gfc_class_data_get (tmp);
6791 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
6792 tmp = gfc_conv_descriptor_data_get (tmp);
6793 }
6794 else
6795 tmp = parmse.expr;
6796
6797 /* If the argument is passed by value, we need to strip the
6798 INDIRECT_REF. */
6799 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
6800 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6801
6802 cond = fold_build2_loc (input_location, EQ_EXPR,
6803 logical_type_node, tmp,
6804 fold_convert (TREE_TYPE (tmp),
6805 null_pointer_node));
6806 }
6807
6808 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
6809 msg);
6810 free (msg);
6811 }
6812 end_pointer_check:
6813
6814 /* Deferred length dummies pass the character length by reference
6815 so that the value can be returned. */
6816 if (parmse.string_length && fsym && fsym->ts.deferred)
6817 {
6818 if (INDIRECT_REF_P (parmse.string_length))
6819 /* In chains of functions/procedure calls the string_length already
6820 is a pointer to the variable holding the length. Therefore
6821 remove the deref on call. */
6822 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
6823 else
6824 {
6825 tmp = parmse.string_length;
6826 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
6827 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
6828 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
6829 }
6830 }
6831
6832 /* Character strings are passed as two parameters, a length and a
6833 pointer - except for Bind(c) which only passes the pointer.
6834 An unlimited polymorphic formal argument likewise does not
6835 need the length. */
6836 if (parmse.string_length != NULL_TREE
6837 && !sym->attr.is_bind_c
6838 && !(fsym && UNLIMITED_POLY (fsym)))
6839 vec_safe_push (stringargs, parmse.string_length);
6840
6841 /* When calling __copy for character expressions to unlimited
6842 polymorphic entities, the dst argument needs a string length. */
6843 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
6844 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
6845 && arg->next && arg->next->expr
6846 && (arg->next->expr->ts.type == BT_DERIVED
6847 || arg->next->expr->ts.type == BT_CLASS)
6848 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
6849 vec_safe_push (stringargs, parmse.string_length);
6850
6851 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6852 pass the token and the offset as additional arguments. */
6853 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
6854 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6855 && !fsym->attr.allocatable)
6856 || (fsym->ts.type == BT_CLASS
6857 && CLASS_DATA (fsym)->attr.codimension
6858 && !CLASS_DATA (fsym)->attr.allocatable)))
6859 {
6860 /* Token and offset. */
6861 vec_safe_push (stringargs, null_pointer_node);
6862 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
6863 gcc_assert (fsym->attr.optional);
6864 }
6865 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
6866 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6867 && !fsym->attr.allocatable)
6868 || (fsym->ts.type == BT_CLASS
6869 && CLASS_DATA (fsym)->attr.codimension
6870 && !CLASS_DATA (fsym)->attr.allocatable)))
6871 {
6872 tree caf_decl, caf_type;
6873 tree offset, tmp2;
6874
6875 caf_decl = gfc_get_tree_for_caf_expr (e);
6876 caf_type = TREE_TYPE (caf_decl);
6877
6878 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6879 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
6880 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
6881 tmp = gfc_conv_descriptor_token (caf_decl);
6882 else if (DECL_LANG_SPECIFIC (caf_decl)
6883 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
6884 tmp = GFC_DECL_TOKEN (caf_decl);
6885 else
6886 {
6887 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
6888 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
6889 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
6890 }
6891
6892 vec_safe_push (stringargs, tmp);
6893
6894 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6895 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
6896 offset = build_int_cst (gfc_array_index_type, 0);
6897 else if (DECL_LANG_SPECIFIC (caf_decl)
6898 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
6899 offset = GFC_DECL_CAF_OFFSET (caf_decl);
6900 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
6901 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
6902 else
6903 offset = build_int_cst (gfc_array_index_type, 0);
6904
6905 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
6906 tmp = gfc_conv_descriptor_data_get (caf_decl);
6907 else
6908 {
6909 gcc_assert (POINTER_TYPE_P (caf_type));
6910 tmp = caf_decl;
6911 }
6912
6913 tmp2 = fsym->ts.type == BT_CLASS
6914 ? gfc_class_data_get (parmse.expr) : parmse.expr;
6915 if ((fsym->ts.type != BT_CLASS
6916 && (fsym->as->type == AS_ASSUMED_SHAPE
6917 || fsym->as->type == AS_ASSUMED_RANK))
6918 || (fsym->ts.type == BT_CLASS
6919 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6920 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6921 {
6922 if (fsym->ts.type == BT_CLASS)
6923 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6924 else
6925 {
6926 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6927 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6928 }
6929 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6930 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6931 }
6932 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6933 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6934 else
6935 {
6936 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6937 }
6938
6939 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6940 gfc_array_index_type,
6941 fold_convert (gfc_array_index_type, tmp2),
6942 fold_convert (gfc_array_index_type, tmp));
6943 offset = fold_build2_loc (input_location, PLUS_EXPR,
6944 gfc_array_index_type, offset, tmp);
6945
6946 vec_safe_push (stringargs, offset);
6947 }
6948
6949 vec_safe_push (arglist, parmse.expr);
6950 }
6951 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6952
6953 if (comp)
6954 ts = comp->ts;
6955 else if (sym->ts.type == BT_CLASS)
6956 ts = CLASS_DATA (sym)->ts;
6957 else
6958 ts = sym->ts;
6959
6960 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6961 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6962 else if (ts.type == BT_CHARACTER)
6963 {
6964 if (ts.u.cl->length == NULL)
6965 {
6966 /* Assumed character length results are not allowed by C418 of the 2003
6967 standard and are trapped in resolve.c; except in the case of SPREAD
6968 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6969 we take the character length of the first argument for the result.
6970 For dummies, we have to look through the formal argument list for
6971 this function and use the character length found there.*/
6972 if (ts.deferred)
6973 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6974 else if (!sym->attr.dummy)
6975 cl.backend_decl = (*stringargs)[0];
6976 else
6977 {
6978 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6979 for (; formal; formal = formal->next)
6980 if (strcmp (formal->sym->name, sym->name) == 0)
6981 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6982 }
6983 len = cl.backend_decl;
6984 }
6985 else
6986 {
6987 tree tmp;
6988
6989 /* Calculate the length of the returned string. */
6990 gfc_init_se (&parmse, NULL);
6991 if (need_interface_mapping)
6992 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6993 else
6994 gfc_conv_expr (&parmse, ts.u.cl->length);
6995 gfc_add_block_to_block (&se->pre, &parmse.pre);
6996 gfc_add_block_to_block (&se->post, &parmse.post);
6997 tmp = parmse.expr;
6998 /* TODO: It would be better to have the charlens as
6999 gfc_charlen_type_node already when the interface is
7000 created instead of converting it here (see PR 84615). */
7001 tmp = fold_build2_loc (input_location, MAX_EXPR,
7002 gfc_charlen_type_node,
7003 fold_convert (gfc_charlen_type_node, tmp),
7004 build_zero_cst (gfc_charlen_type_node));
7005 cl.backend_decl = tmp;
7006 }
7007
7008 /* Set up a charlen structure for it. */
7009 cl.next = NULL;
7010 cl.length = NULL;
7011 ts.u.cl = &cl;
7012
7013 len = cl.backend_decl;
7014 }
7015
7016 byref = (comp && (comp->attr.dimension
7017 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
7018 || (!comp && gfc_return_by_reference (sym));
7019 if (byref)
7020 {
7021 if (se->direct_byref)
7022 {
7023 /* Sometimes, too much indirection can be applied; e.g. for
7024 function_result = array_valued_recursive_function. */
7025 if (TREE_TYPE (TREE_TYPE (se->expr))
7026 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
7027 && GFC_DESCRIPTOR_TYPE_P
7028 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
7029 se->expr = build_fold_indirect_ref_loc (input_location,
7030 se->expr);
7031
7032 /* If the lhs of an assignment x = f(..) is allocatable and
7033 f2003 is allowed, we must do the automatic reallocation.
7034 TODO - deal with intrinsics, without using a temporary. */
7035 if (flag_realloc_lhs
7036 && se->ss && se->ss->loop_chain
7037 && se->ss->loop_chain->is_alloc_lhs
7038 && !expr->value.function.isym
7039 && sym->result->as != NULL)
7040 {
7041 /* Evaluate the bounds of the result, if known. */
7042 gfc_set_loop_bounds_from_array_spec (&mapping, se,
7043 sym->result->as);
7044
7045 /* Perform the automatic reallocation. */
7046 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
7047 expr, NULL);
7048 gfc_add_expr_to_block (&se->pre, tmp);
7049
7050 /* Pass the temporary as the first argument. */
7051 result = info->descriptor;
7052 }
7053 else
7054 result = build_fold_indirect_ref_loc (input_location,
7055 se->expr);
7056 vec_safe_push (retargs, se->expr);
7057 }
7058 else if (comp && comp->attr.dimension)
7059 {
7060 gcc_assert (se->loop && info);
7061
7062 /* Set the type of the array. */
7063 tmp = gfc_typenode_for_spec (&comp->ts);
7064 gcc_assert (se->ss->dimen == se->loop->dimen);
7065
7066 /* Evaluate the bounds of the result, if known. */
7067 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
7068
7069 /* If the lhs of an assignment x = f(..) is allocatable and
7070 f2003 is allowed, we must not generate the function call
7071 here but should just send back the results of the mapping.
7072 This is signalled by the function ss being flagged. */
7073 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
7074 {
7075 gfc_free_interface_mapping (&mapping);
7076 return has_alternate_specifier;
7077 }
7078
7079 /* Create a temporary to store the result. In case the function
7080 returns a pointer, the temporary will be a shallow copy and
7081 mustn't be deallocated. */
7082 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
7083 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
7084 tmp, NULL_TREE, false,
7085 !comp->attr.pointer, callee_alloc,
7086 &se->ss->info->expr->where);
7087
7088 /* Pass the temporary as the first argument. */
7089 result = info->descriptor;
7090 tmp = gfc_build_addr_expr (NULL_TREE, result);
7091 vec_safe_push (retargs, tmp);
7092 }
7093 else if (!comp && sym->result->attr.dimension)
7094 {
7095 gcc_assert (se->loop && info);
7096
7097 /* Set the type of the array. */
7098 tmp = gfc_typenode_for_spec (&ts);
7099 gcc_assert (se->ss->dimen == se->loop->dimen);
7100
7101 /* Evaluate the bounds of the result, if known. */
7102 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
7103
7104 /* If the lhs of an assignment x = f(..) is allocatable and
7105 f2003 is allowed, we must not generate the function call
7106 here but should just send back the results of the mapping.
7107 This is signalled by the function ss being flagged. */
7108 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
7109 {
7110 gfc_free_interface_mapping (&mapping);
7111 return has_alternate_specifier;
7112 }
7113
7114 /* Create a temporary to store the result. In case the function
7115 returns a pointer, the temporary will be a shallow copy and
7116 mustn't be deallocated. */
7117 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
7118 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
7119 tmp, NULL_TREE, false,
7120 !sym->attr.pointer, callee_alloc,
7121 &se->ss->info->expr->where);
7122
7123 /* Pass the temporary as the first argument. */
7124 result = info->descriptor;
7125 tmp = gfc_build_addr_expr (NULL_TREE, result);
7126 vec_safe_push (retargs, tmp);
7127 }
7128 else if (ts.type == BT_CHARACTER)
7129 {
7130 /* Pass the string length. */
7131 type = gfc_get_character_type (ts.kind, ts.u.cl);
7132 type = build_pointer_type (type);
7133
7134 /* Emit a DECL_EXPR for the VLA type. */
7135 tmp = TREE_TYPE (type);
7136 if (TYPE_SIZE (tmp)
7137 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
7138 {
7139 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
7140 DECL_ARTIFICIAL (tmp) = 1;
7141 DECL_IGNORED_P (tmp) = 1;
7142 tmp = fold_build1_loc (input_location, DECL_EXPR,
7143 TREE_TYPE (tmp), tmp);
7144 gfc_add_expr_to_block (&se->pre, tmp);
7145 }
7146
7147 /* Return an address to a char[0:len-1]* temporary for
7148 character pointers. */
7149 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7150 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
7151 {
7152 var = gfc_create_var (type, "pstr");
7153
7154 if ((!comp && sym->attr.allocatable)
7155 || (comp && comp->attr.allocatable))
7156 {
7157 gfc_add_modify (&se->pre, var,
7158 fold_convert (TREE_TYPE (var),
7159 null_pointer_node));
7160 tmp = gfc_call_free (var);
7161 gfc_add_expr_to_block (&se->post, tmp);
7162 }
7163
7164 /* Provide an address expression for the function arguments. */
7165 var = gfc_build_addr_expr (NULL_TREE, var);
7166 }
7167 else
7168 var = gfc_conv_string_tmp (se, type, len);
7169
7170 vec_safe_push (retargs, var);
7171 }
7172 else
7173 {
7174 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
7175
7176 type = gfc_get_complex_type (ts.kind);
7177 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
7178 vec_safe_push (retargs, var);
7179 }
7180
7181 /* Add the string length to the argument list. */
7182 if (ts.type == BT_CHARACTER && ts.deferred)
7183 {
7184 tmp = len;
7185 if (!VAR_P (tmp))
7186 tmp = gfc_evaluate_now (len, &se->pre);
7187 TREE_STATIC (tmp) = 1;
7188 gfc_add_modify (&se->pre, tmp,
7189 build_int_cst (TREE_TYPE (tmp), 0));
7190 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
7191 vec_safe_push (retargs, tmp);
7192 }
7193 else if (ts.type == BT_CHARACTER)
7194 vec_safe_push (retargs, len);
7195 }
7196 gfc_free_interface_mapping (&mapping);
7197
7198 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
7199 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
7200 + vec_safe_length (stringargs) + vec_safe_length (append_args));
7201 vec_safe_reserve (retargs, arglen);
7202
7203 /* Add the return arguments. */
7204 vec_safe_splice (retargs, arglist);
7205
7206 /* Add the hidden present status for optional+value to the arguments. */
7207 vec_safe_splice (retargs, optionalargs);
7208
7209 /* Add the hidden string length parameters to the arguments. */
7210 vec_safe_splice (retargs, stringargs);
7211
7212 /* We may want to append extra arguments here. This is used e.g. for
7213 calls to libgfortran_matmul_??, which need extra information. */
7214 vec_safe_splice (retargs, append_args);
7215
7216 arglist = retargs;
7217
7218 /* Generate the actual call. */
7219 if (base_object == NULL_TREE)
7220 conv_function_val (se, sym, expr, args);
7221 else
7222 conv_base_obj_fcn_val (se, base_object, expr);
7223
7224 /* If there are alternate return labels, function type should be
7225 integer. Can't modify the type in place though, since it can be shared
7226 with other functions. For dummy arguments, the typing is done to
7227 this result, even if it has to be repeated for each call. */
7228 if (has_alternate_specifier
7229 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
7230 {
7231 if (!sym->attr.dummy)
7232 {
7233 TREE_TYPE (sym->backend_decl)
7234 = build_function_type (integer_type_node,
7235 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
7236 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
7237 }
7238 else
7239 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
7240 }
7241
7242 fntype = TREE_TYPE (TREE_TYPE (se->expr));
7243 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
7244
7245 /* Allocatable scalar function results must be freed and nullified
7246 after use. This necessitates the creation of a temporary to
7247 hold the result to prevent duplicate calls. */
7248 if (!byref && sym->ts.type != BT_CHARACTER
7249 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
7250 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
7251 {
7252 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
7253 gfc_add_modify (&se->pre, tmp, se->expr);
7254 se->expr = tmp;
7255 tmp = gfc_call_free (tmp);
7256 gfc_add_expr_to_block (&post, tmp);
7257 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
7258 }
7259
7260 /* If we have a pointer function, but we don't want a pointer, e.g.
7261 something like
7262 x = f()
7263 where f is pointer valued, we have to dereference the result. */
7264 if (!se->want_pointer && !byref
7265 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7266 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
7267 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7268
7269 /* f2c calling conventions require a scalar default real function to
7270 return a double precision result. Convert this back to default
7271 real. We only care about the cases that can happen in Fortran 77.
7272 */
7273 if (flag_f2c && sym->ts.type == BT_REAL
7274 && sym->ts.kind == gfc_default_real_kind
7275 && !sym->attr.always_explicit)
7276 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
7277
7278 /* A pure function may still have side-effects - it may modify its
7279 parameters. */
7280 TREE_SIDE_EFFECTS (se->expr) = 1;
7281 #if 0
7282 if (!sym->attr.pure)
7283 TREE_SIDE_EFFECTS (se->expr) = 1;
7284 #endif
7285
7286 if (byref)
7287 {
7288 /* Add the function call to the pre chain. There is no expression. */
7289 gfc_add_expr_to_block (&se->pre, se->expr);
7290 se->expr = NULL_TREE;
7291
7292 if (!se->direct_byref)
7293 {
7294 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
7295 {
7296 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
7297 {
7298 /* Check the data pointer hasn't been modified. This would
7299 happen in a function returning a pointer. */
7300 tmp = gfc_conv_descriptor_data_get (info->descriptor);
7301 tmp = fold_build2_loc (input_location, NE_EXPR,
7302 logical_type_node,
7303 tmp, info->data);
7304 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
7305 gfc_msg_fault);
7306 }
7307 se->expr = info->descriptor;
7308 /* Bundle in the string length. */
7309 se->string_length = len;
7310 }
7311 else if (ts.type == BT_CHARACTER)
7312 {
7313 /* Dereference for character pointer results. */
7314 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7315 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
7316 se->expr = build_fold_indirect_ref_loc (input_location, var);
7317 else
7318 se->expr = var;
7319
7320 se->string_length = len;
7321 }
7322 else
7323 {
7324 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
7325 se->expr = build_fold_indirect_ref_loc (input_location, var);
7326 }
7327 }
7328 }
7329
7330 /* Associate the rhs class object's meta-data with the result, when the
7331 result is a temporary. */
7332 if (args && args->expr && args->expr->ts.type == BT_CLASS
7333 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
7334 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
7335 {
7336 gfc_se parmse;
7337 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
7338
7339 gfc_init_se (&parmse, NULL);
7340 parmse.data_not_needed = 1;
7341 gfc_conv_expr (&parmse, class_expr);
7342 if (!DECL_LANG_SPECIFIC (result))
7343 gfc_allocate_lang_decl (result);
7344 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
7345 gfc_free_expr (class_expr);
7346 /* -fcheck= can add diagnostic code, which has to be placed before
7347 the call. */
7348 if (parmse.pre.head != NULL)
7349 gfc_add_expr_to_block (&se->pre, parmse.pre.head);
7350 gcc_assert (parmse.post.head == NULL_TREE);
7351 }
7352
7353 /* Follow the function call with the argument post block. */
7354 if (byref)
7355 {
7356 gfc_add_block_to_block (&se->pre, &post);
7357
7358 /* Transformational functions of derived types with allocatable
7359 components must have the result allocatable components copied when the
7360 argument is actually given. */
7361 arg = expr->value.function.actual;
7362 if (result && arg && expr->rank
7363 && expr->value.function.isym
7364 && expr->value.function.isym->transformational
7365 && arg->expr
7366 && arg->expr->ts.type == BT_DERIVED
7367 && arg->expr->ts.u.derived->attr.alloc_comp)
7368 {
7369 tree tmp2;
7370 /* Copy the allocatable components. We have to use a
7371 temporary here to prevent source allocatable components
7372 from being corrupted. */
7373 tmp2 = gfc_evaluate_now (result, &se->pre);
7374 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
7375 result, tmp2, expr->rank, 0);
7376 gfc_add_expr_to_block (&se->pre, tmp);
7377 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
7378 expr->rank);
7379 gfc_add_expr_to_block (&se->pre, tmp);
7380
7381 /* Finally free the temporary's data field. */
7382 tmp = gfc_conv_descriptor_data_get (tmp2);
7383 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7384 NULL_TREE, NULL_TREE, true,
7385 NULL, GFC_CAF_COARRAY_NOCOARRAY);
7386 gfc_add_expr_to_block (&se->pre, tmp);
7387 }
7388 }
7389 else
7390 {
7391 /* For a function with a class array result, save the result as
7392 a temporary, set the info fields needed by the scalarizer and
7393 call the finalization function of the temporary. Note that the
7394 nullification of allocatable components needed by the result
7395 is done in gfc_trans_assignment_1. */
7396 if (expr && ((gfc_is_class_array_function (expr)
7397 && se->ss && se->ss->loop)
7398 || gfc_is_alloc_class_scalar_function (expr))
7399 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
7400 && expr->must_finalize)
7401 {
7402 tree final_fndecl;
7403 tree is_final;
7404 int n;
7405 if (se->ss && se->ss->loop)
7406 {
7407 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
7408 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
7409 tmp = gfc_class_data_get (se->expr);
7410 info->descriptor = tmp;
7411 info->data = gfc_conv_descriptor_data_get (tmp);
7412 info->offset = gfc_conv_descriptor_offset_get (tmp);
7413 for (n = 0; n < se->ss->loop->dimen; n++)
7414 {
7415 tree dim = gfc_rank_cst[n];
7416 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
7417 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
7418 }
7419 }
7420 else
7421 {
7422 /* TODO Eliminate the doubling of temporaries. This
7423 one is necessary to ensure no memory leakage. */
7424 se->expr = gfc_evaluate_now (se->expr, &se->pre);
7425 tmp = gfc_class_data_get (se->expr);
7426 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
7427 CLASS_DATA (expr->value.function.esym->result)->attr);
7428 }
7429
7430 if ((gfc_is_class_array_function (expr)
7431 || gfc_is_alloc_class_scalar_function (expr))
7432 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
7433 goto no_finalization;
7434
7435 final_fndecl = gfc_class_vtab_final_get (se->expr);
7436 is_final = fold_build2_loc (input_location, NE_EXPR,
7437 logical_type_node,
7438 final_fndecl,
7439 fold_convert (TREE_TYPE (final_fndecl),
7440 null_pointer_node));
7441 final_fndecl = build_fold_indirect_ref_loc (input_location,
7442 final_fndecl);
7443 tmp = build_call_expr_loc (input_location,
7444 final_fndecl, 3,
7445 gfc_build_addr_expr (NULL, tmp),
7446 gfc_class_vtab_size_get (se->expr),
7447 boolean_false_node);
7448 tmp = fold_build3_loc (input_location, COND_EXPR,
7449 void_type_node, is_final, tmp,
7450 build_empty_stmt (input_location));
7451
7452 if (se->ss && se->ss->loop)
7453 {
7454 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
7455 tmp = fold_build2_loc (input_location, NE_EXPR,
7456 logical_type_node,
7457 info->data,
7458 fold_convert (TREE_TYPE (info->data),
7459 null_pointer_node));
7460 tmp = fold_build3_loc (input_location, COND_EXPR,
7461 void_type_node, tmp,
7462 gfc_call_free (info->data),
7463 build_empty_stmt (input_location));
7464 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
7465 }
7466 else
7467 {
7468 tree classdata;
7469 gfc_prepend_expr_to_block (&se->post, tmp);
7470 classdata = gfc_class_data_get (se->expr);
7471 tmp = fold_build2_loc (input_location, NE_EXPR,
7472 logical_type_node,
7473 classdata,
7474 fold_convert (TREE_TYPE (classdata),
7475 null_pointer_node));
7476 tmp = fold_build3_loc (input_location, COND_EXPR,
7477 void_type_node, tmp,
7478 gfc_call_free (classdata),
7479 build_empty_stmt (input_location));
7480 gfc_add_expr_to_block (&se->post, tmp);
7481 }
7482 }
7483
7484 no_finalization:
7485 gfc_add_block_to_block (&se->post, &post);
7486 }
7487
7488 return has_alternate_specifier;
7489 }
7490
7491
7492 /* Fill a character string with spaces. */
7493
7494 static tree
fill_with_spaces(tree start,tree type,tree size)7495 fill_with_spaces (tree start, tree type, tree size)
7496 {
7497 stmtblock_t block, loop;
7498 tree i, el, exit_label, cond, tmp;
7499
7500 /* For a simple char type, we can call memset(). */
7501 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
7502 return build_call_expr_loc (input_location,
7503 builtin_decl_explicit (BUILT_IN_MEMSET),
7504 3, start,
7505 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
7506 lang_hooks.to_target_charset (' ')),
7507 fold_convert (size_type_node, size));
7508
7509 /* Otherwise, we use a loop:
7510 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7511 *el = (type) ' ';
7512 */
7513
7514 /* Initialize variables. */
7515 gfc_init_block (&block);
7516 i = gfc_create_var (sizetype, "i");
7517 gfc_add_modify (&block, i, fold_convert (sizetype, size));
7518 el = gfc_create_var (build_pointer_type (type), "el");
7519 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
7520 exit_label = gfc_build_label_decl (NULL_TREE);
7521 TREE_USED (exit_label) = 1;
7522
7523
7524 /* Loop body. */
7525 gfc_init_block (&loop);
7526
7527 /* Exit condition. */
7528 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
7529 build_zero_cst (sizetype));
7530 tmp = build1_v (GOTO_EXPR, exit_label);
7531 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7532 build_empty_stmt (input_location));
7533 gfc_add_expr_to_block (&loop, tmp);
7534
7535 /* Assignment. */
7536 gfc_add_modify (&loop,
7537 fold_build1_loc (input_location, INDIRECT_REF, type, el),
7538 build_int_cst (type, lang_hooks.to_target_charset (' ')));
7539
7540 /* Increment loop variables. */
7541 gfc_add_modify (&loop, i,
7542 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
7543 TYPE_SIZE_UNIT (type)));
7544 gfc_add_modify (&loop, el,
7545 fold_build_pointer_plus_loc (input_location,
7546 el, TYPE_SIZE_UNIT (type)));
7547
7548 /* Making the loop... actually loop! */
7549 tmp = gfc_finish_block (&loop);
7550 tmp = build1_v (LOOP_EXPR, tmp);
7551 gfc_add_expr_to_block (&block, tmp);
7552
7553 /* The exit label. */
7554 tmp = build1_v (LABEL_EXPR, exit_label);
7555 gfc_add_expr_to_block (&block, tmp);
7556
7557
7558 return gfc_finish_block (&block);
7559 }
7560
7561
7562 /* Generate code to copy a string. */
7563
7564 void
gfc_trans_string_copy(stmtblock_t * block,tree dlength,tree dest,int dkind,tree slength,tree src,int skind)7565 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
7566 int dkind, tree slength, tree src, int skind)
7567 {
7568 tree tmp, dlen, slen;
7569 tree dsc;
7570 tree ssc;
7571 tree cond;
7572 tree cond2;
7573 tree tmp2;
7574 tree tmp3;
7575 tree tmp4;
7576 tree chartype;
7577 stmtblock_t tempblock;
7578
7579 gcc_assert (dkind == skind);
7580
7581 if (slength != NULL_TREE)
7582 {
7583 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
7584 ssc = gfc_string_to_single_character (slen, src, skind);
7585 }
7586 else
7587 {
7588 slen = build_one_cst (gfc_charlen_type_node);
7589 ssc = src;
7590 }
7591
7592 if (dlength != NULL_TREE)
7593 {
7594 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
7595 dsc = gfc_string_to_single_character (dlen, dest, dkind);
7596 }
7597 else
7598 {
7599 dlen = build_one_cst (gfc_charlen_type_node);
7600 dsc = dest;
7601 }
7602
7603 /* Assign directly if the types are compatible. */
7604 if (dsc != NULL_TREE && ssc != NULL_TREE
7605 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
7606 {
7607 gfc_add_modify (block, dsc, ssc);
7608 return;
7609 }
7610
7611 /* The string copy algorithm below generates code like
7612
7613 if (destlen > 0)
7614 {
7615 if (srclen < destlen)
7616 {
7617 memmove (dest, src, srclen);
7618 // Pad with spaces.
7619 memset (&dest[srclen], ' ', destlen - srclen);
7620 }
7621 else
7622 {
7623 // Truncate if too long.
7624 memmove (dest, src, destlen);
7625 }
7626 }
7627 */
7628
7629 /* Do nothing if the destination length is zero. */
7630 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
7631 build_zero_cst (TREE_TYPE (dlen)));
7632
7633 /* For non-default character kinds, we have to multiply the string
7634 length by the base type size. */
7635 chartype = gfc_get_char_type (dkind);
7636 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
7637 slen,
7638 fold_convert (TREE_TYPE (slen),
7639 TYPE_SIZE_UNIT (chartype)));
7640 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
7641 dlen,
7642 fold_convert (TREE_TYPE (dlen),
7643 TYPE_SIZE_UNIT (chartype)));
7644
7645 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
7646 dest = fold_convert (pvoid_type_node, dest);
7647 else
7648 dest = gfc_build_addr_expr (pvoid_type_node, dest);
7649
7650 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
7651 src = fold_convert (pvoid_type_node, src);
7652 else
7653 src = gfc_build_addr_expr (pvoid_type_node, src);
7654
7655 /* Truncate string if source is too long. */
7656 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
7657 dlen);
7658
7659 /* Copy and pad with spaces. */
7660 tmp3 = build_call_expr_loc (input_location,
7661 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7662 3, dest, src,
7663 fold_convert (size_type_node, slen));
7664
7665 /* Wstringop-overflow appears at -O3 even though this warning is not
7666 explicitly available in fortran nor can it be switched off. If the
7667 source length is a constant, its negative appears as a very large
7668 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7669 the result of the MINUS_EXPR suppresses this spurious warning. */
7670 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7671 TREE_TYPE(dlen), dlen, slen);
7672 if (slength && TREE_CONSTANT (slength))
7673 tmp = gfc_evaluate_now (tmp, block);
7674
7675 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
7676 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
7677
7678 gfc_init_block (&tempblock);
7679 gfc_add_expr_to_block (&tempblock, tmp3);
7680 gfc_add_expr_to_block (&tempblock, tmp4);
7681 tmp3 = gfc_finish_block (&tempblock);
7682
7683 /* The truncated memmove if the slen >= dlen. */
7684 tmp2 = build_call_expr_loc (input_location,
7685 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7686 3, dest, src,
7687 fold_convert (size_type_node, dlen));
7688
7689 /* The whole copy_string function is there. */
7690 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
7691 tmp3, tmp2);
7692 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7693 build_empty_stmt (input_location));
7694 gfc_add_expr_to_block (block, tmp);
7695 }
7696
7697
7698 /* Translate a statement function.
7699 The value of a statement function reference is obtained by evaluating the
7700 expression using the values of the actual arguments for the values of the
7701 corresponding dummy arguments. */
7702
7703 static void
gfc_conv_statement_function(gfc_se * se,gfc_expr * expr)7704 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
7705 {
7706 gfc_symbol *sym;
7707 gfc_symbol *fsym;
7708 gfc_formal_arglist *fargs;
7709 gfc_actual_arglist *args;
7710 gfc_se lse;
7711 gfc_se rse;
7712 gfc_saved_var *saved_vars;
7713 tree *temp_vars;
7714 tree type;
7715 tree tmp;
7716 int n;
7717
7718 sym = expr->symtree->n.sym;
7719 args = expr->value.function.actual;
7720 gfc_init_se (&lse, NULL);
7721 gfc_init_se (&rse, NULL);
7722
7723 n = 0;
7724 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
7725 n++;
7726 saved_vars = XCNEWVEC (gfc_saved_var, n);
7727 temp_vars = XCNEWVEC (tree, n);
7728
7729 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7730 fargs = fargs->next, n++)
7731 {
7732 /* Each dummy shall be specified, explicitly or implicitly, to be
7733 scalar. */
7734 gcc_assert (fargs->sym->attr.dimension == 0);
7735 fsym = fargs->sym;
7736
7737 if (fsym->ts.type == BT_CHARACTER)
7738 {
7739 /* Copy string arguments. */
7740 tree arglen;
7741
7742 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
7743 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
7744
7745 /* Create a temporary to hold the value. */
7746 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
7747 fsym->ts.u.cl->backend_decl
7748 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
7749
7750 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
7751 temp_vars[n] = gfc_create_var (type, fsym->name);
7752
7753 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
7754
7755 gfc_conv_expr (&rse, args->expr);
7756 gfc_conv_string_parameter (&rse);
7757 gfc_add_block_to_block (&se->pre, &lse.pre);
7758 gfc_add_block_to_block (&se->pre, &rse.pre);
7759
7760 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
7761 rse.string_length, rse.expr, fsym->ts.kind);
7762 gfc_add_block_to_block (&se->pre, &lse.post);
7763 gfc_add_block_to_block (&se->pre, &rse.post);
7764 }
7765 else
7766 {
7767 /* For everything else, just evaluate the expression. */
7768
7769 /* Create a temporary to hold the value. */
7770 type = gfc_typenode_for_spec (&fsym->ts);
7771 temp_vars[n] = gfc_create_var (type, fsym->name);
7772
7773 gfc_conv_expr (&lse, args->expr);
7774
7775 gfc_add_block_to_block (&se->pre, &lse.pre);
7776 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
7777 gfc_add_block_to_block (&se->pre, &lse.post);
7778 }
7779
7780 args = args->next;
7781 }
7782
7783 /* Use the temporary variables in place of the real ones. */
7784 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7785 fargs = fargs->next, n++)
7786 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
7787
7788 gfc_conv_expr (se, sym->value);
7789
7790 if (sym->ts.type == BT_CHARACTER)
7791 {
7792 gfc_conv_const_charlen (sym->ts.u.cl);
7793
7794 /* Force the expression to the correct length. */
7795 if (!INTEGER_CST_P (se->string_length)
7796 || tree_int_cst_lt (se->string_length,
7797 sym->ts.u.cl->backend_decl))
7798 {
7799 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
7800 tmp = gfc_create_var (type, sym->name);
7801 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
7802 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
7803 sym->ts.kind, se->string_length, se->expr,
7804 sym->ts.kind);
7805 se->expr = tmp;
7806 }
7807 se->string_length = sym->ts.u.cl->backend_decl;
7808 }
7809
7810 /* Restore the original variables. */
7811 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7812 fargs = fargs->next, n++)
7813 gfc_restore_sym (fargs->sym, &saved_vars[n]);
7814 free (temp_vars);
7815 free (saved_vars);
7816 }
7817
7818
7819 /* Translate a function expression. */
7820
7821 static void
gfc_conv_function_expr(gfc_se * se,gfc_expr * expr)7822 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
7823 {
7824 gfc_symbol *sym;
7825
7826 if (expr->value.function.isym)
7827 {
7828 gfc_conv_intrinsic_function (se, expr);
7829 return;
7830 }
7831
7832 /* expr.value.function.esym is the resolved (specific) function symbol for
7833 most functions. However this isn't set for dummy procedures. */
7834 sym = expr->value.function.esym;
7835 if (!sym)
7836 sym = expr->symtree->n.sym;
7837
7838 /* The IEEE_ARITHMETIC functions are caught here. */
7839 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
7840 if (gfc_conv_ieee_arithmetic_function (se, expr))
7841 return;
7842
7843 /* We distinguish statement functions from general functions to improve
7844 runtime performance. */
7845 if (sym->attr.proc == PROC_ST_FUNCTION)
7846 {
7847 gfc_conv_statement_function (se, expr);
7848 return;
7849 }
7850
7851 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7852 NULL);
7853 }
7854
7855
7856 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7857
7858 static bool
is_zero_initializer_p(gfc_expr * expr)7859 is_zero_initializer_p (gfc_expr * expr)
7860 {
7861 if (expr->expr_type != EXPR_CONSTANT)
7862 return false;
7863
7864 /* We ignore constants with prescribed memory representations for now. */
7865 if (expr->representation.string)
7866 return false;
7867
7868 switch (expr->ts.type)
7869 {
7870 case BT_INTEGER:
7871 return mpz_cmp_si (expr->value.integer, 0) == 0;
7872
7873 case BT_REAL:
7874 return mpfr_zero_p (expr->value.real)
7875 && MPFR_SIGN (expr->value.real) >= 0;
7876
7877 case BT_LOGICAL:
7878 return expr->value.logical == 0;
7879
7880 case BT_COMPLEX:
7881 return mpfr_zero_p (mpc_realref (expr->value.complex))
7882 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
7883 && mpfr_zero_p (mpc_imagref (expr->value.complex))
7884 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
7885
7886 default:
7887 break;
7888 }
7889 return false;
7890 }
7891
7892
7893 static void
gfc_conv_array_constructor_expr(gfc_se * se,gfc_expr * expr)7894 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
7895 {
7896 gfc_ss *ss;
7897
7898 ss = se->ss;
7899 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
7900 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
7901
7902 gfc_conv_tmp_array_ref (se);
7903 }
7904
7905
7906 /* Build a static initializer. EXPR is the expression for the initial value.
7907 The other parameters describe the variable of the component being
7908 initialized. EXPR may be null. */
7909
7910 tree
gfc_conv_initializer(gfc_expr * expr,gfc_typespec * ts,tree type,bool array,bool pointer,bool procptr)7911 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
7912 bool array, bool pointer, bool procptr)
7913 {
7914 gfc_se se;
7915
7916 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
7917 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7918 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7919 return build_constructor (type, NULL);
7920
7921 if (!(expr || pointer || procptr))
7922 return NULL_TREE;
7923
7924 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7925 (these are the only two iso_c_binding derived types that can be
7926 used as initialization expressions). If so, we need to modify
7927 the 'expr' to be that for a (void *). */
7928 if (expr != NULL && expr->ts.type == BT_DERIVED
7929 && expr->ts.is_iso_c && expr->ts.u.derived)
7930 {
7931 if (TREE_CODE (type) == ARRAY_TYPE)
7932 return build_constructor (type, NULL);
7933 else if (POINTER_TYPE_P (type))
7934 return build_int_cst (type, 0);
7935 else
7936 gcc_unreachable ();
7937 }
7938
7939 if (array && !procptr)
7940 {
7941 tree ctor;
7942 /* Arrays need special handling. */
7943 if (pointer)
7944 ctor = gfc_build_null_descriptor (type);
7945 /* Special case assigning an array to zero. */
7946 else if (is_zero_initializer_p (expr))
7947 ctor = build_constructor (type, NULL);
7948 else
7949 ctor = gfc_conv_array_initializer (type, expr);
7950 TREE_STATIC (ctor) = 1;
7951 return ctor;
7952 }
7953 else if (pointer || procptr)
7954 {
7955 if (ts->type == BT_CLASS && !procptr)
7956 {
7957 gfc_init_se (&se, NULL);
7958 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7959 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7960 TREE_STATIC (se.expr) = 1;
7961 return se.expr;
7962 }
7963 else if (!expr || expr->expr_type == EXPR_NULL)
7964 return fold_convert (type, null_pointer_node);
7965 else
7966 {
7967 gfc_init_se (&se, NULL);
7968 se.want_pointer = 1;
7969 gfc_conv_expr (&se, expr);
7970 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7971 return se.expr;
7972 }
7973 }
7974 else
7975 {
7976 switch (ts->type)
7977 {
7978 case_bt_struct:
7979 case BT_CLASS:
7980 gfc_init_se (&se, NULL);
7981 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7982 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7983 else
7984 gfc_conv_structure (&se, expr, 1);
7985 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7986 TREE_STATIC (se.expr) = 1;
7987 return se.expr;
7988
7989 case BT_CHARACTER:
7990 if (expr->expr_type == EXPR_CONSTANT)
7991 {
7992 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl, expr);
7993 TREE_STATIC (ctor) = 1;
7994 return ctor;
7995 }
7996
7997 /* Fallthrough. */
7998 default:
7999 gfc_init_se (&se, NULL);
8000 gfc_conv_constant (&se, expr);
8001 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
8002 return se.expr;
8003 }
8004 }
8005 }
8006
8007 static tree
gfc_trans_subarray_assign(tree dest,gfc_component * cm,gfc_expr * expr)8008 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
8009 {
8010 gfc_se rse;
8011 gfc_se lse;
8012 gfc_ss *rss;
8013 gfc_ss *lss;
8014 gfc_array_info *lss_array;
8015 stmtblock_t body;
8016 stmtblock_t block;
8017 gfc_loopinfo loop;
8018 int n;
8019 tree tmp;
8020
8021 gfc_start_block (&block);
8022
8023 /* Initialize the scalarizer. */
8024 gfc_init_loopinfo (&loop);
8025
8026 gfc_init_se (&lse, NULL);
8027 gfc_init_se (&rse, NULL);
8028
8029 /* Walk the rhs. */
8030 rss = gfc_walk_expr (expr);
8031 if (rss == gfc_ss_terminator)
8032 /* The rhs is scalar. Add a ss for the expression. */
8033 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
8034
8035 /* Create a SS for the destination. */
8036 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
8037 GFC_SS_COMPONENT);
8038 lss_array = &lss->info->data.array;
8039 lss_array->shape = gfc_get_shape (cm->as->rank);
8040 lss_array->descriptor = dest;
8041 lss_array->data = gfc_conv_array_data (dest);
8042 lss_array->offset = gfc_conv_array_offset (dest);
8043 for (n = 0; n < cm->as->rank; n++)
8044 {
8045 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
8046 lss_array->stride[n] = gfc_index_one_node;
8047
8048 mpz_init (lss_array->shape[n]);
8049 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
8050 cm->as->lower[n]->value.integer);
8051 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
8052 }
8053
8054 /* Associate the SS with the loop. */
8055 gfc_add_ss_to_loop (&loop, lss);
8056 gfc_add_ss_to_loop (&loop, rss);
8057
8058 /* Calculate the bounds of the scalarization. */
8059 gfc_conv_ss_startstride (&loop);
8060
8061 /* Setup the scalarizing loops. */
8062 gfc_conv_loop_setup (&loop, &expr->where);
8063
8064 /* Setup the gfc_se structures. */
8065 gfc_copy_loopinfo_to_se (&lse, &loop);
8066 gfc_copy_loopinfo_to_se (&rse, &loop);
8067
8068 rse.ss = rss;
8069 gfc_mark_ss_chain_used (rss, 1);
8070 lse.ss = lss;
8071 gfc_mark_ss_chain_used (lss, 1);
8072
8073 /* Start the scalarized loop body. */
8074 gfc_start_scalarized_body (&loop, &body);
8075
8076 gfc_conv_tmp_array_ref (&lse);
8077 if (cm->ts.type == BT_CHARACTER)
8078 lse.string_length = cm->ts.u.cl->backend_decl;
8079
8080 gfc_conv_expr (&rse, expr);
8081
8082 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
8083 gfc_add_expr_to_block (&body, tmp);
8084
8085 gcc_assert (rse.ss == gfc_ss_terminator);
8086
8087 /* Generate the copying loops. */
8088 gfc_trans_scalarizing_loops (&loop, &body);
8089
8090 /* Wrap the whole thing up. */
8091 gfc_add_block_to_block (&block, &loop.pre);
8092 gfc_add_block_to_block (&block, &loop.post);
8093
8094 gcc_assert (lss_array->shape != NULL);
8095 gfc_free_shape (&lss_array->shape, cm->as->rank);
8096 gfc_cleanup_loop (&loop);
8097
8098 return gfc_finish_block (&block);
8099 }
8100
8101
8102 static tree
gfc_trans_alloc_subarray_assign(tree dest,gfc_component * cm,gfc_expr * expr)8103 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
8104 gfc_expr * expr)
8105 {
8106 gfc_se se;
8107 stmtblock_t block;
8108 tree offset;
8109 int n;
8110 tree tmp;
8111 tree tmp2;
8112 gfc_array_spec *as;
8113 gfc_expr *arg = NULL;
8114
8115 gfc_start_block (&block);
8116 gfc_init_se (&se, NULL);
8117
8118 /* Get the descriptor for the expressions. */
8119 se.want_pointer = 0;
8120 gfc_conv_expr_descriptor (&se, expr);
8121 gfc_add_block_to_block (&block, &se.pre);
8122 gfc_add_modify (&block, dest, se.expr);
8123
8124 /* Deal with arrays of derived types with allocatable components. */
8125 if (gfc_bt_struct (cm->ts.type)
8126 && cm->ts.u.derived->attr.alloc_comp)
8127 // TODO: Fix caf_mode
8128 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
8129 se.expr, dest,
8130 cm->as->rank, 0);
8131 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
8132 && CLASS_DATA(cm)->attr.allocatable)
8133 {
8134 if (cm->ts.u.derived->attr.alloc_comp)
8135 // TODO: Fix caf_mode
8136 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
8137 se.expr, dest,
8138 expr->rank, 0);
8139 else
8140 {
8141 tmp = TREE_TYPE (dest);
8142 tmp = gfc_duplicate_allocatable (dest, se.expr,
8143 tmp, expr->rank, NULL_TREE);
8144 }
8145 }
8146 else
8147 tmp = gfc_duplicate_allocatable (dest, se.expr,
8148 TREE_TYPE(cm->backend_decl),
8149 cm->as->rank, NULL_TREE);
8150
8151 gfc_add_expr_to_block (&block, tmp);
8152 gfc_add_block_to_block (&block, &se.post);
8153
8154 if (expr->expr_type != EXPR_VARIABLE)
8155 gfc_conv_descriptor_data_set (&block, se.expr,
8156 null_pointer_node);
8157
8158 /* We need to know if the argument of a conversion function is a
8159 variable, so that the correct lower bound can be used. */
8160 if (expr->expr_type == EXPR_FUNCTION
8161 && expr->value.function.isym
8162 && expr->value.function.isym->conversion
8163 && expr->value.function.actual->expr
8164 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
8165 arg = expr->value.function.actual->expr;
8166
8167 /* Obtain the array spec of full array references. */
8168 if (arg)
8169 as = gfc_get_full_arrayspec_from_expr (arg);
8170 else
8171 as = gfc_get_full_arrayspec_from_expr (expr);
8172
8173 /* Shift the lbound and ubound of temporaries to being unity,
8174 rather than zero, based. Always calculate the offset. */
8175 offset = gfc_conv_descriptor_offset_get (dest);
8176 gfc_add_modify (&block, offset, gfc_index_zero_node);
8177 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
8178
8179 for (n = 0; n < expr->rank; n++)
8180 {
8181 tree span;
8182 tree lbound;
8183
8184 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
8185 TODO It looks as if gfc_conv_expr_descriptor should return
8186 the correct bounds and that the following should not be
8187 necessary. This would simplify gfc_conv_intrinsic_bound
8188 as well. */
8189 if (as && as->lower[n])
8190 {
8191 gfc_se lbse;
8192 gfc_init_se (&lbse, NULL);
8193 gfc_conv_expr (&lbse, as->lower[n]);
8194 gfc_add_block_to_block (&block, &lbse.pre);
8195 lbound = gfc_evaluate_now (lbse.expr, &block);
8196 }
8197 else if (as && arg)
8198 {
8199 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
8200 lbound = gfc_conv_descriptor_lbound_get (tmp,
8201 gfc_rank_cst[n]);
8202 }
8203 else if (as)
8204 lbound = gfc_conv_descriptor_lbound_get (dest,
8205 gfc_rank_cst[n]);
8206 else
8207 lbound = gfc_index_one_node;
8208
8209 lbound = fold_convert (gfc_array_index_type, lbound);
8210
8211 /* Shift the bounds and set the offset accordingly. */
8212 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
8213 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8214 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
8215 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
8216 span, lbound);
8217 gfc_conv_descriptor_ubound_set (&block, dest,
8218 gfc_rank_cst[n], tmp);
8219 gfc_conv_descriptor_lbound_set (&block, dest,
8220 gfc_rank_cst[n], lbound);
8221
8222 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
8223 gfc_conv_descriptor_lbound_get (dest,
8224 gfc_rank_cst[n]),
8225 gfc_conv_descriptor_stride_get (dest,
8226 gfc_rank_cst[n]));
8227 gfc_add_modify (&block, tmp2, tmp);
8228 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8229 offset, tmp2);
8230 gfc_conv_descriptor_offset_set (&block, dest, tmp);
8231 }
8232
8233 if (arg)
8234 {
8235 /* If a conversion expression has a null data pointer
8236 argument, nullify the allocatable component. */
8237 tree non_null_expr;
8238 tree null_expr;
8239
8240 if (arg->symtree->n.sym->attr.allocatable
8241 || arg->symtree->n.sym->attr.pointer)
8242 {
8243 non_null_expr = gfc_finish_block (&block);
8244 gfc_start_block (&block);
8245 gfc_conv_descriptor_data_set (&block, dest,
8246 null_pointer_node);
8247 null_expr = gfc_finish_block (&block);
8248 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
8249 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
8250 fold_convert (TREE_TYPE (tmp), null_pointer_node));
8251 return build3_v (COND_EXPR, tmp,
8252 null_expr, non_null_expr);
8253 }
8254 }
8255
8256 return gfc_finish_block (&block);
8257 }
8258
8259
8260 /* Allocate or reallocate scalar component, as necessary. */
8261
8262 static void
alloc_scalar_allocatable_for_subcomponent_assignment(stmtblock_t * block,tree comp,gfc_component * cm,gfc_expr * expr2,gfc_symbol * sym)8263 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
8264 tree comp,
8265 gfc_component *cm,
8266 gfc_expr *expr2,
8267 gfc_symbol *sym)
8268 {
8269 tree tmp;
8270 tree ptr;
8271 tree size;
8272 tree size_in_bytes;
8273 tree lhs_cl_size = NULL_TREE;
8274
8275 if (!comp)
8276 return;
8277
8278 if (!expr2 || expr2->rank)
8279 return;
8280
8281 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
8282
8283 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8284 {
8285 char name[GFC_MAX_SYMBOL_LEN+9];
8286 gfc_component *strlen;
8287 /* Use the rhs string length and the lhs element size. */
8288 gcc_assert (expr2->ts.type == BT_CHARACTER);
8289 if (!expr2->ts.u.cl->backend_decl)
8290 {
8291 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
8292 gcc_assert (expr2->ts.u.cl->backend_decl);
8293 }
8294
8295 size = expr2->ts.u.cl->backend_decl;
8296
8297 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
8298 component. */
8299 sprintf (name, "_%s_length", cm->name);
8300 strlen = gfc_find_component (sym, name, true, true, NULL);
8301 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
8302 gfc_charlen_type_node,
8303 TREE_OPERAND (comp, 0),
8304 strlen->backend_decl, NULL_TREE);
8305
8306 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
8307 tmp = TYPE_SIZE_UNIT (tmp);
8308 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
8309 TREE_TYPE (tmp), tmp,
8310 fold_convert (TREE_TYPE (tmp), size));
8311 }
8312 else if (cm->ts.type == BT_CLASS)
8313 {
8314 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
8315 if (expr2->ts.type == BT_DERIVED)
8316 {
8317 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
8318 size = TYPE_SIZE_UNIT (tmp);
8319 }
8320 else
8321 {
8322 gfc_expr *e2vtab;
8323 gfc_se se;
8324 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
8325 gfc_add_vptr_component (e2vtab);
8326 gfc_add_size_component (e2vtab);
8327 gfc_init_se (&se, NULL);
8328 gfc_conv_expr (&se, e2vtab);
8329 gfc_add_block_to_block (block, &se.pre);
8330 size = fold_convert (size_type_node, se.expr);
8331 gfc_free_expr (e2vtab);
8332 }
8333 size_in_bytes = size;
8334 }
8335 else
8336 {
8337 /* Otherwise use the length in bytes of the rhs. */
8338 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
8339 size_in_bytes = size;
8340 }
8341
8342 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
8343 size_in_bytes, size_one_node);
8344
8345 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
8346 {
8347 tmp = build_call_expr_loc (input_location,
8348 builtin_decl_explicit (BUILT_IN_CALLOC),
8349 2, build_one_cst (size_type_node),
8350 size_in_bytes);
8351 tmp = fold_convert (TREE_TYPE (comp), tmp);
8352 gfc_add_modify (block, comp, tmp);
8353 }
8354 else
8355 {
8356 tmp = build_call_expr_loc (input_location,
8357 builtin_decl_explicit (BUILT_IN_MALLOC),
8358 1, size_in_bytes);
8359 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
8360 ptr = gfc_class_data_get (comp);
8361 else
8362 ptr = comp;
8363 tmp = fold_convert (TREE_TYPE (ptr), tmp);
8364 gfc_add_modify (block, ptr, tmp);
8365 }
8366
8367 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8368 /* Update the lhs character length. */
8369 gfc_add_modify (block, lhs_cl_size,
8370 fold_convert (TREE_TYPE (lhs_cl_size), size));
8371 }
8372
8373
8374 /* Assign a single component of a derived type constructor. */
8375
8376 static tree
gfc_trans_subcomponent_assign(tree dest,gfc_component * cm,gfc_expr * expr,gfc_symbol * sym,bool init)8377 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
8378 gfc_symbol *sym, bool init)
8379 {
8380 gfc_se se;
8381 gfc_se lse;
8382 stmtblock_t block;
8383 tree tmp;
8384 tree vtab;
8385
8386 gfc_start_block (&block);
8387
8388 if (cm->attr.pointer || cm->attr.proc_pointer)
8389 {
8390 /* Only care about pointers here, not about allocatables. */
8391 gfc_init_se (&se, NULL);
8392 /* Pointer component. */
8393 if ((cm->attr.dimension || cm->attr.codimension)
8394 && !cm->attr.proc_pointer)
8395 {
8396 /* Array pointer. */
8397 if (expr->expr_type == EXPR_NULL)
8398 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8399 else
8400 {
8401 se.direct_byref = 1;
8402 se.expr = dest;
8403 gfc_conv_expr_descriptor (&se, expr);
8404 gfc_add_block_to_block (&block, &se.pre);
8405 gfc_add_block_to_block (&block, &se.post);
8406 }
8407 }
8408 else
8409 {
8410 /* Scalar pointers. */
8411 se.want_pointer = 1;
8412 gfc_conv_expr (&se, expr);
8413 gfc_add_block_to_block (&block, &se.pre);
8414
8415 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8416 && expr->symtree->n.sym->attr.dummy)
8417 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8418
8419 gfc_add_modify (&block, dest,
8420 fold_convert (TREE_TYPE (dest), se.expr));
8421 gfc_add_block_to_block (&block, &se.post);
8422 }
8423 }
8424 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
8425 {
8426 /* NULL initialization for CLASS components. */
8427 tmp = gfc_trans_structure_assign (dest,
8428 gfc_class_initializer (&cm->ts, expr),
8429 false);
8430 gfc_add_expr_to_block (&block, tmp);
8431 }
8432 else if ((cm->attr.dimension || cm->attr.codimension)
8433 && !cm->attr.proc_pointer)
8434 {
8435 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8436 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8437 else if (cm->attr.allocatable || cm->attr.pdt_array)
8438 {
8439 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
8440 gfc_add_expr_to_block (&block, tmp);
8441 }
8442 else
8443 {
8444 tmp = gfc_trans_subarray_assign (dest, cm, expr);
8445 gfc_add_expr_to_block (&block, tmp);
8446 }
8447 }
8448 else if (cm->ts.type == BT_CLASS
8449 && CLASS_DATA (cm)->attr.dimension
8450 && CLASS_DATA (cm)->attr.allocatable
8451 && expr->ts.type == BT_DERIVED)
8452 {
8453 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8454 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8455 tmp = gfc_class_vptr_get (dest);
8456 gfc_add_modify (&block, tmp,
8457 fold_convert (TREE_TYPE (tmp), vtab));
8458 tmp = gfc_class_data_get (dest);
8459 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
8460 gfc_add_expr_to_block (&block, tmp);
8461 }
8462 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8463 {
8464 /* NULL initialization for allocatable components. */
8465 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
8466 null_pointer_node));
8467 }
8468 else if (init && (cm->attr.allocatable
8469 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
8470 && expr->ts.type != BT_CLASS)))
8471 {
8472 /* Take care about non-array allocatable components here. The alloc_*
8473 routine below is motivated by the alloc_scalar_allocatable_for_
8474 assignment() routine, but with the realloc portions removed and
8475 different input. */
8476 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
8477 dest,
8478 cm,
8479 expr,
8480 sym);
8481 /* The remainder of these instructions follow the if (cm->attr.pointer)
8482 if (!cm->attr.dimension) part above. */
8483 gfc_init_se (&se, NULL);
8484 gfc_conv_expr (&se, expr);
8485 gfc_add_block_to_block (&block, &se.pre);
8486
8487 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8488 && expr->symtree->n.sym->attr.dummy)
8489 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8490
8491 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
8492 {
8493 tmp = gfc_class_data_get (dest);
8494 tmp = build_fold_indirect_ref_loc (input_location, tmp);
8495 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8496 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8497 gfc_add_modify (&block, gfc_class_vptr_get (dest),
8498 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
8499 }
8500 else
8501 tmp = build_fold_indirect_ref_loc (input_location, dest);
8502
8503 /* For deferred strings insert a memcpy. */
8504 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8505 {
8506 tree size;
8507 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
8508 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
8509 ? se.string_length
8510 : expr->ts.u.cl->backend_decl);
8511 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
8512 gfc_add_expr_to_block (&block, tmp);
8513 }
8514 else
8515 gfc_add_modify (&block, tmp,
8516 fold_convert (TREE_TYPE (tmp), se.expr));
8517 gfc_add_block_to_block (&block, &se.post);
8518 }
8519 else if (expr->ts.type == BT_UNION)
8520 {
8521 tree tmp;
8522 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
8523 /* We mark that the entire union should be initialized with a contrived
8524 EXPR_NULL expression at the beginning. */
8525 if (c != NULL && c->n.component == NULL
8526 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
8527 {
8528 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8529 dest, build_constructor (TREE_TYPE (dest), NULL));
8530 gfc_add_expr_to_block (&block, tmp);
8531 c = gfc_constructor_next (c);
8532 }
8533 /* The following constructor expression, if any, represents a specific
8534 map intializer, as given by the user. */
8535 if (c != NULL && c->expr != NULL)
8536 {
8537 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8538 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8539 gfc_add_expr_to_block (&block, tmp);
8540 }
8541 }
8542 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
8543 {
8544 if (expr->expr_type != EXPR_STRUCTURE)
8545 {
8546 tree dealloc = NULL_TREE;
8547 gfc_init_se (&se, NULL);
8548 gfc_conv_expr (&se, expr);
8549 gfc_add_block_to_block (&block, &se.pre);
8550 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8551 expression in a temporary variable and deallocate the allocatable
8552 components. Then we can the copy the expression to the result. */
8553 if (cm->ts.u.derived->attr.alloc_comp
8554 && expr->expr_type != EXPR_VARIABLE)
8555 {
8556 se.expr = gfc_evaluate_now (se.expr, &block);
8557 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
8558 expr->rank);
8559 }
8560 gfc_add_modify (&block, dest,
8561 fold_convert (TREE_TYPE (dest), se.expr));
8562 if (cm->ts.u.derived->attr.alloc_comp
8563 && expr->expr_type != EXPR_NULL)
8564 {
8565 // TODO: Fix caf_mode
8566 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
8567 dest, expr->rank, 0);
8568 gfc_add_expr_to_block (&block, tmp);
8569 if (dealloc != NULL_TREE)
8570 gfc_add_expr_to_block (&block, dealloc);
8571 }
8572 gfc_add_block_to_block (&block, &se.post);
8573 }
8574 else
8575 {
8576 /* Nested constructors. */
8577 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8578 gfc_add_expr_to_block (&block, tmp);
8579 }
8580 }
8581 else if (gfc_deferred_strlen (cm, &tmp))
8582 {
8583 tree strlen;
8584 strlen = tmp;
8585 gcc_assert (strlen);
8586 strlen = fold_build3_loc (input_location, COMPONENT_REF,
8587 TREE_TYPE (strlen),
8588 TREE_OPERAND (dest, 0),
8589 strlen, NULL_TREE);
8590
8591 if (expr->expr_type == EXPR_NULL)
8592 {
8593 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
8594 gfc_add_modify (&block, dest, tmp);
8595 tmp = build_int_cst (TREE_TYPE (strlen), 0);
8596 gfc_add_modify (&block, strlen, tmp);
8597 }
8598 else
8599 {
8600 tree size;
8601 gfc_init_se (&se, NULL);
8602 gfc_conv_expr (&se, expr);
8603 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
8604 tmp = build_call_expr_loc (input_location,
8605 builtin_decl_explicit (BUILT_IN_MALLOC),
8606 1, size);
8607 gfc_add_modify (&block, dest,
8608 fold_convert (TREE_TYPE (dest), tmp));
8609 gfc_add_modify (&block, strlen,
8610 fold_convert (TREE_TYPE (strlen), se.string_length));
8611 tmp = gfc_build_memcpy_call (dest, se.expr, size);
8612 gfc_add_expr_to_block (&block, tmp);
8613 }
8614 }
8615 else if (!cm->attr.artificial)
8616 {
8617 /* Scalar component (excluding deferred parameters). */
8618 gfc_init_se (&se, NULL);
8619 gfc_init_se (&lse, NULL);
8620
8621 gfc_conv_expr (&se, expr);
8622 if (cm->ts.type == BT_CHARACTER)
8623 lse.string_length = cm->ts.u.cl->backend_decl;
8624 lse.expr = dest;
8625 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
8626 gfc_add_expr_to_block (&block, tmp);
8627 }
8628 return gfc_finish_block (&block);
8629 }
8630
8631 /* Assign a derived type constructor to a variable. */
8632
8633 tree
gfc_trans_structure_assign(tree dest,gfc_expr * expr,bool init,bool coarray)8634 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
8635 {
8636 gfc_constructor *c;
8637 gfc_component *cm;
8638 stmtblock_t block;
8639 tree field;
8640 tree tmp;
8641 gfc_se se;
8642
8643 gfc_start_block (&block);
8644
8645 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
8646 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8647 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
8648 {
8649 gfc_se lse;
8650
8651 gfc_init_se (&se, NULL);
8652 gfc_init_se (&lse, NULL);
8653 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
8654 lse.expr = dest;
8655 gfc_add_modify (&block, lse.expr,
8656 fold_convert (TREE_TYPE (lse.expr), se.expr));
8657
8658 return gfc_finish_block (&block);
8659 }
8660
8661 /* Make sure that the derived type has been completely built. */
8662 if (!expr->ts.u.derived->backend_decl
8663 || !TYPE_FIELDS (expr->ts.u.derived->backend_decl))
8664 {
8665 tmp = gfc_typenode_for_spec (&expr->ts);
8666 gcc_assert (tmp);
8667 }
8668
8669 cm = expr->ts.u.derived->components;
8670
8671
8672 if (coarray)
8673 gfc_init_se (&se, NULL);
8674
8675 for (c = gfc_constructor_first (expr->value.constructor);
8676 c; c = gfc_constructor_next (c), cm = cm->next)
8677 {
8678 /* Skip absent members in default initializers. */
8679 if (!c->expr && !cm->attr.allocatable)
8680 continue;
8681
8682 /* Register the component with the caf-lib before it is initialized.
8683 Register only allocatable components, that are not coarray'ed
8684 components (%comp[*]). Only register when the constructor is not the
8685 null-expression. */
8686 if (coarray && !cm->attr.codimension
8687 && (cm->attr.allocatable || cm->attr.pointer)
8688 && (!c->expr || c->expr->expr_type == EXPR_NULL))
8689 {
8690 tree token, desc, size;
8691 bool is_array = cm->ts.type == BT_CLASS
8692 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
8693
8694 field = cm->backend_decl;
8695 field = fold_build3_loc (input_location, COMPONENT_REF,
8696 TREE_TYPE (field), dest, field, NULL_TREE);
8697 if (cm->ts.type == BT_CLASS)
8698 field = gfc_class_data_get (field);
8699
8700 token = is_array ? gfc_conv_descriptor_token (field)
8701 : fold_build3_loc (input_location, COMPONENT_REF,
8702 TREE_TYPE (cm->caf_token), dest,
8703 cm->caf_token, NULL_TREE);
8704
8705 if (is_array)
8706 {
8707 /* The _caf_register routine looks at the rank of the array
8708 descriptor to decide whether the data registered is an array
8709 or not. */
8710 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
8711 : cm->as->rank;
8712 /* When the rank is not known just set a positive rank, which
8713 suffices to recognize the data as array. */
8714 if (rank < 0)
8715 rank = 1;
8716 size = build_zero_cst (size_type_node);
8717 desc = field;
8718 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
8719 build_int_cst (signed_char_type_node, rank));
8720 }
8721 else
8722 {
8723 desc = gfc_conv_scalar_to_descriptor (&se, field,
8724 cm->ts.type == BT_CLASS
8725 ? CLASS_DATA (cm)->attr
8726 : cm->attr);
8727 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
8728 }
8729 gfc_add_block_to_block (&block, &se.pre);
8730 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
8731 7, size, build_int_cst (
8732 integer_type_node,
8733 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
8734 gfc_build_addr_expr (pvoid_type_node,
8735 token),
8736 gfc_build_addr_expr (NULL_TREE, desc),
8737 null_pointer_node, null_pointer_node,
8738 integer_zero_node);
8739 gfc_add_expr_to_block (&block, tmp);
8740 }
8741 field = cm->backend_decl;
8742 gcc_assert(field);
8743 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8744 dest, field, NULL_TREE);
8745 if (!c->expr)
8746 {
8747 gfc_expr *e = gfc_get_null_expr (NULL);
8748 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
8749 init);
8750 gfc_free_expr (e);
8751 }
8752 else
8753 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
8754 expr->ts.u.derived, init);
8755 gfc_add_expr_to_block (&block, tmp);
8756 }
8757 return gfc_finish_block (&block);
8758 }
8759
8760 void
gfc_conv_union_initializer(vec<constructor_elt,va_gc> * v,gfc_component * un,gfc_expr * init)8761 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
8762 gfc_component *un, gfc_expr *init)
8763 {
8764 gfc_constructor *ctor;
8765
8766 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
8767 return;
8768
8769 ctor = gfc_constructor_first (init->value.constructor);
8770
8771 if (ctor == NULL || ctor->expr == NULL)
8772 return;
8773
8774 gcc_assert (init->expr_type == EXPR_STRUCTURE);
8775
8776 /* If we have an 'initialize all' constructor, do it first. */
8777 if (ctor->expr->expr_type == EXPR_NULL)
8778 {
8779 tree union_type = TREE_TYPE (un->backend_decl);
8780 tree val = build_constructor (union_type, NULL);
8781 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8782 ctor = gfc_constructor_next (ctor);
8783 }
8784
8785 /* Add the map initializer on top. */
8786 if (ctor != NULL && ctor->expr != NULL)
8787 {
8788 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
8789 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
8790 TREE_TYPE (un->backend_decl),
8791 un->attr.dimension, un->attr.pointer,
8792 un->attr.proc_pointer);
8793 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8794 }
8795 }
8796
8797 /* Build an expression for a constructor. If init is nonzero then
8798 this is part of a static variable initializer. */
8799
8800 void
gfc_conv_structure(gfc_se * se,gfc_expr * expr,int init)8801 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
8802 {
8803 gfc_constructor *c;
8804 gfc_component *cm;
8805 tree val;
8806 tree type;
8807 tree tmp;
8808 vec<constructor_elt, va_gc> *v = NULL;
8809
8810 gcc_assert (se->ss == NULL);
8811 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8812 type = gfc_typenode_for_spec (&expr->ts);
8813
8814 if (!init)
8815 {
8816 /* Create a temporary variable and fill it in. */
8817 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
8818 /* The symtree in expr is NULL, if the code to generate is for
8819 initializing the static members only. */
8820 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
8821 se->want_coarray);
8822 gfc_add_expr_to_block (&se->pre, tmp);
8823 return;
8824 }
8825
8826 cm = expr->ts.u.derived->components;
8827
8828 for (c = gfc_constructor_first (expr->value.constructor);
8829 c; c = gfc_constructor_next (c), cm = cm->next)
8830 {
8831 /* Skip absent members in default initializers and allocatable
8832 components. Although the latter have a default initializer
8833 of EXPR_NULL,... by default, the static nullify is not needed
8834 since this is done every time we come into scope. */
8835 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
8836 continue;
8837
8838 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
8839 && strcmp (cm->name, "_extends") == 0
8840 && cm->initializer->symtree)
8841 {
8842 tree vtab;
8843 gfc_symbol *vtabs;
8844 vtabs = cm->initializer->symtree->n.sym;
8845 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
8846 vtab = unshare_expr_without_location (vtab);
8847 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
8848 }
8849 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
8850 {
8851 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
8852 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8853 fold_convert (TREE_TYPE (cm->backend_decl),
8854 val));
8855 }
8856 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
8857 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8858 fold_convert (TREE_TYPE (cm->backend_decl),
8859 integer_zero_node));
8860 else if (cm->ts.type == BT_UNION)
8861 gfc_conv_union_initializer (v, cm, c->expr);
8862 else
8863 {
8864 val = gfc_conv_initializer (c->expr, &cm->ts,
8865 TREE_TYPE (cm->backend_decl),
8866 cm->attr.dimension, cm->attr.pointer,
8867 cm->attr.proc_pointer);
8868 val = unshare_expr_without_location (val);
8869
8870 /* Append it to the constructor list. */
8871 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
8872 }
8873 }
8874
8875 se->expr = build_constructor (type, v);
8876 if (init)
8877 TREE_CONSTANT (se->expr) = 1;
8878 }
8879
8880
8881 /* Translate a substring expression. */
8882
8883 static void
gfc_conv_substring_expr(gfc_se * se,gfc_expr * expr)8884 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
8885 {
8886 gfc_ref *ref;
8887
8888 ref = expr->ref;
8889
8890 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
8891
8892 se->expr = gfc_build_wide_string_const (expr->ts.kind,
8893 expr->value.character.length,
8894 expr->value.character.string);
8895
8896 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
8897 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
8898
8899 if (ref)
8900 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
8901 }
8902
8903
8904 /* Entry point for expression translation. Evaluates a scalar quantity.
8905 EXPR is the expression to be translated, and SE is the state structure if
8906 called from within the scalarized. */
8907
8908 void
gfc_conv_expr(gfc_se * se,gfc_expr * expr)8909 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
8910 {
8911 gfc_ss *ss;
8912
8913 ss = se->ss;
8914 if (ss && ss->info->expr == expr
8915 && (ss->info->type == GFC_SS_SCALAR
8916 || ss->info->type == GFC_SS_REFERENCE))
8917 {
8918 gfc_ss_info *ss_info;
8919
8920 ss_info = ss->info;
8921 /* Substitute a scalar expression evaluated outside the scalarization
8922 loop. */
8923 se->expr = ss_info->data.scalar.value;
8924 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
8925 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8926
8927 se->string_length = ss_info->string_length;
8928 gfc_advance_se_ss_chain (se);
8929 return;
8930 }
8931
8932 /* We need to convert the expressions for the iso_c_binding derived types.
8933 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8934 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8935 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8936 updated to be an integer with a kind equal to the size of a (void *). */
8937 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8938 && expr->ts.u.derived->attr.is_bind_c)
8939 {
8940 if (expr->expr_type == EXPR_VARIABLE
8941 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8942 || expr->symtree->n.sym->intmod_sym_id
8943 == ISOCBINDING_NULL_FUNPTR))
8944 {
8945 /* Set expr_type to EXPR_NULL, which will result in
8946 null_pointer_node being used below. */
8947 expr->expr_type = EXPR_NULL;
8948 }
8949 else
8950 {
8951 /* Update the type/kind of the expression to be what the new
8952 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8953 expr->ts.type = BT_INTEGER;
8954 expr->ts.f90_type = BT_VOID;
8955 expr->ts.kind = gfc_index_integer_kind;
8956 }
8957 }
8958
8959 gfc_fix_class_refs (expr);
8960
8961 switch (expr->expr_type)
8962 {
8963 case EXPR_OP:
8964 gfc_conv_expr_op (se, expr);
8965 break;
8966
8967 case EXPR_FUNCTION:
8968 gfc_conv_function_expr (se, expr);
8969 break;
8970
8971 case EXPR_CONSTANT:
8972 gfc_conv_constant (se, expr);
8973 break;
8974
8975 case EXPR_VARIABLE:
8976 gfc_conv_variable (se, expr);
8977 break;
8978
8979 case EXPR_NULL:
8980 se->expr = null_pointer_node;
8981 break;
8982
8983 case EXPR_SUBSTRING:
8984 gfc_conv_substring_expr (se, expr);
8985 break;
8986
8987 case EXPR_STRUCTURE:
8988 gfc_conv_structure (se, expr, 0);
8989 break;
8990
8991 case EXPR_ARRAY:
8992 gfc_conv_array_constructor_expr (se, expr);
8993 break;
8994
8995 default:
8996 gcc_unreachable ();
8997 break;
8998 }
8999 }
9000
9001 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
9002 of an assignment. */
9003 void
gfc_conv_expr_lhs(gfc_se * se,gfc_expr * expr)9004 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
9005 {
9006 gfc_conv_expr (se, expr);
9007 /* All numeric lvalues should have empty post chains. If not we need to
9008 figure out a way of rewriting an lvalue so that it has no post chain. */
9009 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
9010 }
9011
9012 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
9013 numeric expressions. Used for scalar values where inserting cleanup code
9014 is inconvenient. */
9015 void
gfc_conv_expr_val(gfc_se * se,gfc_expr * expr)9016 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
9017 {
9018 tree val;
9019
9020 gcc_assert (expr->ts.type != BT_CHARACTER);
9021 gfc_conv_expr (se, expr);
9022 if (se->post.head)
9023 {
9024 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
9025 gfc_add_modify (&se->pre, val, se->expr);
9026 se->expr = val;
9027 gfc_add_block_to_block (&se->pre, &se->post);
9028 }
9029 }
9030
9031 /* Helper to translate an expression and convert it to a particular type. */
9032 void
gfc_conv_expr_type(gfc_se * se,gfc_expr * expr,tree type)9033 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
9034 {
9035 gfc_conv_expr_val (se, expr);
9036 se->expr = convert (type, se->expr);
9037 }
9038
9039
9040 /* Converts an expression so that it can be passed by reference. Scalar
9041 values only. */
9042
9043 void
gfc_conv_expr_reference(gfc_se * se,gfc_expr * expr,bool add_clobber)9044 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
9045 {
9046 gfc_ss *ss;
9047 tree var;
9048
9049 ss = se->ss;
9050 if (ss && ss->info->expr == expr
9051 && ss->info->type == GFC_SS_REFERENCE)
9052 {
9053 /* Returns a reference to the scalar evaluated outside the loop
9054 for this case. */
9055 gfc_conv_expr (se, expr);
9056
9057 if (expr->ts.type == BT_CHARACTER
9058 && expr->expr_type != EXPR_FUNCTION)
9059 gfc_conv_string_parameter (se);
9060 else
9061 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
9062
9063 return;
9064 }
9065
9066 if (expr->ts.type == BT_CHARACTER)
9067 {
9068 gfc_conv_expr (se, expr);
9069 gfc_conv_string_parameter (se);
9070 return;
9071 }
9072
9073 if (expr->expr_type == EXPR_VARIABLE)
9074 {
9075 se->want_pointer = 1;
9076 gfc_conv_expr (se, expr);
9077 if (se->post.head)
9078 {
9079 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9080 gfc_add_modify (&se->pre, var, se->expr);
9081 gfc_add_block_to_block (&se->pre, &se->post);
9082 se->expr = var;
9083 }
9084 else if (add_clobber && expr->ref == NULL)
9085 {
9086 tree clobber;
9087 tree var;
9088 /* FIXME: This fails if var is passed by reference, see PR
9089 41453. */
9090 var = expr->symtree->n.sym->backend_decl;
9091 clobber = build_clobber (TREE_TYPE (var));
9092 gfc_add_modify (&se->pre, var, clobber);
9093 }
9094 return;
9095 }
9096
9097 if (expr->expr_type == EXPR_FUNCTION
9098 && ((expr->value.function.esym
9099 && expr->value.function.esym->result
9100 && expr->value.function.esym->result->attr.pointer
9101 && !expr->value.function.esym->result->attr.dimension)
9102 || (!expr->value.function.esym && !expr->ref
9103 && expr->symtree->n.sym->attr.pointer
9104 && !expr->symtree->n.sym->attr.dimension)))
9105 {
9106 se->want_pointer = 1;
9107 gfc_conv_expr (se, expr);
9108 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9109 gfc_add_modify (&se->pre, var, se->expr);
9110 se->expr = var;
9111 return;
9112 }
9113
9114 gfc_conv_expr (se, expr);
9115
9116 /* Create a temporary var to hold the value. */
9117 if (TREE_CONSTANT (se->expr))
9118 {
9119 tree tmp = se->expr;
9120 STRIP_TYPE_NOPS (tmp);
9121 var = build_decl (input_location,
9122 CONST_DECL, NULL, TREE_TYPE (tmp));
9123 DECL_INITIAL (var) = tmp;
9124 TREE_STATIC (var) = 1;
9125 pushdecl (var);
9126 }
9127 else
9128 {
9129 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
9130 gfc_add_modify (&se->pre, var, se->expr);
9131 }
9132
9133 if (!expr->must_finalize)
9134 gfc_add_block_to_block (&se->pre, &se->post);
9135
9136 /* Take the address of that value. */
9137 se->expr = gfc_build_addr_expr (NULL_TREE, var);
9138 }
9139
9140
9141 /* Get the _len component for an unlimited polymorphic expression. */
9142
9143 static tree
trans_get_upoly_len(stmtblock_t * block,gfc_expr * expr)9144 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
9145 {
9146 gfc_se se;
9147 gfc_ref *ref = expr->ref;
9148
9149 gfc_init_se (&se, NULL);
9150 while (ref && ref->next)
9151 ref = ref->next;
9152 gfc_add_len_component (expr);
9153 gfc_conv_expr (&se, expr);
9154 gfc_add_block_to_block (block, &se.pre);
9155 gcc_assert (se.post.head == NULL_TREE);
9156 if (ref)
9157 {
9158 gfc_free_ref_list (ref->next);
9159 ref->next = NULL;
9160 }
9161 else
9162 {
9163 gfc_free_ref_list (expr->ref);
9164 expr->ref = NULL;
9165 }
9166 return se.expr;
9167 }
9168
9169
9170 /* Assign _vptr and _len components as appropriate. BLOCK should be a
9171 statement-list outside of the scalarizer-loop. When code is generated, that
9172 depends on the scalarized expression, it is added to RSE.PRE.
9173 Returns le's _vptr tree and when set the len expressions in to_lenp and
9174 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
9175 expression. */
9176
9177 static tree
trans_class_vptr_len_assignment(stmtblock_t * block,gfc_expr * le,gfc_expr * re,gfc_se * rse,tree * to_lenp,tree * from_lenp)9178 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
9179 gfc_expr * re, gfc_se *rse,
9180 tree * to_lenp, tree * from_lenp)
9181 {
9182 gfc_se se;
9183 gfc_expr * vptr_expr;
9184 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
9185 bool set_vptr = false, temp_rhs = false;
9186 stmtblock_t *pre = block;
9187 tree class_expr = NULL_TREE;
9188
9189 /* Create a temporary for complicated expressions. */
9190 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
9191 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
9192 {
9193 if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
9194 class_expr = gfc_get_class_from_expr (rse->expr);
9195
9196 if (rse->loop)
9197 pre = &rse->loop->pre;
9198 else
9199 pre = &rse->pre;
9200
9201 if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
9202 {
9203 tmp = TREE_OPERAND (rse->expr, 0);
9204 tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
9205 gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
9206 }
9207 else
9208 {
9209 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
9210 gfc_add_modify (&rse->pre, tmp, rse->expr);
9211 }
9212
9213 rse->expr = tmp;
9214 temp_rhs = true;
9215 }
9216
9217 /* Get the _vptr for the left-hand side expression. */
9218 gfc_init_se (&se, NULL);
9219 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
9220 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
9221 {
9222 /* Care about _len for unlimited polymorphic entities. */
9223 if (UNLIMITED_POLY (vptr_expr)
9224 || (vptr_expr->ts.type == BT_DERIVED
9225 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
9226 to_len = trans_get_upoly_len (block, vptr_expr);
9227 gfc_add_vptr_component (vptr_expr);
9228 set_vptr = true;
9229 }
9230 else
9231 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
9232 se.want_pointer = 1;
9233 gfc_conv_expr (&se, vptr_expr);
9234 gfc_free_expr (vptr_expr);
9235 gfc_add_block_to_block (block, &se.pre);
9236 gcc_assert (se.post.head == NULL_TREE);
9237 lhs_vptr = se.expr;
9238 STRIP_NOPS (lhs_vptr);
9239
9240 /* Set the _vptr only when the left-hand side of the assignment is a
9241 class-object. */
9242 if (set_vptr)
9243 {
9244 /* Get the vptr from the rhs expression only, when it is variable.
9245 Functions are expected to be assigned to a temporary beforehand. */
9246 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
9247 ? gfc_find_and_cut_at_last_class_ref (re)
9248 : NULL;
9249 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
9250 {
9251 if (to_len != NULL_TREE)
9252 {
9253 /* Get the _len information from the rhs. */
9254 if (UNLIMITED_POLY (vptr_expr)
9255 || (vptr_expr->ts.type == BT_DERIVED
9256 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
9257 from_len = trans_get_upoly_len (block, vptr_expr);
9258 }
9259 gfc_add_vptr_component (vptr_expr);
9260 }
9261 else
9262 {
9263 if (re->expr_type == EXPR_VARIABLE
9264 && DECL_P (re->symtree->n.sym->backend_decl)
9265 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
9266 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
9267 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
9268 re->symtree->n.sym->backend_decl))))
9269 {
9270 vptr_expr = NULL;
9271 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
9272 re->symtree->n.sym->backend_decl));
9273 if (to_len)
9274 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
9275 re->symtree->n.sym->backend_decl));
9276 }
9277 else if (temp_rhs && re->ts.type == BT_CLASS)
9278 {
9279 vptr_expr = NULL;
9280 if (class_expr)
9281 tmp = class_expr;
9282 else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
9283 tmp = gfc_get_class_from_expr (rse->expr);
9284 else
9285 tmp = rse->expr;
9286
9287 se.expr = gfc_class_vptr_get (tmp);
9288 if (UNLIMITED_POLY (re))
9289 from_len = gfc_class_len_get (tmp);
9290
9291 }
9292 else if (re->expr_type != EXPR_NULL)
9293 /* Only when rhs is non-NULL use its declared type for vptr
9294 initialisation. */
9295 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
9296 else
9297 /* When the rhs is NULL use the vtab of lhs' declared type. */
9298 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
9299 }
9300
9301 if (vptr_expr)
9302 {
9303 gfc_init_se (&se, NULL);
9304 se.want_pointer = 1;
9305 gfc_conv_expr (&se, vptr_expr);
9306 gfc_free_expr (vptr_expr);
9307 gfc_add_block_to_block (block, &se.pre);
9308 gcc_assert (se.post.head == NULL_TREE);
9309 }
9310 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
9311 se.expr));
9312
9313 if (to_len != NULL_TREE)
9314 {
9315 /* The _len component needs to be set. Figure how to get the
9316 value of the right-hand side. */
9317 if (from_len == NULL_TREE)
9318 {
9319 if (rse->string_length != NULL_TREE)
9320 from_len = rse->string_length;
9321 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
9322 {
9323 gfc_init_se (&se, NULL);
9324 gfc_conv_expr (&se, re->ts.u.cl->length);
9325 gfc_add_block_to_block (block, &se.pre);
9326 gcc_assert (se.post.head == NULL_TREE);
9327 from_len = gfc_evaluate_now (se.expr, block);
9328 }
9329 else
9330 from_len = build_zero_cst (gfc_charlen_type_node);
9331 }
9332 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
9333 from_len));
9334 }
9335 }
9336
9337 /* Return the _len trees only, when requested. */
9338 if (to_lenp)
9339 *to_lenp = to_len;
9340 if (from_lenp)
9341 *from_lenp = from_len;
9342 return lhs_vptr;
9343 }
9344
9345
9346 /* Assign tokens for pointer components. */
9347
9348 static void
trans_caf_token_assign(gfc_se * lse,gfc_se * rse,gfc_expr * expr1,gfc_expr * expr2)9349 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
9350 gfc_expr *expr2)
9351 {
9352 symbol_attribute lhs_attr, rhs_attr;
9353 tree tmp, lhs_tok, rhs_tok;
9354 /* Flag to indicated component refs on the rhs. */
9355 bool rhs_cr;
9356
9357 lhs_attr = gfc_caf_attr (expr1);
9358 if (expr2->expr_type != EXPR_NULL)
9359 {
9360 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
9361 if (lhs_attr.codimension && rhs_attr.codimension)
9362 {
9363 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
9364 lhs_tok = build_fold_indirect_ref (lhs_tok);
9365
9366 if (rhs_cr)
9367 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
9368 else
9369 {
9370 tree caf_decl;
9371 caf_decl = gfc_get_tree_for_caf_expr (expr2);
9372 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
9373 NULL_TREE, NULL);
9374 }
9375 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
9376 lhs_tok,
9377 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
9378 gfc_prepend_expr_to_block (&lse->post, tmp);
9379 }
9380 }
9381 else if (lhs_attr.codimension)
9382 {
9383 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
9384 lhs_tok = build_fold_indirect_ref (lhs_tok);
9385 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
9386 lhs_tok, null_pointer_node);
9387 gfc_prepend_expr_to_block (&lse->post, tmp);
9388 }
9389 }
9390
9391
9392 /* Do everything that is needed for a CLASS function expr2. */
9393
9394 static tree
trans_class_pointer_fcn(stmtblock_t * block,gfc_se * lse,gfc_se * rse,gfc_expr * expr1,gfc_expr * expr2)9395 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
9396 gfc_expr *expr1, gfc_expr *expr2)
9397 {
9398 tree expr1_vptr = NULL_TREE;
9399 tree tmp;
9400
9401 gfc_conv_function_expr (rse, expr2);
9402 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
9403
9404 if (expr1->ts.type != BT_CLASS)
9405 rse->expr = gfc_class_data_get (rse->expr);
9406 else
9407 {
9408 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
9409 expr2, rse,
9410 NULL, NULL);
9411 gfc_add_block_to_block (block, &rse->pre);
9412 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
9413 gfc_add_modify (&lse->pre, tmp, rse->expr);
9414
9415 gfc_add_modify (&lse->pre, expr1_vptr,
9416 fold_convert (TREE_TYPE (expr1_vptr),
9417 gfc_class_vptr_get (tmp)));
9418 rse->expr = gfc_class_data_get (tmp);
9419 }
9420
9421 return expr1_vptr;
9422 }
9423
9424
9425 tree
gfc_trans_pointer_assign(gfc_code * code)9426 gfc_trans_pointer_assign (gfc_code * code)
9427 {
9428 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
9429 }
9430
9431
9432 /* Generate code for a pointer assignment. */
9433
9434 tree
gfc_trans_pointer_assignment(gfc_expr * expr1,gfc_expr * expr2)9435 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
9436 {
9437 gfc_se lse;
9438 gfc_se rse;
9439 stmtblock_t block;
9440 tree desc;
9441 tree tmp;
9442 tree expr1_vptr = NULL_TREE;
9443 bool scalar, non_proc_ptr_assign;
9444 gfc_ss *ss;
9445
9446 gfc_start_block (&block);
9447
9448 gfc_init_se (&lse, NULL);
9449
9450 /* Usually testing whether this is not a proc pointer assignment. */
9451 non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
9452 && expr2->expr_type == EXPR_VARIABLE
9453 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
9454
9455 /* Check whether the expression is a scalar or not; we cannot use
9456 expr1->rank as it can be nonzero for proc pointers. */
9457 ss = gfc_walk_expr (expr1);
9458 scalar = ss == gfc_ss_terminator;
9459 if (!scalar)
9460 gfc_free_ss_chain (ss);
9461
9462 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
9463 && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
9464 {
9465 gfc_add_data_component (expr2);
9466 /* The following is required as gfc_add_data_component doesn't
9467 update ts.type if there is a tailing REF_ARRAY. */
9468 expr2->ts.type = BT_DERIVED;
9469 }
9470
9471 if (scalar)
9472 {
9473 /* Scalar pointers. */
9474 lse.want_pointer = 1;
9475 gfc_conv_expr (&lse, expr1);
9476 gfc_init_se (&rse, NULL);
9477 rse.want_pointer = 1;
9478 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9479 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
9480 else
9481 gfc_conv_expr (&rse, expr2);
9482
9483 if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
9484 {
9485 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
9486 NULL);
9487 lse.expr = gfc_class_data_get (lse.expr);
9488 }
9489
9490 if (expr1->symtree->n.sym->attr.proc_pointer
9491 && expr1->symtree->n.sym->attr.dummy)
9492 lse.expr = build_fold_indirect_ref_loc (input_location,
9493 lse.expr);
9494
9495 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
9496 && expr2->symtree->n.sym->attr.dummy)
9497 rse.expr = build_fold_indirect_ref_loc (input_location,
9498 rse.expr);
9499
9500 gfc_add_block_to_block (&block, &lse.pre);
9501 gfc_add_block_to_block (&block, &rse.pre);
9502
9503 /* Check character lengths if character expression. The test is only
9504 really added if -fbounds-check is enabled. Exclude deferred
9505 character length lefthand sides. */
9506 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
9507 && !expr1->ts.deferred
9508 && !expr1->symtree->n.sym->attr.proc_pointer
9509 && !gfc_is_proc_ptr_comp (expr1))
9510 {
9511 gcc_assert (expr2->ts.type == BT_CHARACTER);
9512 gcc_assert (lse.string_length && rse.string_length);
9513 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9514 lse.string_length, rse.string_length,
9515 &block);
9516 }
9517
9518 /* The assignment to an deferred character length sets the string
9519 length to that of the rhs. */
9520 if (expr1->ts.deferred)
9521 {
9522 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
9523 gfc_add_modify (&block, lse.string_length,
9524 fold_convert (TREE_TYPE (lse.string_length),
9525 rse.string_length));
9526 else if (lse.string_length != NULL)
9527 gfc_add_modify (&block, lse.string_length,
9528 build_zero_cst (TREE_TYPE (lse.string_length)));
9529 }
9530
9531 gfc_add_modify (&block, lse.expr,
9532 fold_convert (TREE_TYPE (lse.expr), rse.expr));
9533
9534 /* Also set the tokens for pointer components in derived typed
9535 coarrays. */
9536 if (flag_coarray == GFC_FCOARRAY_LIB)
9537 trans_caf_token_assign (&lse, &rse, expr1, expr2);
9538
9539 gfc_add_block_to_block (&block, &rse.post);
9540 gfc_add_block_to_block (&block, &lse.post);
9541 }
9542 else
9543 {
9544 gfc_ref* remap;
9545 bool rank_remap;
9546 tree strlen_lhs;
9547 tree strlen_rhs = NULL_TREE;
9548
9549 /* Array pointer. Find the last reference on the LHS and if it is an
9550 array section ref, we're dealing with bounds remapping. In this case,
9551 set it to AR_FULL so that gfc_conv_expr_descriptor does
9552 not see it and process the bounds remapping afterwards explicitly. */
9553 for (remap = expr1->ref; remap; remap = remap->next)
9554 if (!remap->next && remap->type == REF_ARRAY
9555 && remap->u.ar.type == AR_SECTION)
9556 break;
9557 rank_remap = (remap && remap->u.ar.end[0]);
9558
9559 if (remap && expr2->expr_type == EXPR_NULL)
9560 {
9561 gfc_error ("If bounds remapping is specified at %L, "
9562 "the pointer target shall not be NULL", &expr1->where);
9563 return NULL_TREE;
9564 }
9565
9566 gfc_init_se (&lse, NULL);
9567 if (remap)
9568 lse.descriptor_only = 1;
9569 gfc_conv_expr_descriptor (&lse, expr1);
9570 strlen_lhs = lse.string_length;
9571 desc = lse.expr;
9572
9573 if (expr2->expr_type == EXPR_NULL)
9574 {
9575 /* Just set the data pointer to null. */
9576 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
9577 }
9578 else if (rank_remap)
9579 {
9580 /* If we are rank-remapping, just get the RHS's descriptor and
9581 process this later on. */
9582 gfc_init_se (&rse, NULL);
9583 rse.direct_byref = 1;
9584 rse.byref_noassign = 1;
9585
9586 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9587 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
9588 expr1, expr2);
9589 else if (expr2->expr_type == EXPR_FUNCTION)
9590 {
9591 tree bound[GFC_MAX_DIMENSIONS];
9592 int i;
9593
9594 for (i = 0; i < expr2->rank; i++)
9595 bound[i] = NULL_TREE;
9596 tmp = gfc_typenode_for_spec (&expr2->ts);
9597 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
9598 bound, bound, 0,
9599 GFC_ARRAY_POINTER_CONT, false);
9600 tmp = gfc_create_var (tmp, "ptrtemp");
9601 rse.descriptor_only = 0;
9602 rse.expr = tmp;
9603 rse.direct_byref = 1;
9604 gfc_conv_expr_descriptor (&rse, expr2);
9605 strlen_rhs = rse.string_length;
9606 rse.expr = tmp;
9607 }
9608 else
9609 {
9610 gfc_conv_expr_descriptor (&rse, expr2);
9611 strlen_rhs = rse.string_length;
9612 if (expr1->ts.type == BT_CLASS)
9613 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9614 expr2, &rse,
9615 NULL, NULL);
9616 }
9617 }
9618 else if (expr2->expr_type == EXPR_VARIABLE)
9619 {
9620 /* Assign directly to the LHS's descriptor. */
9621 lse.descriptor_only = 0;
9622 lse.direct_byref = 1;
9623 gfc_conv_expr_descriptor (&lse, expr2);
9624 strlen_rhs = lse.string_length;
9625
9626 if (expr1->ts.type == BT_CLASS)
9627 {
9628 rse.expr = NULL_TREE;
9629 rse.string_length = NULL_TREE;
9630 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
9631 NULL, NULL);
9632 }
9633
9634 if (remap == NULL)
9635 {
9636 /* If the target is not a whole array, use the target array
9637 reference for remap. */
9638 for (remap = expr2->ref; remap; remap = remap->next)
9639 if (remap->type == REF_ARRAY
9640 && remap->u.ar.type == AR_FULL
9641 && remap->next)
9642 break;
9643 }
9644 }
9645 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9646 {
9647 gfc_init_se (&rse, NULL);
9648 rse.want_pointer = 1;
9649 gfc_conv_function_expr (&rse, expr2);
9650 if (expr1->ts.type != BT_CLASS)
9651 {
9652 rse.expr = gfc_class_data_get (rse.expr);
9653 gfc_add_modify (&lse.pre, desc, rse.expr);
9654 /* Set the lhs span. */
9655 tmp = TREE_TYPE (rse.expr);
9656 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9657 tmp = fold_convert (gfc_array_index_type, tmp);
9658 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
9659 }
9660 else
9661 {
9662 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9663 expr2, &rse, NULL,
9664 NULL);
9665 gfc_add_block_to_block (&block, &rse.pre);
9666 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
9667 gfc_add_modify (&lse.pre, tmp, rse.expr);
9668
9669 gfc_add_modify (&lse.pre, expr1_vptr,
9670 fold_convert (TREE_TYPE (expr1_vptr),
9671 gfc_class_vptr_get (tmp)));
9672 rse.expr = gfc_class_data_get (tmp);
9673 gfc_add_modify (&lse.pre, desc, rse.expr);
9674 }
9675 }
9676 else
9677 {
9678 /* Assign to a temporary descriptor and then copy that
9679 temporary to the pointer. */
9680 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
9681 lse.descriptor_only = 0;
9682 lse.expr = tmp;
9683 lse.direct_byref = 1;
9684 gfc_conv_expr_descriptor (&lse, expr2);
9685 strlen_rhs = lse.string_length;
9686 gfc_add_modify (&lse.pre, desc, tmp);
9687 }
9688
9689 gfc_add_block_to_block (&block, &lse.pre);
9690 if (rank_remap)
9691 gfc_add_block_to_block (&block, &rse.pre);
9692
9693 /* If we do bounds remapping, update LHS descriptor accordingly. */
9694 if (remap)
9695 {
9696 int dim;
9697 gcc_assert (remap->u.ar.dimen == expr1->rank);
9698
9699 if (rank_remap)
9700 {
9701 /* Do rank remapping. We already have the RHS's descriptor
9702 converted in rse and now have to build the correct LHS
9703 descriptor for it. */
9704
9705 tree dtype, data, span;
9706 tree offs, stride;
9707 tree lbound, ubound;
9708
9709 /* Set dtype. */
9710 dtype = gfc_conv_descriptor_dtype (desc);
9711 tmp = gfc_get_dtype (TREE_TYPE (desc));
9712 gfc_add_modify (&block, dtype, tmp);
9713
9714 /* Copy data pointer. */
9715 data = gfc_conv_descriptor_data_get (rse.expr);
9716 gfc_conv_descriptor_data_set (&block, desc, data);
9717
9718 /* Copy the span. */
9719 if (TREE_CODE (rse.expr) == VAR_DECL
9720 && GFC_DECL_PTR_ARRAY_P (rse.expr))
9721 span = gfc_conv_descriptor_span_get (rse.expr);
9722 else
9723 {
9724 tmp = TREE_TYPE (rse.expr);
9725 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9726 span = fold_convert (gfc_array_index_type, tmp);
9727 }
9728 gfc_conv_descriptor_span_set (&block, desc, span);
9729
9730 /* Copy offset but adjust it such that it would correspond
9731 to a lbound of zero. */
9732 offs = gfc_conv_descriptor_offset_get (rse.expr);
9733 for (dim = 0; dim < expr2->rank; ++dim)
9734 {
9735 stride = gfc_conv_descriptor_stride_get (rse.expr,
9736 gfc_rank_cst[dim]);
9737 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
9738 gfc_rank_cst[dim]);
9739 tmp = fold_build2_loc (input_location, MULT_EXPR,
9740 gfc_array_index_type, stride, lbound);
9741 offs = fold_build2_loc (input_location, PLUS_EXPR,
9742 gfc_array_index_type, offs, tmp);
9743 }
9744 gfc_conv_descriptor_offset_set (&block, desc, offs);
9745
9746 /* Set the bounds as declared for the LHS and calculate strides as
9747 well as another offset update accordingly. */
9748 stride = gfc_conv_descriptor_stride_get (rse.expr,
9749 gfc_rank_cst[0]);
9750 for (dim = 0; dim < expr1->rank; ++dim)
9751 {
9752 gfc_se lower_se;
9753 gfc_se upper_se;
9754
9755 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
9756
9757 /* Convert declared bounds. */
9758 gfc_init_se (&lower_se, NULL);
9759 gfc_init_se (&upper_se, NULL);
9760 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
9761 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
9762
9763 gfc_add_block_to_block (&block, &lower_se.pre);
9764 gfc_add_block_to_block (&block, &upper_se.pre);
9765
9766 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
9767 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
9768
9769 lbound = gfc_evaluate_now (lbound, &block);
9770 ubound = gfc_evaluate_now (ubound, &block);
9771
9772 gfc_add_block_to_block (&block, &lower_se.post);
9773 gfc_add_block_to_block (&block, &upper_se.post);
9774
9775 /* Set bounds in descriptor. */
9776 gfc_conv_descriptor_lbound_set (&block, desc,
9777 gfc_rank_cst[dim], lbound);
9778 gfc_conv_descriptor_ubound_set (&block, desc,
9779 gfc_rank_cst[dim], ubound);
9780
9781 /* Set stride. */
9782 stride = gfc_evaluate_now (stride, &block);
9783 gfc_conv_descriptor_stride_set (&block, desc,
9784 gfc_rank_cst[dim], stride);
9785
9786 /* Update offset. */
9787 offs = gfc_conv_descriptor_offset_get (desc);
9788 tmp = fold_build2_loc (input_location, MULT_EXPR,
9789 gfc_array_index_type, lbound, stride);
9790 offs = fold_build2_loc (input_location, MINUS_EXPR,
9791 gfc_array_index_type, offs, tmp);
9792 offs = gfc_evaluate_now (offs, &block);
9793 gfc_conv_descriptor_offset_set (&block, desc, offs);
9794
9795 /* Update stride. */
9796 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
9797 stride = fold_build2_loc (input_location, MULT_EXPR,
9798 gfc_array_index_type, stride, tmp);
9799 }
9800 }
9801 else
9802 {
9803 /* Bounds remapping. Just shift the lower bounds. */
9804
9805 gcc_assert (expr1->rank == expr2->rank);
9806
9807 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
9808 {
9809 gfc_se lbound_se;
9810
9811 gcc_assert (!remap->u.ar.end[dim]);
9812 gfc_init_se (&lbound_se, NULL);
9813 if (remap->u.ar.start[dim])
9814 {
9815 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
9816 gfc_add_block_to_block (&block, &lbound_se.pre);
9817 }
9818 else
9819 /* This remap arises from a target that is not a whole
9820 array. The start expressions will be NULL but we need
9821 the lbounds to be one. */
9822 lbound_se.expr = gfc_index_one_node;
9823 gfc_conv_shift_descriptor_lbound (&block, desc,
9824 dim, lbound_se.expr);
9825 gfc_add_block_to_block (&block, &lbound_se.post);
9826 }
9827 }
9828 }
9829
9830 /* If rank remapping was done, check with -fcheck=bounds that
9831 the target is at least as large as the pointer. */
9832 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
9833 {
9834 tree lsize, rsize;
9835 tree fault;
9836 const char* msg;
9837
9838 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
9839 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
9840
9841 lsize = gfc_evaluate_now (lsize, &block);
9842 rsize = gfc_evaluate_now (rsize, &block);
9843 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
9844 rsize, lsize);
9845
9846 msg = _("Target of rank remapping is too small (%ld < %ld)");
9847 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
9848 msg, rsize, lsize);
9849 }
9850
9851 if (expr1->ts.type == BT_CHARACTER
9852 && expr1->symtree->n.sym->ts.deferred
9853 && expr1->symtree->n.sym->ts.u.cl->backend_decl
9854 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
9855 {
9856 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
9857 if (expr2->expr_type != EXPR_NULL)
9858 gfc_add_modify (&block, tmp,
9859 fold_convert (TREE_TYPE (tmp), strlen_rhs));
9860 else
9861 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
9862 }
9863
9864 /* Check string lengths if applicable. The check is only really added
9865 to the output code if -fbounds-check is enabled. */
9866 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
9867 {
9868 gcc_assert (expr2->ts.type == BT_CHARACTER);
9869 gcc_assert (strlen_lhs && strlen_rhs);
9870 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9871 strlen_lhs, strlen_rhs, &block);
9872 }
9873
9874 gfc_add_block_to_block (&block, &lse.post);
9875 if (rank_remap)
9876 gfc_add_block_to_block (&block, &rse.post);
9877 }
9878
9879 return gfc_finish_block (&block);
9880 }
9881
9882
9883 /* Makes sure se is suitable for passing as a function string parameter. */
9884 /* TODO: Need to check all callers of this function. It may be abused. */
9885
9886 void
gfc_conv_string_parameter(gfc_se * se)9887 gfc_conv_string_parameter (gfc_se * se)
9888 {
9889 tree type;
9890
9891 if (TREE_CODE (se->expr) == STRING_CST)
9892 {
9893 type = TREE_TYPE (TREE_TYPE (se->expr));
9894 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9895 return;
9896 }
9897
9898 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
9899 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
9900 && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
9901 {
9902 if (TREE_CODE (se->expr) != INDIRECT_REF)
9903 {
9904 type = TREE_TYPE (se->expr);
9905 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9906 }
9907 else
9908 {
9909 type = gfc_get_character_type_len (gfc_default_character_kind,
9910 se->string_length);
9911 type = build_pointer_type (type);
9912 se->expr = gfc_build_addr_expr (type, se->expr);
9913 }
9914 }
9915
9916 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
9917 }
9918
9919
9920 /* Generate code for assignment of scalar variables. Includes character
9921 strings and derived types with allocatable components.
9922 If you know that the LHS has no allocations, set dealloc to false.
9923
9924 DEEP_COPY has no effect if the typespec TS is not a derived type with
9925 allocatable components. Otherwise, if it is set, an explicit copy of each
9926 allocatable component is made. This is necessary as a simple copy of the
9927 whole object would copy array descriptors as is, so that the lhs's
9928 allocatable components would point to the rhs's after the assignment.
9929 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9930 necessary if the rhs is a non-pointer function, as the allocatable components
9931 are not accessible by other means than the function's result after the
9932 function has returned. It is even more subtle when temporaries are involved,
9933 as the two following examples show:
9934 1. When we evaluate an array constructor, a temporary is created. Thus
9935 there is theoretically no alias possible. However, no deep copy is
9936 made for this temporary, so that if the constructor is made of one or
9937 more variable with allocatable components, those components still point
9938 to the variable's: DEEP_COPY should be set for the assignment from the
9939 temporary to the lhs in that case.
9940 2. When assigning a scalar to an array, we evaluate the scalar value out
9941 of the loop, store it into a temporary variable, and assign from that.
9942 In that case, deep copying when assigning to the temporary would be a
9943 waste of resources; however deep copies should happen when assigning from
9944 the temporary to each array element: again DEEP_COPY should be set for
9945 the assignment from the temporary to the lhs. */
9946
9947 tree
gfc_trans_scalar_assign(gfc_se * lse,gfc_se * rse,gfc_typespec ts,bool deep_copy,bool dealloc,bool in_coarray)9948 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9949 bool deep_copy, bool dealloc, bool in_coarray)
9950 {
9951 stmtblock_t block;
9952 tree tmp;
9953 tree cond;
9954
9955 gfc_init_block (&block);
9956
9957 if (ts.type == BT_CHARACTER)
9958 {
9959 tree rlen = NULL;
9960 tree llen = NULL;
9961
9962 if (lse->string_length != NULL_TREE)
9963 {
9964 gfc_conv_string_parameter (lse);
9965 gfc_add_block_to_block (&block, &lse->pre);
9966 llen = lse->string_length;
9967 }
9968
9969 if (rse->string_length != NULL_TREE)
9970 {
9971 gfc_conv_string_parameter (rse);
9972 gfc_add_block_to_block (&block, &rse->pre);
9973 rlen = rse->string_length;
9974 }
9975
9976 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9977 rse->expr, ts.kind);
9978 }
9979 else if (gfc_bt_struct (ts.type)
9980 && (ts.u.derived->attr.alloc_comp
9981 || (deep_copy && ts.u.derived->attr.pdt_type)))
9982 {
9983 tree tmp_var = NULL_TREE;
9984 cond = NULL_TREE;
9985
9986 /* Are the rhs and the lhs the same? */
9987 if (deep_copy)
9988 {
9989 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9990 gfc_build_addr_expr (NULL_TREE, lse->expr),
9991 gfc_build_addr_expr (NULL_TREE, rse->expr));
9992 cond = gfc_evaluate_now (cond, &lse->pre);
9993 }
9994
9995 /* Deallocate the lhs allocated components as long as it is not
9996 the same as the rhs. This must be done following the assignment
9997 to prevent deallocating data that could be used in the rhs
9998 expression. */
9999 if (dealloc)
10000 {
10001 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
10002 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
10003 if (deep_copy)
10004 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10005 tmp);
10006 gfc_add_expr_to_block (&lse->post, tmp);
10007 }
10008
10009 gfc_add_block_to_block (&block, &rse->pre);
10010 gfc_add_block_to_block (&block, &lse->pre);
10011
10012 gfc_add_modify (&block, lse->expr,
10013 fold_convert (TREE_TYPE (lse->expr), rse->expr));
10014
10015 /* Restore pointer address of coarray components. */
10016 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
10017 {
10018 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
10019 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10020 tmp);
10021 gfc_add_expr_to_block (&block, tmp);
10022 }
10023
10024 /* Do a deep copy if the rhs is a variable, if it is not the
10025 same as the lhs. */
10026 if (deep_copy)
10027 {
10028 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
10029 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
10030 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
10031 caf_mode);
10032 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
10033 tmp);
10034 gfc_add_expr_to_block (&block, tmp);
10035 }
10036 }
10037 else if (gfc_bt_struct (ts.type))
10038 {
10039 gfc_add_block_to_block (&block, &lse->pre);
10040 gfc_add_block_to_block (&block, &rse->pre);
10041 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
10042 TREE_TYPE (lse->expr), rse->expr);
10043 gfc_add_modify (&block, lse->expr, tmp);
10044 }
10045 /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
10046 else if (ts.type == BT_CLASS)
10047 {
10048 gfc_add_block_to_block (&block, &lse->pre);
10049 gfc_add_block_to_block (&block, &rse->pre);
10050
10051 if (!trans_scalar_class_assign (&block, lse, rse))
10052 {
10053 /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
10054 for the lhs which ensures that class data rhs cast as a string assigns
10055 correctly. */
10056 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
10057 TREE_TYPE (rse->expr), lse->expr);
10058 gfc_add_modify (&block, tmp, rse->expr);
10059 }
10060 }
10061 else if (ts.type != BT_CLASS)
10062 {
10063 gfc_add_block_to_block (&block, &lse->pre);
10064 gfc_add_block_to_block (&block, &rse->pre);
10065
10066 gfc_add_modify (&block, lse->expr,
10067 fold_convert (TREE_TYPE (lse->expr), rse->expr));
10068 }
10069
10070 gfc_add_block_to_block (&block, &lse->post);
10071 gfc_add_block_to_block (&block, &rse->post);
10072
10073 return gfc_finish_block (&block);
10074 }
10075
10076
10077 /* There are quite a lot of restrictions on the optimisation in using an
10078 array function assign without a temporary. */
10079
10080 static bool
arrayfunc_assign_needs_temporary(gfc_expr * expr1,gfc_expr * expr2)10081 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
10082 {
10083 gfc_ref * ref;
10084 bool seen_array_ref;
10085 bool c = false;
10086 gfc_symbol *sym = expr1->symtree->n.sym;
10087
10088 /* Play it safe with class functions assigned to a derived type. */
10089 if (gfc_is_class_array_function (expr2)
10090 && expr1->ts.type == BT_DERIVED)
10091 return true;
10092
10093 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
10094 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
10095 return true;
10096
10097 /* Elemental functions are scalarized so that they don't need a
10098 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
10099 they would need special treatment in gfc_trans_arrayfunc_assign. */
10100 if (expr2->value.function.esym != NULL
10101 && expr2->value.function.esym->attr.elemental)
10102 return true;
10103
10104 /* Need a temporary if rhs is not FULL or a contiguous section. */
10105 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
10106 return true;
10107
10108 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
10109 if (gfc_ref_needs_temporary_p (expr1->ref))
10110 return true;
10111
10112 /* Functions returning pointers or allocatables need temporaries. */
10113 if (gfc_expr_attr (expr2).pointer
10114 || gfc_expr_attr (expr2).allocatable)
10115 return true;
10116
10117 /* Character array functions need temporaries unless the
10118 character lengths are the same. */
10119 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
10120 {
10121 if (expr1->ts.u.cl->length == NULL
10122 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10123 return true;
10124
10125 if (expr2->ts.u.cl->length == NULL
10126 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
10127 return true;
10128
10129 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
10130 expr2->ts.u.cl->length->value.integer) != 0)
10131 return true;
10132 }
10133
10134 /* Check that no LHS component references appear during an array
10135 reference. This is needed because we do not have the means to
10136 span any arbitrary stride with an array descriptor. This check
10137 is not needed for the rhs because the function result has to be
10138 a complete type. */
10139 seen_array_ref = false;
10140 for (ref = expr1->ref; ref; ref = ref->next)
10141 {
10142 if (ref->type == REF_ARRAY)
10143 seen_array_ref= true;
10144 else if (ref->type == REF_COMPONENT && seen_array_ref)
10145 return true;
10146 }
10147
10148 /* Check for a dependency. */
10149 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
10150 expr2->value.function.esym,
10151 expr2->value.function.actual,
10152 NOT_ELEMENTAL))
10153 return true;
10154
10155 /* If we have reached here with an intrinsic function, we do not
10156 need a temporary except in the particular case that reallocation
10157 on assignment is active and the lhs is allocatable and a target,
10158 or a pointer which may be a subref pointer. FIXME: The last
10159 condition can go away when we use span in the intrinsics
10160 directly.*/
10161 if (expr2->value.function.isym)
10162 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target)
10163 || (sym->attr.pointer && sym->attr.subref_array_pointer);
10164
10165 /* If the LHS is a dummy, we need a temporary if it is not
10166 INTENT(OUT). */
10167 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
10168 return true;
10169
10170 /* If the lhs has been host_associated, is in common, a pointer or is
10171 a target and the function is not using a RESULT variable, aliasing
10172 can occur and a temporary is needed. */
10173 if ((sym->attr.host_assoc
10174 || sym->attr.in_common
10175 || sym->attr.pointer
10176 || sym->attr.cray_pointee
10177 || sym->attr.target)
10178 && expr2->symtree != NULL
10179 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
10180 return true;
10181
10182 /* A PURE function can unconditionally be called without a temporary. */
10183 if (expr2->value.function.esym != NULL
10184 && expr2->value.function.esym->attr.pure)
10185 return false;
10186
10187 /* Implicit_pure functions are those which could legally be declared
10188 to be PURE. */
10189 if (expr2->value.function.esym != NULL
10190 && expr2->value.function.esym->attr.implicit_pure)
10191 return false;
10192
10193 if (!sym->attr.use_assoc
10194 && !sym->attr.in_common
10195 && !sym->attr.pointer
10196 && !sym->attr.target
10197 && !sym->attr.cray_pointee
10198 && expr2->value.function.esym)
10199 {
10200 /* A temporary is not needed if the function is not contained and
10201 the variable is local or host associated and not a pointer or
10202 a target. */
10203 if (!expr2->value.function.esym->attr.contained)
10204 return false;
10205
10206 /* A temporary is not needed if the lhs has never been host
10207 associated and the procedure is contained. */
10208 else if (!sym->attr.host_assoc)
10209 return false;
10210
10211 /* A temporary is not needed if the variable is local and not
10212 a pointer, a target or a result. */
10213 if (sym->ns->parent
10214 && expr2->value.function.esym->ns == sym->ns->parent)
10215 return false;
10216 }
10217
10218 /* Default to temporary use. */
10219 return true;
10220 }
10221
10222
10223 /* Provide the loop info so that the lhs descriptor can be built for
10224 reallocatable assignments from extrinsic function calls. */
10225
10226 static void
realloc_lhs_loop_for_fcn_call(gfc_se * se,locus * where,gfc_ss ** ss,gfc_loopinfo * loop)10227 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
10228 gfc_loopinfo *loop)
10229 {
10230 /* Signal that the function call should not be made by
10231 gfc_conv_loop_setup. */
10232 se->ss->is_alloc_lhs = 1;
10233 gfc_init_loopinfo (loop);
10234 gfc_add_ss_to_loop (loop, *ss);
10235 gfc_add_ss_to_loop (loop, se->ss);
10236 gfc_conv_ss_startstride (loop);
10237 gfc_conv_loop_setup (loop, where);
10238 gfc_copy_loopinfo_to_se (se, loop);
10239 gfc_add_block_to_block (&se->pre, &loop->pre);
10240 gfc_add_block_to_block (&se->pre, &loop->post);
10241 se->ss->is_alloc_lhs = 0;
10242 }
10243
10244
10245 /* For assignment to a reallocatable lhs from intrinsic functions,
10246 replace the se.expr (ie. the result) with a temporary descriptor.
10247 Null the data field so that the library allocates space for the
10248 result. Free the data of the original descriptor after the function,
10249 in case it appears in an argument expression and transfer the
10250 result to the original descriptor. */
10251
10252 static void
fcncall_realloc_result(gfc_se * se,int rank)10253 fcncall_realloc_result (gfc_se *se, int rank)
10254 {
10255 tree desc;
10256 tree res_desc;
10257 tree tmp;
10258 tree offset;
10259 tree zero_cond;
10260 tree not_same_shape;
10261 stmtblock_t shape_block;
10262 int n;
10263
10264 /* Use the allocation done by the library. Substitute the lhs
10265 descriptor with a copy, whose data field is nulled.*/
10266 desc = build_fold_indirect_ref_loc (input_location, se->expr);
10267 if (POINTER_TYPE_P (TREE_TYPE (desc)))
10268 desc = build_fold_indirect_ref_loc (input_location, desc);
10269
10270 /* Unallocated, the descriptor does not have a dtype. */
10271 tmp = gfc_conv_descriptor_dtype (desc);
10272 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
10273
10274 res_desc = gfc_evaluate_now (desc, &se->pre);
10275 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
10276 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
10277
10278 /* Free the lhs after the function call and copy the result data to
10279 the lhs descriptor. */
10280 tmp = gfc_conv_descriptor_data_get (desc);
10281 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
10282 logical_type_node, tmp,
10283 build_int_cst (TREE_TYPE (tmp), 0));
10284 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
10285 tmp = gfc_call_free (tmp);
10286 gfc_add_expr_to_block (&se->post, tmp);
10287
10288 tmp = gfc_conv_descriptor_data_get (res_desc);
10289 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
10290
10291 /* Check that the shapes are the same between lhs and expression.
10292 The evaluation of the shape is done in 'shape_block' to avoid
10293 unitialized warnings from the lhs bounds. */
10294 not_same_shape = boolean_false_node;
10295 gfc_start_block (&shape_block);
10296 for (n = 0 ; n < rank; n++)
10297 {
10298 tree tmp1;
10299 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
10300 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
10301 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10302 gfc_array_index_type, tmp, tmp1);
10303 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
10304 tmp = fold_build2_loc (input_location, MINUS_EXPR,
10305 gfc_array_index_type, tmp, tmp1);
10306 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
10307 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10308 gfc_array_index_type, tmp, tmp1);
10309 tmp = fold_build2_loc (input_location, NE_EXPR,
10310 logical_type_node, tmp,
10311 gfc_index_zero_node);
10312 tmp = gfc_evaluate_now (tmp, &shape_block);
10313 if (n == 0)
10314 not_same_shape = tmp;
10315 else
10316 not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR,
10317 logical_type_node, tmp,
10318 not_same_shape);
10319 }
10320
10321 /* 'zero_cond' being true is equal to lhs not being allocated or the
10322 shapes being different. */
10323 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
10324 zero_cond, not_same_shape);
10325 gfc_add_modify (&shape_block, zero_cond, tmp);
10326 tmp = gfc_finish_block (&shape_block);
10327 tmp = build3_v (COND_EXPR, zero_cond,
10328 build_empty_stmt (input_location), tmp);
10329 gfc_add_expr_to_block (&se->post, tmp);
10330
10331 /* Now reset the bounds returned from the function call to bounds based
10332 on the lhs lbounds, except where the lhs is not allocated or the shapes
10333 of 'variable and 'expr' are different. Set the offset accordingly. */
10334 offset = gfc_index_zero_node;
10335 for (n = 0 ; n < rank; n++)
10336 {
10337 tree lbound;
10338
10339 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
10340 lbound = fold_build3_loc (input_location, COND_EXPR,
10341 gfc_array_index_type, zero_cond,
10342 gfc_index_one_node, lbound);
10343 lbound = gfc_evaluate_now (lbound, &se->post);
10344
10345 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
10346 tmp = fold_build2_loc (input_location, PLUS_EXPR,
10347 gfc_array_index_type, tmp, lbound);
10348 gfc_conv_descriptor_lbound_set (&se->post, desc,
10349 gfc_rank_cst[n], lbound);
10350 gfc_conv_descriptor_ubound_set (&se->post, desc,
10351 gfc_rank_cst[n], tmp);
10352
10353 /* Set stride and accumulate the offset. */
10354 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
10355 gfc_conv_descriptor_stride_set (&se->post, desc,
10356 gfc_rank_cst[n], tmp);
10357 tmp = fold_build2_loc (input_location, MULT_EXPR,
10358 gfc_array_index_type, lbound, tmp);
10359 offset = fold_build2_loc (input_location, MINUS_EXPR,
10360 gfc_array_index_type, offset, tmp);
10361 offset = gfc_evaluate_now (offset, &se->post);
10362 }
10363
10364 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
10365 }
10366
10367
10368
10369 /* Try to translate array(:) = func (...), where func is a transformational
10370 array function, without using a temporary. Returns NULL if this isn't the
10371 case. */
10372
10373 static tree
gfc_trans_arrayfunc_assign(gfc_expr * expr1,gfc_expr * expr2)10374 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
10375 {
10376 gfc_se se;
10377 gfc_ss *ss = NULL;
10378 gfc_component *comp = NULL;
10379 gfc_loopinfo loop;
10380
10381 if (arrayfunc_assign_needs_temporary (expr1, expr2))
10382 return NULL;
10383
10384 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
10385 functions. */
10386 comp = gfc_get_proc_ptr_comp (expr2);
10387
10388 if (!(expr2->value.function.isym
10389 || (comp && comp->attr.dimension)
10390 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
10391 && expr2->value.function.esym->result->attr.dimension)))
10392 return NULL;
10393
10394 gfc_init_se (&se, NULL);
10395 gfc_start_block (&se.pre);
10396 se.want_pointer = 1;
10397
10398 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
10399
10400 if (expr1->ts.type == BT_DERIVED
10401 && expr1->ts.u.derived->attr.alloc_comp)
10402 {
10403 tree tmp;
10404 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
10405 expr1->rank);
10406 gfc_add_expr_to_block (&se.pre, tmp);
10407 }
10408
10409 se.direct_byref = 1;
10410 se.ss = gfc_walk_expr (expr2);
10411 gcc_assert (se.ss != gfc_ss_terminator);
10412
10413 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10414 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10415 Clearly, this cannot be done for an allocatable function result, since
10416 the shape of the result is unknown and, in any case, the function must
10417 correctly take care of the reallocation internally. For intrinsic
10418 calls, the array data is freed and the library takes care of allocation.
10419 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10420 to the library. */
10421 if (flag_realloc_lhs
10422 && gfc_is_reallocatable_lhs (expr1)
10423 && !gfc_expr_attr (expr1).codimension
10424 && !gfc_is_coindexed (expr1)
10425 && !(expr2->value.function.esym
10426 && expr2->value.function.esym->result->attr.allocatable))
10427 {
10428 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10429
10430 if (!expr2->value.function.isym)
10431 {
10432 ss = gfc_walk_expr (expr1);
10433 gcc_assert (ss != gfc_ss_terminator);
10434
10435 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
10436 ss->is_alloc_lhs = 1;
10437 }
10438 else
10439 fcncall_realloc_result (&se, expr1->rank);
10440 }
10441
10442 gfc_conv_function_expr (&se, expr2);
10443 gfc_add_block_to_block (&se.pre, &se.post);
10444
10445 if (ss)
10446 gfc_cleanup_loop (&loop);
10447 else
10448 gfc_free_ss_chain (se.ss);
10449
10450 return gfc_finish_block (&se.pre);
10451 }
10452
10453
10454 /* Try to efficiently translate array(:) = 0. Return NULL if this
10455 can't be done. */
10456
10457 static tree
gfc_trans_zero_assign(gfc_expr * expr)10458 gfc_trans_zero_assign (gfc_expr * expr)
10459 {
10460 tree dest, len, type;
10461 tree tmp;
10462 gfc_symbol *sym;
10463
10464 sym = expr->symtree->n.sym;
10465 dest = gfc_get_symbol_decl (sym);
10466
10467 type = TREE_TYPE (dest);
10468 if (POINTER_TYPE_P (type))
10469 type = TREE_TYPE (type);
10470 if (!GFC_ARRAY_TYPE_P (type))
10471 return NULL_TREE;
10472
10473 /* Determine the length of the array. */
10474 len = GFC_TYPE_ARRAY_SIZE (type);
10475 if (!len || TREE_CODE (len) != INTEGER_CST)
10476 return NULL_TREE;
10477
10478 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
10479 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10480 fold_convert (gfc_array_index_type, tmp));
10481
10482 /* If we are zeroing a local array avoid taking its address by emitting
10483 a = {} instead. */
10484 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
10485 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
10486 dest, build_constructor (TREE_TYPE (dest),
10487 NULL));
10488
10489 /* Convert arguments to the correct types. */
10490 dest = fold_convert (pvoid_type_node, dest);
10491 len = fold_convert (size_type_node, len);
10492
10493 /* Construct call to __builtin_memset. */
10494 tmp = build_call_expr_loc (input_location,
10495 builtin_decl_explicit (BUILT_IN_MEMSET),
10496 3, dest, integer_zero_node, len);
10497 return fold_convert (void_type_node, tmp);
10498 }
10499
10500
10501 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10502 that constructs the call to __builtin_memcpy. */
10503
10504 tree
gfc_build_memcpy_call(tree dst,tree src,tree len)10505 gfc_build_memcpy_call (tree dst, tree src, tree len)
10506 {
10507 tree tmp;
10508
10509 /* Convert arguments to the correct types. */
10510 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
10511 dst = gfc_build_addr_expr (pvoid_type_node, dst);
10512 else
10513 dst = fold_convert (pvoid_type_node, dst);
10514
10515 if (!POINTER_TYPE_P (TREE_TYPE (src)))
10516 src = gfc_build_addr_expr (pvoid_type_node, src);
10517 else
10518 src = fold_convert (pvoid_type_node, src);
10519
10520 len = fold_convert (size_type_node, len);
10521
10522 /* Construct call to __builtin_memcpy. */
10523 tmp = build_call_expr_loc (input_location,
10524 builtin_decl_explicit (BUILT_IN_MEMCPY),
10525 3, dst, src, len);
10526 return fold_convert (void_type_node, tmp);
10527 }
10528
10529
10530 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10531 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10532 source/rhs, both are gfc_full_array_ref_p which have been checked for
10533 dependencies. */
10534
10535 static tree
gfc_trans_array_copy(gfc_expr * expr1,gfc_expr * expr2)10536 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
10537 {
10538 tree dst, dlen, dtype;
10539 tree src, slen, stype;
10540 tree tmp;
10541
10542 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10543 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
10544
10545 dtype = TREE_TYPE (dst);
10546 if (POINTER_TYPE_P (dtype))
10547 dtype = TREE_TYPE (dtype);
10548 stype = TREE_TYPE (src);
10549 if (POINTER_TYPE_P (stype))
10550 stype = TREE_TYPE (stype);
10551
10552 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
10553 return NULL_TREE;
10554
10555 /* Determine the lengths of the arrays. */
10556 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
10557 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
10558 return NULL_TREE;
10559 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10560 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10561 dlen, fold_convert (gfc_array_index_type, tmp));
10562
10563 slen = GFC_TYPE_ARRAY_SIZE (stype);
10564 if (!slen || TREE_CODE (slen) != INTEGER_CST)
10565 return NULL_TREE;
10566 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
10567 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10568 slen, fold_convert (gfc_array_index_type, tmp));
10569
10570 /* Sanity check that they are the same. This should always be
10571 the case, as we should already have checked for conformance. */
10572 if (!tree_int_cst_equal (slen, dlen))
10573 return NULL_TREE;
10574
10575 return gfc_build_memcpy_call (dst, src, dlen);
10576 }
10577
10578
10579 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10580 this can't be done. EXPR1 is the destination/lhs for which
10581 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10582
10583 static tree
gfc_trans_array_constructor_copy(gfc_expr * expr1,gfc_expr * expr2)10584 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
10585 {
10586 unsigned HOST_WIDE_INT nelem;
10587 tree dst, dtype;
10588 tree src, stype;
10589 tree len;
10590 tree tmp;
10591
10592 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
10593 if (nelem == 0)
10594 return NULL_TREE;
10595
10596 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10597 dtype = TREE_TYPE (dst);
10598 if (POINTER_TYPE_P (dtype))
10599 dtype = TREE_TYPE (dtype);
10600 if (!GFC_ARRAY_TYPE_P (dtype))
10601 return NULL_TREE;
10602
10603 /* Determine the lengths of the array. */
10604 len = GFC_TYPE_ARRAY_SIZE (dtype);
10605 if (!len || TREE_CODE (len) != INTEGER_CST)
10606 return NULL_TREE;
10607
10608 /* Confirm that the constructor is the same size. */
10609 if (compare_tree_int (len, nelem) != 0)
10610 return NULL_TREE;
10611
10612 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10613 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10614 fold_convert (gfc_array_index_type, tmp));
10615
10616 stype = gfc_typenode_for_spec (&expr2->ts);
10617 src = gfc_build_constant_array_constructor (expr2, stype);
10618
10619 return gfc_build_memcpy_call (dst, src, len);
10620 }
10621
10622
10623 /* Tells whether the expression is to be treated as a variable reference. */
10624
10625 bool
gfc_expr_is_variable(gfc_expr * expr)10626 gfc_expr_is_variable (gfc_expr *expr)
10627 {
10628 gfc_expr *arg;
10629 gfc_component *comp;
10630 gfc_symbol *func_ifc;
10631
10632 if (expr->expr_type == EXPR_VARIABLE)
10633 return true;
10634
10635 arg = gfc_get_noncopying_intrinsic_argument (expr);
10636 if (arg)
10637 {
10638 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
10639 return gfc_expr_is_variable (arg);
10640 }
10641
10642 /* A data-pointer-returning function should be considered as a variable
10643 too. */
10644 if (expr->expr_type == EXPR_FUNCTION
10645 && expr->ref == NULL)
10646 {
10647 if (expr->value.function.isym != NULL)
10648 return false;
10649
10650 if (expr->value.function.esym != NULL)
10651 {
10652 func_ifc = expr->value.function.esym;
10653 goto found_ifc;
10654 }
10655 else
10656 {
10657 gcc_assert (expr->symtree);
10658 func_ifc = expr->symtree->n.sym;
10659 goto found_ifc;
10660 }
10661
10662 gcc_unreachable ();
10663 }
10664
10665 comp = gfc_get_proc_ptr_comp (expr);
10666 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
10667 && comp)
10668 {
10669 func_ifc = comp->ts.interface;
10670 goto found_ifc;
10671 }
10672
10673 if (expr->expr_type == EXPR_COMPCALL)
10674 {
10675 gcc_assert (!expr->value.compcall.tbp->is_generic);
10676 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
10677 goto found_ifc;
10678 }
10679
10680 return false;
10681
10682 found_ifc:
10683 gcc_assert (func_ifc->attr.function
10684 && func_ifc->result != NULL);
10685 return func_ifc->result->attr.pointer;
10686 }
10687
10688
10689 /* Is the lhs OK for automatic reallocation? */
10690
10691 static bool
is_scalar_reallocatable_lhs(gfc_expr * expr)10692 is_scalar_reallocatable_lhs (gfc_expr *expr)
10693 {
10694 gfc_ref * ref;
10695
10696 /* An allocatable variable with no reference. */
10697 if (expr->symtree->n.sym->attr.allocatable
10698 && !expr->ref)
10699 return true;
10700
10701 /* All that can be left are allocatable components. However, we do
10702 not check for allocatable components here because the expression
10703 could be an allocatable component of a pointer component. */
10704 if (expr->symtree->n.sym->ts.type != BT_DERIVED
10705 && expr->symtree->n.sym->ts.type != BT_CLASS)
10706 return false;
10707
10708 /* Find an allocatable component ref last. */
10709 for (ref = expr->ref; ref; ref = ref->next)
10710 if (ref->type == REF_COMPONENT
10711 && !ref->next
10712 && ref->u.c.component->attr.allocatable)
10713 return true;
10714
10715 return false;
10716 }
10717
10718
10719 /* Allocate or reallocate scalar lhs, as necessary. */
10720
10721 static void
alloc_scalar_allocatable_for_assignment(stmtblock_t * block,tree string_length,gfc_expr * expr1,gfc_expr * expr2)10722 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
10723 tree string_length,
10724 gfc_expr *expr1,
10725 gfc_expr *expr2)
10726
10727 {
10728 tree cond;
10729 tree tmp;
10730 tree size;
10731 tree size_in_bytes;
10732 tree jump_label1;
10733 tree jump_label2;
10734 gfc_se lse;
10735 gfc_ref *ref;
10736
10737 if (!expr1 || expr1->rank)
10738 return;
10739
10740 if (!expr2 || expr2->rank)
10741 return;
10742
10743 for (ref = expr1->ref; ref; ref = ref->next)
10744 if (ref->type == REF_SUBSTRING)
10745 return;
10746
10747 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10748
10749 /* Since this is a scalar lhs, we can afford to do this. That is,
10750 there is no risk of side effects being repeated. */
10751 gfc_init_se (&lse, NULL);
10752 lse.want_pointer = 1;
10753 gfc_conv_expr (&lse, expr1);
10754
10755 jump_label1 = gfc_build_label_decl (NULL_TREE);
10756 jump_label2 = gfc_build_label_decl (NULL_TREE);
10757
10758 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10759 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
10760 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10761 lse.expr, tmp);
10762 tmp = build3_v (COND_EXPR, cond,
10763 build1_v (GOTO_EXPR, jump_label1),
10764 build_empty_stmt (input_location));
10765 gfc_add_expr_to_block (block, tmp);
10766
10767 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10768 {
10769 /* Use the rhs string length and the lhs element size. */
10770 size = string_length;
10771 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
10772 tmp = TYPE_SIZE_UNIT (tmp);
10773 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10774 TREE_TYPE (tmp), tmp,
10775 fold_convert (TREE_TYPE (tmp), size));
10776 }
10777 else
10778 {
10779 /* Otherwise use the length in bytes of the rhs. */
10780 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
10781 size_in_bytes = size;
10782 }
10783
10784 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10785 size_in_bytes, size_one_node);
10786
10787 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
10788 {
10789 tree caf_decl, token;
10790 gfc_se caf_se;
10791 symbol_attribute attr;
10792
10793 gfc_clear_attr (&attr);
10794 gfc_init_se (&caf_se, NULL);
10795
10796 caf_decl = gfc_get_tree_for_caf_expr (expr1);
10797 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
10798 NULL);
10799 gfc_add_block_to_block (block, &caf_se.pre);
10800 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
10801 gfc_build_addr_expr (NULL_TREE, token),
10802 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
10803 expr1, 1);
10804 }
10805 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
10806 {
10807 tmp = build_call_expr_loc (input_location,
10808 builtin_decl_explicit (BUILT_IN_CALLOC),
10809 2, build_one_cst (size_type_node),
10810 size_in_bytes);
10811 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10812 gfc_add_modify (block, lse.expr, tmp);
10813 }
10814 else
10815 {
10816 tmp = build_call_expr_loc (input_location,
10817 builtin_decl_explicit (BUILT_IN_MALLOC),
10818 1, size_in_bytes);
10819 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10820 gfc_add_modify (block, lse.expr, tmp);
10821 }
10822
10823 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10824 {
10825 /* Deferred characters need checking for lhs and rhs string
10826 length. Other deferred parameter variables will have to
10827 come here too. */
10828 tmp = build1_v (GOTO_EXPR, jump_label2);
10829 gfc_add_expr_to_block (block, tmp);
10830 }
10831 tmp = build1_v (LABEL_EXPR, jump_label1);
10832 gfc_add_expr_to_block (block, tmp);
10833
10834 /* For a deferred length character, reallocate if lengths of lhs and
10835 rhs are different. */
10836 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10837 {
10838 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10839 lse.string_length,
10840 fold_convert (TREE_TYPE (lse.string_length),
10841 size));
10842 /* Jump past the realloc if the lengths are the same. */
10843 tmp = build3_v (COND_EXPR, cond,
10844 build1_v (GOTO_EXPR, jump_label2),
10845 build_empty_stmt (input_location));
10846 gfc_add_expr_to_block (block, tmp);
10847 tmp = build_call_expr_loc (input_location,
10848 builtin_decl_explicit (BUILT_IN_REALLOC),
10849 2, fold_convert (pvoid_type_node, lse.expr),
10850 size_in_bytes);
10851 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10852 gfc_add_modify (block, lse.expr, tmp);
10853 tmp = build1_v (LABEL_EXPR, jump_label2);
10854 gfc_add_expr_to_block (block, tmp);
10855
10856 /* Update the lhs character length. */
10857 size = string_length;
10858 gfc_add_modify (block, lse.string_length,
10859 fold_convert (TREE_TYPE (lse.string_length), size));
10860 }
10861 }
10862
10863 /* Check for assignments of the type
10864
10865 a = a + 4
10866
10867 to make sure we do not check for reallocation unneccessarily. */
10868
10869
10870 static bool
is_runtime_conformable(gfc_expr * expr1,gfc_expr * expr2)10871 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
10872 {
10873 gfc_actual_arglist *a;
10874 gfc_expr *e1, *e2;
10875
10876 switch (expr2->expr_type)
10877 {
10878 case EXPR_VARIABLE:
10879 return gfc_dep_compare_expr (expr1, expr2) == 0;
10880
10881 case EXPR_FUNCTION:
10882 if (expr2->value.function.esym
10883 && expr2->value.function.esym->attr.elemental)
10884 {
10885 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10886 {
10887 e1 = a->expr;
10888 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10889 return false;
10890 }
10891 return true;
10892 }
10893 else if (expr2->value.function.isym
10894 && expr2->value.function.isym->elemental)
10895 {
10896 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10897 {
10898 e1 = a->expr;
10899 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10900 return false;
10901 }
10902 return true;
10903 }
10904
10905 break;
10906
10907 case EXPR_OP:
10908 switch (expr2->value.op.op)
10909 {
10910 case INTRINSIC_NOT:
10911 case INTRINSIC_UPLUS:
10912 case INTRINSIC_UMINUS:
10913 case INTRINSIC_PARENTHESES:
10914 return is_runtime_conformable (expr1, expr2->value.op.op1);
10915
10916 case INTRINSIC_PLUS:
10917 case INTRINSIC_MINUS:
10918 case INTRINSIC_TIMES:
10919 case INTRINSIC_DIVIDE:
10920 case INTRINSIC_POWER:
10921 case INTRINSIC_AND:
10922 case INTRINSIC_OR:
10923 case INTRINSIC_EQV:
10924 case INTRINSIC_NEQV:
10925 case INTRINSIC_EQ:
10926 case INTRINSIC_NE:
10927 case INTRINSIC_GT:
10928 case INTRINSIC_GE:
10929 case INTRINSIC_LT:
10930 case INTRINSIC_LE:
10931 case INTRINSIC_EQ_OS:
10932 case INTRINSIC_NE_OS:
10933 case INTRINSIC_GT_OS:
10934 case INTRINSIC_GE_OS:
10935 case INTRINSIC_LT_OS:
10936 case INTRINSIC_LE_OS:
10937
10938 e1 = expr2->value.op.op1;
10939 e2 = expr2->value.op.op2;
10940
10941 if (e1->rank == 0 && e2->rank > 0)
10942 return is_runtime_conformable (expr1, e2);
10943 else if (e1->rank > 0 && e2->rank == 0)
10944 return is_runtime_conformable (expr1, e1);
10945 else if (e1->rank > 0 && e2->rank > 0)
10946 return is_runtime_conformable (expr1, e1)
10947 && is_runtime_conformable (expr1, e2);
10948 break;
10949
10950 default:
10951 break;
10952
10953 }
10954
10955 break;
10956
10957 default:
10958 break;
10959 }
10960 return false;
10961 }
10962
10963
10964 static tree
trans_class_assignment(stmtblock_t * block,gfc_expr * lhs,gfc_expr * rhs,gfc_se * lse,gfc_se * rse,bool use_vptr_copy,bool class_realloc)10965 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
10966 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
10967 bool class_realloc)
10968 {
10969 tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
10970 vec<tree, va_gc> *args = NULL;
10971
10972 /* Store the old vptr so that dynamic types can be compared for
10973 reallocation to occur or not. */
10974 if (class_realloc)
10975 {
10976 tmp = lse->expr;
10977 if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
10978 tmp = gfc_get_class_from_expr (tmp);
10979 }
10980
10981 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
10982 &from_len);
10983
10984 /* Generate (re)allocation of the lhs. */
10985 if (class_realloc)
10986 {
10987 stmtblock_t alloc, re_alloc;
10988 tree class_han, re, size;
10989
10990 if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
10991 old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
10992 else
10993 old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
10994
10995 size = gfc_vptr_size_get (vptr);
10996 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10997 ? gfc_class_data_get (lse->expr) : lse->expr;
10998
10999 /* Allocate block. */
11000 gfc_init_block (&alloc);
11001 gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
11002
11003 /* Reallocate if dynamic types are different. */
11004 gfc_init_block (&re_alloc);
11005 re = build_call_expr_loc (input_location,
11006 builtin_decl_explicit (BUILT_IN_REALLOC), 2,
11007 fold_convert (pvoid_type_node, class_han),
11008 size);
11009 tmp = fold_build2_loc (input_location, NE_EXPR,
11010 logical_type_node, vptr, old_vptr);
11011 re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
11012 tmp, re, build_empty_stmt (input_location));
11013 gfc_add_expr_to_block (&re_alloc, re);
11014
11015 /* Allocate if _data is NULL, reallocate otherwise. */
11016 tmp = fold_build2_loc (input_location, EQ_EXPR,
11017 logical_type_node, class_han,
11018 build_int_cst (prvoid_type_node, 0));
11019 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
11020 gfc_unlikely (tmp,
11021 PRED_FORTRAN_FAIL_ALLOC),
11022 gfc_finish_block (&alloc),
11023 gfc_finish_block (&re_alloc));
11024 gfc_add_expr_to_block (&lse->pre, tmp);
11025 }
11026
11027 fcn = gfc_vptr_copy_get (vptr);
11028
11029 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
11030 ? gfc_class_data_get (rse->expr) : rse->expr;
11031 if (use_vptr_copy)
11032 {
11033 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
11034 || INDIRECT_REF_P (tmp)
11035 || (rhs->ts.type == BT_DERIVED
11036 && rhs->ts.u.derived->attr.unlimited_polymorphic
11037 && !rhs->ts.u.derived->attr.pointer
11038 && !rhs->ts.u.derived->attr.allocatable)
11039 || (UNLIMITED_POLY (rhs)
11040 && !CLASS_DATA (rhs)->attr.pointer
11041 && !CLASS_DATA (rhs)->attr.allocatable))
11042 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
11043 else
11044 vec_safe_push (args, tmp);
11045 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11046 ? gfc_class_data_get (lse->expr) : lse->expr;
11047 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
11048 || INDIRECT_REF_P (tmp)
11049 || (lhs->ts.type == BT_DERIVED
11050 && lhs->ts.u.derived->attr.unlimited_polymorphic
11051 && !lhs->ts.u.derived->attr.pointer
11052 && !lhs->ts.u.derived->attr.allocatable)
11053 || (UNLIMITED_POLY (lhs)
11054 && !CLASS_DATA (lhs)->attr.pointer
11055 && !CLASS_DATA (lhs)->attr.allocatable))
11056 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
11057 else
11058 vec_safe_push (args, tmp);
11059
11060 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
11061
11062 if (to_len != NULL_TREE && !integer_zerop (from_len))
11063 {
11064 tree extcopy;
11065 vec_safe_push (args, from_len);
11066 vec_safe_push (args, to_len);
11067 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
11068
11069 tmp = fold_build2_loc (input_location, GT_EXPR,
11070 logical_type_node, from_len,
11071 build_zero_cst (TREE_TYPE (from_len)));
11072 return fold_build3_loc (input_location, COND_EXPR,
11073 void_type_node, tmp,
11074 extcopy, stdcopy);
11075 }
11076 else
11077 return stdcopy;
11078 }
11079 else
11080 {
11081 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
11082 ? gfc_class_data_get (lse->expr) : lse->expr;
11083 stmtblock_t tblock;
11084 gfc_init_block (&tblock);
11085 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
11086 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
11087 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
11088 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
11089 /* When coming from a ptr_copy lhs and rhs are swapped. */
11090 gfc_add_modify_loc (input_location, &tblock, rhst,
11091 fold_convert (TREE_TYPE (rhst), tmp));
11092 return gfc_finish_block (&tblock);
11093 }
11094 }
11095
11096 /* Subroutine of gfc_trans_assignment that actually scalarizes the
11097 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
11098 init_flag indicates initialization expressions and dealloc that no
11099 deallocate prior assignment is needed (if in doubt, set true).
11100 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
11101 routine instead of a pointer assignment. Alias resolution is only done,
11102 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
11103 where it is known, that newly allocated memory on the lhs can never be
11104 an alias of the rhs. */
11105
11106 static tree
gfc_trans_assignment_1(gfc_expr * expr1,gfc_expr * expr2,bool init_flag,bool dealloc,bool use_vptr_copy,bool may_alias)11107 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
11108 bool dealloc, bool use_vptr_copy, bool may_alias)
11109 {
11110 gfc_se lse;
11111 gfc_se rse;
11112 gfc_ss *lss;
11113 gfc_ss *lss_section;
11114 gfc_ss *rss;
11115 gfc_loopinfo loop;
11116 tree tmp;
11117 stmtblock_t block;
11118 stmtblock_t body;
11119 bool l_is_temp;
11120 bool scalar_to_array;
11121 tree string_length;
11122 int n;
11123 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
11124 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
11125 bool is_poly_assign;
11126 bool realloc_flag;
11127
11128 /* Assignment of the form lhs = rhs. */
11129 gfc_start_block (&block);
11130
11131 gfc_init_se (&lse, NULL);
11132 gfc_init_se (&rse, NULL);
11133
11134 /* Walk the lhs. */
11135 lss = gfc_walk_expr (expr1);
11136 if (gfc_is_reallocatable_lhs (expr1))
11137 {
11138 lss->no_bounds_check = 1;
11139 if (!(expr2->expr_type == EXPR_FUNCTION
11140 && expr2->value.function.isym != NULL
11141 && !(expr2->value.function.isym->elemental
11142 || expr2->value.function.isym->conversion)))
11143 lss->is_alloc_lhs = 1;
11144 }
11145 else
11146 lss->no_bounds_check = expr1->no_bounds_check;
11147
11148 rss = NULL;
11149
11150 if ((expr1->ts.type == BT_DERIVED)
11151 && (gfc_is_class_array_function (expr2)
11152 || gfc_is_alloc_class_scalar_function (expr2)))
11153 expr2->must_finalize = 1;
11154
11155 /* Checking whether a class assignment is desired is quite complicated and
11156 needed at two locations, so do it once only before the information is
11157 needed. */
11158 lhs_attr = gfc_expr_attr (expr1);
11159 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
11160 || (lhs_attr.allocatable && !lhs_attr.dimension))
11161 && (expr1->ts.type == BT_CLASS
11162 || gfc_is_class_array_ref (expr1, NULL)
11163 || gfc_is_class_scalar_expr (expr1)
11164 || gfc_is_class_array_ref (expr2, NULL)
11165 || gfc_is_class_scalar_expr (expr2))
11166 && lhs_attr.flavor != FL_PROCEDURE;
11167
11168 realloc_flag = flag_realloc_lhs
11169 && gfc_is_reallocatable_lhs (expr1)
11170 && expr2->rank
11171 && !is_runtime_conformable (expr1, expr2);
11172
11173 /* Only analyze the expressions for coarray properties, when in coarray-lib
11174 mode. */
11175 if (flag_coarray == GFC_FCOARRAY_LIB)
11176 {
11177 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
11178 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
11179 }
11180
11181 if (lss != gfc_ss_terminator)
11182 {
11183 /* The assignment needs scalarization. */
11184 lss_section = lss;
11185
11186 /* Find a non-scalar SS from the lhs. */
11187 while (lss_section != gfc_ss_terminator
11188 && lss_section->info->type != GFC_SS_SECTION)
11189 lss_section = lss_section->next;
11190
11191 gcc_assert (lss_section != gfc_ss_terminator);
11192
11193 /* Initialize the scalarizer. */
11194 gfc_init_loopinfo (&loop);
11195
11196 /* Walk the rhs. */
11197 rss = gfc_walk_expr (expr2);
11198 if (rss == gfc_ss_terminator)
11199 /* The rhs is scalar. Add a ss for the expression. */
11200 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
11201 /* When doing a class assign, then the handle to the rhs needs to be a
11202 pointer to allow for polymorphism. */
11203 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
11204 rss->info->type = GFC_SS_REFERENCE;
11205
11206 rss->no_bounds_check = expr2->no_bounds_check;
11207 /* Associate the SS with the loop. */
11208 gfc_add_ss_to_loop (&loop, lss);
11209 gfc_add_ss_to_loop (&loop, rss);
11210
11211 /* Calculate the bounds of the scalarization. */
11212 gfc_conv_ss_startstride (&loop);
11213 /* Enable loop reversal. */
11214 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
11215 loop.reverse[n] = GFC_ENABLE_REVERSE;
11216 /* Resolve any data dependencies in the statement. */
11217 if (may_alias)
11218 gfc_conv_resolve_dependencies (&loop, lss, rss);
11219 /* Setup the scalarizing loops. */
11220 gfc_conv_loop_setup (&loop, &expr2->where);
11221
11222 /* Setup the gfc_se structures. */
11223 gfc_copy_loopinfo_to_se (&lse, &loop);
11224 gfc_copy_loopinfo_to_se (&rse, &loop);
11225
11226 rse.ss = rss;
11227 gfc_mark_ss_chain_used (rss, 1);
11228 if (loop.temp_ss == NULL)
11229 {
11230 lse.ss = lss;
11231 gfc_mark_ss_chain_used (lss, 1);
11232 }
11233 else
11234 {
11235 lse.ss = loop.temp_ss;
11236 gfc_mark_ss_chain_used (lss, 3);
11237 gfc_mark_ss_chain_used (loop.temp_ss, 3);
11238 }
11239
11240 /* Allow the scalarizer to workshare array assignments. */
11241 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
11242 == OMPWS_WORKSHARE_FLAG
11243 && loop.temp_ss == NULL)
11244 {
11245 maybe_workshare = true;
11246 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
11247 }
11248
11249 /* Start the scalarized loop body. */
11250 gfc_start_scalarized_body (&loop, &body);
11251 }
11252 else
11253 gfc_init_block (&body);
11254
11255 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
11256
11257 /* Translate the expression. */
11258 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
11259 && lhs_caf_attr.codimension;
11260 gfc_conv_expr (&rse, expr2);
11261
11262 /* Deal with the case of a scalar class function assigned to a derived type. */
11263 if (gfc_is_alloc_class_scalar_function (expr2)
11264 && expr1->ts.type == BT_DERIVED)
11265 {
11266 rse.expr = gfc_class_data_get (rse.expr);
11267 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
11268 }
11269
11270 /* Stabilize a string length for temporaries. */
11271 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
11272 && !(VAR_P (rse.string_length)
11273 || TREE_CODE (rse.string_length) == PARM_DECL
11274 || TREE_CODE (rse.string_length) == INDIRECT_REF))
11275 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
11276 else if (expr2->ts.type == BT_CHARACTER)
11277 {
11278 if (expr1->ts.deferred
11279 && gfc_expr_attr (expr1).allocatable
11280 && gfc_check_dependency (expr1, expr2, true))
11281 rse.string_length =
11282 gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
11283 string_length = rse.string_length;
11284 }
11285 else
11286 string_length = NULL_TREE;
11287
11288 if (l_is_temp)
11289 {
11290 gfc_conv_tmp_array_ref (&lse);
11291 if (expr2->ts.type == BT_CHARACTER)
11292 lse.string_length = string_length;
11293 }
11294 else
11295 {
11296 gfc_conv_expr (&lse, expr1);
11297 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
11298 && !init_flag
11299 && gfc_expr_attr (expr1).allocatable
11300 && expr1->rank
11301 && !expr2->rank)
11302 {
11303 tree cond;
11304 const char* msg;
11305
11306 tmp = INDIRECT_REF_P (lse.expr)
11307 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
11308
11309 /* We should only get array references here. */
11310 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
11311 || TREE_CODE (tmp) == ARRAY_REF);
11312
11313 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
11314 or the array itself(ARRAY_REF). */
11315 tmp = TREE_OPERAND (tmp, 0);
11316
11317 /* Provide the address of the array. */
11318 if (TREE_CODE (lse.expr) == ARRAY_REF)
11319 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
11320
11321 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
11322 tmp, build_int_cst (TREE_TYPE (tmp), 0));
11323 msg = _("Assignment of scalar to unallocated array");
11324 gfc_trans_runtime_check (true, false, cond, &loop.pre,
11325 &expr1->where, msg);
11326 }
11327
11328 /* Deallocate the lhs parameterized components if required. */
11329 if (dealloc && expr2->expr_type == EXPR_FUNCTION
11330 && !expr1->symtree->n.sym->attr.associate_var)
11331 {
11332 if (expr1->ts.type == BT_DERIVED
11333 && expr1->ts.u.derived
11334 && expr1->ts.u.derived->attr.pdt_type)
11335 {
11336 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
11337 expr1->rank);
11338 gfc_add_expr_to_block (&lse.pre, tmp);
11339 }
11340 else if (expr1->ts.type == BT_CLASS
11341 && CLASS_DATA (expr1)->ts.u.derived
11342 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
11343 {
11344 tmp = gfc_class_data_get (lse.expr);
11345 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
11346 tmp, expr1->rank);
11347 gfc_add_expr_to_block (&lse.pre, tmp);
11348 }
11349 }
11350 }
11351
11352 /* Assignments of scalar derived types with allocatable components
11353 to arrays must be done with a deep copy and the rhs temporary
11354 must have its components deallocated afterwards. */
11355 scalar_to_array = (expr2->ts.type == BT_DERIVED
11356 && expr2->ts.u.derived->attr.alloc_comp
11357 && !gfc_expr_is_variable (expr2)
11358 && expr1->rank && !expr2->rank);
11359 scalar_to_array |= (expr1->ts.type == BT_DERIVED
11360 && expr1->rank
11361 && expr1->ts.u.derived->attr.alloc_comp
11362 && gfc_is_alloc_class_scalar_function (expr2));
11363 if (scalar_to_array && dealloc)
11364 {
11365 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
11366 gfc_prepend_expr_to_block (&loop.post, tmp);
11367 }
11368
11369 /* When assigning a character function result to a deferred-length variable,
11370 the function call must happen before the (re)allocation of the lhs -
11371 otherwise the character length of the result is not known.
11372 NOTE 1: This relies on having the exact dependence of the length type
11373 parameter available to the caller; gfortran saves it in the .mod files.
11374 NOTE 2: Vector array references generate an index temporary that must
11375 not go outside the loop. Otherwise, variables should not generate
11376 a pre block.
11377 NOTE 3: The concatenation operation generates a temporary pointer,
11378 whose allocation must go to the innermost loop.
11379 NOTE 4: Elemental functions may generate a temporary, too. */
11380 if (flag_realloc_lhs
11381 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
11382 && !(lss != gfc_ss_terminator
11383 && rss != gfc_ss_terminator
11384 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
11385 || (expr2->expr_type == EXPR_FUNCTION
11386 && expr2->value.function.esym != NULL
11387 && expr2->value.function.esym->attr.elemental)
11388 || (expr2->expr_type == EXPR_FUNCTION
11389 && expr2->value.function.isym != NULL
11390 && expr2->value.function.isym->elemental)
11391 || (expr2->expr_type == EXPR_OP
11392 && expr2->value.op.op == INTRINSIC_CONCAT))))
11393 gfc_add_block_to_block (&block, &rse.pre);
11394
11395 /* Nullify the allocatable components corresponding to those of the lhs
11396 derived type, so that the finalization of the function result does not
11397 affect the lhs of the assignment. Prepend is used to ensure that the
11398 nullification occurs before the call to the finalizer. In the case of
11399 a scalar to array assignment, this is done in gfc_trans_scalar_assign
11400 as part of the deep copy. */
11401 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
11402 && (gfc_is_class_array_function (expr2)
11403 || gfc_is_alloc_class_scalar_function (expr2)))
11404 {
11405 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
11406 gfc_prepend_expr_to_block (&rse.post, tmp);
11407 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
11408 gfc_add_block_to_block (&loop.post, &rse.post);
11409 }
11410
11411 tmp = NULL_TREE;
11412
11413 if (is_poly_assign)
11414 {
11415 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
11416 use_vptr_copy || (lhs_attr.allocatable
11417 && !lhs_attr.dimension),
11418 !realloc_flag && flag_realloc_lhs
11419 && !lhs_attr.pointer);
11420 if (expr2->expr_type == EXPR_FUNCTION
11421 && expr2->ts.type == BT_DERIVED
11422 && expr2->ts.u.derived->attr.alloc_comp)
11423 {
11424 tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
11425 rse.expr, expr2->rank);
11426 if (lss == gfc_ss_terminator)
11427 gfc_add_expr_to_block (&rse.post, tmp2);
11428 else
11429 gfc_add_expr_to_block (&loop.post, tmp2);
11430 }
11431 }
11432 else if (flag_coarray == GFC_FCOARRAY_LIB
11433 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
11434 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
11435 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
11436 {
11437 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
11438 allocatable component, because those need to be accessed via the
11439 caf-runtime. No need to check for coindexes here, because resolve
11440 has rewritten those already. */
11441 gfc_code code;
11442 gfc_actual_arglist a1, a2;
11443 /* Clear the structures to prevent accessing garbage. */
11444 memset (&code, '\0', sizeof (gfc_code));
11445 memset (&a1, '\0', sizeof (gfc_actual_arglist));
11446 memset (&a2, '\0', sizeof (gfc_actual_arglist));
11447 a1.expr = expr1;
11448 a1.next = &a2;
11449 a2.expr = expr2;
11450 a2.next = NULL;
11451 code.ext.actual = &a1;
11452 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
11453 tmp = gfc_conv_intrinsic_subroutine (&code);
11454 }
11455 else if (!is_poly_assign && expr2->must_finalize
11456 && expr1->ts.type == BT_CLASS
11457 && expr2->ts.type == BT_CLASS)
11458 {
11459 /* This case comes about when the scalarizer provides array element
11460 references. Use the vptr copy function, since this does a deep
11461 copy of allocatable components, without which the finalizer call
11462 will deallocate the components. */
11463 tmp = gfc_get_vptr_from_expr (rse.expr);
11464 if (tmp != NULL_TREE)
11465 {
11466 tree fcn = gfc_vptr_copy_get (tmp);
11467 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
11468 fcn = build_fold_indirect_ref_loc (input_location, fcn);
11469 tmp = build_call_expr_loc (input_location,
11470 fcn, 2,
11471 gfc_build_addr_expr (NULL, rse.expr),
11472 gfc_build_addr_expr (NULL, lse.expr));
11473 }
11474 }
11475
11476 /* If nothing else works, do it the old fashioned way! */
11477 if (tmp == NULL_TREE)
11478 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
11479 gfc_expr_is_variable (expr2)
11480 || scalar_to_array
11481 || expr2->expr_type == EXPR_ARRAY,
11482 !(l_is_temp || init_flag) && dealloc,
11483 expr1->symtree->n.sym->attr.codimension);
11484
11485 /* Add the pre blocks to the body. */
11486 gfc_add_block_to_block (&body, &rse.pre);
11487 gfc_add_block_to_block (&body, &lse.pre);
11488 gfc_add_expr_to_block (&body, tmp);
11489 /* Add the post blocks to the body. */
11490 gfc_add_block_to_block (&body, &rse.post);
11491 gfc_add_block_to_block (&body, &lse.post);
11492
11493 if (lss == gfc_ss_terminator)
11494 {
11495 /* F2003: Add the code for reallocation on assignment. */
11496 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
11497 && !is_poly_assign)
11498 alloc_scalar_allocatable_for_assignment (&block, string_length,
11499 expr1, expr2);
11500
11501 /* Use the scalar assignment as is. */
11502 gfc_add_block_to_block (&block, &body);
11503 }
11504 else
11505 {
11506 gcc_assert (lse.ss == gfc_ss_terminator
11507 && rse.ss == gfc_ss_terminator);
11508
11509 if (l_is_temp)
11510 {
11511 gfc_trans_scalarized_loop_boundary (&loop, &body);
11512
11513 /* We need to copy the temporary to the actual lhs. */
11514 gfc_init_se (&lse, NULL);
11515 gfc_init_se (&rse, NULL);
11516 gfc_copy_loopinfo_to_se (&lse, &loop);
11517 gfc_copy_loopinfo_to_se (&rse, &loop);
11518
11519 rse.ss = loop.temp_ss;
11520 lse.ss = lss;
11521
11522 gfc_conv_tmp_array_ref (&rse);
11523 gfc_conv_expr (&lse, expr1);
11524
11525 gcc_assert (lse.ss == gfc_ss_terminator
11526 && rse.ss == gfc_ss_terminator);
11527
11528 if (expr2->ts.type == BT_CHARACTER)
11529 rse.string_length = string_length;
11530
11531 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
11532 false, dealloc);
11533 gfc_add_expr_to_block (&body, tmp);
11534 }
11535
11536 /* F2003: Allocate or reallocate lhs of allocatable array. */
11537 if (realloc_flag)
11538 {
11539 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
11540 ompws_flags &= ~OMPWS_SCALARIZER_WS;
11541 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
11542 if (tmp != NULL_TREE)
11543 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
11544 }
11545
11546 if (maybe_workshare)
11547 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
11548
11549 /* Generate the copying loops. */
11550 gfc_trans_scalarizing_loops (&loop, &body);
11551
11552 /* Wrap the whole thing up. */
11553 gfc_add_block_to_block (&block, &loop.pre);
11554 gfc_add_block_to_block (&block, &loop.post);
11555
11556 gfc_cleanup_loop (&loop);
11557 }
11558
11559 return gfc_finish_block (&block);
11560 }
11561
11562
11563 /* Check whether EXPR is a copyable array. */
11564
11565 static bool
copyable_array_p(gfc_expr * expr)11566 copyable_array_p (gfc_expr * expr)
11567 {
11568 if (expr->expr_type != EXPR_VARIABLE)
11569 return false;
11570
11571 /* First check it's an array. */
11572 if (expr->rank < 1 || !expr->ref || expr->ref->next)
11573 return false;
11574
11575 if (!gfc_full_array_ref_p (expr->ref, NULL))
11576 return false;
11577
11578 /* Next check that it's of a simple enough type. */
11579 switch (expr->ts.type)
11580 {
11581 case BT_INTEGER:
11582 case BT_REAL:
11583 case BT_COMPLEX:
11584 case BT_LOGICAL:
11585 return true;
11586
11587 case BT_CHARACTER:
11588 return false;
11589
11590 case_bt_struct:
11591 return !expr->ts.u.derived->attr.alloc_comp;
11592
11593 default:
11594 break;
11595 }
11596
11597 return false;
11598 }
11599
11600 /* Translate an assignment. */
11601
11602 tree
gfc_trans_assignment(gfc_expr * expr1,gfc_expr * expr2,bool init_flag,bool dealloc,bool use_vptr_copy,bool may_alias)11603 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
11604 bool dealloc, bool use_vptr_copy, bool may_alias)
11605 {
11606 tree tmp;
11607
11608 /* Special case a single function returning an array. */
11609 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
11610 {
11611 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
11612 if (tmp)
11613 return tmp;
11614 }
11615
11616 /* Special case assigning an array to zero. */
11617 if (copyable_array_p (expr1)
11618 && is_zero_initializer_p (expr2))
11619 {
11620 tmp = gfc_trans_zero_assign (expr1);
11621 if (tmp)
11622 return tmp;
11623 }
11624
11625 /* Special case copying one array to another. */
11626 if (copyable_array_p (expr1)
11627 && copyable_array_p (expr2)
11628 && gfc_compare_types (&expr1->ts, &expr2->ts)
11629 && !gfc_check_dependency (expr1, expr2, 0))
11630 {
11631 tmp = gfc_trans_array_copy (expr1, expr2);
11632 if (tmp)
11633 return tmp;
11634 }
11635
11636 /* Special case initializing an array from a constant array constructor. */
11637 if (copyable_array_p (expr1)
11638 && expr2->expr_type == EXPR_ARRAY
11639 && gfc_compare_types (&expr1->ts, &expr2->ts))
11640 {
11641 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
11642 if (tmp)
11643 return tmp;
11644 }
11645
11646 if (UNLIMITED_POLY (expr1) && expr1->rank)
11647 use_vptr_copy = true;
11648
11649 /* Fallback to the scalarizer to generate explicit loops. */
11650 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
11651 use_vptr_copy, may_alias);
11652 }
11653
11654 tree
gfc_trans_init_assign(gfc_code * code)11655 gfc_trans_init_assign (gfc_code * code)
11656 {
11657 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
11658 }
11659
11660 tree
gfc_trans_assign(gfc_code * code)11661 gfc_trans_assign (gfc_code * code)
11662 {
11663 return gfc_trans_assignment (code->expr1, code->expr2, false, true);
11664 }
11665