1 /* Expression translation
2 Copyright (C) 2002-2019 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
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
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
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/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.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"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
51 enum gfc_array_kind akind;
54 akind = GFC_ARRAY_POINTER_CONT;
55 else if (attr.allocatable)
56 akind = GFC_ARRAY_ALLOCATABLE;
58 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
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));
67 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
69 tree desc, type, etype;
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;
76 if (CONSTANT_CLASS_P (scalar))
79 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
80 gfc_add_modify (&se->pre, tmp, scalar);
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);
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)));
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. */
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
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;
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))
122 if (last_caf_ref == NULL)
125 tree comp = last_caf_ref->u.c.component->caf_token, caf;
127 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
128 if (comp == NULL_TREE && comp_ref)
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);
138 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
139 se.expr = TREE_OPERAND (se.expr, 0);
140 gfc_free_expr (caf_expr);
143 caf = fold_build3_loc (input_location, COMPONENT_REF,
144 TREE_TYPE (comp), se.expr, comp, NULL_TREE);
146 caf = gfc_conv_descriptor_token (se.expr);
147 return gfc_build_addr_expr (NULL_TREE, caf);
151 /* This is the seed for an eventual trans-class.c
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
168 gfc_class_set_static_fields (tree decl, tree vptr, tree data)
172 vec<constructor_elt, va_gc> *init = NULL;
174 field = TYPE_FIELDS (TREE_TYPE (decl));
175 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
176 CONSTRUCTOR_APPEND_ELT (init, tmp, data);
178 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
179 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
181 return build_constructor (TREE_TYPE (decl), init);
186 gfc_class_data_get (tree decl)
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)),
193 return fold_build3_loc (input_location, COMPONENT_REF,
194 TREE_TYPE (data), decl, data,
200 gfc_class_vptr_get (tree decl)
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)),
212 return fold_build3_loc (input_location, COMPONENT_REF,
213 TREE_TYPE (vptr), decl, vptr,
219 gfc_class_len_get (tree decl)
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)),
231 return fold_build3_loc (input_location, COMPONENT_REF,
232 TREE_TYPE (len), decl, len,
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. */
241 gfc_class_len_or_zero_get (tree decl)
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)),
253 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
254 TREE_TYPE (len), decl, len,
256 : build_zero_cst (gfc_charlen_type_node);
260 /* Get the specified FIELD from the VPTR. */
263 vptr_field_get (tree vptr, int fieldno)
266 vptr = build_fold_indirect_ref_loc (input_location, vptr);
267 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
269 field = fold_build3_loc (input_location, COMPONENT_REF,
270 TREE_TYPE (field), vptr, field,
277 /* Get the field from the class' vptr. */
280 class_vtab_field_get (tree decl, int fieldno)
283 vptr = gfc_class_vptr_get (decl);
284 return vptr_field_get (vptr, fieldno);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
303 VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
304 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
305 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
306 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
307 VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
314 gfc_class_vtab_size_get (tree cl)
317 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
318 /* Always return size as an array index type. */
319 size = fold_convert (gfc_array_index_type, size);
325 gfc_vptr_size_get (tree vptr)
328 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
329 /* Always return size as an array index type. */
330 size = fold_convert (gfc_array_index_type, size);
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
355 gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
358 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
360 /* Find the last class reference. */
363 for (ref = e->ref; ref; ref = ref->next)
365 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
368 if (ref->type == REF_COMPONENT
369 && ref->u.c.component->ts.type == BT_CLASS)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
380 if (ref->next == NULL)
384 /* Remove and store all subsequent references after the
388 tail = class_ref->next;
389 class_ref->next = NULL;
391 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
398 base_expr = gfc_expr_to_initialize (e);
400 base_expr = gfc_copy_expr (e);
402 /* Restore the original tail expression. */
405 gfc_free_ref_list (class_ref->next);
406 class_ref->next = tail;
408 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
410 gfc_free_ref_list (e->ref);
417 /* Reset the vptr to the declared type, e.g. after deallocation. */
420 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
427 /* Evaluate the expression and obtain the vptr from it. */
428 gfc_init_se (&se, NULL);
430 gfc_conv_expr_descriptor (&se, e);
432 gfc_conv_expr (&se, e);
433 gfc_add_block_to_block (block, &se.pre);
434 vptr = gfc_get_vptr_from_expr (se.expr);
436 /* If a vptr is not found, we can do nothing more. */
437 if (vptr == NULL_TREE)
440 if (UNLIMITED_POLY (e))
441 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
444 /* Return the vptr to the address of the declared type. */
445 vtab = gfc_find_derived_vtab (e->ts.u.derived);
446 vtable = vtab->backend_decl;
447 if (vtable == NULL_TREE)
448 vtable = gfc_get_symbol_decl (vtab);
449 vtable = gfc_build_addr_expr (NULL, vtable);
450 vtable = fold_convert (TREE_TYPE (vptr), vtable);
451 gfc_add_modify (block, vptr, vtable);
456 /* Reset the len for unlimited polymorphic objects. */
459 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
463 e = gfc_find_and_cut_at_last_class_ref (expr);
466 gfc_add_len_component (e);
467 gfc_init_se (&se_len, NULL);
468 gfc_conv_expr (&se_len, e);
469 gfc_add_modify (block, se_len.expr,
470 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
475 /* Obtain the vptr of the last class reference in an expression.
476 Return NULL_TREE if no class reference is found. */
479 gfc_get_vptr_from_expr (tree expr)
484 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
486 type = TREE_TYPE (tmp);
489 if (GFC_CLASS_TYPE_P (type))
490 return gfc_class_vptr_get (tmp);
491 if (type != TYPE_CANONICAL (type))
492 type = TYPE_CANONICAL (type);
496 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
500 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
501 tmp = build_fold_indirect_ref_loc (input_location, tmp);
503 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
504 return gfc_class_vptr_get (tmp);
511 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
514 tree tmp, tmp2, type;
516 gfc_conv_descriptor_data_set (block, lhs_desc,
517 gfc_conv_descriptor_data_get (rhs_desc));
518 gfc_conv_descriptor_offset_set (block, lhs_desc,
519 gfc_conv_descriptor_offset_get (rhs_desc));
521 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
522 gfc_conv_descriptor_dtype (rhs_desc));
524 /* Assign the dimension as range-ref. */
525 tmp = gfc_get_descriptor_dimension (lhs_desc);
526 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
528 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
529 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
530 gfc_index_zero_node, NULL_TREE, NULL_TREE);
531 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
532 gfc_index_zero_node, NULL_TREE, NULL_TREE);
533 gfc_add_modify (block, tmp, tmp2);
537 /* Takes a derived type expression and returns the address of a temporary
538 class object of the 'declared' type. If vptr is not NULL, this is
539 used for the temporary class object.
540 optional_alloc_ptr is false when the dummy is neither allocatable
541 nor a pointer; that's only relevant for the optional handling. */
543 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
544 gfc_typespec class_ts, tree vptr, bool optional,
545 bool optional_alloc_ptr)
548 tree cond_optional = NULL_TREE;
555 /* The derived type needs to be converted to a temporary
557 tmp = gfc_typenode_for_spec (&class_ts);
558 var = gfc_create_var (tmp, "class");
561 ctree = gfc_class_vptr_get (var);
563 if (vptr != NULL_TREE)
565 /* Use the dynamic vptr. */
570 /* In this case the vtab corresponds to the derived type and the
571 vptr must point to it. */
572 vtab = gfc_find_derived_vtab (e->ts.u.derived);
574 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
576 gfc_add_modify (&parmse->pre, ctree,
577 fold_convert (TREE_TYPE (ctree), tmp));
579 /* Now set the data field. */
580 ctree = gfc_class_data_get (var);
583 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
585 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
587 /* If there is a ready made pointer to a derived type, use it
588 rather than evaluating the expression again. */
589 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
590 gfc_add_modify (&parmse->pre, ctree, tmp);
592 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
594 /* For an array reference in an elemental procedure call we need
595 to retain the ss to provide the scalarized array reference. */
596 gfc_conv_expr_reference (parmse, e);
597 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
599 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
601 fold_convert (TREE_TYPE (tmp), null_pointer_node));
602 gfc_add_modify (&parmse->pre, ctree, tmp);
606 ss = gfc_walk_expr (e);
607 if (ss == gfc_ss_terminator)
610 gfc_conv_expr_reference (parmse, e);
612 /* Scalar to an assumed-rank array. */
613 if (class_ts.u.derived->components->as)
616 type = get_scalar_to_descriptor_type (parmse->expr,
618 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
619 gfc_get_dtype (type));
621 parmse->expr = build3_loc (input_location, COND_EXPR,
622 TREE_TYPE (parmse->expr),
623 cond_optional, parmse->expr,
624 fold_convert (TREE_TYPE (parmse->expr),
626 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
630 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
632 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
634 fold_convert (TREE_TYPE (tmp),
636 gfc_add_modify (&parmse->pre, ctree, tmp);
642 gfc_init_block (&block);
646 parmse->use_offset = 1;
647 gfc_conv_expr_descriptor (parmse, e);
649 /* Detect any array references with vector subscripts. */
650 for (ref = e->ref; ref; ref = ref->next)
651 if (ref->type == REF_ARRAY
652 && ref->u.ar.type != AR_ELEMENT
653 && ref->u.ar.type != AR_FULL)
655 for (dim = 0; dim < ref->u.ar.dimen; dim++)
656 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
658 if (dim < ref->u.ar.dimen)
662 /* Array references with vector subscripts and non-variable expressions
663 need be converted to a one-based descriptor. */
664 if (ref || e->expr_type != EXPR_VARIABLE)
666 for (dim = 0; dim < e->rank; ++dim)
667 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
671 if (e->rank != class_ts.u.derived->components->as->rank)
673 gcc_assert (class_ts.u.derived->components->as->type
675 class_array_data_assign (&block, ctree, parmse->expr, false);
679 if (gfc_expr_attr (e).codimension)
680 parmse->expr = fold_build1_loc (input_location,
684 gfc_add_modify (&block, ctree, parmse->expr);
689 tmp = gfc_finish_block (&block);
691 gfc_init_block (&block);
692 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
694 tmp = build3_v (COND_EXPR, cond_optional, tmp,
695 gfc_finish_block (&block));
696 gfc_add_expr_to_block (&parmse->pre, tmp);
699 gfc_add_block_to_block (&parmse->pre, &block);
703 if (class_ts.u.derived->components->ts.type == BT_DERIVED
704 && class_ts.u.derived->components->ts.u.derived
705 ->attr.unlimited_polymorphic)
707 /* Take care about initializing the _len component correctly. */
708 ctree = gfc_class_len_get (var);
709 if (UNLIMITED_POLY (e))
714 len = gfc_copy_expr (e);
715 gfc_add_len_component (len);
716 gfc_init_se (&se, NULL);
717 gfc_conv_expr (&se, len);
719 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
720 cond_optional, se.expr,
721 fold_convert (TREE_TYPE (se.expr),
727 tmp = integer_zero_node;
728 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
731 /* Pass the address of the class object. */
732 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
734 if (optional && optional_alloc_ptr)
735 parmse->expr = build3_loc (input_location, COND_EXPR,
736 TREE_TYPE (parmse->expr),
737 cond_optional, parmse->expr,
738 fold_convert (TREE_TYPE (parmse->expr),
743 /* Create a new class container, which is required as scalar coarrays
744 have an array descriptor while normal scalars haven't. Optionally,
745 NULL pointer checks are added if the argument is OPTIONAL. */
748 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
749 gfc_typespec class_ts, bool optional)
751 tree var, ctree, tmp;
756 gfc_init_block (&block);
759 for (ref = e->ref; ref; ref = ref->next)
761 if (ref->type == REF_COMPONENT
762 && ref->u.c.component->ts.type == BT_CLASS)
766 if (class_ref == NULL
767 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
768 tmp = e->symtree->n.sym->backend_decl;
771 /* Remove everything after the last class reference, convert the
772 expression and then recover its tailend once more. */
774 ref = class_ref->next;
775 class_ref->next = NULL;
776 gfc_init_se (&tmpse, NULL);
777 gfc_conv_expr (&tmpse, e);
778 class_ref->next = ref;
782 var = gfc_typenode_for_spec (&class_ts);
783 var = gfc_create_var (var, "class");
785 ctree = gfc_class_vptr_get (var);
786 gfc_add_modify (&block, ctree,
787 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
789 ctree = gfc_class_data_get (var);
790 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
791 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
793 /* Pass the address of the class object. */
794 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
798 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
801 tmp = gfc_finish_block (&block);
803 gfc_init_block (&block);
804 tmp2 = gfc_class_data_get (var);
805 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
807 tmp2 = gfc_finish_block (&block);
809 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
811 gfc_add_expr_to_block (&parmse->pre, tmp);
814 gfc_add_block_to_block (&parmse->pre, &block);
818 /* Takes an intrinsic type expression and returns the address of a temporary
819 class object of the 'declared' type. */
821 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
822 gfc_typespec class_ts)
830 /* The intrinsic type needs to be converted to a temporary
832 tmp = gfc_typenode_for_spec (&class_ts);
833 var = gfc_create_var (tmp, "class");
836 ctree = gfc_class_vptr_get (var);
838 vtab = gfc_find_vtab (&e->ts);
840 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
841 gfc_add_modify (&parmse->pre, ctree,
842 fold_convert (TREE_TYPE (ctree), tmp));
844 /* Now set the data field. */
845 ctree = gfc_class_data_get (var);
846 if (parmse->ss && parmse->ss->info->useflags)
848 /* For an array reference in an elemental procedure call we need
849 to retain the ss to provide the scalarized array reference. */
850 gfc_conv_expr_reference (parmse, e);
851 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
852 gfc_add_modify (&parmse->pre, ctree, tmp);
856 ss = gfc_walk_expr (e);
857 if (ss == gfc_ss_terminator)
860 gfc_conv_expr_reference (parmse, e);
861 if (class_ts.u.derived->components->as
862 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
864 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
866 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
867 TREE_TYPE (ctree), tmp);
870 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
871 gfc_add_modify (&parmse->pre, ctree, tmp);
876 parmse->use_offset = 1;
877 gfc_conv_expr_descriptor (parmse, e);
878 if (class_ts.u.derived->components->as->rank != e->rank)
880 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
881 TREE_TYPE (ctree), parmse->expr);
882 gfc_add_modify (&parmse->pre, ctree, tmp);
885 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
889 gcc_assert (class_ts.type == BT_CLASS);
890 if (class_ts.u.derived->components->ts.type == BT_DERIVED
891 && class_ts.u.derived->components->ts.u.derived
892 ->attr.unlimited_polymorphic)
894 ctree = gfc_class_len_get (var);
895 /* When the actual arg is a char array, then set the _len component of the
896 unlimited polymorphic entity to the length of the string. */
897 if (e->ts.type == BT_CHARACTER)
899 /* Start with parmse->string_length because this seems to be set to a
900 correct value more often. */
901 if (parmse->string_length)
902 tmp = parmse->string_length;
903 /* When the string_length is not yet set, then try the backend_decl of
905 else if (e->ts.u.cl->backend_decl)
906 tmp = e->ts.u.cl->backend_decl;
907 /* If both of the above approaches fail, then try to generate an
908 expression from the input, which is only feasible currently, when the
909 expression can be evaluated to a constant one. */
912 /* Try to simplify the expression. */
913 gfc_simplify_expr (e, 0);
914 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
916 /* Amazingly all data is present to compute the length of a
917 constant string, but the expression is not yet there. */
918 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
919 gfc_charlen_int_kind,
921 mpz_set_ui (e->ts.u.cl->length->value.integer,
922 e->value.character.length);
923 gfc_conv_const_charlen (e->ts.u.cl);
924 e->ts.u.cl->resolved = 1;
925 tmp = e->ts.u.cl->backend_decl;
929 gfc_error ("Cannot compute the length of the char array "
930 "at %L.", &e->where);
935 tmp = integer_zero_node;
937 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
939 else if (class_ts.type == BT_CLASS
940 && class_ts.u.derived->components
941 && class_ts.u.derived->components->ts.u
942 .derived->attr.unlimited_polymorphic)
944 ctree = gfc_class_len_get (var);
945 gfc_add_modify (&parmse->pre, ctree,
946 fold_convert (TREE_TYPE (ctree),
949 /* Pass the address of the class object. */
950 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
954 /* Takes a scalarized class array expression and returns the
955 address of a temporary scalar class object of the 'declared'
957 OOP-TODO: This could be improved by adding code that branched on
958 the dynamic type being the same as the declared type. In this case
959 the original class expression can be passed directly.
960 optional_alloc_ptr is false when the dummy is neither allocatable
961 nor a pointer; that's relevant for the optional handling.
962 Set copyback to true if class container's _data and _vtab pointers
963 might get modified. */
966 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
967 bool elemental, bool copyback, bool optional,
968 bool optional_alloc_ptr)
974 tree cond = NULL_TREE;
975 tree slen = NULL_TREE;
979 bool full_array = false;
981 gfc_init_block (&block);
984 for (ref = e->ref; ref; ref = ref->next)
986 if (ref->type == REF_COMPONENT
987 && ref->u.c.component->ts.type == BT_CLASS)
990 if (ref->next == NULL)
994 if ((ref == NULL || class_ref == ref)
995 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
996 && (!class_ts.u.derived->components->as
997 || class_ts.u.derived->components->as->rank != -1))
1000 /* Test for FULL_ARRAY. */
1001 if (e->rank == 0 && gfc_expr_attr (e).codimension
1002 && gfc_expr_attr (e).dimension)
1005 gfc_is_class_array_ref (e, &full_array);
1007 /* The derived type needs to be converted to a temporary
1009 tmp = gfc_typenode_for_spec (&class_ts);
1010 var = gfc_create_var (tmp, "class");
1013 ctree = gfc_class_data_get (var);
1014 if (class_ts.u.derived->components->as
1015 && e->rank != class_ts.u.derived->components->as->rank)
1019 tree type = get_scalar_to_descriptor_type (parmse->expr,
1021 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1022 gfc_get_dtype (type));
1024 tmp = gfc_class_data_get (parmse->expr);
1025 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1026 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1028 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1031 class_array_data_assign (&block, ctree, parmse->expr, false);
1035 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1036 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1037 TREE_TYPE (ctree), parmse->expr);
1038 gfc_add_modify (&block, ctree, parmse->expr);
1041 /* Return the data component, except in the case of scalarized array
1042 references, where nullification of the cannot occur and so there
1044 if (!elemental && full_array && copyback)
1046 if (class_ts.u.derived->components->as
1047 && e->rank != class_ts.u.derived->components->as->rank)
1050 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1051 gfc_conv_descriptor_data_get (ctree));
1053 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1056 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1060 ctree = gfc_class_vptr_get (var);
1062 /* The vptr is the second field of the actual argument.
1063 First we have to find the corresponding class reference. */
1066 if (gfc_is_class_array_function (e)
1067 && parmse->class_vptr != NULL_TREE)
1068 tmp = parmse->class_vptr;
1069 else if (class_ref == NULL
1070 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1072 tmp = e->symtree->n.sym->backend_decl;
1074 if (TREE_CODE (tmp) == FUNCTION_DECL)
1075 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1077 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1078 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1080 slen = build_zero_cst (size_type_node);
1084 /* Remove everything after the last class reference, convert the
1085 expression and then recover its tailend once more. */
1087 ref = class_ref->next;
1088 class_ref->next = NULL;
1089 gfc_init_se (&tmpse, NULL);
1090 gfc_conv_expr (&tmpse, e);
1091 class_ref->next = ref;
1093 slen = tmpse.string_length;
1096 gcc_assert (tmp != NULL_TREE);
1098 /* Dereference if needs be. */
1099 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1100 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1102 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1103 vptr = gfc_class_vptr_get (tmp);
1107 gfc_add_modify (&block, ctree,
1108 fold_convert (TREE_TYPE (ctree), vptr));
1110 /* Return the vptr component, except in the case of scalarized array
1111 references, where the dynamic type cannot change. */
1112 if (!elemental && full_array && copyback)
1113 gfc_add_modify (&parmse->post, vptr,
1114 fold_convert (TREE_TYPE (vptr), ctree));
1116 /* For unlimited polymorphic objects also set the _len component. */
1117 if (class_ts.type == BT_CLASS
1118 && class_ts.u.derived->components
1119 && class_ts.u.derived->components->ts.u
1120 .derived->attr.unlimited_polymorphic)
1122 ctree = gfc_class_len_get (var);
1123 if (UNLIMITED_POLY (e))
1124 tmp = gfc_class_len_get (tmp);
1125 else if (e->ts.type == BT_CHARACTER)
1127 gcc_assert (slen != NULL_TREE);
1131 tmp = build_zero_cst (size_type_node);
1132 gfc_add_modify (&parmse->pre, ctree,
1133 fold_convert (TREE_TYPE (ctree), tmp));
1135 /* Return the len component, except in the case of scalarized array
1136 references, where the dynamic type cannot change. */
1137 if (!elemental && full_array && copyback
1138 && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1139 gfc_add_modify (&parmse->post, tmp,
1140 fold_convert (TREE_TYPE (tmp), ctree));
1147 cond = gfc_conv_expr_present (e->symtree->n.sym);
1148 /* parmse->pre may contain some preparatory instructions for the
1149 temporary array descriptor. Those may only be executed when the
1150 optional argument is set, therefore add parmse->pre's instructions
1151 to block, which is later guarded by an if (optional_arg_given). */
1152 gfc_add_block_to_block (&parmse->pre, &block);
1153 block.head = parmse->pre.head;
1154 parmse->pre.head = NULL_TREE;
1155 tmp = gfc_finish_block (&block);
1157 if (optional_alloc_ptr)
1158 tmp2 = build_empty_stmt (input_location);
1161 gfc_init_block (&block);
1163 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1164 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1165 null_pointer_node));
1166 tmp2 = gfc_finish_block (&block);
1169 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1171 gfc_add_expr_to_block (&parmse->pre, tmp);
1174 gfc_add_block_to_block (&parmse->pre, &block);
1176 /* Pass the address of the class object. */
1177 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1179 if (optional && optional_alloc_ptr)
1180 parmse->expr = build3_loc (input_location, COND_EXPR,
1181 TREE_TYPE (parmse->expr),
1183 fold_convert (TREE_TYPE (parmse->expr),
1184 null_pointer_node));
1188 /* Given a class array declaration and an index, returns the address
1189 of the referenced element. */
1192 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1195 tree data, size, tmp, ctmp, offset, ptr;
1197 data = data_comp != NULL_TREE ? data_comp :
1198 gfc_class_data_get (class_decl);
1199 size = gfc_class_vtab_size_get (class_decl);
1203 tmp = fold_convert (gfc_array_index_type,
1204 gfc_class_len_get (class_decl));
1205 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1206 gfc_array_index_type, size, tmp);
1207 tmp = fold_build2_loc (input_location, GT_EXPR,
1208 logical_type_node, tmp,
1209 build_zero_cst (TREE_TYPE (tmp)));
1210 size = fold_build3_loc (input_location, COND_EXPR,
1211 gfc_array_index_type, tmp, ctmp, size);
1214 offset = fold_build2_loc (input_location, MULT_EXPR,
1215 gfc_array_index_type,
1218 data = gfc_conv_descriptor_data_get (data);
1219 ptr = fold_convert (pvoid_type_node, data);
1220 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1221 return fold_convert (TREE_TYPE (data), ptr);
1225 /* Copies one class expression to another, assuming that if either
1226 'to' or 'from' are arrays they are packed. Should 'from' be
1227 NULL_TREE, the initialization expression for 'to' is used, assuming
1228 that the _vptr is set. */
1231 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1241 vec<tree, va_gc> *args;
1246 bool is_from_desc = false, is_to_class = false;
1249 /* To prevent warnings on uninitialized variables. */
1250 from_len = to_len = NULL_TREE;
1252 if (from != NULL_TREE)
1253 fcn = gfc_class_vtab_copy_get (from);
1255 fcn = gfc_class_vtab_copy_get (to);
1257 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1259 if (from != NULL_TREE)
1261 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1265 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1269 /* Check that from is a class. When the class is part of a coarray,
1270 then from is a common pointer and is to be used as is. */
1271 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1272 ? build_fold_indirect_ref (from) : from;
1274 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1275 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1276 ? gfc_class_data_get (from) : from;
1277 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1281 from_data = gfc_class_vtab_def_init_get (to);
1285 if (from != NULL_TREE && unlimited)
1286 from_len = gfc_class_len_or_zero_get (from);
1288 from_len = build_zero_cst (size_type_node);
1291 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1294 to_data = gfc_class_data_get (to);
1296 to_len = gfc_class_len_get (to);
1299 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1302 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1304 stmtblock_t loopbody;
1308 tree orig_nelems = nelems; /* Needed for bounds check. */
1310 gfc_init_block (&body);
1311 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1312 gfc_array_index_type, nelems,
1313 gfc_index_one_node);
1314 nelems = gfc_evaluate_now (tmp, &body);
1315 index = gfc_create_var (gfc_array_index_type, "S");
1319 from_ref = gfc_get_class_array_ref (index, from, from_data,
1321 vec_safe_push (args, from_ref);
1324 vec_safe_push (args, from_data);
1327 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1330 tmp = gfc_conv_array_data (to);
1331 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1332 to_ref = gfc_build_addr_expr (NULL_TREE,
1333 gfc_build_array_ref (tmp, index, to));
1335 vec_safe_push (args, to_ref);
1337 /* Add bounds check. */
1338 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1341 const char *name = "<<unknown>>";
1345 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1347 from_len = gfc_conv_descriptor_size (from_data, 1);
1348 tmp = fold_build2_loc (input_location, NE_EXPR,
1349 logical_type_node, from_len, orig_nelems);
1350 msg = xasprintf ("Array bound mismatch for dimension %d "
1351 "of array '%s' (%%ld/%%ld)",
1354 gfc_trans_runtime_check (true, false, tmp, &body,
1355 &gfc_current_locus, msg,
1356 fold_convert (long_integer_type_node, orig_nelems),
1357 fold_convert (long_integer_type_node, from_len));
1362 tmp = build_call_vec (fcn_type, fcn, args);
1364 /* Build the body of the loop. */
1365 gfc_init_block (&loopbody);
1366 gfc_add_expr_to_block (&loopbody, tmp);
1368 /* Build the loop and return. */
1369 gfc_init_loopinfo (&loop);
1371 loop.from[0] = gfc_index_zero_node;
1372 loop.loopvar[0] = index;
1373 loop.to[0] = nelems;
1374 gfc_trans_scalarizing_loops (&loop, &loopbody);
1375 gfc_init_block (&ifbody);
1376 gfc_add_block_to_block (&ifbody, &loop.pre);
1377 stdcopy = gfc_finish_block (&ifbody);
1378 /* In initialization mode from_len is a constant zero. */
1379 if (unlimited && !integer_zerop (from_len))
1381 vec_safe_push (args, from_len);
1382 vec_safe_push (args, to_len);
1383 tmp = build_call_vec (fcn_type, fcn, args);
1384 /* Build the body of the loop. */
1385 gfc_init_block (&loopbody);
1386 gfc_add_expr_to_block (&loopbody, tmp);
1388 /* Build the loop and return. */
1389 gfc_init_loopinfo (&loop);
1391 loop.from[0] = gfc_index_zero_node;
1392 loop.loopvar[0] = index;
1393 loop.to[0] = nelems;
1394 gfc_trans_scalarizing_loops (&loop, &loopbody);
1395 gfc_init_block (&ifbody);
1396 gfc_add_block_to_block (&ifbody, &loop.pre);
1397 extcopy = gfc_finish_block (&ifbody);
1399 tmp = fold_build2_loc (input_location, GT_EXPR,
1400 logical_type_node, from_len,
1401 build_zero_cst (TREE_TYPE (from_len)));
1402 tmp = fold_build3_loc (input_location, COND_EXPR,
1403 void_type_node, tmp, extcopy, stdcopy);
1404 gfc_add_expr_to_block (&body, tmp);
1405 tmp = gfc_finish_block (&body);
1409 gfc_add_expr_to_block (&body, stdcopy);
1410 tmp = gfc_finish_block (&body);
1412 gfc_cleanup_loop (&loop);
1416 gcc_assert (!is_from_desc);
1417 vec_safe_push (args, from_data);
1418 vec_safe_push (args, to_data);
1419 stdcopy = build_call_vec (fcn_type, fcn, args);
1421 /* In initialization mode from_len is a constant zero. */
1422 if (unlimited && !integer_zerop (from_len))
1424 vec_safe_push (args, from_len);
1425 vec_safe_push (args, to_len);
1426 extcopy = build_call_vec (fcn_type, fcn, args);
1427 tmp = fold_build2_loc (input_location, GT_EXPR,
1428 logical_type_node, from_len,
1429 build_zero_cst (TREE_TYPE (from_len)));
1430 tmp = fold_build3_loc (input_location, COND_EXPR,
1431 void_type_node, tmp, extcopy, stdcopy);
1437 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1438 if (from == NULL_TREE)
1441 cond = fold_build2_loc (input_location, NE_EXPR,
1443 from_data, null_pointer_node);
1444 tmp = fold_build3_loc (input_location, COND_EXPR,
1445 void_type_node, cond,
1446 tmp, build_empty_stmt (input_location));
1454 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1456 gfc_actual_arglist *actual;
1461 actual = gfc_get_actual_arglist ();
1462 actual->expr = gfc_copy_expr (rhs);
1463 actual->next = gfc_get_actual_arglist ();
1464 actual->next->expr = gfc_copy_expr (lhs);
1465 ppc = gfc_copy_expr (obj);
1466 gfc_add_vptr_component (ppc);
1467 gfc_add_component_ref (ppc, "_copy");
1468 ppc_code = gfc_get_code (EXEC_CALL);
1469 ppc_code->resolved_sym = ppc->symtree->n.sym;
1470 /* Although '_copy' is set to be elemental in class.c, it is
1471 not staying that way. Find out why, sometime.... */
1472 ppc_code->resolved_sym->attr.elemental = 1;
1473 ppc_code->ext.actual = actual;
1474 ppc_code->expr1 = ppc;
1475 /* Since '_copy' is elemental, the scalarizer will take care
1476 of arrays in gfc_trans_call. */
1477 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1478 gfc_free_statements (ppc_code);
1480 if (UNLIMITED_POLY(obj))
1482 /* Check if rhs is non-NULL. */
1484 gfc_init_se (&src, NULL);
1485 gfc_conv_expr (&src, rhs);
1486 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1487 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1488 src.expr, fold_convert (TREE_TYPE (src.expr),
1489 null_pointer_node));
1490 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1491 build_empty_stmt (input_location));
1497 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1498 A MEMCPY is needed to copy the full data from the default initializer
1499 of the dynamic type. */
1502 gfc_trans_class_init_assign (gfc_code *code)
1506 gfc_se dst,src,memsz;
1507 gfc_expr *lhs, *rhs, *sz;
1509 gfc_start_block (&block);
1511 lhs = gfc_copy_expr (code->expr1);
1513 rhs = gfc_copy_expr (code->expr1);
1514 gfc_add_vptr_component (rhs);
1516 /* Make sure that the component backend_decls have been built, which
1517 will not have happened if the derived types concerned have not
1519 gfc_get_derived_type (rhs->ts.u.derived);
1520 gfc_add_def_init_component (rhs);
1521 /* The _def_init is always scalar. */
1524 if (code->expr1->ts.type == BT_CLASS
1525 && CLASS_DATA (code->expr1)->attr.dimension)
1527 gfc_array_spec *tmparr = gfc_get_array_spec ();
1528 *tmparr = *CLASS_DATA (code->expr1)->as;
1529 /* Adding the array ref to the class expression results in correct
1530 indexing to the dynamic type. */
1531 gfc_add_full_array_ref (lhs, tmparr);
1532 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1536 /* Scalar initialization needs the _data component. */
1537 gfc_add_data_component (lhs);
1538 sz = gfc_copy_expr (code->expr1);
1539 gfc_add_vptr_component (sz);
1540 gfc_add_size_component (sz);
1542 gfc_init_se (&dst, NULL);
1543 gfc_init_se (&src, NULL);
1544 gfc_init_se (&memsz, NULL);
1545 gfc_conv_expr (&dst, lhs);
1546 gfc_conv_expr (&src, rhs);
1547 gfc_conv_expr (&memsz, sz);
1548 gfc_add_block_to_block (&block, &src.pre);
1549 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1551 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1553 if (UNLIMITED_POLY(code->expr1))
1555 /* Check if _def_init is non-NULL. */
1556 tree cond = fold_build2_loc (input_location, NE_EXPR,
1557 logical_type_node, src.expr,
1558 fold_convert (TREE_TYPE (src.expr),
1559 null_pointer_node));
1560 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1561 tmp, build_empty_stmt (input_location));
1565 if (code->expr1->symtree->n.sym->attr.optional
1566 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1568 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1569 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1571 build_empty_stmt (input_location));
1574 gfc_add_expr_to_block (&block, tmp);
1576 return gfc_finish_block (&block);
1580 /* End of prototype trans-class.c */
1584 realloc_lhs_warning (bt type, bool array, locus *where)
1586 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1587 gfc_warning (OPT_Wrealloc_lhs,
1588 "Code for reallocating the allocatable array at %L will "
1590 else if (warn_realloc_lhs_all)
1591 gfc_warning (OPT_Wrealloc_lhs_all,
1592 "Code for reallocating the allocatable variable at %L "
1593 "will be added", where);
1597 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1600 /* Copy the scalarization loop variables. */
1603 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1606 dest->loop = src->loop;
1610 /* Initialize a simple expression holder.
1612 Care must be taken when multiple se are created with the same parent.
1613 The child se must be kept in sync. The easiest way is to delay creation
1614 of a child se until after after the previous se has been translated. */
1617 gfc_init_se (gfc_se * se, gfc_se * parent)
1619 memset (se, 0, sizeof (gfc_se));
1620 gfc_init_block (&se->pre);
1621 gfc_init_block (&se->post);
1623 se->parent = parent;
1626 gfc_copy_se_loopvars (se, parent);
1630 /* Advances to the next SS in the chain. Use this rather than setting
1631 se->ss = se->ss->next because all the parents needs to be kept in sync.
1635 gfc_advance_se_ss_chain (gfc_se * se)
1640 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1643 /* Walk down the parent chain. */
1646 /* Simple consistency check. */
1647 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1648 || p->parent->ss->nested_ss == p->ss);
1650 /* If we were in a nested loop, the next scalarized expression can be
1651 on the parent ss' next pointer. Thus we should not take the next
1652 pointer blindly, but rather go up one nest level as long as next
1653 is the end of chain. */
1655 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1665 /* Ensures the result of the expression as either a temporary variable
1666 or a constant so that it can be used repeatedly. */
1669 gfc_make_safe_expr (gfc_se * se)
1673 if (CONSTANT_CLASS_P (se->expr))
1676 /* We need a temporary for this result. */
1677 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1678 gfc_add_modify (&se->pre, var, se->expr);
1683 /* Return an expression which determines if a dummy parameter is present.
1684 Also used for arguments to procedures with multiple entry points. */
1687 gfc_conv_expr_present (gfc_symbol * sym)
1691 gcc_assert (sym->attr.dummy);
1692 decl = gfc_get_symbol_decl (sym);
1694 /* Intrinsic scalars with VALUE attribute which are passed by value
1695 use a hidden argument to denote the present status. */
1696 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1697 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1698 && !sym->attr.dimension)
1700 char name[GFC_MAX_SYMBOL_LEN + 2];
1703 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1705 strcpy (&name[1], sym->name);
1706 tree_name = get_identifier (name);
1708 /* Walk function argument list to find hidden arg. */
1709 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1710 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1711 if (DECL_NAME (cond) == tree_name)
1718 if (TREE_CODE (decl) != PARM_DECL)
1720 /* Array parameters use a temporary descriptor, we want the real
1722 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1723 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1724 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1727 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1728 fold_convert (TREE_TYPE (decl), null_pointer_node));
1730 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1731 as actual argument to denote absent dummies. For array descriptors,
1732 we thus also need to check the array descriptor. For BT_CLASS, it
1733 can also occur for scalars and F2003 due to type->class wrapping and
1734 class->class wrapping. Note further that BT_CLASS always uses an
1735 array descriptor for arrays, also for explicit-shape/assumed-size. */
1737 if (!sym->attr.allocatable
1738 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1739 || (sym->ts.type == BT_CLASS
1740 && !CLASS_DATA (sym)->attr.allocatable
1741 && !CLASS_DATA (sym)->attr.class_pointer))
1742 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1743 || sym->ts.type == BT_CLASS))
1747 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1748 || sym->as->type == AS_ASSUMED_RANK
1749 || sym->attr.codimension))
1750 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1752 tmp = build_fold_indirect_ref_loc (input_location, decl);
1753 if (sym->ts.type == BT_CLASS)
1754 tmp = gfc_class_data_get (tmp);
1755 tmp = gfc_conv_array_data (tmp);
1757 else if (sym->ts.type == BT_CLASS)
1758 tmp = gfc_class_data_get (decl);
1762 if (tmp != NULL_TREE)
1764 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1765 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1766 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1767 logical_type_node, cond, tmp);
1775 /* Converts a missing, dummy argument into a null or zero. */
1778 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1783 present = gfc_conv_expr_present (arg->symtree->n.sym);
1787 /* Create a temporary and convert it to the correct type. */
1788 tmp = gfc_get_int_type (kind);
1789 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1792 /* Test for a NULL value. */
1793 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1794 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1795 tmp = gfc_evaluate_now (tmp, &se->pre);
1796 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1800 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1802 build_zero_cst (TREE_TYPE (se->expr)));
1803 tmp = gfc_evaluate_now (tmp, &se->pre);
1807 if (ts.type == BT_CHARACTER)
1809 tmp = build_int_cst (gfc_charlen_type_node, 0);
1810 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1811 present, se->string_length, tmp);
1812 tmp = gfc_evaluate_now (tmp, &se->pre);
1813 se->string_length = tmp;
1819 /* Get the character length of an expression, looking through gfc_refs
1823 gfc_get_expr_charlen (gfc_expr *e)
1829 gcc_assert (e->expr_type == EXPR_VARIABLE
1830 && e->ts.type == BT_CHARACTER);
1832 length = NULL; /* To silence compiler warning. */
1834 if (is_subref_array (e) && e->ts.u.cl->length)
1837 gfc_init_se (&tmpse, NULL);
1838 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1839 e->ts.u.cl->backend_decl = tmpse.expr;
1843 /* First candidate: if the variable is of type CHARACTER, the
1844 expression's length could be the length of the character
1846 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1847 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1849 /* Look through the reference chain for component references. */
1850 for (r = e->ref; r; r = r->next)
1855 if (r->u.c.component->ts.type == BT_CHARACTER)
1856 length = r->u.c.component->ts.u.cl->backend_decl;
1864 gfc_init_se (&se, NULL);
1865 gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
1867 gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
1868 length = fold_build2_loc (input_location, MINUS_EXPR,
1869 gfc_charlen_type_node,
1871 length = fold_build2_loc (input_location, PLUS_EXPR,
1872 gfc_charlen_type_node, length,
1873 gfc_index_one_node);
1882 gcc_assert (length != NULL);
1887 /* Return for an expression the backend decl of the coarray. */
1890 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1896 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1898 /* Not-implemented diagnostic. */
1899 if (expr->symtree->n.sym->ts.type == BT_CLASS
1900 && UNLIMITED_POLY (expr->symtree->n.sym)
1901 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1902 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1903 "%L is not supported", &expr->where);
1905 for (ref = expr->ref; ref; ref = ref->next)
1906 if (ref->type == REF_COMPONENT)
1908 if (ref->u.c.component->ts.type == BT_CLASS
1909 && UNLIMITED_POLY (ref->u.c.component)
1910 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1911 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1912 "component at %L is not supported", &expr->where);
1915 /* Make sure the backend_decl is present before accessing it. */
1916 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1917 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1918 : expr->symtree->n.sym->backend_decl;
1920 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1922 if (expr->ref && expr->ref->type == REF_ARRAY)
1924 caf_decl = gfc_class_data_get (caf_decl);
1925 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1928 for (ref = expr->ref; ref; ref = ref->next)
1930 if (ref->type == REF_COMPONENT
1931 && strcmp (ref->u.c.component->name, "_data") != 0)
1933 caf_decl = gfc_class_data_get (caf_decl);
1934 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1938 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1942 if (expr->symtree->n.sym->attr.codimension)
1945 /* The following code assumes that the coarray is a component reachable via
1946 only scalar components/variables; the Fortran standard guarantees this. */
1948 for (ref = expr->ref; ref; ref = ref->next)
1949 if (ref->type == REF_COMPONENT)
1951 gfc_component *comp = ref->u.c.component;
1953 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1954 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1955 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1956 TREE_TYPE (comp->backend_decl), caf_decl,
1957 comp->backend_decl, NULL_TREE);
1958 if (comp->ts.type == BT_CLASS)
1960 caf_decl = gfc_class_data_get (caf_decl);
1961 if (CLASS_DATA (comp)->attr.codimension)
1967 if (comp->attr.codimension)
1973 gcc_assert (found && caf_decl);
1978 /* Obtain the Coarray token - and optionally also the offset. */
1981 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1982 tree se_expr, gfc_expr *expr)
1986 /* Coarray token. */
1987 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1989 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1990 == GFC_ARRAY_ALLOCATABLE
1991 || expr->symtree->n.sym->attr.select_type_temporary);
1992 *token = gfc_conv_descriptor_token (caf_decl);
1994 else if (DECL_LANG_SPECIFIC (caf_decl)
1995 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1996 *token = GFC_DECL_TOKEN (caf_decl);
1999 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2000 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2001 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2007 /* Offset between the coarray base address and the address wanted. */
2008 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2009 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2010 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2011 *offset = build_int_cst (gfc_array_index_type, 0);
2012 else if (DECL_LANG_SPECIFIC (caf_decl)
2013 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2014 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2015 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2016 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2018 *offset = build_int_cst (gfc_array_index_type, 0);
2020 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2021 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2023 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2024 tmp = gfc_conv_descriptor_data_get (tmp);
2026 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2027 tmp = gfc_conv_descriptor_data_get (se_expr);
2030 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2034 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2035 *offset, fold_convert (gfc_array_index_type, tmp));
2037 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2038 && expr->symtree->n.sym->attr.codimension
2039 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2041 gfc_expr *base_expr = gfc_copy_expr (expr);
2042 gfc_ref *ref = base_expr->ref;
2045 // Iterate through the refs until the last one.
2049 if (ref->type == REF_ARRAY
2050 && ref->u.ar.type != AR_FULL)
2052 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2054 for (i = 0; i < ranksum; ++i)
2056 ref->u.ar.start[i] = NULL;
2057 ref->u.ar.end[i] = NULL;
2059 ref->u.ar.type = AR_FULL;
2061 gfc_init_se (&base_se, NULL);
2062 if (gfc_caf_attr (base_expr).dimension)
2064 gfc_conv_expr_descriptor (&base_se, base_expr);
2065 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2069 gfc_conv_expr (&base_se, base_expr);
2073 gfc_free_expr (base_expr);
2074 gfc_add_block_to_block (&se->pre, &base_se.pre);
2075 gfc_add_block_to_block (&se->post, &base_se.post);
2077 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2078 tmp = gfc_conv_descriptor_data_get (caf_decl);
2081 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2085 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2086 fold_convert (gfc_array_index_type, *offset),
2087 fold_convert (gfc_array_index_type, tmp));
2091 /* Convert the coindex of a coarray into an image index; the result is
2092 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2093 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2096 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2099 tree lbound, ubound, extent, tmp, img_idx;
2103 for (ref = e->ref; ref; ref = ref->next)
2104 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2106 gcc_assert (ref != NULL);
2108 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2110 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2114 img_idx = build_zero_cst (gfc_array_index_type);
2115 extent = build_one_cst (gfc_array_index_type);
2116 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2117 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2119 gfc_init_se (&se, NULL);
2120 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2121 gfc_add_block_to_block (block, &se.pre);
2122 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2123 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2124 TREE_TYPE (lbound), se.expr, lbound);
2125 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2127 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2128 TREE_TYPE (tmp), img_idx, tmp);
2129 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2131 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2132 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2133 extent = fold_build2_loc (input_location, MULT_EXPR,
2134 TREE_TYPE (tmp), extent, tmp);
2138 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2140 gfc_init_se (&se, NULL);
2141 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2142 gfc_add_block_to_block (block, &se.pre);
2143 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2144 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2145 TREE_TYPE (lbound), se.expr, lbound);
2146 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2148 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2150 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2152 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2153 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2154 TREE_TYPE (ubound), ubound, lbound);
2155 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2156 tmp, build_one_cst (TREE_TYPE (tmp)));
2157 extent = fold_build2_loc (input_location, MULT_EXPR,
2158 TREE_TYPE (tmp), extent, tmp);
2161 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2162 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2163 return fold_convert (integer_type_node, img_idx);
2167 /* For each character array constructor subexpression without a ts.u.cl->length,
2168 replace it by its first element (if there aren't any elements, the length
2169 should already be set to zero). */
2172 flatten_array_ctors_without_strlen (gfc_expr* e)
2174 gfc_actual_arglist* arg;
2180 switch (e->expr_type)
2184 flatten_array_ctors_without_strlen (e->value.op.op1);
2185 flatten_array_ctors_without_strlen (e->value.op.op2);
2189 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2193 for (arg = e->value.function.actual; arg; arg = arg->next)
2194 flatten_array_ctors_without_strlen (arg->expr);
2199 /* We've found what we're looking for. */
2200 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2205 gcc_assert (e->value.constructor);
2207 c = gfc_constructor_first (e->value.constructor);
2211 flatten_array_ctors_without_strlen (new_expr);
2212 gfc_replace_expr (e, new_expr);
2216 /* Otherwise, fall through to handle constructor elements. */
2218 case EXPR_STRUCTURE:
2219 for (c = gfc_constructor_first (e->value.constructor);
2220 c; c = gfc_constructor_next (c))
2221 flatten_array_ctors_without_strlen (c->expr);
2231 /* Generate code to initialize a string length variable. Returns the
2232 value. For array constructors, cl->length might be NULL and in this case,
2233 the first element of the constructor is needed. expr is the original
2234 expression so we can access it but can be NULL if this is not needed. */
2237 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2241 gfc_init_se (&se, NULL);
2243 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2246 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2247 "flatten" array constructors by taking their first element; all elements
2248 should be the same length or a cl->length should be present. */
2251 gfc_expr* expr_flat;
2254 expr_flat = gfc_copy_expr (expr);
2255 flatten_array_ctors_without_strlen (expr_flat);
2256 gfc_resolve_expr (expr_flat);
2258 gfc_conv_expr (&se, expr_flat);
2259 gfc_add_block_to_block (pblock, &se.pre);
2260 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2262 gfc_free_expr (expr_flat);
2266 /* Convert cl->length. */
2268 gcc_assert (cl->length);
2270 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2271 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2272 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2273 gfc_add_block_to_block (pblock, &se.pre);
2275 if (cl->backend_decl)
2276 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2278 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2283 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2284 const char *name, locus *where)
2294 type = gfc_get_character_type (kind, ref->u.ss.length);
2295 type = build_pointer_type (type);
2297 gfc_init_se (&start, se);
2298 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2299 gfc_add_block_to_block (&se->pre, &start.pre);
2301 if (integer_onep (start.expr))
2302 gfc_conv_string_parameter (se);
2307 /* Avoid multiple evaluation of substring start. */
2308 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2309 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2311 /* Change the start of the string. */
2312 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2315 tmp = build_fold_indirect_ref_loc (input_location,
2317 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2318 se->expr = gfc_build_addr_expr (type, tmp);
2321 /* Length = end + 1 - start. */
2322 gfc_init_se (&end, se);
2323 if (ref->u.ss.end == NULL)
2324 end.expr = se->string_length;
2327 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2328 gfc_add_block_to_block (&se->pre, &end.pre);
2332 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2333 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2335 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2337 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2338 logical_type_node, start.expr,
2341 /* Check lower bound. */
2342 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2344 build_one_cst (TREE_TYPE (start.expr)));
2345 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2346 logical_type_node, nonempty, fault);
2348 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2349 "is less than one", name);
2351 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2352 "is less than one");
2353 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2354 fold_convert (long_integer_type_node,
2358 /* Check upper bound. */
2359 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2360 end.expr, se->string_length);
2361 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2362 logical_type_node, nonempty, fault);
2364 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2365 "exceeds string length (%%ld)", name);
2367 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2368 "exceeds string length (%%ld)");
2369 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2370 fold_convert (long_integer_type_node, end.expr),
2371 fold_convert (long_integer_type_node,
2372 se->string_length));
2376 /* Try to calculate the length from the start and end expressions. */
2378 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2380 HOST_WIDE_INT i_len;
2382 i_len = gfc_mpz_get_hwi (length) + 1;
2386 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2387 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2391 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2392 fold_convert (gfc_charlen_type_node, end.expr),
2393 fold_convert (gfc_charlen_type_node, start.expr));
2394 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2395 build_int_cst (gfc_charlen_type_node, 1), tmp);
2396 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2397 tmp, build_int_cst (gfc_charlen_type_node, 0));
2400 se->string_length = tmp;
2404 /* Convert a derived type component reference. */
2407 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2415 c = ref->u.c.component;
2417 if (c->backend_decl == NULL_TREE
2418 && ref->u.c.sym != NULL)
2419 gfc_get_derived_type (ref->u.c.sym);
2421 field = c->backend_decl;
2422 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2424 context = DECL_FIELD_CONTEXT (field);
2426 /* Components can correspond to fields of different containing
2427 types, as components are created without context, whereas
2428 a concrete use of a component has the type of decl as context.
2429 So, if the type doesn't match, we search the corresponding
2430 FIELD_DECL in the parent type. To not waste too much time
2431 we cache this result in norestrict_decl.
2432 On the other hand, if the context is a UNION or a MAP (a
2433 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2435 if (context != TREE_TYPE (decl)
2436 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2437 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2439 tree f2 = c->norestrict_decl;
2440 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2441 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2442 if (TREE_CODE (f2) == FIELD_DECL
2443 && DECL_NAME (f2) == DECL_NAME (field))
2446 c->norestrict_decl = f2;
2450 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2451 && strcmp ("_data", c->name) == 0)
2453 /* Found a ref to the _data component. Store the associated ref to
2454 the vptr in se->class_vptr. */
2455 se->class_vptr = gfc_class_vptr_get (decl);
2458 se->class_vptr = NULL_TREE;
2460 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2461 decl, field, NULL_TREE);
2465 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2466 strlen () conditional below. */
2467 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2468 && !(c->attr.allocatable && c->ts.deferred)
2469 && !c->attr.pdt_string)
2471 tmp = c->ts.u.cl->backend_decl;
2472 /* Components must always be constant length. */
2473 gcc_assert (tmp && INTEGER_CST_P (tmp));
2474 se->string_length = tmp;
2477 if (gfc_deferred_strlen (c, &field))
2479 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2481 decl, field, NULL_TREE);
2482 se->string_length = tmp;
2485 if (((c->attr.pointer || c->attr.allocatable)
2486 && (!c->attr.dimension && !c->attr.codimension)
2487 && c->ts.type != BT_CHARACTER)
2488 || c->attr.proc_pointer)
2489 se->expr = build_fold_indirect_ref_loc (input_location,
2494 /* This function deals with component references to components of the
2495 parent type for derived type extensions. */
2497 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2505 c = ref->u.c.component;
2507 /* Return if the component is in the parent type. */
2508 for (cmp = dt->components; cmp; cmp = cmp->next)
2509 if (strcmp (c->name, cmp->name) == 0)
2512 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2513 parent.type = REF_COMPONENT;
2515 parent.u.c.sym = dt;
2516 parent.u.c.component = dt->components;
2518 if (dt->backend_decl == NULL)
2519 gfc_get_derived_type (dt);
2521 /* Build the reference and call self. */
2522 gfc_conv_component_ref (se, &parent);
2523 parent.u.c.sym = dt->components->ts.u.derived;
2524 parent.u.c.component = c;
2525 conv_parent_component_references (se, &parent);
2530 conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2532 tree res = se->expr;
2537 res = fold_build1_loc (input_location, REALPART_EXPR,
2538 TREE_TYPE (TREE_TYPE (res)), res);
2542 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2543 TREE_TYPE (TREE_TYPE (res)), res);
2547 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2552 res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2562 /* Return the contents of a variable. Also handles reference/pointer
2563 variables (all Fortran pointer references are implicit). */
2566 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2571 tree parent_decl = NULL_TREE;
2574 bool alternate_entry;
2577 bool first_time = true;
2579 sym = expr->symtree->n.sym;
2580 is_classarray = IS_CLASS_ARRAY (sym);
2584 gfc_ss_info *ss_info = ss->info;
2586 /* Check that something hasn't gone horribly wrong. */
2587 gcc_assert (ss != gfc_ss_terminator);
2588 gcc_assert (ss_info->expr == expr);
2590 /* A scalarized term. We already know the descriptor. */
2591 se->expr = ss_info->data.array.descriptor;
2592 se->string_length = ss_info->string_length;
2593 ref = ss_info->data.array.ref;
2595 gcc_assert (ref->type == REF_ARRAY
2596 && ref->u.ar.type != AR_ELEMENT);
2598 gfc_conv_tmp_array_ref (se);
2602 tree se_expr = NULL_TREE;
2604 se->expr = gfc_get_symbol_decl (sym);
2606 /* Deal with references to a parent results or entries by storing
2607 the current_function_decl and moving to the parent_decl. */
2608 return_value = sym->attr.function && sym->result == sym;
2609 alternate_entry = sym->attr.function && sym->attr.entry
2610 && sym->result == sym;
2611 entry_master = sym->attr.result
2612 && sym->ns->proc_name->attr.entry_master
2613 && !gfc_return_by_reference (sym->ns->proc_name);
2614 if (current_function_decl)
2615 parent_decl = DECL_CONTEXT (current_function_decl);
2617 if ((se->expr == parent_decl && return_value)
2618 || (sym->ns && sym->ns->proc_name
2620 && sym->ns->proc_name->backend_decl == parent_decl
2621 && (alternate_entry || entry_master)))
2626 /* Special case for assigning the return value of a function.
2627 Self recursive functions must have an explicit return value. */
2628 if (return_value && (se->expr == current_function_decl || parent_flag))
2629 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2631 /* Similarly for alternate entry points. */
2632 else if (alternate_entry
2633 && (sym->ns->proc_name->backend_decl == current_function_decl
2636 gfc_entry_list *el = NULL;
2638 for (el = sym->ns->entries; el; el = el->next)
2641 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2646 else if (entry_master
2647 && (sym->ns->proc_name->backend_decl == current_function_decl
2649 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2654 /* Procedure actual arguments. Look out for temporary variables
2655 with the same attributes as function values. */
2656 else if (!sym->attr.temporary
2657 && sym->attr.flavor == FL_PROCEDURE
2658 && se->expr != current_function_decl)
2660 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2662 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2663 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2669 /* Dereference the expression, where needed. Since characters
2670 are entirely different from other types, they are treated
2672 if (sym->ts.type == BT_CHARACTER)
2674 /* Dereference character pointer dummy arguments
2676 if ((sym->attr.pointer || sym->attr.allocatable)
2678 || sym->attr.function
2679 || sym->attr.result))
2680 se->expr = build_fold_indirect_ref_loc (input_location,
2684 else if (!sym->attr.value)
2686 /* Dereference temporaries for class array dummy arguments. */
2687 if (sym->attr.dummy && is_classarray
2688 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2690 if (!se->descriptor_only)
2691 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2693 se->expr = build_fold_indirect_ref_loc (input_location,
2697 /* Dereference non-character scalar dummy arguments. */
2698 if (sym->attr.dummy && !sym->attr.dimension
2699 && !(sym->attr.codimension && sym->attr.allocatable)
2700 && (sym->ts.type != BT_CLASS
2701 || (!CLASS_DATA (sym)->attr.dimension
2702 && !(CLASS_DATA (sym)->attr.codimension
2703 && CLASS_DATA (sym)->attr.allocatable))))
2704 se->expr = build_fold_indirect_ref_loc (input_location,
2707 /* Dereference scalar hidden result. */
2708 if (flag_f2c && sym->ts.type == BT_COMPLEX
2709 && (sym->attr.function || sym->attr.result)
2710 && !sym->attr.dimension && !sym->attr.pointer
2711 && !sym->attr.always_explicit)
2712 se->expr = build_fold_indirect_ref_loc (input_location,
2715 /* Dereference non-character, non-class pointer variables.
2716 These must be dummies, results, or scalars. */
2718 && (sym->attr.pointer || sym->attr.allocatable
2719 || gfc_is_associate_pointer (sym)
2720 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2722 || sym->attr.function
2724 || (!sym->attr.dimension
2725 && (!sym->attr.codimension || !sym->attr.allocatable))))
2726 se->expr = build_fold_indirect_ref_loc (input_location,
2728 /* Now treat the class array pointer variables accordingly. */
2729 else if (sym->ts.type == BT_CLASS
2731 && (CLASS_DATA (sym)->attr.dimension
2732 || CLASS_DATA (sym)->attr.codimension)
2733 && ((CLASS_DATA (sym)->as
2734 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2735 || CLASS_DATA (sym)->attr.allocatable
2736 || CLASS_DATA (sym)->attr.class_pointer))
2737 se->expr = build_fold_indirect_ref_loc (input_location,
2739 /* And the case where a non-dummy, non-result, non-function,
2740 non-allotable and non-pointer classarray is present. This case was
2741 previously covered by the first if, but with introducing the
2742 condition !is_classarray there, that case has to be covered
2744 else if (sym->ts.type == BT_CLASS
2746 && !sym->attr.function
2747 && !sym->attr.result
2748 && (CLASS_DATA (sym)->attr.dimension
2749 || CLASS_DATA (sym)->attr.codimension)
2751 || !CLASS_DATA (sym)->attr.allocatable)
2752 && !CLASS_DATA (sym)->attr.class_pointer)
2753 se->expr = build_fold_indirect_ref_loc (input_location,
2760 /* For character variables, also get the length. */
2761 if (sym->ts.type == BT_CHARACTER)
2763 /* If the character length of an entry isn't set, get the length from
2764 the master function instead. */
2765 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2766 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2768 se->string_length = sym->ts.u.cl->backend_decl;
2769 gcc_assert (se->string_length);
2772 gfc_typespec *ts = &sym->ts;
2778 /* Return the descriptor if that's what we want and this is an array
2779 section reference. */
2780 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2782 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2783 /* Return the descriptor for array pointers and allocations. */
2784 if (se->want_pointer
2785 && ref->next == NULL && (se->descriptor_only))
2788 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2789 /* Return a pointer to an element. */
2793 ts = &ref->u.c.component->ts;
2794 if (first_time && is_classarray && sym->attr.dummy
2795 && se->descriptor_only
2796 && !CLASS_DATA (sym)->attr.allocatable
2797 && !CLASS_DATA (sym)->attr.class_pointer
2798 && CLASS_DATA (sym)->as
2799 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2800 && strcmp ("_data", ref->u.c.component->name) == 0)
2801 /* Skip the first ref of a _data component, because for class
2802 arrays that one is already done by introducing a temporary
2803 array descriptor. */
2806 if (ref->u.c.sym->attr.extension)
2807 conv_parent_component_references (se, ref);
2809 gfc_conv_component_ref (se, ref);
2810 if (!ref->next && ref->u.c.sym->attr.codimension
2811 && se->want_pointer && se->descriptor_only)
2817 gfc_conv_substring (se, ref, expr->ts.kind,
2818 expr->symtree->name, &expr->where);
2822 conv_inquiry (se, ref, expr, ts);
2832 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2834 if (se->want_pointer)
2836 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2837 gfc_conv_string_parameter (se);
2839 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2844 /* Unary ops are easy... Or they would be if ! was a valid op. */
2847 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2852 gcc_assert (expr->ts.type != BT_CHARACTER);
2853 /* Initialize the operand. */
2854 gfc_init_se (&operand, se);
2855 gfc_conv_expr_val (&operand, expr->value.op.op1);
2856 gfc_add_block_to_block (&se->pre, &operand.pre);
2858 type = gfc_typenode_for_spec (&expr->ts);
2860 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2861 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2862 All other unary operators have an equivalent GIMPLE unary operator. */
2863 if (code == TRUTH_NOT_EXPR)
2864 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2865 build_int_cst (type, 0));
2867 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2871 /* Expand power operator to optimal multiplications when a value is raised
2872 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2873 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2874 Programming", 3rd Edition, 1998. */
2876 /* This code is mostly duplicated from expand_powi in the backend.
2877 We establish the "optimal power tree" lookup table with the defined size.
2878 The items in the table are the exponents used to calculate the index
2879 exponents. Any integer n less than the value can get an "addition chain",
2880 with the first node being one. */
2881 #define POWI_TABLE_SIZE 256
2883 /* The table is from builtins.c. */
2884 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2886 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2887 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2888 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2889 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2890 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2891 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2892 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2893 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2894 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2895 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2896 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2897 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2898 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2899 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2900 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2901 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2902 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2903 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2904 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2905 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2906 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2907 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2908 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2909 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2910 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2911 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2912 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2913 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2914 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2915 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2916 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2917 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2920 /* If n is larger than lookup table's max index, we use the "window
2922 #define POWI_WINDOW_SIZE 3
2924 /* Recursive function to expand the power operator. The temporary
2925 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2927 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2934 if (n < POWI_TABLE_SIZE)
2939 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2940 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2944 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2945 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2946 op1 = gfc_conv_powi (se, digit, tmpvar);
2950 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2954 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2955 tmp = gfc_evaluate_now (tmp, &se->pre);
2957 if (n < POWI_TABLE_SIZE)
2964 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2965 return 1. Else return 0 and a call to runtime library functions
2966 will have to be built. */
2968 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2973 tree vartmp[POWI_TABLE_SIZE];
2975 unsigned HOST_WIDE_INT n;
2977 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2979 /* If exponent is too large, we won't expand it anyway, so don't bother
2980 with large integer values. */
2981 if (!wi::fits_shwi_p (wrhs))
2984 m = wrhs.to_shwi ();
2985 /* Use the wide_int's routine to reliably get the absolute value on all
2986 platforms. Then convert it to a HOST_WIDE_INT like above. */
2987 n = wi::abs (wrhs).to_shwi ();
2989 type = TREE_TYPE (lhs);
2990 sgn = tree_int_cst_sgn (rhs);
2992 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2993 || optimize_size) && (m > 2 || m < -1))
2999 se->expr = gfc_build_const (type, integer_one_node);
3003 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3004 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3006 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3007 lhs, build_int_cst (TREE_TYPE (lhs), -1));
3008 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3009 lhs, build_int_cst (TREE_TYPE (lhs), 1));
3012 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3015 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3016 logical_type_node, tmp, cond);
3017 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3018 tmp, build_int_cst (type, 1),
3019 build_int_cst (type, 0));
3023 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3024 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3025 build_int_cst (type, -1),
3026 build_int_cst (type, 0));
3027 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3028 cond, build_int_cst (type, 1), tmp);
3032 memset (vartmp, 0, sizeof (vartmp));
3036 tmp = gfc_build_const (type, integer_one_node);
3037 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3041 se->expr = gfc_conv_powi (se, n, vartmp);
3047 /* Power op (**). Constant integer exponent has special handling. */
3050 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3052 tree gfc_int4_type_node;
3055 int res_ikind_1, res_ikind_2;
3060 gfc_init_se (&lse, se);
3061 gfc_conv_expr_val (&lse, expr->value.op.op1);
3062 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3063 gfc_add_block_to_block (&se->pre, &lse.pre);
3065 gfc_init_se (&rse, se);
3066 gfc_conv_expr_val (&rse, expr->value.op.op2);
3067 gfc_add_block_to_block (&se->pre, &rse.pre);
3069 if (expr->value.op.op2->ts.type == BT_INTEGER
3070 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3071 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3074 if (INTEGER_CST_P (lse.expr)
3075 && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3077 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3079 int kind, ikind, bit_size;
3081 v = wlhs.to_shwi ();
3084 kind = expr->value.op.op1->ts.kind;
3085 ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3086 bit_size = gfc_integer_kinds[ikind].bit_size;
3090 /* 1**something is always 1. */
3091 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3096 /* (-1)**n is 1 - ((n & 1) << 1) */
3100 type = TREE_TYPE (lse.expr);
3101 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3102 rse.expr, build_int_cst (type, 1));
3103 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3104 tmp, build_int_cst (type, 1));
3105 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3106 build_int_cst (type, 1), tmp);
3110 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3112 /* Here v is +/- 2**e. The further simplification uses
3113 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3114 1<<(4*n), etc., but we have to make sure to return zero
3115 if the number of bits is too large. */
3125 type = TREE_TYPE (lse.expr);
3130 shift = fold_build2_loc (input_location, PLUS_EXPR,
3131 TREE_TYPE (rse.expr),
3132 rse.expr, rse.expr);
3135 /* use popcount for fast log2(w) */
3136 int e = wi::popcount (w-1);
3137 shift = fold_build2_loc (input_location, MULT_EXPR,
3138 TREE_TYPE (rse.expr),
3139 build_int_cst (TREE_TYPE (rse.expr), e),
3143 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3144 build_int_cst (type, 1), shift);
3145 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3146 rse.expr, build_int_cst (type, 0));
3147 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3148 build_int_cst (type, 0));
3149 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3150 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3151 rse.expr, num_bits);
3152 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3153 build_int_cst (type, 0), cond);
3160 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3162 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3163 rse.expr, build_int_cst (type, 1));
3164 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3165 tmp2, build_int_cst (type, 1));
3166 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3167 build_int_cst (type, 1), tmp2);
3168 se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3175 gfc_int4_type_node = gfc_get_int_type (4);
3177 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3178 library routine. But in the end, we have to convert the result back
3179 if this case applies -- with res_ikind_K, we keep track whether operand K
3180 falls into this case. */
3184 kind = expr->value.op.op1->ts.kind;
3185 switch (expr->value.op.op2->ts.type)
3188 ikind = expr->value.op.op2->ts.kind;
3193 rse.expr = convert (gfc_int4_type_node, rse.expr);
3194 res_ikind_2 = ikind;
3216 if (expr->value.op.op1->ts.type == BT_INTEGER)
3218 lse.expr = convert (gfc_int4_type_node, lse.expr);
3245 switch (expr->value.op.op1->ts.type)
3248 if (kind == 3) /* Case 16 was not handled properly above. */
3250 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3254 /* Use builtins for real ** int4. */
3260 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3264 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3268 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3272 /* Use the __builtin_powil() only if real(kind=16) is
3273 actually the C long double type. */
3274 if (!gfc_real16_is_float128)
3275 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3283 /* If we don't have a good builtin for this, go for the
3284 library function. */
3286 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3290 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3299 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3303 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3311 se->expr = build_call_expr_loc (input_location,
3312 fndecl, 2, lse.expr, rse.expr);
3314 /* Convert the result back if it is of wrong integer kind. */
3315 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3317 /* We want the maximum of both operand kinds as result. */
3318 if (res_ikind_1 < res_ikind_2)
3319 res_ikind_1 = res_ikind_2;
3320 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3325 /* Generate code to allocate a string temporary. */
3328 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3333 if (gfc_can_put_var_on_stack (len))
3335 /* Create a temporary variable to hold the result. */
3336 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3337 TREE_TYPE (len), len,
3338 build_int_cst (TREE_TYPE (len), 1));
3339 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3341 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3342 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3344 tmp = build_array_type (TREE_TYPE (type), tmp);
3346 var = gfc_create_var (tmp, "str");
3347 var = gfc_build_addr_expr (type, var);
3351 /* Allocate a temporary to hold the result. */
3352 var = gfc_create_var (type, "pstr");
3353 gcc_assert (POINTER_TYPE_P (type));
3354 tmp = TREE_TYPE (type);
3355 if (TREE_CODE (tmp) == ARRAY_TYPE)
3356 tmp = TREE_TYPE (tmp);
3357 tmp = TYPE_SIZE_UNIT (tmp);
3358 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3359 fold_convert (size_type_node, len),
3360 fold_convert (size_type_node, tmp));
3361 tmp = gfc_call_malloc (&se->pre, type, tmp);
3362 gfc_add_modify (&se->pre, var, tmp);
3364 /* Free the temporary afterwards. */
3365 tmp = gfc_call_free (var);
3366 gfc_add_expr_to_block (&se->post, tmp);
3373 /* Handle a string concatenation operation. A temporary will be allocated to
3377 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3380 tree len, type, var, tmp, fndecl;
3382 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3383 && expr->value.op.op2->ts.type == BT_CHARACTER);
3384 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3386 gfc_init_se (&lse, se);
3387 gfc_conv_expr (&lse, expr->value.op.op1);
3388 gfc_conv_string_parameter (&lse);
3389 gfc_init_se (&rse, se);
3390 gfc_conv_expr (&rse, expr->value.op.op2);
3391 gfc_conv_string_parameter (&rse);
3393 gfc_add_block_to_block (&se->pre, &lse.pre);
3394 gfc_add_block_to_block (&se->pre, &rse.pre);
3396 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3397 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3398 if (len == NULL_TREE)
3400 len = fold_build2_loc (input_location, PLUS_EXPR,
3401 gfc_charlen_type_node,
3402 fold_convert (gfc_charlen_type_node,
3404 fold_convert (gfc_charlen_type_node,
3405 rse.string_length));
3408 type = build_pointer_type (type);
3410 var = gfc_conv_string_tmp (se, type, len);
3412 /* Do the actual concatenation. */
3413 if (expr->ts.kind == 1)
3414 fndecl = gfor_fndecl_concat_string;
3415 else if (expr->ts.kind == 4)
3416 fndecl = gfor_fndecl_concat_string_char4;
3420 tmp = build_call_expr_loc (input_location,
3421 fndecl, 6, len, var, lse.string_length, lse.expr,
3422 rse.string_length, rse.expr);
3423 gfc_add_expr_to_block (&se->pre, tmp);
3425 /* Add the cleanup for the operands. */
3426 gfc_add_block_to_block (&se->pre, &rse.post);
3427 gfc_add_block_to_block (&se->pre, &lse.post);
3430 se->string_length = len;
3433 /* Translates an op expression. Common (binary) cases are handled by this
3434 function, others are passed on. Recursion is used in either case.
3435 We use the fact that (op1.ts == op2.ts) (except for the power
3437 Operators need no special handling for scalarized expressions as long as
3438 they call gfc_conv_simple_val to get their operands.
3439 Character strings get special handling. */
3442 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3444 enum tree_code code;
3453 switch (expr->value.op.op)
3455 case INTRINSIC_PARENTHESES:
3456 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3457 && flag_protect_parens)
3459 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3460 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3465 case INTRINSIC_UPLUS:
3466 gfc_conv_expr (se, expr->value.op.op1);
3469 case INTRINSIC_UMINUS:
3470 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3474 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3477 case INTRINSIC_PLUS:
3481 case INTRINSIC_MINUS:
3485 case INTRINSIC_TIMES:
3489 case INTRINSIC_DIVIDE:
3490 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3491 an integer, we must round towards zero, so we use a
3493 if (expr->ts.type == BT_INTEGER)
3494 code = TRUNC_DIV_EXPR;
3499 case INTRINSIC_POWER:
3500 gfc_conv_power_op (se, expr);
3503 case INTRINSIC_CONCAT:
3504 gfc_conv_concat_op (se, expr);
3508 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3513 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3517 /* EQV and NEQV only work on logicals, but since we represent them
3518 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3520 case INTRINSIC_EQ_OS:
3528 case INTRINSIC_NE_OS:
3529 case INTRINSIC_NEQV:
3536 case INTRINSIC_GT_OS:
3543 case INTRINSIC_GE_OS:
3550 case INTRINSIC_LT_OS:
3557 case INTRINSIC_LE_OS:
3563 case INTRINSIC_USER:
3564 case INTRINSIC_ASSIGN:
3565 /* These should be converted into function calls by the frontend. */
3569 fatal_error (input_location, "Unknown intrinsic op");
3573 /* The only exception to this is **, which is handled separately anyway. */
3574 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3576 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3580 gfc_init_se (&lse, se);
3581 gfc_conv_expr (&lse, expr->value.op.op1);
3582 gfc_add_block_to_block (&se->pre, &lse.pre);
3585 gfc_init_se (&rse, se);
3586 gfc_conv_expr (&rse, expr->value.op.op2);
3587 gfc_add_block_to_block (&se->pre, &rse.pre);
3591 gfc_conv_string_parameter (&lse);
3592 gfc_conv_string_parameter (&rse);
3594 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3595 rse.string_length, rse.expr,
3596 expr->value.op.op1->ts.kind,
3598 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3599 gfc_add_block_to_block (&lse.post, &rse.post);
3602 type = gfc_typenode_for_spec (&expr->ts);
3606 /* The result of logical ops is always logical_type_node. */
3607 tmp = fold_build2_loc (input_location, code, logical_type_node,
3608 lse.expr, rse.expr);
3609 se->expr = convert (type, tmp);
3612 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3614 /* Add the post blocks. */
3615 gfc_add_block_to_block (&se->post, &rse.post);
3616 gfc_add_block_to_block (&se->post, &lse.post);
3619 /* If a string's length is one, we convert it to a single character. */
3622 gfc_string_to_single_character (tree len, tree str, int kind)
3626 || !tree_fits_uhwi_p (len)
3627 || !POINTER_TYPE_P (TREE_TYPE (str)))
3630 if (TREE_INT_CST_LOW (len) == 1)
3632 str = fold_convert (gfc_get_pchar_type (kind), str);
3633 return build_fold_indirect_ref_loc (input_location, str);
3637 && TREE_CODE (str) == ADDR_EXPR
3638 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3639 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3640 && array_ref_low_bound (TREE_OPERAND (str, 0))
3641 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3642 && TREE_INT_CST_LOW (len) > 1
3643 && TREE_INT_CST_LOW (len)
3644 == (unsigned HOST_WIDE_INT)
3645 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3647 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3648 ret = build_fold_indirect_ref_loc (input_location, ret);
3649 if (TREE_CODE (ret) == INTEGER_CST)
3651 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3652 int i, length = TREE_STRING_LENGTH (string_cst);
3653 const char *ptr = TREE_STRING_POINTER (string_cst);
3655 for (i = 1; i < length; i++)
3668 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3671 if (sym->backend_decl)
3673 /* This becomes the nominal_type in
3674 function.c:assign_parm_find_data_types. */
3675 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3676 /* This becomes the passed_type in
3677 function.c:assign_parm_find_data_types. C promotes char to
3678 integer for argument passing. */
3679 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3681 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3686 /* If we have a constant character expression, make it into an
3688 if ((*expr)->expr_type == EXPR_CONSTANT)
3693 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3694 (int)(*expr)->value.character.string[0]);
3695 if ((*expr)->ts.kind != gfc_c_int_kind)
3697 /* The expr needs to be compatible with a C int. If the
3698 conversion fails, then the 2 causes an ICE. */
3699 ts.type = BT_INTEGER;
3700 ts.kind = gfc_c_int_kind;
3701 gfc_convert_type (*expr, &ts, 2);
3704 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3706 if ((*expr)->ref == NULL)
3708 se->expr = gfc_string_to_single_character
3709 (build_int_cst (integer_type_node, 1),
3710 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3712 ((*expr)->symtree->n.sym)),
3717 gfc_conv_variable (se, *expr);
3718 se->expr = gfc_string_to_single_character
3719 (build_int_cst (integer_type_node, 1),
3720 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3728 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3729 if STR is a string literal, otherwise return -1. */
3732 gfc_optimize_len_trim (tree len, tree str, int kind)
3735 && TREE_CODE (str) == ADDR_EXPR
3736 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3737 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3738 && array_ref_low_bound (TREE_OPERAND (str, 0))
3739 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3740 && tree_fits_uhwi_p (len)
3741 && tree_to_uhwi (len) >= 1
3742 && tree_to_uhwi (len)
3743 == (unsigned HOST_WIDE_INT)
3744 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3746 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3747 folded = build_fold_indirect_ref_loc (input_location, folded);
3748 if (TREE_CODE (folded) == INTEGER_CST)
3750 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3751 int length = TREE_STRING_LENGTH (string_cst);
3752 const char *ptr = TREE_STRING_POINTER (string_cst);
3754 for (; length > 0; length--)
3755 if (ptr[length - 1] != ' ')
3764 /* Helper to build a call to memcmp. */
3767 build_memcmp_call (tree s1, tree s2, tree n)
3771 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3772 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3774 s1 = fold_convert (pvoid_type_node, s1);
3776 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3777 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3779 s2 = fold_convert (pvoid_type_node, s2);
3781 n = fold_convert (size_type_node, n);
3783 tmp = build_call_expr_loc (input_location,
3784 builtin_decl_explicit (BUILT_IN_MEMCMP),
3787 return fold_convert (integer_type_node, tmp);
3790 /* Compare two strings. If they are all single characters, the result is the
3791 subtraction of them. Otherwise, we build a library call. */
3794 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3795 enum tree_code code)
3801 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3802 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3804 sc1 = gfc_string_to_single_character (len1, str1, kind);
3805 sc2 = gfc_string_to_single_character (len2, str2, kind);
3807 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3809 /* Deal with single character specially. */
3810 sc1 = fold_convert (integer_type_node, sc1);
3811 sc2 = fold_convert (integer_type_node, sc2);
3812 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3816 if ((code == EQ_EXPR || code == NE_EXPR)
3818 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3820 /* If one string is a string literal with LEN_TRIM longer
3821 than the length of the second string, the strings
3823 int len = gfc_optimize_len_trim (len1, str1, kind);
3824 if (len > 0 && compare_tree_int (len2, len) < 0)
3825 return integer_one_node;
3826 len = gfc_optimize_len_trim (len2, str2, kind);
3827 if (len > 0 && compare_tree_int (len1, len) < 0)
3828 return integer_one_node;
3831 /* We can compare via memcpy if the strings are known to be equal
3832 in length and they are
3834 - kind=4 and the comparison is for (in)equality. */
3836 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3837 && tree_int_cst_equal (len1, len2)
3838 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3843 chartype = gfc_get_char_type (kind);
3844 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3845 fold_convert (TREE_TYPE(len1),
3846 TYPE_SIZE_UNIT(chartype)),
3848 return build_memcmp_call (str1, str2, tmp);
3851 /* Build a call for the comparison. */
3853 fndecl = gfor_fndecl_compare_string;
3855 fndecl = gfor_fndecl_compare_string_char4;
3859 return build_call_expr_loc (input_location, fndecl, 4,
3860 len1, str1, len2, str2);
3864 /* Return the backend_decl for a procedure pointer component. */
3867 get_proc_ptr_comp (gfc_expr *e)
3873 gfc_init_se (&comp_se, NULL);
3874 e2 = gfc_copy_expr (e);
3875 /* We have to restore the expr type later so that gfc_free_expr frees
3876 the exact same thing that was allocated.
3877 TODO: This is ugly. */
3878 old_type = e2->expr_type;
3879 e2->expr_type = EXPR_VARIABLE;
3880 gfc_conv_expr (&comp_se, e2);
3881 e2->expr_type = old_type;
3883 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3887 /* Convert a typebound function reference from a class object. */
3889 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3894 if (!VAR_P (base_object))
3896 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3897 gfc_add_modify (&se->pre, var, base_object);
3899 se->expr = gfc_class_vptr_get (base_object);
3900 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3902 while (ref && ref->next)
3904 gcc_assert (ref && ref->type == REF_COMPONENT);
3905 if (ref->u.c.sym->attr.extension)
3906 conv_parent_component_references (se, ref);
3907 gfc_conv_component_ref (se, ref);
3908 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3913 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
3914 gfc_actual_arglist *actual_args)
3918 if (gfc_is_proc_ptr_comp (expr))
3919 tmp = get_proc_ptr_comp (expr);
3920 else if (sym->attr.dummy)
3922 tmp = gfc_get_symbol_decl (sym);
3923 if (sym->attr.proc_pointer)
3924 tmp = build_fold_indirect_ref_loc (input_location,
3926 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3927 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3931 if (!sym->backend_decl)
3932 sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
3934 TREE_USED (sym->backend_decl) = 1;
3936 tmp = sym->backend_decl;
3938 if (sym->attr.cray_pointee)
3940 /* TODO - make the cray pointee a pointer to a procedure,
3941 assign the pointer to it and use it for the call. This
3943 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3944 gfc_get_symbol_decl (sym->cp_pointer));
3945 tmp = gfc_evaluate_now (tmp, &se->pre);
3948 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3950 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3951 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3958 /* Initialize MAPPING. */
3961 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3963 mapping->syms = NULL;
3964 mapping->charlens = NULL;
3968 /* Free all memory held by MAPPING (but not MAPPING itself). */
3971 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3973 gfc_interface_sym_mapping *sym;
3974 gfc_interface_sym_mapping *nextsym;
3976 gfc_charlen *nextcl;
3978 for (sym = mapping->syms; sym; sym = nextsym)
3980 nextsym = sym->next;
3981 sym->new_sym->n.sym->formal = NULL;
3982 gfc_free_symbol (sym->new_sym->n.sym);
3983 gfc_free_expr (sym->expr);
3984 free (sym->new_sym);
3987 for (cl = mapping->charlens; cl; cl = nextcl)
3990 gfc_free_expr (cl->length);
3996 /* Return a copy of gfc_charlen CL. Add the returned structure to
3997 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3999 static gfc_charlen *
4000 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4003 gfc_charlen *new_charlen;
4005 new_charlen = gfc_get_charlen ();
4006 new_charlen->next = mapping->charlens;
4007 new_charlen->length = gfc_copy_expr (cl->length);
4009 mapping->charlens = new_charlen;
4014 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4015 array variable that can be used as the actual argument for dummy
4016 argument SYM. Add any initialization code to BLOCK. PACKED is as
4017 for gfc_get_nodesc_array_type and DATA points to the first element
4018 in the passed array. */
4021 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4022 gfc_packed packed, tree data)
4027 type = gfc_typenode_for_spec (&sym->ts);
4028 type = gfc_get_nodesc_array_type (type, sym->as, packed,
4029 !sym->attr.target && !sym->attr.pointer
4030 && !sym->attr.proc_pointer);
4032 var = gfc_create_var (type, "ifm");
4033 gfc_add_modify (block, var, fold_convert (type, data));
4039 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4040 and offset of descriptorless array type TYPE given that it has the same
4041 size as DESC. Add any set-up code to BLOCK. */
4044 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4051 offset = gfc_index_zero_node;
4052 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4054 dim = gfc_rank_cst[n];
4055 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4056 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4058 GFC_TYPE_ARRAY_LBOUND (type, n)
4059 = gfc_conv_descriptor_lbound_get (desc, dim);
4060 GFC_TYPE_ARRAY_UBOUND (type, n)
4061 = gfc_conv_descriptor_ubound_get (desc, dim);
4063 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4065 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4066 gfc_array_index_type,
4067 gfc_conv_descriptor_ubound_get (desc, dim),
4068 gfc_conv_descriptor_lbound_get (desc, dim));
4069 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4070 gfc_array_index_type,
4071 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4072 tmp = gfc_evaluate_now (tmp, block);
4073 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4075 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4076 GFC_TYPE_ARRAY_LBOUND (type, n),
4077 GFC_TYPE_ARRAY_STRIDE (type, n));
4078 offset = fold_build2_loc (input_location, MINUS_EXPR,
4079 gfc_array_index_type, offset, tmp);
4081 offset = gfc_evaluate_now (offset, block);
4082 GFC_TYPE_ARRAY_OFFSET (type) = offset;
4086 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4087 in SE. The caller may still use se->expr and se->string_length after
4088 calling this function. */
4091 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4092 gfc_symbol * sym, gfc_se * se,
4095 gfc_interface_sym_mapping *sm;
4099 gfc_symbol *new_sym;
4101 gfc_symtree *new_symtree;
4103 /* Create a new symbol to represent the actual argument. */
4104 new_sym = gfc_new_symbol (sym->name, NULL);
4105 new_sym->ts = sym->ts;
4106 new_sym->as = gfc_copy_array_spec (sym->as);
4107 new_sym->attr.referenced = 1;
4108 new_sym->attr.dimension = sym->attr.dimension;
4109 new_sym->attr.contiguous = sym->attr.contiguous;
4110 new_sym->attr.codimension = sym->attr.codimension;
4111 new_sym->attr.pointer = sym->attr.pointer;
4112 new_sym->attr.allocatable = sym->attr.allocatable;
4113 new_sym->attr.flavor = sym->attr.flavor;
4114 new_sym->attr.function = sym->attr.function;
4116 /* Ensure that the interface is available and that
4117 descriptors are passed for array actual arguments. */
4118 if (sym->attr.flavor == FL_PROCEDURE)
4120 new_sym->formal = expr->symtree->n.sym->formal;
4121 new_sym->attr.always_explicit
4122 = expr->symtree->n.sym->attr.always_explicit;
4125 /* Create a fake symtree for it. */
4127 new_symtree = gfc_new_symtree (&root, sym->name);
4128 new_symtree->n.sym = new_sym;
4129 gcc_assert (new_symtree == root);
4131 /* Create a dummy->actual mapping. */
4132 sm = XCNEW (gfc_interface_sym_mapping);
4133 sm->next = mapping->syms;
4135 sm->new_sym = new_symtree;
4136 sm->expr = gfc_copy_expr (expr);
4139 /* Stabilize the argument's value. */
4140 if (!sym->attr.function && se)
4141 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4143 if (sym->ts.type == BT_CHARACTER)
4145 /* Create a copy of the dummy argument's length. */
4146 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4147 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4149 /* If the length is specified as "*", record the length that
4150 the caller is passing. We should use the callee's length
4151 in all other cases. */
4152 if (!new_sym->ts.u.cl->length && se)
4154 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4155 new_sym->ts.u.cl->backend_decl = se->string_length;
4162 /* Use the passed value as-is if the argument is a function. */
4163 if (sym->attr.flavor == FL_PROCEDURE)
4166 /* If the argument is a pass-by-value scalar, use the value as is. */
4167 else if (!sym->attr.dimension && sym->attr.value)
4170 /* If the argument is either a string or a pointer to a string,
4171 convert it to a boundless character type. */
4172 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4174 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4175 tmp = build_pointer_type (tmp);
4176 if (sym->attr.pointer)
4177 value = build_fold_indirect_ref_loc (input_location,
4181 value = fold_convert (tmp, value);
4184 /* If the argument is a scalar, a pointer to an array or an allocatable,
4186 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4187 value = build_fold_indirect_ref_loc (input_location,
4190 /* For character(*), use the actual argument's descriptor. */
4191 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4192 value = build_fold_indirect_ref_loc (input_location,
4195 /* If the argument is an array descriptor, use it to determine
4196 information about the actual argument's shape. */
4197 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4198 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4200 /* Get the actual argument's descriptor. */
4201 desc = build_fold_indirect_ref_loc (input_location,
4204 /* Create the replacement variable. */
4205 tmp = gfc_conv_descriptor_data_get (desc);
4206 value = gfc_get_interface_mapping_array (&se->pre, sym,
4209 /* Use DESC to work out the upper bounds, strides and offset. */
4210 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4213 /* Otherwise we have a packed array. */
4214 value = gfc_get_interface_mapping_array (&se->pre, sym,
4215 PACKED_FULL, se->expr);
4217 new_sym->backend_decl = value;
4221 /* Called once all dummy argument mappings have been added to MAPPING,
4222 but before the mapping is used to evaluate expressions. Pre-evaluate
4223 the length of each argument, adding any initialization code to PRE and
4224 any finalization code to POST. */
4227 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4228 stmtblock_t * pre, stmtblock_t * post)
4230 gfc_interface_sym_mapping *sym;
4234 for (sym = mapping->syms; sym; sym = sym->next)
4235 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4236 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4238 expr = sym->new_sym->n.sym->ts.u.cl->length;
4239 gfc_apply_interface_mapping_to_expr (mapping, expr);
4240 gfc_init_se (&se, NULL);
4241 gfc_conv_expr (&se, expr);
4242 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4243 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4244 gfc_add_block_to_block (pre, &se.pre);
4245 gfc_add_block_to_block (post, &se.post);
4247 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4252 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4256 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4257 gfc_constructor_base base)
4260 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4262 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4265 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4266 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4267 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4273 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4277 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4282 for (; ref; ref = ref->next)
4286 for (n = 0; n < ref->u.ar.dimen; n++)
4288 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4289 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4290 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4299 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4300 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4306 /* Convert intrinsic function calls into result expressions. */
4309 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4317 arg1 = expr->value.function.actual->expr;
4318 if (expr->value.function.actual->next)
4319 arg2 = expr->value.function.actual->next->expr;
4323 sym = arg1->symtree->n.sym;
4325 if (sym->attr.dummy)
4330 switch (expr->value.function.isym->id)
4333 /* TODO figure out why this condition is necessary. */
4334 if (sym->attr.function
4335 && (arg1->ts.u.cl->length == NULL
4336 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4337 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4340 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4343 case GFC_ISYM_LEN_TRIM:
4344 new_expr = gfc_copy_expr (arg1);
4345 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4350 gfc_replace_expr (arg1, new_expr);
4354 if (!sym->as || sym->as->rank == 0)
4357 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4359 dup = mpz_get_si (arg2->value.integer);
4364 dup = sym->as->rank;
4368 for (; d < dup; d++)
4372 if (!sym->as->upper[d] || !sym->as->lower[d])
4374 gfc_free_expr (new_expr);
4378 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4379 gfc_get_int_expr (gfc_default_integer_kind,
4381 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4383 new_expr = gfc_multiply (new_expr, tmp);
4389 case GFC_ISYM_LBOUND:
4390 case GFC_ISYM_UBOUND:
4391 /* TODO These implementations of lbound and ubound do not limit if
4392 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4394 if (!sym->as || sym->as->rank == 0)
4397 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4398 d = mpz_get_si (arg2->value.integer) - 1;
4402 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4404 if (sym->as->lower[d])
4405 new_expr = gfc_copy_expr (sym->as->lower[d]);
4409 if (sym->as->upper[d])
4410 new_expr = gfc_copy_expr (sym->as->upper[d]);
4418 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4422 gfc_replace_expr (expr, new_expr);
4428 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4429 gfc_interface_mapping * mapping)
4431 gfc_formal_arglist *f;
4432 gfc_actual_arglist *actual;
4434 actual = expr->value.function.actual;
4435 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4437 for (; f && actual; f = f->next, actual = actual->next)
4442 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4445 if (map_expr->symtree->n.sym->attr.dimension)
4450 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4452 for (d = 0; d < as->rank; d++)
4454 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4455 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4458 expr->value.function.esym->as = as;
4461 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4463 expr->value.function.esym->ts.u.cl->length
4464 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4466 gfc_apply_interface_mapping_to_expr (mapping,
4467 expr->value.function.esym->ts.u.cl->length);
4472 /* EXPR is a copy of an expression that appeared in the interface
4473 associated with MAPPING. Walk it recursively looking for references to
4474 dummy arguments that MAPPING maps to actual arguments. Replace each such
4475 reference with a reference to the associated actual argument. */
4478 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4481 gfc_interface_sym_mapping *sym;
4482 gfc_actual_arglist *actual;
4487 /* Copying an expression does not copy its length, so do that here. */
4488 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4490 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4491 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4494 /* Apply the mapping to any references. */
4495 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4497 /* ...and to the expression's symbol, if it has one. */
4498 /* TODO Find out why the condition on expr->symtree had to be moved into
4499 the loop rather than being outside it, as originally. */
4500 for (sym = mapping->syms; sym; sym = sym->next)
4501 if (expr->symtree && sym->old == expr->symtree->n.sym)
4503 if (sym->new_sym->n.sym->backend_decl)
4504 expr->symtree = sym->new_sym;
4506 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4509 /* ...and to subexpressions in expr->value. */
4510 switch (expr->expr_type)
4515 case EXPR_SUBSTRING:
4519 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4520 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4524 for (actual = expr->value.function.actual; actual; actual = actual->next)
4525 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4527 if (expr->value.function.esym == NULL
4528 && expr->value.function.isym != NULL
4529 && expr->value.function.actual
4530 && expr->value.function.actual->expr
4531 && expr->value.function.actual->expr->symtree
4532 && gfc_map_intrinsic_function (expr, mapping))
4535 for (sym = mapping->syms; sym; sym = sym->next)
4536 if (sym->old == expr->value.function.esym)
4538 expr->value.function.esym = sym->new_sym->n.sym;
4539 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4540 expr->value.function.esym->result = sym->new_sym->n.sym;
4545 case EXPR_STRUCTURE:
4546 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4560 /* Evaluate interface expression EXPR using MAPPING. Store the result
4564 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4565 gfc_se * se, gfc_expr * expr)
4567 expr = gfc_copy_expr (expr);
4568 gfc_apply_interface_mapping_to_expr (mapping, expr);
4569 gfc_conv_expr (se, expr);
4570 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4571 gfc_free_expr (expr);
4575 /* Returns a reference to a temporary array into which a component of
4576 an actual argument derived type array is copied and then returned
4577 after the function call. */
4579 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4580 sym_intent intent, bool formal_ptr)
4588 gfc_array_info *info;
4598 gfc_init_se (&lse, NULL);
4599 gfc_init_se (&rse, NULL);
4601 /* Walk the argument expression. */
4602 rss = gfc_walk_expr (expr);
4604 gcc_assert (rss != gfc_ss_terminator);
4606 /* Initialize the scalarizer. */
4607 gfc_init_loopinfo (&loop);
4608 gfc_add_ss_to_loop (&loop, rss);
4610 /* Calculate the bounds of the scalarization. */
4611 gfc_conv_ss_startstride (&loop);
4613 /* Build an ss for the temporary. */
4614 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4615 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4617 base_type = gfc_typenode_for_spec (&expr->ts);
4618 if (GFC_ARRAY_TYPE_P (base_type)
4619 || GFC_DESCRIPTOR_TYPE_P (base_type))
4620 base_type = gfc_get_element_type (base_type);
4622 if (expr->ts.type == BT_CLASS)
4623 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4625 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4626 ? expr->ts.u.cl->backend_decl
4630 parmse->string_length = loop.temp_ss->info->string_length;
4632 /* Associate the SS with the loop. */
4633 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4635 /* Setup the scalarizing loops. */
4636 gfc_conv_loop_setup (&loop, &expr->where);
4638 /* Pass the temporary descriptor back to the caller. */
4639 info = &loop.temp_ss->info->data.array;
4640 parmse->expr = info->descriptor;
4642 /* Setup the gfc_se structures. */
4643 gfc_copy_loopinfo_to_se (&lse, &loop);
4644 gfc_copy_loopinfo_to_se (&rse, &loop);
4647 lse.ss = loop.temp_ss;
4648 gfc_mark_ss_chain_used (rss, 1);
4649 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4651 /* Start the scalarized loop body. */
4652 gfc_start_scalarized_body (&loop, &body);
4654 /* Translate the expression. */
4655 gfc_conv_expr (&rse, expr);
4657 /* Reset the offset for the function call since the loop
4658 is zero based on the data pointer. Note that the temp
4659 comes first in the loop chain since it is added second. */
4660 if (gfc_is_class_array_function (expr))
4662 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4663 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4664 gfc_index_zero_node);
4667 gfc_conv_tmp_array_ref (&lse);
4669 if (intent != INTENT_OUT)
4671 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4672 gfc_add_expr_to_block (&body, tmp);
4673 gcc_assert (rse.ss == gfc_ss_terminator);
4674 gfc_trans_scalarizing_loops (&loop, &body);
4678 /* Make sure that the temporary declaration survives by merging
4679 all the loop declarations into the current context. */
4680 for (n = 0; n < loop.dimen; n++)
4682 gfc_merge_block_scope (&body);
4683 body = loop.code[loop.order[n]];
4685 gfc_merge_block_scope (&body);
4688 /* Add the post block after the second loop, so that any
4689 freeing of allocated memory is done at the right time. */
4690 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4692 /**********Copy the temporary back again.*********/
4694 gfc_init_se (&lse, NULL);
4695 gfc_init_se (&rse, NULL);
4697 /* Walk the argument expression. */
4698 lss = gfc_walk_expr (expr);
4699 rse.ss = loop.temp_ss;
4702 /* Initialize the scalarizer. */
4703 gfc_init_loopinfo (&loop2);
4704 gfc_add_ss_to_loop (&loop2, lss);
4706 dimen = rse.ss->dimen;
4708 /* Skip the write-out loop for this case. */
4709 if (gfc_is_class_array_function (expr))
4710 goto class_array_fcn;
4712 /* Calculate the bounds of the scalarization. */
4713 gfc_conv_ss_startstride (&loop2);
4715 /* Setup the scalarizing loops. */
4716 gfc_conv_loop_setup (&loop2, &expr->where);
4718 gfc_copy_loopinfo_to_se (&lse, &loop2);
4719 gfc_copy_loopinfo_to_se (&rse, &loop2);
4721 gfc_mark_ss_chain_used (lss, 1);
4722 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4724 /* Declare the variable to hold the temporary offset and start the
4725 scalarized loop body. */
4726 offset = gfc_create_var (gfc_array_index_type, NULL);
4727 gfc_start_scalarized_body (&loop2, &body);
4729 /* Build the offsets for the temporary from the loop variables. The
4730 temporary array has lbounds of zero and strides of one in all
4731 dimensions, so this is very simple. The offset is only computed
4732 outside the innermost loop, so the overall transfer could be
4733 optimized further. */
4734 info = &rse.ss->info->data.array;
4736 tmp_index = gfc_index_zero_node;
4737 for (n = dimen - 1; n > 0; n--)
4740 tmp = rse.loop->loopvar[n];
4741 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4742 tmp, rse.loop->from[n]);
4743 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4746 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4747 gfc_array_index_type,
4748 rse.loop->to[n-1], rse.loop->from[n-1]);
4749 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4750 gfc_array_index_type,
4751 tmp_str, gfc_index_one_node);
4753 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4754 gfc_array_index_type, tmp, tmp_str);
4757 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4758 gfc_array_index_type,
4759 tmp_index, rse.loop->from[0]);
4760 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4762 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4763 gfc_array_index_type,
4764 rse.loop->loopvar[0], offset);
4766 /* Now use the offset for the reference. */
4767 tmp = build_fold_indirect_ref_loc (input_location,
4769 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4771 if (expr->ts.type == BT_CHARACTER)
4772 rse.string_length = expr->ts.u.cl->backend_decl;
4774 gfc_conv_expr (&lse, expr);
4776 gcc_assert (lse.ss == gfc_ss_terminator);
4778 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4779 gfc_add_expr_to_block (&body, tmp);
4781 /* Generate the copying loops. */
4782 gfc_trans_scalarizing_loops (&loop2, &body);
4784 /* Wrap the whole thing up by adding the second loop to the post-block
4785 and following it by the post-block of the first loop. In this way,
4786 if the temporary needs freeing, it is done after use! */
4787 if (intent != INTENT_IN)
4789 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4790 gfc_add_block_to_block (&parmse->post, &loop2.post);
4795 gfc_add_block_to_block (&parmse->post, &loop.post);
4797 gfc_cleanup_loop (&loop);
4798 gfc_cleanup_loop (&loop2);
4800 /* Pass the string length to the argument expression. */
4801 if (expr->ts.type == BT_CHARACTER)
4802 parmse->string_length = expr->ts.u.cl->backend_decl;
4804 /* Determine the offset for pointer formal arguments and set the
4808 size = gfc_index_one_node;
4809 offset = gfc_index_zero_node;
4810 for (n = 0; n < dimen; n++)
4812 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4814 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4815 gfc_array_index_type, tmp,
4816 gfc_index_one_node);
4817 gfc_conv_descriptor_ubound_set (&parmse->pre,
4821 gfc_conv_descriptor_lbound_set (&parmse->pre,
4824 gfc_index_one_node);
4825 size = gfc_evaluate_now (size, &parmse->pre);
4826 offset = fold_build2_loc (input_location, MINUS_EXPR,
4827 gfc_array_index_type,
4829 offset = gfc_evaluate_now (offset, &parmse->pre);
4830 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4831 gfc_array_index_type,
4832 rse.loop->to[n], rse.loop->from[n]);
4833 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4834 gfc_array_index_type,
4835 tmp, gfc_index_one_node);
4836 size = fold_build2_loc (input_location, MULT_EXPR,
4837 gfc_array_index_type, size, tmp);
4840 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4844 /* We want either the address for the data or the address of the descriptor,
4845 depending on the mode of passing array arguments. */
4847 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4849 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4855 /* Generate the code for argument list functions. */
4858 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4860 /* Pass by value for g77 %VAL(arg), pass the address
4861 indirectly for %LOC, else by reference. Thus %REF
4862 is a "do-nothing" and %LOC is the same as an F95
4864 if (strcmp (name, "%VAL") == 0)
4865 gfc_conv_expr (se, expr);
4866 else if (strcmp (name, "%LOC") == 0)
4868 gfc_conv_expr_reference (se, expr);
4869 se->expr = gfc_build_addr_expr (NULL, se->expr);
4871 else if (strcmp (name, "%REF") == 0)
4872 gfc_conv_expr_reference (se, expr);
4874 gfc_error ("Unknown argument list function at %L", &expr->where);
4878 /* This function tells whether the middle-end representation of the expression
4879 E given as input may point to data otherwise accessible through a variable
4881 It is assumed that the only expressions that may alias are variables,
4882 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4884 This function is used to decide whether freeing an expression's allocatable
4885 components is safe or should be avoided.
4887 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4888 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4889 is necessary because for array constructors, aliasing depends on how
4891 - If E is an array constructor used as argument to an elemental procedure,
4892 the array, which is generated through shallow copy by the scalarizer,
4893 is used directly and can alias the expressions it was copied from.
4894 - If E is an array constructor used as argument to a non-elemental
4895 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4896 the array as in the previous case, but then that array is used
4897 to initialize a new descriptor through deep copy. There is no alias
4898 possible in that case.
4899 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4903 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4907 if (e->expr_type == EXPR_VARIABLE)
4909 else if (e->expr_type == EXPR_FUNCTION)
4911 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4913 if (proc_ifc->result != NULL
4914 && ((proc_ifc->result->ts.type == BT_CLASS
4915 && proc_ifc->result->ts.u.derived->attr.is_class
4916 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4917 || proc_ifc->result->attr.pointer))
4922 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4925 for (c = gfc_constructor_first (e->value.constructor);
4926 c; c = gfc_constructor_next (c))
4928 && expr_may_alias_variables (c->expr, array_may_alias))
4935 /* A helper function to set the dtype for unallocated or unassociated
4939 set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
4947 /* TODO Figure out how to handle optional dummies. */
4948 if (e && e->expr_type == EXPR_VARIABLE
4949 && e->symtree->n.sym->attr.optional)
4952 desc = parmse->expr;
4953 if (desc == NULL_TREE)
4956 if (POINTER_TYPE_P (TREE_TYPE (desc)))
4957 desc = build_fold_indirect_ref_loc (input_location, desc);
4959 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
4962 gfc_init_block (&block);
4963 tmp = gfc_conv_descriptor_data_get (desc);
4964 cond = fold_build2_loc (input_location, EQ_EXPR,
4965 logical_type_node, tmp,
4966 build_int_cst (TREE_TYPE (tmp), 0));
4967 tmp = gfc_conv_descriptor_dtype (desc);
4968 type = gfc_get_element_type (TREE_TYPE (desc));
4969 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
4970 TREE_TYPE (tmp), tmp,
4971 gfc_get_dtype_rank_type (e->rank, type));
4972 gfc_add_expr_to_block (&block, tmp);
4973 cond = build3_v (COND_EXPR, cond,
4974 gfc_finish_block (&block),
4975 build_empty_stmt (input_location));
4976 gfc_add_expr_to_block (&parmse->pre, cond);
4981 /* Provide an interface between gfortran array descriptors and the F2018:18.4
4982 ISO_Fortran_binding array descriptors. */
4985 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
4993 symbol_attribute attr = gfc_expr_attr (e);
4996 /* If this is a full array or a scalar, the allocatable and pointer
4997 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
4999 if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
5001 if (fsym->attr.pointer)
5003 else if (fsym->attr.allocatable)
5009 if (fsym->attr.contiguous
5010 && !gfc_is_simply_contiguous (e, false, true))
5011 gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
5012 fsym->attr.pointer);
5014 gfc_conv_expr_descriptor (parmse, e);
5016 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5017 parmse->expr = build_fold_indirect_ref_loc (input_location,
5020 /* Unallocated allocatable arrays and unassociated pointer arrays
5021 need their dtype setting if they are argument associated with
5022 assumed rank dummies. */
5023 if (fsym && fsym->as
5024 && (gfc_expr_attr (e).pointer
5025 || gfc_expr_attr (e).allocatable))
5026 set_dtype_for_unallocated (parmse, e);
5028 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5029 the expression type is different from the descriptor type, then
5030 the offset must be found (eg. to a component ref or substring)
5031 and the dtype updated. Assumed type entities are only allowed
5032 to be dummies in Fortran. They therefore lack the decl specific
5033 appendiges and so must be treated differently from other fortran
5034 entities passed to CFI descriptors in the interface decl. */
5035 type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
5038 if (type && DECL_ARTIFICIAL (parmse->expr)
5039 && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
5041 /* Obtain the offset to the data. */
5042 gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
5043 gfc_index_zero_node, true, e);
5045 /* Update the dtype. */
5046 gfc_add_modify (&parmse->pre,
5047 gfc_conv_descriptor_dtype (parmse->expr),
5048 gfc_get_dtype_rank_type (e->rank, type));
5050 else if (type == NULL_TREE
5051 || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)))
5053 /* Make sure that the span is set for expressions where it
5054 might not have been done already. */
5055 tmp = gfc_conv_descriptor_elem_len (parmse->expr);
5056 tmp = fold_convert (gfc_array_index_type, tmp);
5057 gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
5062 gfc_conv_expr (parmse, e);
5064 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5065 parmse->expr = build_fold_indirect_ref_loc (input_location,
5068 parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
5069 parmse->expr, attr);
5072 /* Set the CFI attribute field. */
5073 tmp = gfc_conv_descriptor_attribute (parmse->expr);
5074 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5075 void_type_node, tmp,
5076 build_int_cst (TREE_TYPE (tmp), attribute));
5077 gfc_add_expr_to_block (&parmse->pre, tmp);
5079 /* Now pass the gfc_descriptor by reference. */
5080 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5082 /* Variables to point to the gfc and CFI descriptors. */
5083 gfc_desc_ptr = parmse->expr;
5084 cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
5085 gfc_add_modify (&parmse->pre, cfi_desc_ptr,
5086 build_int_cst (pvoid_type_node, 0));
5088 /* Allocate the CFI descriptor and fill the fields. */
5089 tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
5090 tmp = build_call_expr_loc (input_location,
5091 gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
5092 gfc_add_expr_to_block (&parmse->pre, tmp);
5094 /* The CFI descriptor is passed to the bind_C procedure. */
5095 parmse->expr = cfi_desc_ptr;
5097 /* Free the CFI descriptor. */
5098 gfc_init_block (&block);
5099 cond = fold_build2_loc (input_location, NE_EXPR,
5100 logical_type_node, cfi_desc_ptr,
5101 build_int_cst (TREE_TYPE (cfi_desc_ptr), 0));
5102 tmp = gfc_call_free (cfi_desc_ptr);
5103 gfc_add_expr_to_block (&block, tmp);
5104 tmp = build3_v (COND_EXPR, cond,
5105 gfc_finish_block (&block),
5106 build_empty_stmt (input_location));
5107 gfc_prepend_expr_to_block (&parmse->post, tmp);
5109 /* Transfer values back to gfc descriptor. */
5110 tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5111 tmp = build_call_expr_loc (input_location,
5112 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
5113 gfc_prepend_expr_to_block (&parmse->post, tmp);
5117 /* Generate code for a procedure call. Note can return se->post != NULL.
5118 If se->direct_byref is set then se->expr contains the return parameter.
5119 Return nonzero, if the call has alternate specifiers.
5120 'expr' is only needed for procedure pointer components. */
5123 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
5124 gfc_actual_arglist * args, gfc_expr * expr,
5125 vec<tree, va_gc> *append_args)
5127 gfc_interface_mapping mapping;
5128 vec<tree, va_gc> *arglist;
5129 vec<tree, va_gc> *retargs;
5133 gfc_array_info *info;
5140 vec<tree, va_gc> *stringargs;
5141 vec<tree, va_gc> *optionalargs;
5143 gfc_formal_arglist *formal;
5144 gfc_actual_arglist *arg;
5145 int has_alternate_specifier = 0;
5146 bool need_interface_mapping;
5154 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
5155 gfc_component *comp = NULL;
5162 optionalargs = NULL;
5167 comp = gfc_get_proc_ptr_comp (expr);
5169 bool elemental_proc = (comp
5170 && comp->ts.interface
5171 && comp->ts.interface->attr.elemental)
5172 || (comp && comp->attr.elemental)
5173 || sym->attr.elemental;
5177 if (!elemental_proc)
5179 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
5180 if (se->ss->info->useflags)
5182 gcc_assert ((!comp && gfc_return_by_reference (sym)
5183 && sym->result->attr.dimension)
5184 || (comp && comp->attr.dimension)
5185 || gfc_is_class_array_function (expr));
5186 gcc_assert (se->loop != NULL);
5187 /* Access the previously obtained result. */
5188 gfc_conv_tmp_array_ref (se);
5192 info = &se->ss->info->data.array;
5197 gfc_init_block (&post);
5198 gfc_init_interface_mapping (&mapping);
5201 formal = gfc_sym_get_dummy_args (sym);
5202 need_interface_mapping = sym->attr.dimension ||
5203 (sym->ts.type == BT_CHARACTER
5204 && sym->ts.u.cl->length
5205 && sym->ts.u.cl->length->expr_type
5210 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
5211 need_interface_mapping = comp->attr.dimension ||
5212 (comp->ts.type == BT_CHARACTER
5213 && comp->ts.u.cl->length
5214 && comp->ts.u.cl->length->expr_type
5218 base_object = NULL_TREE;
5219 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5220 is the third and fourth argument to such a function call a value
5221 denoting the number of elements to copy (i.e., most of the time the
5222 length of a deferred length string). */
5223 ulim_copy = (formal == NULL)
5224 && UNLIMITED_POLY (sym)
5225 && comp && (strcmp ("_copy", comp->name) == 0);
5227 /* Evaluate the arguments. */
5228 for (arg = args, argc = 0; arg != NULL;
5229 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
5231 bool finalized = false;
5232 bool non_unity_length_string = false;
5235 fsym = formal ? formal->sym : NULL;
5236 parm_kind = MISSING;
5238 if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
5239 && (!fsym->ts.u.cl->length
5240 || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5241 || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
5242 non_unity_length_string = true;
5244 /* If the procedure requires an explicit interface, the actual
5245 argument is passed according to the corresponding formal
5246 argument. If the corresponding formal argument is a POINTER,
5247 ALLOCATABLE or assumed shape, we do not use g77's calling
5248 convention, and pass the address of the array descriptor
5249 instead. Otherwise we use g77's calling convention, in other words
5250 pass the array data pointer without descriptor. */
5251 bool nodesc_arg = fsym != NULL
5252 && !(fsym->attr.pointer || fsym->attr.allocatable)
5254 && fsym->as->type != AS_ASSUMED_SHAPE
5255 && fsym->as->type != AS_ASSUMED_RANK;
5257 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
5259 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
5261 /* Class array expressions are sometimes coming completely unadorned
5262 with either arrayspec or _data component. Correct that here.
5263 OOP-TODO: Move this to the frontend. */
5264 if (e && e->expr_type == EXPR_VARIABLE
5266 && e->ts.type == BT_CLASS
5267 && (CLASS_DATA (e)->attr.codimension
5268 || CLASS_DATA (e)->attr.dimension))
5270 gfc_typespec temp_ts = e->ts;
5271 gfc_add_class_array_ref (e);
5277 if (se->ignore_optional)
5279 /* Some intrinsics have already been resolved to the correct
5283 else if (arg->label)
5285 has_alternate_specifier = 1;
5290 gfc_init_se (&parmse, NULL);
5292 /* For scalar arguments with VALUE attribute which are passed by
5293 value, pass "0" and a hidden argument gives the optional
5295 if (fsym && fsym->attr.optional && fsym->attr.value
5296 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
5297 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
5299 parmse.expr = fold_convert (gfc_sym_type (fsym),
5301 vec_safe_push (optionalargs, boolean_false_node);
5305 /* Pass a NULL pointer for an absent arg. */
5306 parmse.expr = null_pointer_node;
5307 if (arg->missing_arg_type == BT_CHARACTER)
5308 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5313 else if (arg->expr->expr_type == EXPR_NULL
5314 && fsym && !fsym->attr.pointer
5315 && (fsym->ts.type != BT_CLASS
5316 || !CLASS_DATA (fsym)->attr.class_pointer))
5318 /* Pass a NULL pointer to denote an absent arg. */
5319 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5320 && (fsym->ts.type != BT_CLASS
5321 || !CLASS_DATA (fsym)->attr.allocatable));
5322 gfc_init_se (&parmse, NULL);
5323 parmse.expr = null_pointer_node;
5324 if (arg->missing_arg_type == BT_CHARACTER)
5325 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5327 else if (fsym && fsym->ts.type == BT_CLASS
5328 && e->ts.type == BT_DERIVED)
5330 /* The derived type needs to be converted to a temporary
5332 gfc_init_se (&parmse, se);
5333 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5335 && e->expr_type == EXPR_VARIABLE
5336 && e->symtree->n.sym->attr.optional,
5337 CLASS_DATA (fsym)->attr.class_pointer
5338 || CLASS_DATA (fsym)->attr.allocatable);
5340 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
5342 /* The intrinsic type needs to be converted to a temporary
5343 CLASS object for the unlimited polymorphic formal. */
5344 gfc_init_se (&parmse, se);
5345 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5347 else if (se->ss && se->ss->info->useflags)
5353 /* An elemental function inside a scalarized loop. */
5354 gfc_init_se (&parmse, se);
5355 parm_kind = ELEMENTAL;
5357 /* When no fsym is present, ulim_copy is set and this is a third or
5358 fourth argument, use call-by-value instead of by reference to
5359 hand the length properties to the copy routine (i.e., most of the
5360 time this will be a call to a __copy_character_* routine where the
5361 third and fourth arguments are the lengths of a deferred length
5363 if ((fsym && fsym->attr.value)
5364 || (ulim_copy && (argc == 2 || argc == 3)))
5365 gfc_conv_expr (&parmse, e);
5367 gfc_conv_expr_reference (&parmse, e);
5369 if (e->ts.type == BT_CHARACTER && !e->rank
5370 && e->expr_type == EXPR_FUNCTION)
5371 parmse.expr = build_fold_indirect_ref_loc (input_location,
5374 if (fsym && fsym->ts.type == BT_DERIVED
5375 && gfc_is_class_container_ref (e))
5377 parmse.expr = gfc_class_data_get (parmse.expr);
5379 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5380 && e->symtree->n.sym->attr.optional)
5382 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5383 parmse.expr = build3_loc (input_location, COND_EXPR,
5384 TREE_TYPE (parmse.expr),
5386 fold_convert (TREE_TYPE (parmse.expr),
5387 null_pointer_node));
5391 /* If we are passing an absent array as optional dummy to an
5392 elemental procedure, make sure that we pass NULL when the data
5393 pointer is NULL. We need this extra conditional because of
5394 scalarization which passes arrays elements to the procedure,
5395 ignoring the fact that the array can be absent/unallocated/... */
5396 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5398 tree descriptor_data;
5400 descriptor_data = ss->info->data.array.data;
5401 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5403 fold_convert (TREE_TYPE (descriptor_data),
5404 null_pointer_node));
5406 = fold_build3_loc (input_location, COND_EXPR,
5407 TREE_TYPE (parmse.expr),
5408 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5409 fold_convert (TREE_TYPE (parmse.expr),
5414 /* The scalarizer does not repackage the reference to a class
5415 array - instead it returns a pointer to the data element. */
5416 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5417 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5418 fsym->attr.intent != INTENT_IN
5419 && (CLASS_DATA (fsym)->attr.class_pointer
5420 || CLASS_DATA (fsym)->attr.allocatable),
5422 && e->expr_type == EXPR_VARIABLE
5423 && e->symtree->n.sym->attr.optional,
5424 CLASS_DATA (fsym)->attr.class_pointer
5425 || CLASS_DATA (fsym)->attr.allocatable);
5432 gfc_init_se (&parmse, NULL);
5434 /* Check whether the expression is a scalar or not; we cannot use
5435 e->rank as it can be nonzero for functions arguments. */
5436 argss = gfc_walk_expr (e);
5437 scalar = argss == gfc_ss_terminator;
5439 gfc_free_ss_chain (argss);
5441 /* Special handling for passing scalar polymorphic coarrays;
5442 otherwise one passes "class->_data.data" instead of "&class". */
5443 if (e->rank == 0 && e->ts.type == BT_CLASS
5444 && fsym && fsym->ts.type == BT_CLASS
5445 && CLASS_DATA (fsym)->attr.codimension
5446 && !CLASS_DATA (fsym)->attr.dimension)
5448 gfc_add_class_array_ref (e);
5449 parmse.want_coarray = 1;
5453 /* A scalar or transformational function. */
5456 if (e->expr_type == EXPR_VARIABLE
5457 && e->symtree->n.sym->attr.cray_pointee
5458 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5460 /* The Cray pointer needs to be converted to a pointer to
5461 a type given by the expression. */
5462 gfc_conv_expr (&parmse, e);
5463 type = build_pointer_type (TREE_TYPE (parmse.expr));
5464 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5465 parmse.expr = convert (type, tmp);
5468 else if (sym->attr.is_bind_c && e
5469 && (is_CFI_desc (fsym, NULL)
5470 || non_unity_length_string))
5471 /* Implement F2018, C.12.6.1: paragraph (2). */
5472 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5474 else if (fsym && fsym->attr.value)
5476 if (fsym->ts.type == BT_CHARACTER
5477 && fsym->ts.is_c_interop
5478 && fsym->ns->proc_name != NULL
5479 && fsym->ns->proc_name->attr.is_bind_c)
5482 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5483 if (parmse.expr == NULL)
5484 gfc_conv_expr (&parmse, e);
5488 gfc_conv_expr (&parmse, e);
5489 if (fsym->attr.optional
5490 && fsym->ts.type != BT_CLASS
5491 && fsym->ts.type != BT_DERIVED)
5493 if (e->expr_type != EXPR_VARIABLE
5494 || !e->symtree->n.sym->attr.optional
5496 vec_safe_push (optionalargs, boolean_true_node);
5499 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5500 if (!e->symtree->n.sym->attr.value)
5502 = fold_build3_loc (input_location, COND_EXPR,
5503 TREE_TYPE (parmse.expr),
5505 fold_convert (TREE_TYPE (parmse.expr),
5506 integer_zero_node));
5508 vec_safe_push (optionalargs, tmp);
5514 else if (arg->name && arg->name[0] == '%')
5515 /* Argument list functions %VAL, %LOC and %REF are signalled
5516 through arg->name. */
5517 conv_arglist_function (&parmse, arg->expr, arg->name);
5518 else if ((e->expr_type == EXPR_FUNCTION)
5519 && ((e->value.function.esym
5520 && e->value.function.esym->result->attr.pointer)
5521 || (!e->value.function.esym
5522 && e->symtree->n.sym->attr.pointer))
5523 && fsym && fsym->attr.target)
5525 gfc_conv_expr (&parmse, e);
5526 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5529 else if (e->expr_type == EXPR_FUNCTION
5530 && e->symtree->n.sym->result
5531 && e->symtree->n.sym->result != e->symtree->n.sym
5532 && e->symtree->n.sym->result->attr.proc_pointer)
5534 /* Functions returning procedure pointers. */
5535 gfc_conv_expr (&parmse, e);
5536 if (fsym && fsym->attr.proc_pointer)
5537 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5542 if (e->ts.type == BT_CLASS && fsym
5543 && fsym->ts.type == BT_CLASS
5544 && (!CLASS_DATA (fsym)->as
5545 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5546 && CLASS_DATA (e)->attr.codimension)
5548 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5549 gcc_assert (!CLASS_DATA (fsym)->as);
5550 gfc_add_class_array_ref (e);
5551 parmse.want_coarray = 1;
5552 gfc_conv_expr_reference (&parmse, e);
5553 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5555 && e->expr_type == EXPR_VARIABLE);
5557 else if (e->ts.type == BT_CLASS && fsym
5558 && fsym->ts.type == BT_CLASS
5559 && !CLASS_DATA (fsym)->as
5560 && !CLASS_DATA (e)->as
5561 && strcmp (fsym->ts.u.derived->name,
5562 e->ts.u.derived->name))
5564 type = gfc_typenode_for_spec (&fsym->ts);
5565 var = gfc_create_var (type, fsym->name);
5566 gfc_conv_expr (&parmse, e);
5567 if (fsym->attr.optional
5568 && e->expr_type == EXPR_VARIABLE
5569 && e->symtree->n.sym->attr.optional)
5573 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5574 cond = fold_build2_loc (input_location, NE_EXPR,
5575 logical_type_node, tmp,
5576 fold_convert (TREE_TYPE (tmp),
5577 null_pointer_node));
5578 gfc_start_block (&block);
5579 gfc_add_modify (&block, var,
5580 fold_build1_loc (input_location,
5582 type, parmse.expr));
5583 gfc_add_expr_to_block (&parmse.pre,
5584 fold_build3_loc (input_location,
5585 COND_EXPR, void_type_node,
5586 cond, gfc_finish_block (&block),
5587 build_empty_stmt (input_location)));
5588 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5589 parmse.expr = build3_loc (input_location, COND_EXPR,
5590 TREE_TYPE (parmse.expr),
5592 fold_convert (TREE_TYPE (parmse.expr),
5593 null_pointer_node));
5597 /* Since the internal representation of unlimited
5598 polymorphic expressions includes an extra field
5599 that other class objects do not, a cast to the
5600 formal type does not work. */
5601 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5605 /* Set the _data field. */
5606 tmp = gfc_class_data_get (var);
5607 efield = fold_convert (TREE_TYPE (tmp),
5608 gfc_class_data_get (parmse.expr));
5609 gfc_add_modify (&parmse.pre, tmp, efield);
5611 /* Set the _vptr field. */
5612 tmp = gfc_class_vptr_get (var);
5613 efield = fold_convert (TREE_TYPE (tmp),
5614 gfc_class_vptr_get (parmse.expr));
5615 gfc_add_modify (&parmse.pre, tmp, efield);
5617 /* Set the _len field. */
5618 tmp = gfc_class_len_get (var);
5619 gfc_add_modify (&parmse.pre, tmp,
5620 build_int_cst (TREE_TYPE (tmp), 0));
5624 tmp = fold_build1_loc (input_location,
5627 gfc_add_modify (&parmse.pre, var, tmp);
5630 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5636 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5637 && !fsym->attr.allocatable && !fsym->attr.pointer
5638 && !e->symtree->n.sym->attr.dimension
5639 && !e->symtree->n.sym->attr.pointer
5641 && !e->symtree->n.sym->attr.dummy
5642 /* FIXME - PR 87395 and PR 41453 */
5643 && e->symtree->n.sym->attr.save == SAVE_NONE
5644 && !e->symtree->n.sym->attr.associate_var
5645 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5646 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5648 gfc_conv_expr_reference (&parmse, e, add_clobber);
5650 /* Catch base objects that are not variables. */
5651 if (e->ts.type == BT_CLASS
5652 && e->expr_type != EXPR_VARIABLE
5653 && expr && e == expr->base_expr)
5654 base_object = build_fold_indirect_ref_loc (input_location,
5657 /* A class array element needs converting back to be a
5658 class object, if the formal argument is a class object. */
5659 if (fsym && fsym->ts.type == BT_CLASS
5660 && e->ts.type == BT_CLASS
5661 && ((CLASS_DATA (fsym)->as
5662 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5663 || CLASS_DATA (e)->attr.dimension))
5664 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5665 fsym->attr.intent != INTENT_IN
5666 && (CLASS_DATA (fsym)->attr.class_pointer
5667 || CLASS_DATA (fsym)->attr.allocatable),
5669 && e->expr_type == EXPR_VARIABLE
5670 && e->symtree->n.sym->attr.optional,
5671 CLASS_DATA (fsym)->attr.class_pointer
5672 || CLASS_DATA (fsym)->attr.allocatable);
5674 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5675 allocated on entry, it must be deallocated. */
5676 if (fsym && fsym->attr.intent == INTENT_OUT
5677 && (fsym->attr.allocatable
5678 || (fsym->ts.type == BT_CLASS
5679 && CLASS_DATA (fsym)->attr.allocatable)))
5684 gfc_init_block (&block);
5686 if (e->ts.type == BT_CLASS)
5687 ptr = gfc_class_data_get (ptr);
5689 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5692 gfc_add_expr_to_block (&block, tmp);
5693 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5694 void_type_node, ptr,
5696 gfc_add_expr_to_block (&block, tmp);
5698 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5700 gfc_add_modify (&block, ptr,
5701 fold_convert (TREE_TYPE (ptr),
5702 null_pointer_node));
5703 gfc_add_expr_to_block (&block, tmp);
5705 else if (fsym->ts.type == BT_CLASS)
5708 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5709 tmp = gfc_get_symbol_decl (vtab);
5710 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5711 ptr = gfc_class_vptr_get (parmse.expr);
5712 gfc_add_modify (&block, ptr,
5713 fold_convert (TREE_TYPE (ptr), tmp));
5714 gfc_add_expr_to_block (&block, tmp);
5717 if (fsym->attr.optional
5718 && e->expr_type == EXPR_VARIABLE
5719 && e->symtree->n.sym->attr.optional)
5721 tmp = fold_build3_loc (input_location, COND_EXPR,
5723 gfc_conv_expr_present (e->symtree->n.sym),
5724 gfc_finish_block (&block),
5725 build_empty_stmt (input_location));
5728 tmp = gfc_finish_block (&block);
5730 gfc_add_expr_to_block (&se->pre, tmp);
5733 if (fsym && (fsym->ts.type == BT_DERIVED
5734 || fsym->ts.type == BT_ASSUMED)
5735 && e->ts.type == BT_CLASS
5736 && !CLASS_DATA (e)->attr.dimension
5737 && !CLASS_DATA (e)->attr.codimension)
5739 parmse.expr = gfc_class_data_get (parmse.expr);
5740 /* The result is a class temporary, whose _data component
5741 must be freed to avoid a memory leak. */
5742 if (e->expr_type == EXPR_FUNCTION
5743 && CLASS_DATA (e)->attr.allocatable)
5749 /* Borrow the function symbol to make a call to
5750 gfc_add_finalizer_call and then restore it. */
5751 tmp = e->symtree->n.sym->backend_decl;
5752 e->symtree->n.sym->backend_decl
5753 = TREE_OPERAND (parmse.expr, 0);
5754 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5755 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5756 finalized = gfc_add_finalizer_call (&parmse.post,
5758 gfc_free_expr (var);
5759 e->symtree->n.sym->backend_decl = tmp;
5760 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5762 /* Then free the class _data. */
5763 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5764 tmp = fold_build2_loc (input_location, NE_EXPR,
5767 tmp = build3_v (COND_EXPR, tmp,
5768 gfc_call_free (parmse.expr),
5769 build_empty_stmt (input_location));
5770 gfc_add_expr_to_block (&parmse.post, tmp);
5771 gfc_add_modify (&parmse.post, parmse.expr, zero);
5775 /* Wrap scalar variable in a descriptor. We need to convert
5776 the address of a pointer back to the pointer itself before,
5777 we can assign it to the data field. */
5779 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5780 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5783 if (TREE_CODE (tmp) == ADDR_EXPR)
5784 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5785 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5787 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5790 else if (fsym && e->expr_type != EXPR_NULL
5791 && ((fsym->attr.pointer
5792 && fsym->attr.flavor != FL_PROCEDURE)
5793 || (fsym->attr.proc_pointer
5794 && !(e->expr_type == EXPR_VARIABLE
5795 && e->symtree->n.sym->attr.dummy))
5796 || (fsym->attr.proc_pointer
5797 && e->expr_type == EXPR_VARIABLE
5798 && gfc_is_proc_ptr_comp (e))
5799 || (fsym->attr.allocatable
5800 && fsym->attr.flavor != FL_PROCEDURE)))
5802 /* Scalar pointer dummy args require an extra level of
5803 indirection. The null pointer already contains
5804 this level of indirection. */
5805 parm_kind = SCALAR_POINTER;
5806 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5810 else if (e->ts.type == BT_CLASS
5811 && fsym && fsym->ts.type == BT_CLASS
5812 && (CLASS_DATA (fsym)->attr.dimension
5813 || CLASS_DATA (fsym)->attr.codimension))
5815 /* Pass a class array. */
5816 parmse.use_offset = 1;
5817 gfc_conv_expr_descriptor (&parmse, e);
5819 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5820 allocated on entry, it must be deallocated. */
5821 if (fsym->attr.intent == INTENT_OUT
5822 && CLASS_DATA (fsym)->attr.allocatable)
5827 gfc_init_block (&block);
5829 ptr = gfc_class_data_get (ptr);
5831 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5832 NULL_TREE, NULL_TREE,
5834 GFC_CAF_COARRAY_NOCOARRAY);
5835 gfc_add_expr_to_block (&block, tmp);
5836 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5837 void_type_node, ptr,
5839 gfc_add_expr_to_block (&block, tmp);
5840 gfc_reset_vptr (&block, e);
5842 if (fsym->attr.optional
5843 && e->expr_type == EXPR_VARIABLE
5845 || (e->ref->type == REF_ARRAY
5846 && e->ref->u.ar.type != AR_FULL))
5847 && e->symtree->n.sym->attr.optional)
5849 tmp = fold_build3_loc (input_location, COND_EXPR,
5851 gfc_conv_expr_present (e->symtree->n.sym),
5852 gfc_finish_block (&block),
5853 build_empty_stmt (input_location));
5856 tmp = gfc_finish_block (&block);
5858 gfc_add_expr_to_block (&se->pre, tmp);
5861 /* The conversion does not repackage the reference to a class
5862 array - _data descriptor. */
5863 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5864 fsym->attr.intent != INTENT_IN
5865 && (CLASS_DATA (fsym)->attr.class_pointer
5866 || CLASS_DATA (fsym)->attr.allocatable),
5868 && e->expr_type == EXPR_VARIABLE
5869 && e->symtree->n.sym->attr.optional,
5870 CLASS_DATA (fsym)->attr.class_pointer
5871 || CLASS_DATA (fsym)->attr.allocatable);
5875 /* If the argument is a function call that may not create
5876 a temporary for the result, we have to check that we
5877 can do it, i.e. that there is no alias between this
5878 argument and another one. */
5879 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5885 intent = fsym->attr.intent;
5887 intent = INTENT_UNKNOWN;
5889 if (gfc_check_fncall_dependency (e, intent, sym, args,
5891 parmse.force_tmp = 1;
5893 iarg = e->value.function.actual->expr;
5895 /* Temporary needed if aliasing due to host association. */
5896 if (sym->attr.contained
5898 && !sym->attr.implicit_pure
5899 && !sym->attr.use_assoc
5900 && iarg->expr_type == EXPR_VARIABLE
5901 && sym->ns == iarg->symtree->n.sym->ns)
5902 parmse.force_tmp = 1;
5904 /* Ditto within module. */
5905 if (sym->attr.use_assoc
5907 && !sym->attr.implicit_pure
5908 && iarg->expr_type == EXPR_VARIABLE
5909 && sym->module == iarg->symtree->n.sym->module)
5910 parmse.force_tmp = 1;
5913 if (sym->attr.is_bind_c && e
5914 && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
5915 /* Implement F2018, C.12.6.1: paragraph (2). */
5916 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5918 else if (e->expr_type == EXPR_VARIABLE
5919 && is_subref_array (e)
5920 && !(fsym && fsym->attr.pointer))
5921 /* The actual argument is a component reference to an
5922 array of derived types. In this case, the argument
5923 is converted to a temporary, which is passed and then
5924 written back after the procedure call. */
5925 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5926 fsym ? fsym->attr.intent : INTENT_INOUT,
5927 fsym && fsym->attr.pointer);
5929 else if (gfc_is_class_array_ref (e, NULL)
5930 && fsym && fsym->ts.type == BT_DERIVED)
5931 /* The actual argument is a component reference to an
5932 array of derived types. In this case, the argument
5933 is converted to a temporary, which is passed and then
5934 written back after the procedure call.
5935 OOP-TODO: Insert code so that if the dynamic type is
5936 the same as the declared type, copy-in/copy-out does
5938 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5939 fsym ? fsym->attr.intent : INTENT_INOUT,
5940 fsym && fsym->attr.pointer);
5942 else if (gfc_is_class_array_function (e)
5943 && fsym && fsym->ts.type == BT_DERIVED)
5944 /* See previous comment. For function actual argument,
5945 the write out is not needed so the intent is set as
5948 e->must_finalize = 1;
5949 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5951 fsym && fsym->attr.pointer);
5953 else if (fsym && fsym->attr.contiguous
5954 && !gfc_is_simply_contiguous (e, false, true))
5956 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5957 fsym ? fsym->attr.intent : INTENT_INOUT,
5958 fsym && fsym->attr.pointer);
5961 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5964 /* Unallocated allocatable arrays and unassociated pointer arrays
5965 need their dtype setting if they are argument associated with
5966 assumed rank dummies. */
5967 if (!sym->attr.is_bind_c && e && fsym && fsym->as
5968 && fsym->as->type == AS_ASSUMED_RANK)
5970 if (gfc_expr_attr (e).pointer
5971 || gfc_expr_attr (e).allocatable)
5972 set_dtype_for_unallocated (&parmse, e);
5973 else if (e->expr_type == EXPR_VARIABLE
5974 && e->symtree->n.sym->attr.dummy
5975 && e->symtree->n.sym->as
5976 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
5979 tmp = build_fold_indirect_ref_loc (input_location,
5981 minus_one = build_int_cst (gfc_array_index_type, -1);
5982 gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
5983 gfc_rank_cst[e->rank - 1],
5988 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5989 allocated on entry, it must be deallocated. */
5990 if (fsym && fsym->attr.allocatable
5991 && fsym->attr.intent == INTENT_OUT)
5993 if (fsym->ts.type == BT_DERIVED
5994 && fsym->ts.u.derived->attr.alloc_comp)
5996 // deallocate the components first
5997 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5998 parmse.expr, e->rank);
5999 if (tmp != NULL_TREE)
6000 gfc_add_expr_to_block (&se->pre, tmp);
6003 tmp = build_fold_indirect_ref_loc (input_location,
6005 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
6006 tmp = gfc_conv_descriptor_data_get (tmp);
6007 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6008 NULL_TREE, NULL_TREE, true,
6010 GFC_CAF_COARRAY_NOCOARRAY);
6011 if (fsym->attr.optional
6012 && e->expr_type == EXPR_VARIABLE
6013 && e->symtree->n.sym->attr.optional)
6014 tmp = fold_build3_loc (input_location, COND_EXPR,
6016 gfc_conv_expr_present (e->symtree->n.sym),
6017 tmp, build_empty_stmt (input_location));
6018 gfc_add_expr_to_block (&se->pre, tmp);
6023 /* The case with fsym->attr.optional is that of a user subroutine
6024 with an interface indicating an optional argument. When we call
6025 an intrinsic subroutine, however, fsym is NULL, but we might still
6026 have an optional argument, so we proceed to the substitution
6028 if (e && (fsym == NULL || fsym->attr.optional))
6030 /* If an optional argument is itself an optional dummy argument,
6031 check its presence and substitute a null if absent. This is
6032 only needed when passing an array to an elemental procedure
6033 as then array elements are accessed - or no NULL pointer is
6034 allowed and a "1" or "0" should be passed if not present.
6035 When passing a non-array-descriptor full array to a
6036 non-array-descriptor dummy, no check is needed. For
6037 array-descriptor actual to array-descriptor dummy, see
6038 PR 41911 for why a check has to be inserted.
6039 fsym == NULL is checked as intrinsics required the descriptor
6040 but do not always set fsym.
6041 Also, it is necessary to pass a NULL pointer to library routines
6042 which usually ignore optional arguments, so they can handle
6043 these themselves. */
6044 if (e->expr_type == EXPR_VARIABLE
6045 && e->symtree->n.sym->attr.optional
6046 && (((e->rank != 0 && elemental_proc)
6047 || e->representation.length || e->ts.type == BT_CHARACTER
6051 && (fsym->as->type == AS_ASSUMED_SHAPE
6052 || fsym->as->type == AS_ASSUMED_RANK
6053 || fsym->as->type == AS_DEFERRED)))))
6054 || se->ignore_optional))
6055 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
6056 e->representation.length);
6061 /* Obtain the character length of an assumed character length
6062 length procedure from the typespec. */
6063 if (fsym->ts.type == BT_CHARACTER
6064 && parmse.string_length == NULL_TREE
6065 && e->ts.type == BT_PROCEDURE
6066 && e->symtree->n.sym->ts.type == BT_CHARACTER
6067 && e->symtree->n.sym->ts.u.cl->length != NULL
6068 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6070 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
6071 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
6075 if (fsym && need_interface_mapping && e)
6076 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
6078 gfc_add_block_to_block (&se->pre, &parmse.pre);
6079 gfc_add_block_to_block (&post, &parmse.post);
6081 /* Allocated allocatable components of derived types must be
6082 deallocated for non-variable scalars, array arguments to elemental
6083 procedures, and array arguments with descriptor to non-elemental
6084 procedures. As bounds information for descriptorless arrays is no
6085 longer available here, they are dealt with in trans-array.c
6086 (gfc_conv_array_parameter). */
6087 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
6088 && e->ts.u.derived->attr.alloc_comp
6089 && (e->rank == 0 || elemental_proc || !nodesc_arg)
6090 && !expr_may_alias_variables (e, elemental_proc))
6093 /* It is known the e returns a structure type with at least one
6094 allocatable component. When e is a function, ensure that the
6095 function is called once only by using a temporary variable. */
6096 if (!DECL_P (parmse.expr))
6097 parmse.expr = gfc_evaluate_now_loc (input_location,
6098 parmse.expr, &se->pre);
6100 if (fsym && fsym->attr.value)
6103 tmp = build_fold_indirect_ref_loc (input_location,
6106 parm_rank = e->rank;
6114 case (SCALAR_POINTER):
6115 tmp = build_fold_indirect_ref_loc (input_location,
6120 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
6122 /* The derived type is passed to gfc_deallocate_alloc_comp.
6123 Therefore, class actuals can be handled correctly but derived
6124 types passed to class formals need the _data component. */
6125 tmp = gfc_class_data_get (tmp);
6126 if (!CLASS_DATA (fsym)->attr.dimension)
6127 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6130 if (e->expr_type == EXPR_OP
6131 && e->value.op.op == INTRINSIC_PARENTHESES
6132 && e->value.op.op1->expr_type == EXPR_VARIABLE)
6135 local_tmp = gfc_evaluate_now (tmp, &se->pre);
6136 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
6138 gfc_add_expr_to_block (&se->post, local_tmp);
6141 if (!finalized && !e->must_finalize)
6143 if ((e->ts.type == BT_CLASS
6144 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
6145 || e->ts.type == BT_DERIVED)
6146 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
6148 else if (e->ts.type == BT_CLASS)
6149 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
6151 gfc_prepend_expr_to_block (&post, tmp);
6155 /* Add argument checking of passing an unallocated/NULL actual to
6156 a nonallocatable/nonpointer dummy. */
6158 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
6160 symbol_attribute attr;
6164 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
6165 attr = gfc_expr_attr (e);
6167 goto end_pointer_check;
6169 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6170 allocatable to an optional dummy, cf. 12.5.2.12. */
6171 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
6172 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6173 goto end_pointer_check;
6177 /* If the actual argument is an optional pointer/allocatable and
6178 the formal argument takes an nonpointer optional value,
6179 it is invalid to pass a non-present argument on, even
6180 though there is no technical reason for this in gfortran.
6181 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6182 tree present, null_ptr, type;
6184 if (attr.allocatable
6185 && (fsym == NULL || !fsym->attr.allocatable))
6186 msg = xasprintf ("Allocatable actual argument '%s' is not "
6187 "allocated or not present",
6188 e->symtree->n.sym->name);
6189 else if (attr.pointer
6190 && (fsym == NULL || !fsym->attr.pointer))
6191 msg = xasprintf ("Pointer actual argument '%s' is not "
6192 "associated or not present",
6193 e->symtree->n.sym->name);
6194 else if (attr.proc_pointer
6195 && (fsym == NULL || !fsym->attr.proc_pointer))
6196 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6197 "associated or not present",
6198 e->symtree->n.sym->name);
6200 goto end_pointer_check;
6202 present = gfc_conv_expr_present (e->symtree->n.sym);
6203 type = TREE_TYPE (present);
6204 present = fold_build2_loc (input_location, EQ_EXPR,
6205 logical_type_node, present,
6207 null_pointer_node));
6208 type = TREE_TYPE (parmse.expr);
6209 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
6210 logical_type_node, parmse.expr,
6212 null_pointer_node));
6213 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6214 logical_type_node, present, null_ptr);
6218 if (attr.allocatable
6219 && (fsym == NULL || !fsym->attr.allocatable))
6220 msg = xasprintf ("Allocatable actual argument '%s' is not "
6221 "allocated", e->symtree->n.sym->name);
6222 else if (attr.pointer
6223 && (fsym == NULL || !fsym->attr.pointer))
6224 msg = xasprintf ("Pointer actual argument '%s' is not "
6225 "associated", e->symtree->n.sym->name);
6226 else if (attr.proc_pointer
6227 && (fsym == NULL || !fsym->attr.proc_pointer))
6228 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6229 "associated", e->symtree->n.sym->name);
6231 goto end_pointer_check;
6235 /* If the argument is passed by value, we need to strip the
6237 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
6238 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6240 cond = fold_build2_loc (input_location, EQ_EXPR,
6241 logical_type_node, tmp,
6242 fold_convert (TREE_TYPE (tmp),
6243 null_pointer_node));
6246 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
6252 /* Deferred length dummies pass the character length by reference
6253 so that the value can be returned. */
6254 if (parmse.string_length && fsym && fsym->ts.deferred)
6256 if (INDIRECT_REF_P (parmse.string_length))
6257 /* In chains of functions/procedure calls the string_length already
6258 is a pointer to the variable holding the length. Therefore
6259 remove the deref on call. */
6260 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
6263 tmp = parmse.string_length;
6264 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
6265 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
6266 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
6270 /* Character strings are passed as two parameters, a length and a
6271 pointer - except for Bind(c) which only passes the pointer.
6272 An unlimited polymorphic formal argument likewise does not
6274 if (parmse.string_length != NULL_TREE
6275 && !sym->attr.is_bind_c
6276 && !(fsym && UNLIMITED_POLY (fsym)))
6277 vec_safe_push (stringargs, parmse.string_length);
6279 /* When calling __copy for character expressions to unlimited
6280 polymorphic entities, the dst argument needs a string length. */
6281 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
6282 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
6283 && arg->next && arg->next->expr
6284 && (arg->next->expr->ts.type == BT_DERIVED
6285 || arg->next->expr->ts.type == BT_CLASS)
6286 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
6287 vec_safe_push (stringargs, parmse.string_length);
6289 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6290 pass the token and the offset as additional arguments. */
6291 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
6292 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6293 && !fsym->attr.allocatable)
6294 || (fsym->ts.type == BT_CLASS
6295 && CLASS_DATA (fsym)->attr.codimension
6296 && !CLASS_DATA (fsym)->attr.allocatable)))
6298 /* Token and offset. */
6299 vec_safe_push (stringargs, null_pointer_node);
6300 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
6301 gcc_assert (fsym->attr.optional);
6303 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
6304 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6305 && !fsym->attr.allocatable)
6306 || (fsym->ts.type == BT_CLASS
6307 && CLASS_DATA (fsym)->attr.codimension
6308 && !CLASS_DATA (fsym)->attr.allocatable)))
6310 tree caf_decl, caf_type;
6313 caf_decl = gfc_get_tree_for_caf_expr (e);
6314 caf_type = TREE_TYPE (caf_decl);
6316 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6317 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
6318 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
6319 tmp = gfc_conv_descriptor_token (caf_decl);
6320 else if (DECL_LANG_SPECIFIC (caf_decl)
6321 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
6322 tmp = GFC_DECL_TOKEN (caf_decl);
6325 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
6326 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
6327 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
6330 vec_safe_push (stringargs, tmp);
6332 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6333 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
6334 offset = build_int_cst (gfc_array_index_type, 0);
6335 else if (DECL_LANG_SPECIFIC (caf_decl)
6336 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
6337 offset = GFC_DECL_CAF_OFFSET (caf_decl);
6338 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
6339 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
6341 offset = build_int_cst (gfc_array_index_type, 0);
6343 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
6344 tmp = gfc_conv_descriptor_data_get (caf_decl);
6347 gcc_assert (POINTER_TYPE_P (caf_type));
6351 tmp2 = fsym->ts.type == BT_CLASS
6352 ? gfc_class_data_get (parmse.expr) : parmse.expr;
6353 if ((fsym->ts.type != BT_CLASS
6354 && (fsym->as->type == AS_ASSUMED_SHAPE
6355 || fsym->as->type == AS_ASSUMED_RANK))
6356 || (fsym->ts.type == BT_CLASS
6357 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6358 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6360 if (fsym->ts.type == BT_CLASS)
6361 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6364 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6365 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6367 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6368 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6370 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6371 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6374 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6377 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6378 gfc_array_index_type,
6379 fold_convert (gfc_array_index_type, tmp2),
6380 fold_convert (gfc_array_index_type, tmp));
6381 offset = fold_build2_loc (input_location, PLUS_EXPR,
6382 gfc_array_index_type, offset, tmp);
6384 vec_safe_push (stringargs, offset);
6387 vec_safe_push (arglist, parmse.expr);
6389 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6393 else if (sym->ts.type == BT_CLASS)
6394 ts = CLASS_DATA (sym)->ts;
6398 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6399 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6400 else if (ts.type == BT_CHARACTER)
6402 if (ts.u.cl->length == NULL)
6404 /* Assumed character length results are not allowed by C418 of the 2003
6405 standard and are trapped in resolve.c; except in the case of SPREAD
6406 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6407 we take the character length of the first argument for the result.
6408 For dummies, we have to look through the formal argument list for
6409 this function and use the character length found there.*/
6411 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6412 else if (!sym->attr.dummy)
6413 cl.backend_decl = (*stringargs)[0];
6416 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6417 for (; formal; formal = formal->next)
6418 if (strcmp (formal->sym->name, sym->name) == 0)
6419 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6421 len = cl.backend_decl;
6427 /* Calculate the length of the returned string. */
6428 gfc_init_se (&parmse, NULL);
6429 if (need_interface_mapping)
6430 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6432 gfc_conv_expr (&parmse, ts.u.cl->length);
6433 gfc_add_block_to_block (&se->pre, &parmse.pre);
6434 gfc_add_block_to_block (&se->post, &parmse.post);
6436 /* TODO: It would be better to have the charlens as
6437 gfc_charlen_type_node already when the interface is
6438 created instead of converting it here (see PR 84615). */
6439 tmp = fold_build2_loc (input_location, MAX_EXPR,
6440 gfc_charlen_type_node,
6441 fold_convert (gfc_charlen_type_node, tmp),
6442 build_zero_cst (gfc_charlen_type_node));
6443 cl.backend_decl = tmp;
6446 /* Set up a charlen structure for it. */
6451 len = cl.backend_decl;
6454 byref = (comp && (comp->attr.dimension
6455 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6456 || (!comp && gfc_return_by_reference (sym));
6459 if (se->direct_byref)
6461 /* Sometimes, too much indirection can be applied; e.g. for
6462 function_result = array_valued_recursive_function. */
6463 if (TREE_TYPE (TREE_TYPE (se->expr))
6464 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6465 && GFC_DESCRIPTOR_TYPE_P
6466 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6467 se->expr = build_fold_indirect_ref_loc (input_location,
6470 /* If the lhs of an assignment x = f(..) is allocatable and
6471 f2003 is allowed, we must do the automatic reallocation.
6472 TODO - deal with intrinsics, without using a temporary. */
6473 if (flag_realloc_lhs
6474 && se->ss && se->ss->loop_chain
6475 && se->ss->loop_chain->is_alloc_lhs
6476 && !expr->value.function.isym
6477 && sym->result->as != NULL)
6479 /* Evaluate the bounds of the result, if known. */
6480 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6483 /* Perform the automatic reallocation. */
6484 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6486 gfc_add_expr_to_block (&se->pre, tmp);
6488 /* Pass the temporary as the first argument. */
6489 result = info->descriptor;
6492 result = build_fold_indirect_ref_loc (input_location,
6494 vec_safe_push (retargs, se->expr);
6496 else if (comp && comp->attr.dimension)
6498 gcc_assert (se->loop && info);
6500 /* Set the type of the array. */
6501 tmp = gfc_typenode_for_spec (&comp->ts);
6502 gcc_assert (se->ss->dimen == se->loop->dimen);
6504 /* Evaluate the bounds of the result, if known. */
6505 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6507 /* If the lhs of an assignment x = f(..) is allocatable and
6508 f2003 is allowed, we must not generate the function call
6509 here but should just send back the results of the mapping.
6510 This is signalled by the function ss being flagged. */
6511 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6513 gfc_free_interface_mapping (&mapping);
6514 return has_alternate_specifier;
6517 /* Create a temporary to store the result. In case the function
6518 returns a pointer, the temporary will be a shallow copy and
6519 mustn't be deallocated. */
6520 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6521 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6522 tmp, NULL_TREE, false,
6523 !comp->attr.pointer, callee_alloc,
6524 &se->ss->info->expr->where);
6526 /* Pass the temporary as the first argument. */
6527 result = info->descriptor;
6528 tmp = gfc_build_addr_expr (NULL_TREE, result);
6529 vec_safe_push (retargs, tmp);
6531 else if (!comp && sym->result->attr.dimension)
6533 gcc_assert (se->loop && info);
6535 /* Set the type of the array. */
6536 tmp = gfc_typenode_for_spec (&ts);
6537 gcc_assert (se->ss->dimen == se->loop->dimen);
6539 /* Evaluate the bounds of the result, if known. */
6540 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6542 /* If the lhs of an assignment x = f(..) is allocatable and
6543 f2003 is allowed, we must not generate the function call
6544 here but should just send back the results of the mapping.
6545 This is signalled by the function ss being flagged. */
6546 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6548 gfc_free_interface_mapping (&mapping);
6549 return has_alternate_specifier;
6552 /* Create a temporary to store the result. In case the function
6553 returns a pointer, the temporary will be a shallow copy and
6554 mustn't be deallocated. */
6555 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6556 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6557 tmp, NULL_TREE, false,
6558 !sym->attr.pointer, callee_alloc,
6559 &se->ss->info->expr->where);
6561 /* Pass the temporary as the first argument. */
6562 result = info->descriptor;
6563 tmp = gfc_build_addr_expr (NULL_TREE, result);
6564 vec_safe_push (retargs, tmp);
6566 else if (ts.type == BT_CHARACTER)
6568 /* Pass the string length. */
6569 type = gfc_get_character_type (ts.kind, ts.u.cl);
6570 type = build_pointer_type (type);
6572 /* Emit a DECL_EXPR for the VLA type. */
6573 tmp = TREE_TYPE (type);
6575 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6577 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6578 DECL_ARTIFICIAL (tmp) = 1;
6579 DECL_IGNORED_P (tmp) = 1;
6580 tmp = fold_build1_loc (input_location, DECL_EXPR,
6581 TREE_TYPE (tmp), tmp);
6582 gfc_add_expr_to_block (&se->pre, tmp);
6585 /* Return an address to a char[0:len-1]* temporary for
6586 character pointers. */
6587 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6588 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6590 var = gfc_create_var (type, "pstr");
6592 if ((!comp && sym->attr.allocatable)
6593 || (comp && comp->attr.allocatable))
6595 gfc_add_modify (&se->pre, var,
6596 fold_convert (TREE_TYPE (var),
6597 null_pointer_node));
6598 tmp = gfc_call_free (var);
6599 gfc_add_expr_to_block (&se->post, tmp);
6602 /* Provide an address expression for the function arguments. */
6603 var = gfc_build_addr_expr (NULL_TREE, var);
6606 var = gfc_conv_string_tmp (se, type, len);
6608 vec_safe_push (retargs, var);
6612 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6614 type = gfc_get_complex_type (ts.kind);
6615 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6616 vec_safe_push (retargs, var);
6619 /* Add the string length to the argument list. */
6620 if (ts.type == BT_CHARACTER && ts.deferred)
6624 tmp = gfc_evaluate_now (len, &se->pre);
6625 TREE_STATIC (tmp) = 1;
6626 gfc_add_modify (&se->pre, tmp,
6627 build_int_cst (TREE_TYPE (tmp), 0));
6628 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6629 vec_safe_push (retargs, tmp);
6631 else if (ts.type == BT_CHARACTER)
6632 vec_safe_push (retargs, len);
6634 gfc_free_interface_mapping (&mapping);
6636 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6637 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6638 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6639 vec_safe_reserve (retargs, arglen);
6641 /* Add the return arguments. */
6642 vec_safe_splice (retargs, arglist);
6644 /* Add the hidden present status for optional+value to the arguments. */
6645 vec_safe_splice (retargs, optionalargs);
6647 /* Add the hidden string length parameters to the arguments. */
6648 vec_safe_splice (retargs, stringargs);
6650 /* We may want to append extra arguments here. This is used e.g. for
6651 calls to libgfortran_matmul_??, which need extra information. */
6652 vec_safe_splice (retargs, append_args);
6656 /* Generate the actual call. */
6657 if (base_object == NULL_TREE)
6658 conv_function_val (se, sym, expr, args);
6660 conv_base_obj_fcn_val (se, base_object, expr);
6662 /* If there are alternate return labels, function type should be
6663 integer. Can't modify the type in place though, since it can be shared
6664 with other functions. For dummy arguments, the typing is done to
6665 this result, even if it has to be repeated for each call. */
6666 if (has_alternate_specifier
6667 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6669 if (!sym->attr.dummy)
6671 TREE_TYPE (sym->backend_decl)
6672 = build_function_type (integer_type_node,
6673 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6674 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6677 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6680 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6681 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6683 /* Allocatable scalar function results must be freed and nullified
6684 after use. This necessitates the creation of a temporary to
6685 hold the result to prevent duplicate calls. */
6686 if (!byref && sym->ts.type != BT_CHARACTER
6687 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6688 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6690 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6691 gfc_add_modify (&se->pre, tmp, se->expr);
6693 tmp = gfc_call_free (tmp);
6694 gfc_add_expr_to_block (&post, tmp);
6695 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6698 /* If we have a pointer function, but we don't want a pointer, e.g.
6701 where f is pointer valued, we have to dereference the result. */
6702 if (!se->want_pointer && !byref
6703 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6704 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6705 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6707 /* f2c calling conventions require a scalar default real function to
6708 return a double precision result. Convert this back to default
6709 real. We only care about the cases that can happen in Fortran 77.
6711 if (flag_f2c && sym->ts.type == BT_REAL
6712 && sym->ts.kind == gfc_default_real_kind
6713 && !sym->attr.always_explicit)
6714 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6716 /* A pure function may still have side-effects - it may modify its
6718 TREE_SIDE_EFFECTS (se->expr) = 1;
6720 if (!sym->attr.pure)
6721 TREE_SIDE_EFFECTS (se->expr) = 1;
6726 /* Add the function call to the pre chain. There is no expression. */
6727 gfc_add_expr_to_block (&se->pre, se->expr);
6728 se->expr = NULL_TREE;
6730 if (!se->direct_byref)
6732 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6734 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6736 /* Check the data pointer hasn't been modified. This would
6737 happen in a function returning a pointer. */
6738 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6739 tmp = fold_build2_loc (input_location, NE_EXPR,
6742 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6745 se->expr = info->descriptor;
6746 /* Bundle in the string length. */
6747 se->string_length = len;
6749 else if (ts.type == BT_CHARACTER)
6751 /* Dereference for character pointer results. */
6752 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6753 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6754 se->expr = build_fold_indirect_ref_loc (input_location, var);
6758 se->string_length = len;
6762 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6763 se->expr = build_fold_indirect_ref_loc (input_location, var);
6768 /* Associate the rhs class object's meta-data with the result, when the
6769 result is a temporary. */
6770 if (args && args->expr && args->expr->ts.type == BT_CLASS
6771 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6772 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6775 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6777 gfc_init_se (&parmse, NULL);
6778 parmse.data_not_needed = 1;
6779 gfc_conv_expr (&parmse, class_expr);
6780 if (!DECL_LANG_SPECIFIC (result))
6781 gfc_allocate_lang_decl (result);
6782 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6783 gfc_free_expr (class_expr);
6784 gcc_assert (parmse.pre.head == NULL_TREE
6785 && parmse.post.head == NULL_TREE);
6788 /* Follow the function call with the argument post block. */
6791 gfc_add_block_to_block (&se->pre, &post);
6793 /* Transformational functions of derived types with allocatable
6794 components must have the result allocatable components copied when the
6795 argument is actually given. */
6796 arg = expr->value.function.actual;
6797 if (result && arg && expr->rank
6798 && expr->value.function.isym
6799 && expr->value.function.isym->transformational
6801 && arg->expr->ts.type == BT_DERIVED
6802 && arg->expr->ts.u.derived->attr.alloc_comp)
6805 /* Copy the allocatable components. We have to use a
6806 temporary here to prevent source allocatable components
6807 from being corrupted. */
6808 tmp2 = gfc_evaluate_now (result, &se->pre);
6809 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6810 result, tmp2, expr->rank, 0);
6811 gfc_add_expr_to_block (&se->pre, tmp);
6812 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6814 gfc_add_expr_to_block (&se->pre, tmp);
6816 /* Finally free the temporary's data field. */
6817 tmp = gfc_conv_descriptor_data_get (tmp2);
6818 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6819 NULL_TREE, NULL_TREE, true,
6820 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6821 gfc_add_expr_to_block (&se->pre, tmp);
6826 /* For a function with a class array result, save the result as
6827 a temporary, set the info fields needed by the scalarizer and
6828 call the finalization function of the temporary. Note that the
6829 nullification of allocatable components needed by the result
6830 is done in gfc_trans_assignment_1. */
6831 if (expr && ((gfc_is_class_array_function (expr)
6832 && se->ss && se->ss->loop)
6833 || gfc_is_alloc_class_scalar_function (expr))
6834 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6835 && expr->must_finalize)
6840 if (se->ss && se->ss->loop)
6842 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6843 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6844 tmp = gfc_class_data_get (se->expr);
6845 info->descriptor = tmp;
6846 info->data = gfc_conv_descriptor_data_get (tmp);
6847 info->offset = gfc_conv_descriptor_offset_get (tmp);
6848 for (n = 0; n < se->ss->loop->dimen; n++)
6850 tree dim = gfc_rank_cst[n];
6851 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6852 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6857 /* TODO Eliminate the doubling of temporaries. This
6858 one is necessary to ensure no memory leakage. */
6859 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6860 tmp = gfc_class_data_get (se->expr);
6861 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6862 CLASS_DATA (expr->value.function.esym->result)->attr);
6865 if ((gfc_is_class_array_function (expr)
6866 || gfc_is_alloc_class_scalar_function (expr))
6867 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6868 goto no_finalization;
6870 final_fndecl = gfc_class_vtab_final_get (se->expr);
6871 is_final = fold_build2_loc (input_location, NE_EXPR,
6874 fold_convert (TREE_TYPE (final_fndecl),
6875 null_pointer_node));
6876 final_fndecl = build_fold_indirect_ref_loc (input_location,
6878 tmp = build_call_expr_loc (input_location,
6880 gfc_build_addr_expr (NULL, tmp),
6881 gfc_class_vtab_size_get (se->expr),
6882 boolean_false_node);
6883 tmp = fold_build3_loc (input_location, COND_EXPR,
6884 void_type_node, is_final, tmp,
6885 build_empty_stmt (input_location));
6887 if (se->ss && se->ss->loop)
6889 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
6890 tmp = fold_build2_loc (input_location, NE_EXPR,
6893 fold_convert (TREE_TYPE (info->data),
6894 null_pointer_node));
6895 tmp = fold_build3_loc (input_location, COND_EXPR,
6896 void_type_node, tmp,
6897 gfc_call_free (info->data),
6898 build_empty_stmt (input_location));
6899 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6904 gfc_prepend_expr_to_block (&se->post, tmp);
6905 classdata = gfc_class_data_get (se->expr);
6906 tmp = fold_build2_loc (input_location, NE_EXPR,
6909 fold_convert (TREE_TYPE (classdata),
6910 null_pointer_node));
6911 tmp = fold_build3_loc (input_location, COND_EXPR,
6912 void_type_node, tmp,
6913 gfc_call_free (classdata),
6914 build_empty_stmt (input_location));
6915 gfc_add_expr_to_block (&se->post, tmp);
6920 gfc_add_block_to_block (&se->post, &post);
6923 return has_alternate_specifier;
6927 /* Fill a character string with spaces. */
6930 fill_with_spaces (tree start, tree type, tree size)
6932 stmtblock_t block, loop;
6933 tree i, el, exit_label, cond, tmp;
6935 /* For a simple char type, we can call memset(). */
6936 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6937 return build_call_expr_loc (input_location,
6938 builtin_decl_explicit (BUILT_IN_MEMSET),
6940 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6941 lang_hooks.to_target_charset (' ')),
6942 fold_convert (size_type_node, size));
6944 /* Otherwise, we use a loop:
6945 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6949 /* Initialize variables. */
6950 gfc_init_block (&block);
6951 i = gfc_create_var (sizetype, "i");
6952 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6953 el = gfc_create_var (build_pointer_type (type), "el");
6954 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6955 exit_label = gfc_build_label_decl (NULL_TREE);
6956 TREE_USED (exit_label) = 1;
6960 gfc_init_block (&loop);
6962 /* Exit condition. */
6963 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6964 build_zero_cst (sizetype));
6965 tmp = build1_v (GOTO_EXPR, exit_label);
6966 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6967 build_empty_stmt (input_location));
6968 gfc_add_expr_to_block (&loop, tmp);
6971 gfc_add_modify (&loop,
6972 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6973 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6975 /* Increment loop variables. */
6976 gfc_add_modify (&loop, i,
6977 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6978 TYPE_SIZE_UNIT (type)));
6979 gfc_add_modify (&loop, el,
6980 fold_build_pointer_plus_loc (input_location,
6981 el, TYPE_SIZE_UNIT (type)));
6983 /* Making the loop... actually loop! */
6984 tmp = gfc_finish_block (&loop);
6985 tmp = build1_v (LOOP_EXPR, tmp);
6986 gfc_add_expr_to_block (&block, tmp);
6988 /* The exit label. */
6989 tmp = build1_v (LABEL_EXPR, exit_label);
6990 gfc_add_expr_to_block (&block, tmp);
6993 return gfc_finish_block (&block);
6997 /* Generate code to copy a string. */
7000 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
7001 int dkind, tree slength, tree src, int skind)
7003 tree tmp, dlen, slen;
7012 stmtblock_t tempblock;
7014 gcc_assert (dkind == skind);
7016 if (slength != NULL_TREE)
7018 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
7019 ssc = gfc_string_to_single_character (slen, src, skind);
7023 slen = build_one_cst (gfc_charlen_type_node);
7027 if (dlength != NULL_TREE)
7029 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
7030 dsc = gfc_string_to_single_character (dlen, dest, dkind);
7034 dlen = build_one_cst (gfc_charlen_type_node);
7038 /* Assign directly if the types are compatible. */
7039 if (dsc != NULL_TREE && ssc != NULL_TREE
7040 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
7042 gfc_add_modify (block, dsc, ssc);
7046 /* The string copy algorithm below generates code like
7050 if (srclen < destlen)
7052 memmove (dest, src, srclen);
7054 memset (&dest[srclen], ' ', destlen - srclen);
7058 // Truncate if too long.
7059 memmove (dest, src, destlen);
7064 /* Do nothing if the destination length is zero. */
7065 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
7066 build_zero_cst (TREE_TYPE (dlen)));
7068 /* For non-default character kinds, we have to multiply the string
7069 length by the base type size. */
7070 chartype = gfc_get_char_type (dkind);
7071 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
7073 fold_convert (TREE_TYPE (slen),
7074 TYPE_SIZE_UNIT (chartype)));
7075 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
7077 fold_convert (TREE_TYPE (dlen),
7078 TYPE_SIZE_UNIT (chartype)));
7080 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
7081 dest = fold_convert (pvoid_type_node, dest);
7083 dest = gfc_build_addr_expr (pvoid_type_node, dest);
7085 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
7086 src = fold_convert (pvoid_type_node, src);
7088 src = gfc_build_addr_expr (pvoid_type_node, src);
7090 /* Truncate string if source is too long. */
7091 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
7094 /* Copy and pad with spaces. */
7095 tmp3 = build_call_expr_loc (input_location,
7096 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7098 fold_convert (size_type_node, slen));
7100 /* Wstringop-overflow appears at -O3 even though this warning is not
7101 explicitly available in fortran nor can it be switched off. If the
7102 source length is a constant, its negative appears as a very large
7103 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7104 the result of the MINUS_EXPR suppresses this spurious warning. */
7105 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7106 TREE_TYPE(dlen), dlen, slen);
7107 if (slength && TREE_CONSTANT (slength))
7108 tmp = gfc_evaluate_now (tmp, block);
7110 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
7111 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
7113 gfc_init_block (&tempblock);
7114 gfc_add_expr_to_block (&tempblock, tmp3);
7115 gfc_add_expr_to_block (&tempblock, tmp4);
7116 tmp3 = gfc_finish_block (&tempblock);
7118 /* The truncated memmove if the slen >= dlen. */
7119 tmp2 = build_call_expr_loc (input_location,
7120 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7122 fold_convert (size_type_node, dlen));
7124 /* The whole copy_string function is there. */
7125 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
7127 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7128 build_empty_stmt (input_location));
7129 gfc_add_expr_to_block (block, tmp);
7133 /* Translate a statement function.
7134 The value of a statement function reference is obtained by evaluating the
7135 expression using the values of the actual arguments for the values of the
7136 corresponding dummy arguments. */
7139 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
7143 gfc_formal_arglist *fargs;
7144 gfc_actual_arglist *args;
7147 gfc_saved_var *saved_vars;
7153 sym = expr->symtree->n.sym;
7154 args = expr->value.function.actual;
7155 gfc_init_se (&lse, NULL);
7156 gfc_init_se (&rse, NULL);
7159 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
7161 saved_vars = XCNEWVEC (gfc_saved_var, n);
7162 temp_vars = XCNEWVEC (tree, n);
7164 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7165 fargs = fargs->next, n++)
7167 /* Each dummy shall be specified, explicitly or implicitly, to be
7169 gcc_assert (fargs->sym->attr.dimension == 0);
7172 if (fsym->ts.type == BT_CHARACTER)
7174 /* Copy string arguments. */
7177 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
7178 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
7180 /* Create a temporary to hold the value. */
7181 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
7182 fsym->ts.u.cl->backend_decl
7183 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
7185 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
7186 temp_vars[n] = gfc_create_var (type, fsym->name);
7188 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
7190 gfc_conv_expr (&rse, args->expr);
7191 gfc_conv_string_parameter (&rse);
7192 gfc_add_block_to_block (&se->pre, &lse.pre);
7193 gfc_add_block_to_block (&se->pre, &rse.pre);
7195 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
7196 rse.string_length, rse.expr, fsym->ts.kind);
7197 gfc_add_block_to_block (&se->pre, &lse.post);
7198 gfc_add_block_to_block (&se->pre, &rse.post);
7202 /* For everything else, just evaluate the expression. */
7204 /* Create a temporary to hold the value. */
7205 type = gfc_typenode_for_spec (&fsym->ts);
7206 temp_vars[n] = gfc_create_var (type, fsym->name);
7208 gfc_conv_expr (&lse, args->expr);
7210 gfc_add_block_to_block (&se->pre, &lse.pre);
7211 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
7212 gfc_add_block_to_block (&se->pre, &lse.post);
7218 /* Use the temporary variables in place of the real ones. */
7219 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7220 fargs = fargs->next, n++)
7221 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
7223 gfc_conv_expr (se, sym->value);
7225 if (sym->ts.type == BT_CHARACTER)
7227 gfc_conv_const_charlen (sym->ts.u.cl);
7229 /* Force the expression to the correct length. */
7230 if (!INTEGER_CST_P (se->string_length)
7231 || tree_int_cst_lt (se->string_length,
7232 sym->ts.u.cl->backend_decl))
7234 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
7235 tmp = gfc_create_var (type, sym->name);
7236 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
7237 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
7238 sym->ts.kind, se->string_length, se->expr,
7242 se->string_length = sym->ts.u.cl->backend_decl;
7245 /* Restore the original variables. */
7246 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7247 fargs = fargs->next, n++)
7248 gfc_restore_sym (fargs->sym, &saved_vars[n]);
7254 /* Translate a function expression. */
7257 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
7261 if (expr->value.function.isym)
7263 gfc_conv_intrinsic_function (se, expr);
7267 /* expr.value.function.esym is the resolved (specific) function symbol for
7268 most functions. However this isn't set for dummy procedures. */
7269 sym = expr->value.function.esym;
7271 sym = expr->symtree->n.sym;
7273 /* The IEEE_ARITHMETIC functions are caught here. */
7274 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
7275 if (gfc_conv_ieee_arithmetic_function (se, expr))
7278 /* We distinguish statement functions from general functions to improve
7279 runtime performance. */
7280 if (sym->attr.proc == PROC_ST_FUNCTION)
7282 gfc_conv_statement_function (se, expr);
7286 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7291 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7294 is_zero_initializer_p (gfc_expr * expr)
7296 if (expr->expr_type != EXPR_CONSTANT)
7299 /* We ignore constants with prescribed memory representations for now. */
7300 if (expr->representation.string)
7303 switch (expr->ts.type)
7306 return mpz_cmp_si (expr->value.integer, 0) == 0;
7309 return mpfr_zero_p (expr->value.real)
7310 && MPFR_SIGN (expr->value.real) >= 0;
7313 return expr->value.logical == 0;
7316 return mpfr_zero_p (mpc_realref (expr->value.complex))
7317 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
7318 && mpfr_zero_p (mpc_imagref (expr->value.complex))
7319 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
7329 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
7334 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
7335 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
7337 gfc_conv_tmp_array_ref (se);
7341 /* Build a static initializer. EXPR is the expression for the initial value.
7342 The other parameters describe the variable of the component being
7343 initialized. EXPR may be null. */
7346 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
7347 bool array, bool pointer, bool procptr)
7351 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
7352 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7353 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7354 return build_constructor (type, NULL);
7356 if (!(expr || pointer || procptr))
7359 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7360 (these are the only two iso_c_binding derived types that can be
7361 used as initialization expressions). If so, we need to modify
7362 the 'expr' to be that for a (void *). */
7363 if (expr != NULL && expr->ts.type == BT_DERIVED
7364 && expr->ts.is_iso_c && expr->ts.u.derived)
7366 if (TREE_CODE (type) == ARRAY_TYPE)
7367 return build_constructor (type, NULL);
7368 else if (POINTER_TYPE_P (type))
7369 return build_int_cst (type, 0);
7374 if (array && !procptr)
7377 /* Arrays need special handling. */
7379 ctor = gfc_build_null_descriptor (type);
7380 /* Special case assigning an array to zero. */
7381 else if (is_zero_initializer_p (expr))
7382 ctor = build_constructor (type, NULL);
7384 ctor = gfc_conv_array_initializer (type, expr);
7385 TREE_STATIC (ctor) = 1;
7388 else if (pointer || procptr)
7390 if (ts->type == BT_CLASS && !procptr)
7392 gfc_init_se (&se, NULL);
7393 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7394 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7395 TREE_STATIC (se.expr) = 1;
7398 else if (!expr || expr->expr_type == EXPR_NULL)
7399 return fold_convert (type, null_pointer_node);
7402 gfc_init_se (&se, NULL);
7403 se.want_pointer = 1;
7404 gfc_conv_expr (&se, expr);
7405 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7415 gfc_init_se (&se, NULL);
7416 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7417 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7419 gfc_conv_structure (&se, expr, 1);
7420 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7421 TREE_STATIC (se.expr) = 1;
7426 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7427 TREE_STATIC (ctor) = 1;
7432 gfc_init_se (&se, NULL);
7433 gfc_conv_constant (&se, expr);
7434 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7441 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7447 gfc_array_info *lss_array;
7454 gfc_start_block (&block);
7456 /* Initialize the scalarizer. */
7457 gfc_init_loopinfo (&loop);
7459 gfc_init_se (&lse, NULL);
7460 gfc_init_se (&rse, NULL);
7463 rss = gfc_walk_expr (expr);
7464 if (rss == gfc_ss_terminator)
7465 /* The rhs is scalar. Add a ss for the expression. */
7466 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7468 /* Create a SS for the destination. */
7469 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7471 lss_array = &lss->info->data.array;
7472 lss_array->shape = gfc_get_shape (cm->as->rank);
7473 lss_array->descriptor = dest;
7474 lss_array->data = gfc_conv_array_data (dest);
7475 lss_array->offset = gfc_conv_array_offset (dest);
7476 for (n = 0; n < cm->as->rank; n++)
7478 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7479 lss_array->stride[n] = gfc_index_one_node;
7481 mpz_init (lss_array->shape[n]);
7482 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7483 cm->as->lower[n]->value.integer);
7484 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7487 /* Associate the SS with the loop. */
7488 gfc_add_ss_to_loop (&loop, lss);
7489 gfc_add_ss_to_loop (&loop, rss);
7491 /* Calculate the bounds of the scalarization. */
7492 gfc_conv_ss_startstride (&loop);
7494 /* Setup the scalarizing loops. */
7495 gfc_conv_loop_setup (&loop, &expr->where);
7497 /* Setup the gfc_se structures. */
7498 gfc_copy_loopinfo_to_se (&lse, &loop);
7499 gfc_copy_loopinfo_to_se (&rse, &loop);
7502 gfc_mark_ss_chain_used (rss, 1);
7504 gfc_mark_ss_chain_used (lss, 1);
7506 /* Start the scalarized loop body. */
7507 gfc_start_scalarized_body (&loop, &body);
7509 gfc_conv_tmp_array_ref (&lse);
7510 if (cm->ts.type == BT_CHARACTER)
7511 lse.string_length = cm->ts.u.cl->backend_decl;
7513 gfc_conv_expr (&rse, expr);
7515 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7516 gfc_add_expr_to_block (&body, tmp);
7518 gcc_assert (rse.ss == gfc_ss_terminator);
7520 /* Generate the copying loops. */
7521 gfc_trans_scalarizing_loops (&loop, &body);
7523 /* Wrap the whole thing up. */
7524 gfc_add_block_to_block (&block, &loop.pre);
7525 gfc_add_block_to_block (&block, &loop.post);
7527 gcc_assert (lss_array->shape != NULL);
7528 gfc_free_shape (&lss_array->shape, cm->as->rank);
7529 gfc_cleanup_loop (&loop);
7531 return gfc_finish_block (&block);
7536 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7546 gfc_expr *arg = NULL;
7548 gfc_start_block (&block);
7549 gfc_init_se (&se, NULL);
7551 /* Get the descriptor for the expressions. */
7552 se.want_pointer = 0;
7553 gfc_conv_expr_descriptor (&se, expr);
7554 gfc_add_block_to_block (&block, &se.pre);
7555 gfc_add_modify (&block, dest, se.expr);
7557 /* Deal with arrays of derived types with allocatable components. */
7558 if (gfc_bt_struct (cm->ts.type)
7559 && cm->ts.u.derived->attr.alloc_comp)
7560 // TODO: Fix caf_mode
7561 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7564 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7565 && CLASS_DATA(cm)->attr.allocatable)
7567 if (cm->ts.u.derived->attr.alloc_comp)
7568 // TODO: Fix caf_mode
7569 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7574 tmp = TREE_TYPE (dest);
7575 tmp = gfc_duplicate_allocatable (dest, se.expr,
7576 tmp, expr->rank, NULL_TREE);
7580 tmp = gfc_duplicate_allocatable (dest, se.expr,
7581 TREE_TYPE(cm->backend_decl),
7582 cm->as->rank, NULL_TREE);
7584 gfc_add_expr_to_block (&block, tmp);
7585 gfc_add_block_to_block (&block, &se.post);
7587 if (expr->expr_type != EXPR_VARIABLE)
7588 gfc_conv_descriptor_data_set (&block, se.expr,
7591 /* We need to know if the argument of a conversion function is a
7592 variable, so that the correct lower bound can be used. */
7593 if (expr->expr_type == EXPR_FUNCTION
7594 && expr->value.function.isym
7595 && expr->value.function.isym->conversion
7596 && expr->value.function.actual->expr
7597 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7598 arg = expr->value.function.actual->expr;
7600 /* Obtain the array spec of full array references. */
7602 as = gfc_get_full_arrayspec_from_expr (arg);
7604 as = gfc_get_full_arrayspec_from_expr (expr);
7606 /* Shift the lbound and ubound of temporaries to being unity,
7607 rather than zero, based. Always calculate the offset. */
7608 offset = gfc_conv_descriptor_offset_get (dest);
7609 gfc_add_modify (&block, offset, gfc_index_zero_node);
7610 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7612 for (n = 0; n < expr->rank; n++)
7617 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7618 TODO It looks as if gfc_conv_expr_descriptor should return
7619 the correct bounds and that the following should not be
7620 necessary. This would simplify gfc_conv_intrinsic_bound
7622 if (as && as->lower[n])
7625 gfc_init_se (&lbse, NULL);
7626 gfc_conv_expr (&lbse, as->lower[n]);
7627 gfc_add_block_to_block (&block, &lbse.pre);
7628 lbound = gfc_evaluate_now (lbse.expr, &block);
7632 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7633 lbound = gfc_conv_descriptor_lbound_get (tmp,
7637 lbound = gfc_conv_descriptor_lbound_get (dest,
7640 lbound = gfc_index_one_node;
7642 lbound = fold_convert (gfc_array_index_type, lbound);
7644 /* Shift the bounds and set the offset accordingly. */
7645 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7646 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7647 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7648 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7650 gfc_conv_descriptor_ubound_set (&block, dest,
7651 gfc_rank_cst[n], tmp);
7652 gfc_conv_descriptor_lbound_set (&block, dest,
7653 gfc_rank_cst[n], lbound);
7655 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7656 gfc_conv_descriptor_lbound_get (dest,
7658 gfc_conv_descriptor_stride_get (dest,
7660 gfc_add_modify (&block, tmp2, tmp);
7661 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7663 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7668 /* If a conversion expression has a null data pointer
7669 argument, nullify the allocatable component. */
7673 if (arg->symtree->n.sym->attr.allocatable
7674 || arg->symtree->n.sym->attr.pointer)
7676 non_null_expr = gfc_finish_block (&block);
7677 gfc_start_block (&block);
7678 gfc_conv_descriptor_data_set (&block, dest,
7680 null_expr = gfc_finish_block (&block);
7681 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7682 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7683 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7684 return build3_v (COND_EXPR, tmp,
7685 null_expr, non_null_expr);
7689 return gfc_finish_block (&block);
7693 /* Allocate or reallocate scalar component, as necessary. */
7696 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7706 tree lhs_cl_size = NULL_TREE;
7711 if (!expr2 || expr2->rank)
7714 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7716 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7718 char name[GFC_MAX_SYMBOL_LEN+9];
7719 gfc_component *strlen;
7720 /* Use the rhs string length and the lhs element size. */
7721 gcc_assert (expr2->ts.type == BT_CHARACTER);
7722 if (!expr2->ts.u.cl->backend_decl)
7724 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7725 gcc_assert (expr2->ts.u.cl->backend_decl);
7728 size = expr2->ts.u.cl->backend_decl;
7730 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7732 sprintf (name, "_%s_length", cm->name);
7733 strlen = gfc_find_component (sym, name, true, true, NULL);
7734 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7735 gfc_charlen_type_node,
7736 TREE_OPERAND (comp, 0),
7737 strlen->backend_decl, NULL_TREE);
7739 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7740 tmp = TYPE_SIZE_UNIT (tmp);
7741 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7742 TREE_TYPE (tmp), tmp,
7743 fold_convert (TREE_TYPE (tmp), size));
7745 else if (cm->ts.type == BT_CLASS)
7747 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7748 if (expr2->ts.type == BT_DERIVED)
7750 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7751 size = TYPE_SIZE_UNIT (tmp);
7757 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7758 gfc_add_vptr_component (e2vtab);
7759 gfc_add_size_component (e2vtab);
7760 gfc_init_se (&se, NULL);
7761 gfc_conv_expr (&se, e2vtab);
7762 gfc_add_block_to_block (block, &se.pre);
7763 size = fold_convert (size_type_node, se.expr);
7764 gfc_free_expr (e2vtab);
7766 size_in_bytes = size;
7770 /* Otherwise use the length in bytes of the rhs. */
7771 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7772 size_in_bytes = size;
7775 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7776 size_in_bytes, size_one_node);
7778 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7780 tmp = build_call_expr_loc (input_location,
7781 builtin_decl_explicit (BUILT_IN_CALLOC),
7782 2, build_one_cst (size_type_node),
7784 tmp = fold_convert (TREE_TYPE (comp), tmp);
7785 gfc_add_modify (block, comp, tmp);
7789 tmp = build_call_expr_loc (input_location,
7790 builtin_decl_explicit (BUILT_IN_MALLOC),
7792 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7793 ptr = gfc_class_data_get (comp);
7796 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7797 gfc_add_modify (block, ptr, tmp);
7800 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7801 /* Update the lhs character length. */
7802 gfc_add_modify (block, lhs_cl_size,
7803 fold_convert (TREE_TYPE (lhs_cl_size), size));
7807 /* Assign a single component of a derived type constructor. */
7810 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7811 gfc_symbol *sym, bool init)
7819 gfc_start_block (&block);
7821 if (cm->attr.pointer || cm->attr.proc_pointer)
7823 /* Only care about pointers here, not about allocatables. */
7824 gfc_init_se (&se, NULL);
7825 /* Pointer component. */
7826 if ((cm->attr.dimension || cm->attr.codimension)
7827 && !cm->attr.proc_pointer)
7829 /* Array pointer. */
7830 if (expr->expr_type == EXPR_NULL)
7831 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7834 se.direct_byref = 1;
7836 gfc_conv_expr_descriptor (&se, expr);
7837 gfc_add_block_to_block (&block, &se.pre);
7838 gfc_add_block_to_block (&block, &se.post);
7843 /* Scalar pointers. */
7844 se.want_pointer = 1;
7845 gfc_conv_expr (&se, expr);
7846 gfc_add_block_to_block (&block, &se.pre);
7848 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7849 && expr->symtree->n.sym->attr.dummy)
7850 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7852 gfc_add_modify (&block, dest,
7853 fold_convert (TREE_TYPE (dest), se.expr));
7854 gfc_add_block_to_block (&block, &se.post);
7857 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7859 /* NULL initialization for CLASS components. */
7860 tmp = gfc_trans_structure_assign (dest,
7861 gfc_class_initializer (&cm->ts, expr),
7863 gfc_add_expr_to_block (&block, tmp);
7865 else if ((cm->attr.dimension || cm->attr.codimension)
7866 && !cm->attr.proc_pointer)
7868 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7869 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7870 else if (cm->attr.allocatable || cm->attr.pdt_array)
7872 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7873 gfc_add_expr_to_block (&block, tmp);
7877 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7878 gfc_add_expr_to_block (&block, tmp);
7881 else if (cm->ts.type == BT_CLASS
7882 && CLASS_DATA (cm)->attr.dimension
7883 && CLASS_DATA (cm)->attr.allocatable
7884 && expr->ts.type == BT_DERIVED)
7886 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7887 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7888 tmp = gfc_class_vptr_get (dest);
7889 gfc_add_modify (&block, tmp,
7890 fold_convert (TREE_TYPE (tmp), vtab));
7891 tmp = gfc_class_data_get (dest);
7892 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7893 gfc_add_expr_to_block (&block, tmp);
7895 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7897 /* NULL initialization for allocatable components. */
7898 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7899 null_pointer_node));
7901 else if (init && (cm->attr.allocatable
7902 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7903 && expr->ts.type != BT_CLASS)))
7905 /* Take care about non-array allocatable components here. The alloc_*
7906 routine below is motivated by the alloc_scalar_allocatable_for_
7907 assignment() routine, but with the realloc portions removed and
7909 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7914 /* The remainder of these instructions follow the if (cm->attr.pointer)
7915 if (!cm->attr.dimension) part above. */
7916 gfc_init_se (&se, NULL);
7917 gfc_conv_expr (&se, expr);
7918 gfc_add_block_to_block (&block, &se.pre);
7920 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7921 && expr->symtree->n.sym->attr.dummy)
7922 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7924 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7926 tmp = gfc_class_data_get (dest);
7927 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7928 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7929 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7930 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7931 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7934 tmp = build_fold_indirect_ref_loc (input_location, dest);
7936 /* For deferred strings insert a memcpy. */
7937 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7940 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7941 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7943 : expr->ts.u.cl->backend_decl);
7944 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7945 gfc_add_expr_to_block (&block, tmp);
7948 gfc_add_modify (&block, tmp,
7949 fold_convert (TREE_TYPE (tmp), se.expr));
7950 gfc_add_block_to_block (&block, &se.post);
7952 else if (expr->ts.type == BT_UNION)
7955 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7956 /* We mark that the entire union should be initialized with a contrived
7957 EXPR_NULL expression at the beginning. */
7958 if (c != NULL && c->n.component == NULL
7959 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7961 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7962 dest, build_constructor (TREE_TYPE (dest), NULL));
7963 gfc_add_expr_to_block (&block, tmp);
7964 c = gfc_constructor_next (c);
7966 /* The following constructor expression, if any, represents a specific
7967 map intializer, as given by the user. */
7968 if (c != NULL && c->expr != NULL)
7970 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7971 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7972 gfc_add_expr_to_block (&block, tmp);
7975 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7977 if (expr->expr_type != EXPR_STRUCTURE)
7979 tree dealloc = NULL_TREE;
7980 gfc_init_se (&se, NULL);
7981 gfc_conv_expr (&se, expr);
7982 gfc_add_block_to_block (&block, &se.pre);
7983 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7984 expression in a temporary variable and deallocate the allocatable
7985 components. Then we can the copy the expression to the result. */
7986 if (cm->ts.u.derived->attr.alloc_comp
7987 && expr->expr_type != EXPR_VARIABLE)
7989 se.expr = gfc_evaluate_now (se.expr, &block);
7990 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7993 gfc_add_modify (&block, dest,
7994 fold_convert (TREE_TYPE (dest), se.expr));
7995 if (cm->ts.u.derived->attr.alloc_comp
7996 && expr->expr_type != EXPR_NULL)
7998 // TODO: Fix caf_mode
7999 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
8000 dest, expr->rank, 0);
8001 gfc_add_expr_to_block (&block, tmp);
8002 if (dealloc != NULL_TREE)
8003 gfc_add_expr_to_block (&block, dealloc);
8005 gfc_add_block_to_block (&block, &se.post);
8009 /* Nested constructors. */
8010 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8011 gfc_add_expr_to_block (&block, tmp);
8014 else if (gfc_deferred_strlen (cm, &tmp))
8018 gcc_assert (strlen);
8019 strlen = fold_build3_loc (input_location, COMPONENT_REF,
8021 TREE_OPERAND (dest, 0),
8024 if (expr->expr_type == EXPR_NULL)
8026 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
8027 gfc_add_modify (&block, dest, tmp);
8028 tmp = build_int_cst (TREE_TYPE (strlen), 0);
8029 gfc_add_modify (&block, strlen, tmp);
8034 gfc_init_se (&se, NULL);
8035 gfc_conv_expr (&se, expr);
8036 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
8037 tmp = build_call_expr_loc (input_location,
8038 builtin_decl_explicit (BUILT_IN_MALLOC),
8040 gfc_add_modify (&block, dest,
8041 fold_convert (TREE_TYPE (dest), tmp));
8042 gfc_add_modify (&block, strlen,
8043 fold_convert (TREE_TYPE (strlen), se.string_length));
8044 tmp = gfc_build_memcpy_call (dest, se.expr, size);
8045 gfc_add_expr_to_block (&block, tmp);
8048 else if (!cm->attr.artificial)
8050 /* Scalar component (excluding deferred parameters). */
8051 gfc_init_se (&se, NULL);
8052 gfc_init_se (&lse, NULL);
8054 gfc_conv_expr (&se, expr);
8055 if (cm->ts.type == BT_CHARACTER)
8056 lse.string_length = cm->ts.u.cl->backend_decl;
8058 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
8059 gfc_add_expr_to_block (&block, tmp);
8061 return gfc_finish_block (&block);
8064 /* Assign a derived type constructor to a variable. */
8067 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
8076 gfc_start_block (&block);
8077 cm = expr->ts.u.derived->components;
8079 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
8080 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8081 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
8085 gfc_init_se (&se, NULL);
8086 gfc_init_se (&lse, NULL);
8087 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
8089 gfc_add_modify (&block, lse.expr,
8090 fold_convert (TREE_TYPE (lse.expr), se.expr));
8092 return gfc_finish_block (&block);
8096 gfc_init_se (&se, NULL);
8098 for (c = gfc_constructor_first (expr->value.constructor);
8099 c; c = gfc_constructor_next (c), cm = cm->next)
8101 /* Skip absent members in default initializers. */
8102 if (!c->expr && !cm->attr.allocatable)
8105 /* Register the component with the caf-lib before it is initialized.
8106 Register only allocatable components, that are not coarray'ed
8107 components (%comp[*]). Only register when the constructor is not the
8109 if (coarray && !cm->attr.codimension
8110 && (cm->attr.allocatable || cm->attr.pointer)
8111 && (!c->expr || c->expr->expr_type == EXPR_NULL))
8113 tree token, desc, size;
8114 bool is_array = cm->ts.type == BT_CLASS
8115 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
8117 field = cm->backend_decl;
8118 field = fold_build3_loc (input_location, COMPONENT_REF,
8119 TREE_TYPE (field), dest, field, NULL_TREE);
8120 if (cm->ts.type == BT_CLASS)
8121 field = gfc_class_data_get (field);
8123 token = is_array ? gfc_conv_descriptor_token (field)
8124 : fold_build3_loc (input_location, COMPONENT_REF,
8125 TREE_TYPE (cm->caf_token), dest,
8126 cm->caf_token, NULL_TREE);
8130 /* The _caf_register routine looks at the rank of the array
8131 descriptor to decide whether the data registered is an array
8133 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
8135 /* When the rank is not known just set a positive rank, which
8136 suffices to recognize the data as array. */
8139 size = build_zero_cst (size_type_node);
8141 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
8142 build_int_cst (signed_char_type_node, rank));
8146 desc = gfc_conv_scalar_to_descriptor (&se, field,
8147 cm->ts.type == BT_CLASS
8148 ? CLASS_DATA (cm)->attr
8150 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
8152 gfc_add_block_to_block (&block, &se.pre);
8153 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
8154 7, size, build_int_cst (
8156 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
8157 gfc_build_addr_expr (pvoid_type_node,
8159 gfc_build_addr_expr (NULL_TREE, desc),
8160 null_pointer_node, null_pointer_node,
8162 gfc_add_expr_to_block (&block, tmp);
8164 field = cm->backend_decl;
8165 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8166 dest, field, NULL_TREE);
8169 gfc_expr *e = gfc_get_null_expr (NULL);
8170 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
8175 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
8176 expr->ts.u.derived, init);
8177 gfc_add_expr_to_block (&block, tmp);
8179 return gfc_finish_block (&block);
8183 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
8184 gfc_component *un, gfc_expr *init)
8186 gfc_constructor *ctor;
8188 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
8191 ctor = gfc_constructor_first (init->value.constructor);
8193 if (ctor == NULL || ctor->expr == NULL)
8196 gcc_assert (init->expr_type == EXPR_STRUCTURE);
8198 /* If we have an 'initialize all' constructor, do it first. */
8199 if (ctor->expr->expr_type == EXPR_NULL)
8201 tree union_type = TREE_TYPE (un->backend_decl);
8202 tree val = build_constructor (union_type, NULL);
8203 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8204 ctor = gfc_constructor_next (ctor);
8207 /* Add the map initializer on top. */
8208 if (ctor != NULL && ctor->expr != NULL)
8210 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
8211 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
8212 TREE_TYPE (un->backend_decl),
8213 un->attr.dimension, un->attr.pointer,
8214 un->attr.proc_pointer);
8215 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8219 /* Build an expression for a constructor. If init is nonzero then
8220 this is part of a static variable initializer. */
8223 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
8230 vec<constructor_elt, va_gc> *v = NULL;
8232 gcc_assert (se->ss == NULL);
8233 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8234 type = gfc_typenode_for_spec (&expr->ts);
8238 /* Create a temporary variable and fill it in. */
8239 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
8240 /* The symtree in expr is NULL, if the code to generate is for
8241 initializing the static members only. */
8242 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
8244 gfc_add_expr_to_block (&se->pre, tmp);
8248 cm = expr->ts.u.derived->components;
8250 for (c = gfc_constructor_first (expr->value.constructor);
8251 c; c = gfc_constructor_next (c), cm = cm->next)
8253 /* Skip absent members in default initializers and allocatable
8254 components. Although the latter have a default initializer
8255 of EXPR_NULL,... by default, the static nullify is not needed
8256 since this is done every time we come into scope. */
8257 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
8260 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
8261 && strcmp (cm->name, "_extends") == 0
8262 && cm->initializer->symtree)
8266 vtabs = cm->initializer->symtree->n.sym;
8267 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
8268 vtab = unshare_expr_without_location (vtab);
8269 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
8271 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
8273 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
8274 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8275 fold_convert (TREE_TYPE (cm->backend_decl),
8278 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
8279 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8280 fold_convert (TREE_TYPE (cm->backend_decl),
8281 integer_zero_node));
8282 else if (cm->ts.type == BT_UNION)
8283 gfc_conv_union_initializer (v, cm, c->expr);
8286 val = gfc_conv_initializer (c->expr, &cm->ts,
8287 TREE_TYPE (cm->backend_decl),
8288 cm->attr.dimension, cm->attr.pointer,
8289 cm->attr.proc_pointer);
8290 val = unshare_expr_without_location (val);
8292 /* Append it to the constructor list. */
8293 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
8297 se->expr = build_constructor (type, v);
8299 TREE_CONSTANT (se->expr) = 1;
8303 /* Translate a substring expression. */
8306 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
8312 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
8314 se->expr = gfc_build_wide_string_const (expr->ts.kind,
8315 expr->value.character.length,
8316 expr->value.character.string);
8318 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
8319 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
8322 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
8326 /* Entry point for expression translation. Evaluates a scalar quantity.
8327 EXPR is the expression to be translated, and SE is the state structure if
8328 called from within the scalarized. */
8331 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
8336 if (ss && ss->info->expr == expr
8337 && (ss->info->type == GFC_SS_SCALAR
8338 || ss->info->type == GFC_SS_REFERENCE))
8340 gfc_ss_info *ss_info;
8343 /* Substitute a scalar expression evaluated outside the scalarization
8345 se->expr = ss_info->data.scalar.value;
8346 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
8347 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8349 se->string_length = ss_info->string_length;
8350 gfc_advance_se_ss_chain (se);
8354 /* We need to convert the expressions for the iso_c_binding derived types.
8355 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8356 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8357 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8358 updated to be an integer with a kind equal to the size of a (void *). */
8359 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8360 && expr->ts.u.derived->attr.is_bind_c)
8362 if (expr->expr_type == EXPR_VARIABLE
8363 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8364 || expr->symtree->n.sym->intmod_sym_id
8365 == ISOCBINDING_NULL_FUNPTR))
8367 /* Set expr_type to EXPR_NULL, which will result in
8368 null_pointer_node being used below. */
8369 expr->expr_type = EXPR_NULL;
8373 /* Update the type/kind of the expression to be what the new
8374 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8375 expr->ts.type = BT_INTEGER;
8376 expr->ts.f90_type = BT_VOID;
8377 expr->ts.kind = gfc_index_integer_kind;
8381 gfc_fix_class_refs (expr);
8383 switch (expr->expr_type)
8386 gfc_conv_expr_op (se, expr);
8390 gfc_conv_function_expr (se, expr);
8394 gfc_conv_constant (se, expr);
8398 gfc_conv_variable (se, expr);
8402 se->expr = null_pointer_node;
8405 case EXPR_SUBSTRING:
8406 gfc_conv_substring_expr (se, expr);
8409 case EXPR_STRUCTURE:
8410 gfc_conv_structure (se, expr, 0);
8414 gfc_conv_array_constructor_expr (se, expr);
8423 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8424 of an assignment. */
8426 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8428 gfc_conv_expr (se, expr);
8429 /* All numeric lvalues should have empty post chains. If not we need to
8430 figure out a way of rewriting an lvalue so that it has no post chain. */
8431 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8434 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8435 numeric expressions. Used for scalar values where inserting cleanup code
8438 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8442 gcc_assert (expr->ts.type != BT_CHARACTER);
8443 gfc_conv_expr (se, expr);
8446 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8447 gfc_add_modify (&se->pre, val, se->expr);
8449 gfc_add_block_to_block (&se->pre, &se->post);
8453 /* Helper to translate an expression and convert it to a particular type. */
8455 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8457 gfc_conv_expr_val (se, expr);
8458 se->expr = convert (type, se->expr);
8462 /* Converts an expression so that it can be passed by reference. Scalar
8466 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8472 if (ss && ss->info->expr == expr
8473 && ss->info->type == GFC_SS_REFERENCE)
8475 /* Returns a reference to the scalar evaluated outside the loop
8477 gfc_conv_expr (se, expr);
8479 if (expr->ts.type == BT_CHARACTER
8480 && expr->expr_type != EXPR_FUNCTION)
8481 gfc_conv_string_parameter (se);
8483 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8488 if (expr->ts.type == BT_CHARACTER)
8490 gfc_conv_expr (se, expr);
8491 gfc_conv_string_parameter (se);
8495 if (expr->expr_type == EXPR_VARIABLE)
8497 se->want_pointer = 1;
8498 gfc_conv_expr (se, expr);
8501 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8502 gfc_add_modify (&se->pre, var, se->expr);
8503 gfc_add_block_to_block (&se->pre, &se->post);
8506 else if (add_clobber && expr->ref == NULL)
8510 /* FIXME: This fails if var is passed by reference, see PR
8512 var = expr->symtree->n.sym->backend_decl;
8513 clobber = build_clobber (TREE_TYPE (var));
8514 gfc_add_modify (&se->pre, var, clobber);
8519 if (expr->expr_type == EXPR_FUNCTION
8520 && ((expr->value.function.esym
8521 && expr->value.function.esym->result->attr.pointer
8522 && !expr->value.function.esym->result->attr.dimension)
8523 || (!expr->value.function.esym && !expr->ref
8524 && expr->symtree->n.sym->attr.pointer
8525 && !expr->symtree->n.sym->attr.dimension)))
8527 se->want_pointer = 1;
8528 gfc_conv_expr (se, expr);
8529 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8530 gfc_add_modify (&se->pre, var, se->expr);
8535 gfc_conv_expr (se, expr);
8537 /* Create a temporary var to hold the value. */
8538 if (TREE_CONSTANT (se->expr))
8540 tree tmp = se->expr;
8541 STRIP_TYPE_NOPS (tmp);
8542 var = build_decl (input_location,
8543 CONST_DECL, NULL, TREE_TYPE (tmp));
8544 DECL_INITIAL (var) = tmp;
8545 TREE_STATIC (var) = 1;
8550 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8551 gfc_add_modify (&se->pre, var, se->expr);
8554 if (!expr->must_finalize)
8555 gfc_add_block_to_block (&se->pre, &se->post);
8557 /* Take the address of that value. */
8558 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8562 /* Get the _len component for an unlimited polymorphic expression. */
8565 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8568 gfc_ref *ref = expr->ref;
8570 gfc_init_se (&se, NULL);
8571 while (ref && ref->next)
8573 gfc_add_len_component (expr);
8574 gfc_conv_expr (&se, expr);
8575 gfc_add_block_to_block (block, &se.pre);
8576 gcc_assert (se.post.head == NULL_TREE);
8579 gfc_free_ref_list (ref->next);
8584 gfc_free_ref_list (expr->ref);
8591 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8592 statement-list outside of the scalarizer-loop. When code is generated, that
8593 depends on the scalarized expression, it is added to RSE.PRE.
8594 Returns le's _vptr tree and when set the len expressions in to_lenp and
8595 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8599 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8600 gfc_expr * re, gfc_se *rse,
8601 tree * to_lenp, tree * from_lenp)
8604 gfc_expr * vptr_expr;
8605 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8606 bool set_vptr = false, temp_rhs = false;
8607 stmtblock_t *pre = block;
8609 /* Create a temporary for complicated expressions. */
8610 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8611 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8613 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8615 gfc_add_modify (&rse->pre, tmp, rse->expr);
8620 /* Get the _vptr for the left-hand side expression. */
8621 gfc_init_se (&se, NULL);
8622 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8623 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8625 /* Care about _len for unlimited polymorphic entities. */
8626 if (UNLIMITED_POLY (vptr_expr)
8627 || (vptr_expr->ts.type == BT_DERIVED
8628 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8629 to_len = trans_get_upoly_len (block, vptr_expr);
8630 gfc_add_vptr_component (vptr_expr);
8634 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8635 se.want_pointer = 1;
8636 gfc_conv_expr (&se, vptr_expr);
8637 gfc_free_expr (vptr_expr);
8638 gfc_add_block_to_block (block, &se.pre);
8639 gcc_assert (se.post.head == NULL_TREE);
8641 STRIP_NOPS (lhs_vptr);
8643 /* Set the _vptr only when the left-hand side of the assignment is a
8647 /* Get the vptr from the rhs expression only, when it is variable.
8648 Functions are expected to be assigned to a temporary beforehand. */
8649 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8650 ? gfc_find_and_cut_at_last_class_ref (re)
8652 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8654 if (to_len != NULL_TREE)
8656 /* Get the _len information from the rhs. */
8657 if (UNLIMITED_POLY (vptr_expr)
8658 || (vptr_expr->ts.type == BT_DERIVED
8659 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8660 from_len = trans_get_upoly_len (block, vptr_expr);
8662 gfc_add_vptr_component (vptr_expr);
8666 if (re->expr_type == EXPR_VARIABLE
8667 && DECL_P (re->symtree->n.sym->backend_decl)
8668 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8669 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8670 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8671 re->symtree->n.sym->backend_decl))))
8674 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8675 re->symtree->n.sym->backend_decl));
8677 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8678 re->symtree->n.sym->backend_decl));
8680 else if (temp_rhs && re->ts.type == BT_CLASS)
8683 se.expr = gfc_class_vptr_get (rse->expr);
8684 if (UNLIMITED_POLY (re))
8685 from_len = gfc_class_len_get (rse->expr);
8687 else if (re->expr_type != EXPR_NULL)
8688 /* Only when rhs is non-NULL use its declared type for vptr
8690 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8692 /* When the rhs is NULL use the vtab of lhs' declared type. */
8693 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8698 gfc_init_se (&se, NULL);
8699 se.want_pointer = 1;
8700 gfc_conv_expr (&se, vptr_expr);
8701 gfc_free_expr (vptr_expr);
8702 gfc_add_block_to_block (block, &se.pre);
8703 gcc_assert (se.post.head == NULL_TREE);
8705 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8708 if (to_len != NULL_TREE)
8710 /* The _len component needs to be set. Figure how to get the
8711 value of the right-hand side. */
8712 if (from_len == NULL_TREE)
8714 if (rse->string_length != NULL_TREE)
8715 from_len = rse->string_length;
8716 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8718 from_len = gfc_get_expr_charlen (re);
8719 gfc_init_se (&se, NULL);
8720 gfc_conv_expr (&se, re->ts.u.cl->length);
8721 gfc_add_block_to_block (block, &se.pre);
8722 gcc_assert (se.post.head == NULL_TREE);
8723 from_len = gfc_evaluate_now (se.expr, block);
8726 from_len = build_zero_cst (gfc_charlen_type_node);
8728 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8733 /* Return the _len trees only, when requested. */
8737 *from_lenp = from_len;
8742 /* Assign tokens for pointer components. */
8745 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8748 symbol_attribute lhs_attr, rhs_attr;
8749 tree tmp, lhs_tok, rhs_tok;
8750 /* Flag to indicated component refs on the rhs. */
8753 lhs_attr = gfc_caf_attr (expr1);
8754 if (expr2->expr_type != EXPR_NULL)
8756 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8757 if (lhs_attr.codimension && rhs_attr.codimension)
8759 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8760 lhs_tok = build_fold_indirect_ref (lhs_tok);
8763 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8767 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8768 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8771 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8773 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8774 gfc_prepend_expr_to_block (&lse->post, tmp);
8777 else if (lhs_attr.codimension)
8779 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8780 lhs_tok = build_fold_indirect_ref (lhs_tok);
8781 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8782 lhs_tok, null_pointer_node);
8783 gfc_prepend_expr_to_block (&lse->post, tmp);
8787 /* Indentify class valued proc_pointer assignments. */
8790 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8795 while (ref && ref->next)
8798 return ref && ref->type == REF_COMPONENT
8799 && ref->u.c.component->attr.proc_pointer
8800 && expr2->expr_type == EXPR_VARIABLE
8801 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8805 /* Do everything that is needed for a CLASS function expr2. */
8808 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8809 gfc_expr *expr1, gfc_expr *expr2)
8811 tree expr1_vptr = NULL_TREE;
8814 gfc_conv_function_expr (rse, expr2);
8815 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8817 if (expr1->ts.type != BT_CLASS)
8818 rse->expr = gfc_class_data_get (rse->expr);
8821 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8824 gfc_add_block_to_block (block, &rse->pre);
8825 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8826 gfc_add_modify (&lse->pre, tmp, rse->expr);
8828 gfc_add_modify (&lse->pre, expr1_vptr,
8829 fold_convert (TREE_TYPE (expr1_vptr),
8830 gfc_class_vptr_get (tmp)));
8831 rse->expr = gfc_class_data_get (tmp);
8839 gfc_trans_pointer_assign (gfc_code * code)
8841 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8845 /* Generate code for a pointer assignment. */
8848 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8855 tree expr1_vptr = NULL_TREE;
8856 bool scalar, non_proc_pointer_assign;
8859 gfc_start_block (&block);
8861 gfc_init_se (&lse, NULL);
8863 /* Usually testing whether this is not a proc pointer assignment. */
8864 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8866 /* Check whether the expression is a scalar or not; we cannot use
8867 expr1->rank as it can be nonzero for proc pointers. */
8868 ss = gfc_walk_expr (expr1);
8869 scalar = ss == gfc_ss_terminator;
8871 gfc_free_ss_chain (ss);
8873 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8874 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8876 gfc_add_data_component (expr2);
8877 /* The following is required as gfc_add_data_component doesn't
8878 update ts.type if there is a tailing REF_ARRAY. */
8879 expr2->ts.type = BT_DERIVED;
8884 /* Scalar pointers. */
8885 lse.want_pointer = 1;
8886 gfc_conv_expr (&lse, expr1);
8887 gfc_init_se (&rse, NULL);
8888 rse.want_pointer = 1;
8889 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8890 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8892 gfc_conv_expr (&rse, expr2);
8894 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8896 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8898 lse.expr = gfc_class_data_get (lse.expr);
8901 if (expr1->symtree->n.sym->attr.proc_pointer
8902 && expr1->symtree->n.sym->attr.dummy)
8903 lse.expr = build_fold_indirect_ref_loc (input_location,
8906 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8907 && expr2->symtree->n.sym->attr.dummy)
8908 rse.expr = build_fold_indirect_ref_loc (input_location,
8911 gfc_add_block_to_block (&block, &lse.pre);
8912 gfc_add_block_to_block (&block, &rse.pre);
8914 /* Check character lengths if character expression. The test is only
8915 really added if -fbounds-check is enabled. Exclude deferred
8916 character length lefthand sides. */
8917 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8918 && !expr1->ts.deferred
8919 && !expr1->symtree->n.sym->attr.proc_pointer
8920 && !gfc_is_proc_ptr_comp (expr1))
8922 gcc_assert (expr2->ts.type == BT_CHARACTER);
8923 gcc_assert (lse.string_length && rse.string_length);
8924 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8925 lse.string_length, rse.string_length,
8929 /* The assignment to an deferred character length sets the string
8930 length to that of the rhs. */
8931 if (expr1->ts.deferred)
8933 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8934 gfc_add_modify (&block, lse.string_length,
8935 fold_convert (TREE_TYPE (lse.string_length),
8936 rse.string_length));
8937 else if (lse.string_length != NULL)
8938 gfc_add_modify (&block, lse.string_length,
8939 build_zero_cst (TREE_TYPE (lse.string_length)));
8942 gfc_add_modify (&block, lse.expr,
8943 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8945 /* Also set the tokens for pointer components in derived typed
8947 if (flag_coarray == GFC_FCOARRAY_LIB)
8948 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8950 gfc_add_block_to_block (&block, &rse.post);
8951 gfc_add_block_to_block (&block, &lse.post);
8958 tree strlen_rhs = NULL_TREE;
8960 /* Array pointer. Find the last reference on the LHS and if it is an
8961 array section ref, we're dealing with bounds remapping. In this case,
8962 set it to AR_FULL so that gfc_conv_expr_descriptor does
8963 not see it and process the bounds remapping afterwards explicitly. */
8964 for (remap = expr1->ref; remap; remap = remap->next)
8965 if (!remap->next && remap->type == REF_ARRAY
8966 && remap->u.ar.type == AR_SECTION)
8968 rank_remap = (remap && remap->u.ar.end[0]);
8970 gfc_init_se (&lse, NULL);
8972 lse.descriptor_only = 1;
8973 gfc_conv_expr_descriptor (&lse, expr1);
8974 strlen_lhs = lse.string_length;
8977 if (expr2->expr_type == EXPR_NULL)
8979 /* Just set the data pointer to null. */
8980 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8982 else if (rank_remap)
8984 /* If we are rank-remapping, just get the RHS's descriptor and
8985 process this later on. */
8986 gfc_init_se (&rse, NULL);
8987 rse.direct_byref = 1;
8988 rse.byref_noassign = 1;
8990 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8991 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8993 else if (expr2->expr_type == EXPR_FUNCTION)
8995 tree bound[GFC_MAX_DIMENSIONS];
8998 for (i = 0; i < expr2->rank; i++)
8999 bound[i] = NULL_TREE;
9000 tmp = gfc_typenode_for_spec (&expr2->ts);
9001 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
9003 GFC_ARRAY_POINTER_CONT, false);
9004 tmp = gfc_create_var (tmp, "ptrtemp");
9005 rse.descriptor_only = 0;
9007 rse.direct_byref = 1;
9008 gfc_conv_expr_descriptor (&rse, expr2);
9009 strlen_rhs = rse.string_length;
9014 gfc_conv_expr_descriptor (&rse, expr2);
9015 strlen_rhs = rse.string_length;
9016 if (expr1->ts.type == BT_CLASS)
9017 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9022 else if (expr2->expr_type == EXPR_VARIABLE)
9024 /* Assign directly to the LHS's descriptor. */
9025 lse.descriptor_only = 0;
9026 lse.direct_byref = 1;
9027 gfc_conv_expr_descriptor (&lse, expr2);
9028 strlen_rhs = lse.string_length;
9030 if (expr1->ts.type == BT_CLASS)
9032 rse.expr = NULL_TREE;
9033 rse.string_length = NULL_TREE;
9034 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
9040 /* If the target is not a whole array, use the target array
9041 reference for remap. */
9042 for (remap = expr2->ref; remap; remap = remap->next)
9043 if (remap->type == REF_ARRAY
9044 && remap->u.ar.type == AR_FULL
9049 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9051 gfc_init_se (&rse, NULL);
9052 rse.want_pointer = 1;
9053 gfc_conv_function_expr (&rse, expr2);
9054 if (expr1->ts.type != BT_CLASS)
9056 rse.expr = gfc_class_data_get (rse.expr);
9057 gfc_add_modify (&lse.pre, desc, rse.expr);
9058 /* Set the lhs span. */
9059 tmp = TREE_TYPE (rse.expr);
9060 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9061 tmp = fold_convert (gfc_array_index_type, tmp);
9062 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
9066 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9069 gfc_add_block_to_block (&block, &rse.pre);
9070 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
9071 gfc_add_modify (&lse.pre, tmp, rse.expr);
9073 gfc_add_modify (&lse.pre, expr1_vptr,
9074 fold_convert (TREE_TYPE (expr1_vptr),
9075 gfc_class_vptr_get (tmp)));
9076 rse.expr = gfc_class_data_get (tmp);
9077 gfc_add_modify (&lse.pre, desc, rse.expr);
9082 /* Assign to a temporary descriptor and then copy that
9083 temporary to the pointer. */
9084 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
9085 lse.descriptor_only = 0;
9087 lse.direct_byref = 1;
9088 gfc_conv_expr_descriptor (&lse, expr2);
9089 strlen_rhs = lse.string_length;
9090 gfc_add_modify (&lse.pre, desc, tmp);
9093 gfc_add_block_to_block (&block, &lse.pre);
9095 gfc_add_block_to_block (&block, &rse.pre);
9097 /* If we do bounds remapping, update LHS descriptor accordingly. */
9101 gcc_assert (remap->u.ar.dimen == expr1->rank);
9105 /* Do rank remapping. We already have the RHS's descriptor
9106 converted in rse and now have to build the correct LHS
9107 descriptor for it. */
9109 tree dtype, data, span;
9111 tree lbound, ubound;
9114 dtype = gfc_conv_descriptor_dtype (desc);
9115 tmp = gfc_get_dtype (TREE_TYPE (desc));
9116 gfc_add_modify (&block, dtype, tmp);
9118 /* Copy data pointer. */
9119 data = gfc_conv_descriptor_data_get (rse.expr);
9120 gfc_conv_descriptor_data_set (&block, desc, data);
9122 /* Copy the span. */
9123 if (TREE_CODE (rse.expr) == VAR_DECL
9124 && GFC_DECL_PTR_ARRAY_P (rse.expr))
9125 span = gfc_conv_descriptor_span_get (rse.expr);
9128 tmp = TREE_TYPE (rse.expr);
9129 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9130 span = fold_convert (gfc_array_index_type, tmp);
9132 gfc_conv_descriptor_span_set (&block, desc, span);
9134 /* Copy offset but adjust it such that it would correspond
9135 to a lbound of zero. */
9136 offs = gfc_conv_descriptor_offset_get (rse.expr);
9137 for (dim = 0; dim < expr2->rank; ++dim)
9139 stride = gfc_conv_descriptor_stride_get (rse.expr,
9141 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
9143 tmp = fold_build2_loc (input_location, MULT_EXPR,
9144 gfc_array_index_type, stride, lbound);
9145 offs = fold_build2_loc (input_location, PLUS_EXPR,
9146 gfc_array_index_type, offs, tmp);
9148 gfc_conv_descriptor_offset_set (&block, desc, offs);
9150 /* Set the bounds as declared for the LHS and calculate strides as
9151 well as another offset update accordingly. */
9152 stride = gfc_conv_descriptor_stride_get (rse.expr,
9154 for (dim = 0; dim < expr1->rank; ++dim)
9159 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
9161 /* Convert declared bounds. */
9162 gfc_init_se (&lower_se, NULL);
9163 gfc_init_se (&upper_se, NULL);
9164 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
9165 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
9167 gfc_add_block_to_block (&block, &lower_se.pre);
9168 gfc_add_block_to_block (&block, &upper_se.pre);
9170 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
9171 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
9173 lbound = gfc_evaluate_now (lbound, &block);
9174 ubound = gfc_evaluate_now (ubound, &block);
9176 gfc_add_block_to_block (&block, &lower_se.post);
9177 gfc_add_block_to_block (&block, &upper_se.post);
9179 /* Set bounds in descriptor. */
9180 gfc_conv_descriptor_lbound_set (&block, desc,
9181 gfc_rank_cst[dim], lbound);
9182 gfc_conv_descriptor_ubound_set (&block, desc,
9183 gfc_rank_cst[dim], ubound);
9186 stride = gfc_evaluate_now (stride, &block);
9187 gfc_conv_descriptor_stride_set (&block, desc,
9188 gfc_rank_cst[dim], stride);
9190 /* Update offset. */
9191 offs = gfc_conv_descriptor_offset_get (desc);
9192 tmp = fold_build2_loc (input_location, MULT_EXPR,
9193 gfc_array_index_type, lbound, stride);
9194 offs = fold_build2_loc (input_location, MINUS_EXPR,
9195 gfc_array_index_type, offs, tmp);
9196 offs = gfc_evaluate_now (offs, &block);
9197 gfc_conv_descriptor_offset_set (&block, desc, offs);
9199 /* Update stride. */
9200 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
9201 stride = fold_build2_loc (input_location, MULT_EXPR,
9202 gfc_array_index_type, stride, tmp);
9207 /* Bounds remapping. Just shift the lower bounds. */
9209 gcc_assert (expr1->rank == expr2->rank);
9211 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
9215 gcc_assert (!remap->u.ar.end[dim]);
9216 gfc_init_se (&lbound_se, NULL);
9217 if (remap->u.ar.start[dim])
9219 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
9220 gfc_add_block_to_block (&block, &lbound_se.pre);
9223 /* This remap arises from a target that is not a whole
9224 array. The start expressions will be NULL but we need
9225 the lbounds to be one. */
9226 lbound_se.expr = gfc_index_one_node;
9227 gfc_conv_shift_descriptor_lbound (&block, desc,
9228 dim, lbound_se.expr);
9229 gfc_add_block_to_block (&block, &lbound_se.post);
9234 /* If rank remapping was done, check with -fcheck=bounds that
9235 the target is at least as large as the pointer. */
9236 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
9242 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
9243 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
9245 lsize = gfc_evaluate_now (lsize, &block);
9246 rsize = gfc_evaluate_now (rsize, &block);
9247 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
9250 msg = _("Target of rank remapping is too small (%ld < %ld)");
9251 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
9255 if (expr1->ts.type == BT_CHARACTER
9256 && expr1->symtree->n.sym->ts.deferred
9257 && expr1->symtree->n.sym->ts.u.cl->backend_decl
9258 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
9260 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
9261 if (expr2->expr_type != EXPR_NULL)
9262 gfc_add_modify (&block, tmp,
9263 fold_convert (TREE_TYPE (tmp), strlen_rhs));
9265 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
9268 /* Check string lengths if applicable. The check is only really added
9269 to the output code if -fbounds-check is enabled. */
9270 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
9272 gcc_assert (expr2->ts.type == BT_CHARACTER);
9273 gcc_assert (strlen_lhs && strlen_rhs);
9274 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9275 strlen_lhs, strlen_rhs, &block);
9278 gfc_add_block_to_block (&block, &lse.post);
9280 gfc_add_block_to_block (&block, &rse.post);
9283 return gfc_finish_block (&block);
9287 /* Makes sure se is suitable for passing as a function string parameter. */
9288 /* TODO: Need to check all callers of this function. It may be abused. */
9291 gfc_conv_string_parameter (gfc_se * se)
9295 if (TREE_CODE (se->expr) == STRING_CST)
9297 type = TREE_TYPE (TREE_TYPE (se->expr));
9298 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9302 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
9304 if (TREE_CODE (se->expr) != INDIRECT_REF)
9306 type = TREE_TYPE (se->expr);
9307 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9311 type = gfc_get_character_type_len (gfc_default_character_kind,
9313 type = build_pointer_type (type);
9314 se->expr = gfc_build_addr_expr (type, se->expr);
9318 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
9322 /* Generate code for assignment of scalar variables. Includes character
9323 strings and derived types with allocatable components.
9324 If you know that the LHS has no allocations, set dealloc to false.
9326 DEEP_COPY has no effect if the typespec TS is not a derived type with
9327 allocatable components. Otherwise, if it is set, an explicit copy of each
9328 allocatable component is made. This is necessary as a simple copy of the
9329 whole object would copy array descriptors as is, so that the lhs's
9330 allocatable components would point to the rhs's after the assignment.
9331 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9332 necessary if the rhs is a non-pointer function, as the allocatable components
9333 are not accessible by other means than the function's result after the
9334 function has returned. It is even more subtle when temporaries are involved,
9335 as the two following examples show:
9336 1. When we evaluate an array constructor, a temporary is created. Thus
9337 there is theoretically no alias possible. However, no deep copy is
9338 made for this temporary, so that if the constructor is made of one or
9339 more variable with allocatable components, those components still point
9340 to the variable's: DEEP_COPY should be set for the assignment from the
9341 temporary to the lhs in that case.
9342 2. When assigning a scalar to an array, we evaluate the scalar value out
9343 of the loop, store it into a temporary variable, and assign from that.
9344 In that case, deep copying when assigning to the temporary would be a
9345 waste of resources; however deep copies should happen when assigning from
9346 the temporary to each array element: again DEEP_COPY should be set for
9347 the assignment from the temporary to the lhs. */
9350 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9351 bool deep_copy, bool dealloc, bool in_coarray)
9357 gfc_init_block (&block);
9359 if (ts.type == BT_CHARACTER)
9364 if (lse->string_length != NULL_TREE)
9366 gfc_conv_string_parameter (lse);
9367 gfc_add_block_to_block (&block, &lse->pre);
9368 llen = lse->string_length;
9371 if (rse->string_length != NULL_TREE)
9373 gfc_conv_string_parameter (rse);
9374 gfc_add_block_to_block (&block, &rse->pre);
9375 rlen = rse->string_length;
9378 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9379 rse->expr, ts.kind);
9381 else if (gfc_bt_struct (ts.type)
9382 && (ts.u.derived->attr.alloc_comp
9383 || (deep_copy && ts.u.derived->attr.pdt_type)))
9385 tree tmp_var = NULL_TREE;
9388 /* Are the rhs and the lhs the same? */
9391 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9392 gfc_build_addr_expr (NULL_TREE, lse->expr),
9393 gfc_build_addr_expr (NULL_TREE, rse->expr));
9394 cond = gfc_evaluate_now (cond, &lse->pre);
9397 /* Deallocate the lhs allocated components as long as it is not
9398 the same as the rhs. This must be done following the assignment
9399 to prevent deallocating data that could be used in the rhs
9403 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9404 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9406 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9408 gfc_add_expr_to_block (&lse->post, tmp);
9411 gfc_add_block_to_block (&block, &rse->pre);
9412 gfc_add_block_to_block (&block, &lse->pre);
9414 gfc_add_modify (&block, lse->expr,
9415 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9417 /* Restore pointer address of coarray components. */
9418 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9420 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9421 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9423 gfc_add_expr_to_block (&block, tmp);
9426 /* Do a deep copy if the rhs is a variable, if it is not the
9430 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9431 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9432 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9434 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9436 gfc_add_expr_to_block (&block, tmp);
9439 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9441 gfc_add_block_to_block (&block, &lse->pre);
9442 gfc_add_block_to_block (&block, &rse->pre);
9443 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9444 TREE_TYPE (lse->expr), rse->expr);
9445 gfc_add_modify (&block, lse->expr, tmp);
9449 gfc_add_block_to_block (&block, &lse->pre);
9450 gfc_add_block_to_block (&block, &rse->pre);
9452 gfc_add_modify (&block, lse->expr,
9453 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9456 gfc_add_block_to_block (&block, &lse->post);
9457 gfc_add_block_to_block (&block, &rse->post);
9459 return gfc_finish_block (&block);
9463 /* There are quite a lot of restrictions on the optimisation in using an
9464 array function assign without a temporary. */
9467 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9470 bool seen_array_ref;
9472 gfc_symbol *sym = expr1->symtree->n.sym;
9474 /* Play it safe with class functions assigned to a derived type. */
9475 if (gfc_is_class_array_function (expr2)
9476 && expr1->ts.type == BT_DERIVED)
9479 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9480 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9483 /* Elemental functions are scalarized so that they don't need a
9484 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9485 they would need special treatment in gfc_trans_arrayfunc_assign. */
9486 if (expr2->value.function.esym != NULL
9487 && expr2->value.function.esym->attr.elemental)
9490 /* Need a temporary if rhs is not FULL or a contiguous section. */
9491 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9494 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9495 if (gfc_ref_needs_temporary_p (expr1->ref))
9498 /* Functions returning pointers or allocatables need temporaries. */
9499 c = expr2->value.function.esym
9500 ? (expr2->value.function.esym->attr.pointer
9501 || expr2->value.function.esym->attr.allocatable)
9502 : (expr2->symtree->n.sym->attr.pointer
9503 || expr2->symtree->n.sym->attr.allocatable);
9507 /* Character array functions need temporaries unless the
9508 character lengths are the same. */
9509 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9511 if (expr1->ts.u.cl->length == NULL
9512 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9515 if (expr2->ts.u.cl->length == NULL
9516 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9519 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9520 expr2->ts.u.cl->length->value.integer) != 0)
9524 /* Check that no LHS component references appear during an array
9525 reference. This is needed because we do not have the means to
9526 span any arbitrary stride with an array descriptor. This check
9527 is not needed for the rhs because the function result has to be
9529 seen_array_ref = false;
9530 for (ref = expr1->ref; ref; ref = ref->next)
9532 if (ref->type == REF_ARRAY)
9533 seen_array_ref= true;
9534 else if (ref->type == REF_COMPONENT && seen_array_ref)
9538 /* Check for a dependency. */
9539 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9540 expr2->value.function.esym,
9541 expr2->value.function.actual,
9545 /* If we have reached here with an intrinsic function, we do not
9546 need a temporary except in the particular case that reallocation
9547 on assignment is active and the lhs is allocatable and a target. */
9548 if (expr2->value.function.isym)
9549 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9551 /* If the LHS is a dummy, we need a temporary if it is not
9553 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9556 /* If the lhs has been host_associated, is in common, a pointer or is
9557 a target and the function is not using a RESULT variable, aliasing
9558 can occur and a temporary is needed. */
9559 if ((sym->attr.host_assoc
9560 || sym->attr.in_common
9561 || sym->attr.pointer
9562 || sym->attr.cray_pointee
9563 || sym->attr.target)
9564 && expr2->symtree != NULL
9565 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9568 /* A PURE function can unconditionally be called without a temporary. */
9569 if (expr2->value.function.esym != NULL
9570 && expr2->value.function.esym->attr.pure)
9573 /* Implicit_pure functions are those which could legally be declared
9575 if (expr2->value.function.esym != NULL
9576 && expr2->value.function.esym->attr.implicit_pure)
9579 if (!sym->attr.use_assoc
9580 && !sym->attr.in_common
9581 && !sym->attr.pointer
9582 && !sym->attr.target
9583 && !sym->attr.cray_pointee
9584 && expr2->value.function.esym)
9586 /* A temporary is not needed if the function is not contained and
9587 the variable is local or host associated and not a pointer or
9589 if (!expr2->value.function.esym->attr.contained)
9592 /* A temporary is not needed if the lhs has never been host
9593 associated and the procedure is contained. */
9594 else if (!sym->attr.host_assoc)
9597 /* A temporary is not needed if the variable is local and not
9598 a pointer, a target or a result. */
9600 && expr2->value.function.esym->ns == sym->ns->parent)
9604 /* Default to temporary use. */
9609 /* Provide the loop info so that the lhs descriptor can be built for
9610 reallocatable assignments from extrinsic function calls. */
9613 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9616 /* Signal that the function call should not be made by
9617 gfc_conv_loop_setup. */
9618 se->ss->is_alloc_lhs = 1;
9619 gfc_init_loopinfo (loop);
9620 gfc_add_ss_to_loop (loop, *ss);
9621 gfc_add_ss_to_loop (loop, se->ss);
9622 gfc_conv_ss_startstride (loop);
9623 gfc_conv_loop_setup (loop, where);
9624 gfc_copy_loopinfo_to_se (se, loop);
9625 gfc_add_block_to_block (&se->pre, &loop->pre);
9626 gfc_add_block_to_block (&se->pre, &loop->post);
9627 se->ss->is_alloc_lhs = 0;
9631 /* For assignment to a reallocatable lhs from intrinsic functions,
9632 replace the se.expr (ie. the result) with a temporary descriptor.
9633 Null the data field so that the library allocates space for the
9634 result. Free the data of the original descriptor after the function,
9635 in case it appears in an argument expression and transfer the
9636 result to the original descriptor. */
9639 fcncall_realloc_result (gfc_se *se, int rank)
9648 /* Use the allocation done by the library. Substitute the lhs
9649 descriptor with a copy, whose data field is nulled.*/
9650 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9651 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9652 desc = build_fold_indirect_ref_loc (input_location, desc);
9654 /* Unallocated, the descriptor does not have a dtype. */
9655 tmp = gfc_conv_descriptor_dtype (desc);
9656 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9658 res_desc = gfc_evaluate_now (desc, &se->pre);
9659 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9660 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9662 /* Free the lhs after the function call and copy the result data to
9663 the lhs descriptor. */
9664 tmp = gfc_conv_descriptor_data_get (desc);
9665 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9666 logical_type_node, tmp,
9667 build_int_cst (TREE_TYPE (tmp), 0));
9668 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9669 tmp = gfc_call_free (tmp);
9670 gfc_add_expr_to_block (&se->post, tmp);
9672 tmp = gfc_conv_descriptor_data_get (res_desc);
9673 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9675 /* Check that the shapes are the same between lhs and expression. */
9676 for (n = 0 ; n < rank; n++)
9679 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9680 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9681 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9682 gfc_array_index_type, tmp, tmp1);
9683 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9684 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9685 gfc_array_index_type, tmp, tmp1);
9686 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9687 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9688 gfc_array_index_type, tmp, tmp1);
9689 tmp = fold_build2_loc (input_location, NE_EXPR,
9690 logical_type_node, tmp,
9691 gfc_index_zero_node);
9692 tmp = gfc_evaluate_now (tmp, &se->post);
9693 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9694 logical_type_node, tmp,
9698 /* 'zero_cond' being true is equal to lhs not being allocated or the
9699 shapes being different. */
9700 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9702 /* Now reset the bounds returned from the function call to bounds based
9703 on the lhs lbounds, except where the lhs is not allocated or the shapes
9704 of 'variable and 'expr' are different. Set the offset accordingly. */
9705 offset = gfc_index_zero_node;
9706 for (n = 0 ; n < rank; n++)
9710 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9711 lbound = fold_build3_loc (input_location, COND_EXPR,
9712 gfc_array_index_type, zero_cond,
9713 gfc_index_one_node, lbound);
9714 lbound = gfc_evaluate_now (lbound, &se->post);
9716 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9717 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9718 gfc_array_index_type, tmp, lbound);
9719 gfc_conv_descriptor_lbound_set (&se->post, desc,
9720 gfc_rank_cst[n], lbound);
9721 gfc_conv_descriptor_ubound_set (&se->post, desc,
9722 gfc_rank_cst[n], tmp);
9724 /* Set stride and accumulate the offset. */
9725 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9726 gfc_conv_descriptor_stride_set (&se->post, desc,
9727 gfc_rank_cst[n], tmp);
9728 tmp = fold_build2_loc (input_location, MULT_EXPR,
9729 gfc_array_index_type, lbound, tmp);
9730 offset = fold_build2_loc (input_location, MINUS_EXPR,
9731 gfc_array_index_type, offset, tmp);
9732 offset = gfc_evaluate_now (offset, &se->post);
9735 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9740 /* Try to translate array(:) = func (...), where func is a transformational
9741 array function, without using a temporary. Returns NULL if this isn't the
9745 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9749 gfc_component *comp = NULL;
9752 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9755 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9757 comp = gfc_get_proc_ptr_comp (expr2);
9759 if (!(expr2->value.function.isym
9760 || (comp && comp->attr.dimension)
9761 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9762 && expr2->value.function.esym->result->attr.dimension)))
9765 gfc_init_se (&se, NULL);
9766 gfc_start_block (&se.pre);
9767 se.want_pointer = 1;
9769 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9771 if (expr1->ts.type == BT_DERIVED
9772 && expr1->ts.u.derived->attr.alloc_comp)
9775 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9777 gfc_add_expr_to_block (&se.pre, tmp);
9780 se.direct_byref = 1;
9781 se.ss = gfc_walk_expr (expr2);
9782 gcc_assert (se.ss != gfc_ss_terminator);
9784 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9785 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9786 Clearly, this cannot be done for an allocatable function result, since
9787 the shape of the result is unknown and, in any case, the function must
9788 correctly take care of the reallocation internally. For intrinsic
9789 calls, the array data is freed and the library takes care of allocation.
9790 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9792 if (flag_realloc_lhs
9793 && gfc_is_reallocatable_lhs (expr1)
9794 && !gfc_expr_attr (expr1).codimension
9795 && !gfc_is_coindexed (expr1)
9796 && !(expr2->value.function.esym
9797 && expr2->value.function.esym->result->attr.allocatable))
9799 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9801 if (!expr2->value.function.isym)
9803 ss = gfc_walk_expr (expr1);
9804 gcc_assert (ss != gfc_ss_terminator);
9806 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9807 ss->is_alloc_lhs = 1;
9810 fcncall_realloc_result (&se, expr1->rank);
9813 gfc_conv_function_expr (&se, expr2);
9814 gfc_add_block_to_block (&se.pre, &se.post);
9817 gfc_cleanup_loop (&loop);
9819 gfc_free_ss_chain (se.ss);
9821 return gfc_finish_block (&se.pre);
9825 /* Try to efficiently translate array(:) = 0. Return NULL if this
9829 gfc_trans_zero_assign (gfc_expr * expr)
9831 tree dest, len, type;
9835 sym = expr->symtree->n.sym;
9836 dest = gfc_get_symbol_decl (sym);
9838 type = TREE_TYPE (dest);
9839 if (POINTER_TYPE_P (type))
9840 type = TREE_TYPE (type);
9841 if (!GFC_ARRAY_TYPE_P (type))
9844 /* Determine the length of the array. */
9845 len = GFC_TYPE_ARRAY_SIZE (type);
9846 if (!len || TREE_CODE (len) != INTEGER_CST)
9849 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9850 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9851 fold_convert (gfc_array_index_type, tmp));
9853 /* If we are zeroing a local array avoid taking its address by emitting
9855 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9856 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9857 dest, build_constructor (TREE_TYPE (dest),
9860 /* Convert arguments to the correct types. */
9861 dest = fold_convert (pvoid_type_node, dest);
9862 len = fold_convert (size_type_node, len);
9864 /* Construct call to __builtin_memset. */
9865 tmp = build_call_expr_loc (input_location,
9866 builtin_decl_explicit (BUILT_IN_MEMSET),
9867 3, dest, integer_zero_node, len);
9868 return fold_convert (void_type_node, tmp);
9872 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9873 that constructs the call to __builtin_memcpy. */
9876 gfc_build_memcpy_call (tree dst, tree src, tree len)
9880 /* Convert arguments to the correct types. */
9881 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9882 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9884 dst = fold_convert (pvoid_type_node, dst);
9886 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9887 src = gfc_build_addr_expr (pvoid_type_node, src);
9889 src = fold_convert (pvoid_type_node, src);
9891 len = fold_convert (size_type_node, len);
9893 /* Construct call to __builtin_memcpy. */
9894 tmp = build_call_expr_loc (input_location,
9895 builtin_decl_explicit (BUILT_IN_MEMCPY),
9897 return fold_convert (void_type_node, tmp);
9901 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9902 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9903 source/rhs, both are gfc_full_array_ref_p which have been checked for
9907 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9909 tree dst, dlen, dtype;
9910 tree src, slen, stype;
9913 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9914 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9916 dtype = TREE_TYPE (dst);
9917 if (POINTER_TYPE_P (dtype))
9918 dtype = TREE_TYPE (dtype);
9919 stype = TREE_TYPE (src);
9920 if (POINTER_TYPE_P (stype))
9921 stype = TREE_TYPE (stype);
9923 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9926 /* Determine the lengths of the arrays. */
9927 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9928 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9930 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9931 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9932 dlen, fold_convert (gfc_array_index_type, tmp));
9934 slen = GFC_TYPE_ARRAY_SIZE (stype);
9935 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9937 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9938 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9939 slen, fold_convert (gfc_array_index_type, tmp));
9941 /* Sanity check that they are the same. This should always be
9942 the case, as we should already have checked for conformance. */
9943 if (!tree_int_cst_equal (slen, dlen))
9946 return gfc_build_memcpy_call (dst, src, dlen);
9950 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9951 this can't be done. EXPR1 is the destination/lhs for which
9952 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9955 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9957 unsigned HOST_WIDE_INT nelem;
9963 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9967 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9968 dtype = TREE_TYPE (dst);
9969 if (POINTER_TYPE_P (dtype))
9970 dtype = TREE_TYPE (dtype);
9971 if (!GFC_ARRAY_TYPE_P (dtype))
9974 /* Determine the lengths of the array. */
9975 len = GFC_TYPE_ARRAY_SIZE (dtype);
9976 if (!len || TREE_CODE (len) != INTEGER_CST)
9979 /* Confirm that the constructor is the same size. */
9980 if (compare_tree_int (len, nelem) != 0)
9983 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9984 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9985 fold_convert (gfc_array_index_type, tmp));
9987 stype = gfc_typenode_for_spec (&expr2->ts);
9988 src = gfc_build_constant_array_constructor (expr2, stype);
9990 stype = TREE_TYPE (src);
9991 if (POINTER_TYPE_P (stype))
9992 stype = TREE_TYPE (stype);
9994 return gfc_build_memcpy_call (dst, src, len);
9998 /* Tells whether the expression is to be treated as a variable reference. */
10001 gfc_expr_is_variable (gfc_expr *expr)
10004 gfc_component *comp;
10005 gfc_symbol *func_ifc;
10007 if (expr->expr_type == EXPR_VARIABLE)
10010 arg = gfc_get_noncopying_intrinsic_argument (expr);
10013 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
10014 return gfc_expr_is_variable (arg);
10017 /* A data-pointer-returning function should be considered as a variable
10019 if (expr->expr_type == EXPR_FUNCTION
10020 && expr->ref == NULL)
10022 if (expr->value.function.isym != NULL)
10025 if (expr->value.function.esym != NULL)
10027 func_ifc = expr->value.function.esym;
10032 gcc_assert (expr->symtree);
10033 func_ifc = expr->symtree->n.sym;
10037 gcc_unreachable ();
10040 comp = gfc_get_proc_ptr_comp (expr);
10041 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
10044 func_ifc = comp->ts.interface;
10048 if (expr->expr_type == EXPR_COMPCALL)
10050 gcc_assert (!expr->value.compcall.tbp->is_generic);
10051 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
10058 gcc_assert (func_ifc->attr.function
10059 && func_ifc->result != NULL);
10060 return func_ifc->result->attr.pointer;
10064 /* Is the lhs OK for automatic reallocation? */
10067 is_scalar_reallocatable_lhs (gfc_expr *expr)
10071 /* An allocatable variable with no reference. */
10072 if (expr->symtree->n.sym->attr.allocatable
10076 /* All that can be left are allocatable components. However, we do
10077 not check for allocatable components here because the expression
10078 could be an allocatable component of a pointer component. */
10079 if (expr->symtree->n.sym->ts.type != BT_DERIVED
10080 && expr->symtree->n.sym->ts.type != BT_CLASS)
10083 /* Find an allocatable component ref last. */
10084 for (ref = expr->ref; ref; ref = ref->next)
10085 if (ref->type == REF_COMPONENT
10087 && ref->u.c.component->attr.allocatable)
10094 /* Allocate or reallocate scalar lhs, as necessary. */
10097 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
10098 tree string_length,
10106 tree size_in_bytes;
10112 if (!expr1 || expr1->rank)
10115 if (!expr2 || expr2->rank)
10118 for (ref = expr1->ref; ref; ref = ref->next)
10119 if (ref->type == REF_SUBSTRING)
10122 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10124 /* Since this is a scalar lhs, we can afford to do this. That is,
10125 there is no risk of side effects being repeated. */
10126 gfc_init_se (&lse, NULL);
10127 lse.want_pointer = 1;
10128 gfc_conv_expr (&lse, expr1);
10130 jump_label1 = gfc_build_label_decl (NULL_TREE);
10131 jump_label2 = gfc_build_label_decl (NULL_TREE);
10133 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10134 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
10135 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10137 tmp = build3_v (COND_EXPR, cond,
10138 build1_v (GOTO_EXPR, jump_label1),
10139 build_empty_stmt (input_location));
10140 gfc_add_expr_to_block (block, tmp);
10142 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10144 /* Use the rhs string length and the lhs element size. */
10145 size = string_length;
10146 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
10147 tmp = TYPE_SIZE_UNIT (tmp);
10148 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10149 TREE_TYPE (tmp), tmp,
10150 fold_convert (TREE_TYPE (tmp), size));
10154 /* Otherwise use the length in bytes of the rhs. */
10155 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
10156 size_in_bytes = size;
10159 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10160 size_in_bytes, size_one_node);
10162 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
10164 tree caf_decl, token;
10166 symbol_attribute attr;
10168 gfc_clear_attr (&attr);
10169 gfc_init_se (&caf_se, NULL);
10171 caf_decl = gfc_get_tree_for_caf_expr (expr1);
10172 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
10174 gfc_add_block_to_block (block, &caf_se.pre);
10175 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
10176 gfc_build_addr_expr (NULL_TREE, token),
10177 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
10180 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
10182 tmp = build_call_expr_loc (input_location,
10183 builtin_decl_explicit (BUILT_IN_CALLOC),
10184 2, build_one_cst (size_type_node),
10186 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10187 gfc_add_modify (block, lse.expr, tmp);
10191 tmp = build_call_expr_loc (input_location,
10192 builtin_decl_explicit (BUILT_IN_MALLOC),
10194 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10195 gfc_add_modify (block, lse.expr, tmp);
10198 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10200 /* Deferred characters need checking for lhs and rhs string
10201 length. Other deferred parameter variables will have to
10203 tmp = build1_v (GOTO_EXPR, jump_label2);
10204 gfc_add_expr_to_block (block, tmp);
10206 tmp = build1_v (LABEL_EXPR, jump_label1);
10207 gfc_add_expr_to_block (block, tmp);
10209 /* For a deferred length character, reallocate if lengths of lhs and
10210 rhs are different. */
10211 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10213 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10215 fold_convert (TREE_TYPE (lse.string_length),
10217 /* Jump past the realloc if the lengths are the same. */
10218 tmp = build3_v (COND_EXPR, cond,
10219 build1_v (GOTO_EXPR, jump_label2),
10220 build_empty_stmt (input_location));
10221 gfc_add_expr_to_block (block, tmp);
10222 tmp = build_call_expr_loc (input_location,
10223 builtin_decl_explicit (BUILT_IN_REALLOC),
10224 2, fold_convert (pvoid_type_node, lse.expr),
10226 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10227 gfc_add_modify (block, lse.expr, tmp);
10228 tmp = build1_v (LABEL_EXPR, jump_label2);
10229 gfc_add_expr_to_block (block, tmp);
10231 /* Update the lhs character length. */
10232 size = string_length;
10233 gfc_add_modify (block, lse.string_length,
10234 fold_convert (TREE_TYPE (lse.string_length), size));
10238 /* Check for assignments of the type
10242 to make sure we do not check for reallocation unneccessarily. */
10246 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
10248 gfc_actual_arglist *a;
10251 switch (expr2->expr_type)
10253 case EXPR_VARIABLE:
10254 return gfc_dep_compare_expr (expr1, expr2) == 0;
10256 case EXPR_FUNCTION:
10257 if (expr2->value.function.esym
10258 && expr2->value.function.esym->attr.elemental)
10260 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10263 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10268 else if (expr2->value.function.isym
10269 && expr2->value.function.isym->elemental)
10271 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10274 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10283 switch (expr2->value.op.op)
10285 case INTRINSIC_NOT:
10286 case INTRINSIC_UPLUS:
10287 case INTRINSIC_UMINUS:
10288 case INTRINSIC_PARENTHESES:
10289 return is_runtime_conformable (expr1, expr2->value.op.op1);
10291 case INTRINSIC_PLUS:
10292 case INTRINSIC_MINUS:
10293 case INTRINSIC_TIMES:
10294 case INTRINSIC_DIVIDE:
10295 case INTRINSIC_POWER:
10296 case INTRINSIC_AND:
10298 case INTRINSIC_EQV:
10299 case INTRINSIC_NEQV:
10306 case INTRINSIC_EQ_OS:
10307 case INTRINSIC_NE_OS:
10308 case INTRINSIC_GT_OS:
10309 case INTRINSIC_GE_OS:
10310 case INTRINSIC_LT_OS:
10311 case INTRINSIC_LE_OS:
10313 e1 = expr2->value.op.op1;
10314 e2 = expr2->value.op.op2;
10316 if (e1->rank == 0 && e2->rank > 0)
10317 return is_runtime_conformable (expr1, e2);
10318 else if (e1->rank > 0 && e2->rank == 0)
10319 return is_runtime_conformable (expr1, e1);
10320 else if (e1->rank > 0 && e2->rank > 0)
10321 return is_runtime_conformable (expr1, e1)
10322 && is_runtime_conformable (expr1, e2);
10340 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
10341 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
10342 bool class_realloc)
10344 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
10345 vec<tree, va_gc> *args = NULL;
10347 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
10350 /* Generate allocation of the lhs. */
10356 tmp = gfc_vptr_size_get (vptr);
10357 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10358 ? gfc_class_data_get (lse->expr) : lse->expr;
10359 gfc_init_block (&alloc);
10360 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
10361 tmp = fold_build2_loc (input_location, EQ_EXPR,
10362 logical_type_node, class_han,
10363 build_int_cst (prvoid_type_node, 0));
10364 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10366 PRED_FORTRAN_FAIL_ALLOC),
10367 gfc_finish_block (&alloc),
10368 build_empty_stmt (input_location));
10369 gfc_add_expr_to_block (&lse->pre, tmp);
10372 fcn = gfc_vptr_copy_get (vptr);
10374 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
10375 ? gfc_class_data_get (rse->expr) : rse->expr;
10378 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10379 || INDIRECT_REF_P (tmp)
10380 || (rhs->ts.type == BT_DERIVED
10381 && rhs->ts.u.derived->attr.unlimited_polymorphic
10382 && !rhs->ts.u.derived->attr.pointer
10383 && !rhs->ts.u.derived->attr.allocatable)
10384 || (UNLIMITED_POLY (rhs)
10385 && !CLASS_DATA (rhs)->attr.pointer
10386 && !CLASS_DATA (rhs)->attr.allocatable))
10387 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10389 vec_safe_push (args, tmp);
10390 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10391 ? gfc_class_data_get (lse->expr) : lse->expr;
10392 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10393 || INDIRECT_REF_P (tmp)
10394 || (lhs->ts.type == BT_DERIVED
10395 && lhs->ts.u.derived->attr.unlimited_polymorphic
10396 && !lhs->ts.u.derived->attr.pointer
10397 && !lhs->ts.u.derived->attr.allocatable)
10398 || (UNLIMITED_POLY (lhs)
10399 && !CLASS_DATA (lhs)->attr.pointer
10400 && !CLASS_DATA (lhs)->attr.allocatable))
10401 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10403 vec_safe_push (args, tmp);
10405 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10407 if (to_len != NULL_TREE && !integer_zerop (from_len))
10410 vec_safe_push (args, from_len);
10411 vec_safe_push (args, to_len);
10412 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10414 tmp = fold_build2_loc (input_location, GT_EXPR,
10415 logical_type_node, from_len,
10416 build_zero_cst (TREE_TYPE (from_len)));
10417 return fold_build3_loc (input_location, COND_EXPR,
10418 void_type_node, tmp,
10426 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10427 ? gfc_class_data_get (lse->expr) : lse->expr;
10428 stmtblock_t tblock;
10429 gfc_init_block (&tblock);
10430 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10431 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10432 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10433 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10434 /* When coming from a ptr_copy lhs and rhs are swapped. */
10435 gfc_add_modify_loc (input_location, &tblock, rhst,
10436 fold_convert (TREE_TYPE (rhst), tmp));
10437 return gfc_finish_block (&tblock);
10441 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10442 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10443 init_flag indicates initialization expressions and dealloc that no
10444 deallocate prior assignment is needed (if in doubt, set true).
10445 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10446 routine instead of a pointer assignment. Alias resolution is only done,
10447 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10448 where it is known, that newly allocated memory on the lhs can never be
10449 an alias of the rhs. */
10452 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10453 bool dealloc, bool use_vptr_copy, bool may_alias)
10458 gfc_ss *lss_section;
10465 bool scalar_to_array;
10466 tree string_length;
10468 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10469 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10470 bool is_poly_assign;
10472 /* Assignment of the form lhs = rhs. */
10473 gfc_start_block (&block);
10475 gfc_init_se (&lse, NULL);
10476 gfc_init_se (&rse, NULL);
10478 /* Walk the lhs. */
10479 lss = gfc_walk_expr (expr1);
10480 if (gfc_is_reallocatable_lhs (expr1))
10482 lss->no_bounds_check = 1;
10483 if (!(expr2->expr_type == EXPR_FUNCTION
10484 && expr2->value.function.isym != NULL
10485 && !(expr2->value.function.isym->elemental
10486 || expr2->value.function.isym->conversion)))
10487 lss->is_alloc_lhs = 1;
10490 lss->no_bounds_check = expr1->no_bounds_check;
10494 if ((expr1->ts.type == BT_DERIVED)
10495 && (gfc_is_class_array_function (expr2)
10496 || gfc_is_alloc_class_scalar_function (expr2)))
10497 expr2->must_finalize = 1;
10499 /* Checking whether a class assignment is desired is quite complicated and
10500 needed at two locations, so do it once only before the information is
10502 lhs_attr = gfc_expr_attr (expr1);
10503 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10504 || (lhs_attr.allocatable && !lhs_attr.dimension))
10505 && (expr1->ts.type == BT_CLASS
10506 || gfc_is_class_array_ref (expr1, NULL)
10507 || gfc_is_class_scalar_expr (expr1)
10508 || gfc_is_class_array_ref (expr2, NULL)
10509 || gfc_is_class_scalar_expr (expr2));
10512 /* Only analyze the expressions for coarray properties, when in coarray-lib
10514 if (flag_coarray == GFC_FCOARRAY_LIB)
10516 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10517 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10520 if (lss != gfc_ss_terminator)
10522 /* The assignment needs scalarization. */
10525 /* Find a non-scalar SS from the lhs. */
10526 while (lss_section != gfc_ss_terminator
10527 && lss_section->info->type != GFC_SS_SECTION)
10528 lss_section = lss_section->next;
10530 gcc_assert (lss_section != gfc_ss_terminator);
10532 /* Initialize the scalarizer. */
10533 gfc_init_loopinfo (&loop);
10535 /* Walk the rhs. */
10536 rss = gfc_walk_expr (expr2);
10537 if (rss == gfc_ss_terminator)
10538 /* The rhs is scalar. Add a ss for the expression. */
10539 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10540 /* When doing a class assign, then the handle to the rhs needs to be a
10541 pointer to allow for polymorphism. */
10542 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10543 rss->info->type = GFC_SS_REFERENCE;
10545 rss->no_bounds_check = expr2->no_bounds_check;
10546 /* Associate the SS with the loop. */
10547 gfc_add_ss_to_loop (&loop, lss);
10548 gfc_add_ss_to_loop (&loop, rss);
10550 /* Calculate the bounds of the scalarization. */
10551 gfc_conv_ss_startstride (&loop);
10552 /* Enable loop reversal. */
10553 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10554 loop.reverse[n] = GFC_ENABLE_REVERSE;
10555 /* Resolve any data dependencies in the statement. */
10557 gfc_conv_resolve_dependencies (&loop, lss, rss);
10558 /* Setup the scalarizing loops. */
10559 gfc_conv_loop_setup (&loop, &expr2->where);
10561 /* Setup the gfc_se structures. */
10562 gfc_copy_loopinfo_to_se (&lse, &loop);
10563 gfc_copy_loopinfo_to_se (&rse, &loop);
10566 gfc_mark_ss_chain_used (rss, 1);
10567 if (loop.temp_ss == NULL)
10570 gfc_mark_ss_chain_used (lss, 1);
10574 lse.ss = loop.temp_ss;
10575 gfc_mark_ss_chain_used (lss, 3);
10576 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10579 /* Allow the scalarizer to workshare array assignments. */
10580 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10581 == OMPWS_WORKSHARE_FLAG
10582 && loop.temp_ss == NULL)
10584 maybe_workshare = true;
10585 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10588 /* Start the scalarized loop body. */
10589 gfc_start_scalarized_body (&loop, &body);
10592 gfc_init_block (&body);
10594 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10596 /* Translate the expression. */
10597 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10598 && lhs_caf_attr.codimension;
10599 gfc_conv_expr (&rse, expr2);
10601 /* Deal with the case of a scalar class function assigned to a derived type. */
10602 if (gfc_is_alloc_class_scalar_function (expr2)
10603 && expr1->ts.type == BT_DERIVED)
10605 rse.expr = gfc_class_data_get (rse.expr);
10606 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10609 /* Stabilize a string length for temporaries. */
10610 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10611 && !(VAR_P (rse.string_length)
10612 || TREE_CODE (rse.string_length) == PARM_DECL
10613 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10614 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10615 else if (expr2->ts.type == BT_CHARACTER)
10617 if (expr1->ts.deferred
10618 && gfc_expr_attr (expr1).allocatable
10619 && gfc_check_dependency (expr1, expr2, true))
10620 rse.string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10621 string_length = rse.string_length;
10624 string_length = NULL_TREE;
10628 gfc_conv_tmp_array_ref (&lse);
10629 if (expr2->ts.type == BT_CHARACTER)
10630 lse.string_length = string_length;
10634 gfc_conv_expr (&lse, expr1);
10635 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10637 && gfc_expr_attr (expr1).allocatable
10644 tmp = INDIRECT_REF_P (lse.expr)
10645 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10647 /* We should only get array references here. */
10648 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10649 || TREE_CODE (tmp) == ARRAY_REF);
10651 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10652 or the array itself(ARRAY_REF). */
10653 tmp = TREE_OPERAND (tmp, 0);
10655 /* Provide the address of the array. */
10656 if (TREE_CODE (lse.expr) == ARRAY_REF)
10657 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10659 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10660 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10661 msg = _("Assignment of scalar to unallocated array");
10662 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10663 &expr1->where, msg);
10666 /* Deallocate the lhs parameterized components if required. */
10667 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10668 && !expr1->symtree->n.sym->attr.associate_var)
10670 if (expr1->ts.type == BT_DERIVED
10671 && expr1->ts.u.derived
10672 && expr1->ts.u.derived->attr.pdt_type)
10674 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10676 gfc_add_expr_to_block (&lse.pre, tmp);
10678 else if (expr1->ts.type == BT_CLASS
10679 && CLASS_DATA (expr1)->ts.u.derived
10680 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10682 tmp = gfc_class_data_get (lse.expr);
10683 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10685 gfc_add_expr_to_block (&lse.pre, tmp);
10690 /* Assignments of scalar derived types with allocatable components
10691 to arrays must be done with a deep copy and the rhs temporary
10692 must have its components deallocated afterwards. */
10693 scalar_to_array = (expr2->ts.type == BT_DERIVED
10694 && expr2->ts.u.derived->attr.alloc_comp
10695 && !gfc_expr_is_variable (expr2)
10696 && expr1->rank && !expr2->rank);
10697 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10699 && expr1->ts.u.derived->attr.alloc_comp
10700 && gfc_is_alloc_class_scalar_function (expr2));
10701 if (scalar_to_array && dealloc)
10703 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10704 gfc_prepend_expr_to_block (&loop.post, tmp);
10707 /* When assigning a character function result to a deferred-length variable,
10708 the function call must happen before the (re)allocation of the lhs -
10709 otherwise the character length of the result is not known.
10710 NOTE 1: This relies on having the exact dependence of the length type
10711 parameter available to the caller; gfortran saves it in the .mod files.
10712 NOTE 2: Vector array references generate an index temporary that must
10713 not go outside the loop. Otherwise, variables should not generate
10715 NOTE 3: The concatenation operation generates a temporary pointer,
10716 whose allocation must go to the innermost loop.
10717 NOTE 4: Elemental functions may generate a temporary, too. */
10718 if (flag_realloc_lhs
10719 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10720 && !(lss != gfc_ss_terminator
10721 && rss != gfc_ss_terminator
10722 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10723 || (expr2->expr_type == EXPR_FUNCTION
10724 && expr2->value.function.esym != NULL
10725 && expr2->value.function.esym->attr.elemental)
10726 || (expr2->expr_type == EXPR_FUNCTION
10727 && expr2->value.function.isym != NULL
10728 && expr2->value.function.isym->elemental)
10729 || (expr2->expr_type == EXPR_OP
10730 && expr2->value.op.op == INTRINSIC_CONCAT))))
10731 gfc_add_block_to_block (&block, &rse.pre);
10733 /* Nullify the allocatable components corresponding to those of the lhs
10734 derived type, so that the finalization of the function result does not
10735 affect the lhs of the assignment. Prepend is used to ensure that the
10736 nullification occurs before the call to the finalizer. In the case of
10737 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10738 as part of the deep copy. */
10739 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10740 && (gfc_is_class_array_function (expr2)
10741 || gfc_is_alloc_class_scalar_function (expr2)))
10744 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10745 gfc_prepend_expr_to_block (&rse.post, tmp);
10746 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10747 gfc_add_block_to_block (&loop.post, &rse.post);
10752 if (is_poly_assign)
10753 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10754 use_vptr_copy || (lhs_attr.allocatable
10755 && !lhs_attr.dimension),
10756 flag_realloc_lhs && !lhs_attr.pointer);
10757 else if (flag_coarray == GFC_FCOARRAY_LIB
10758 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10759 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10760 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10762 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10763 allocatable component, because those need to be accessed via the
10764 caf-runtime. No need to check for coindexes here, because resolve
10765 has rewritten those already. */
10767 gfc_actual_arglist a1, a2;
10768 /* Clear the structures to prevent accessing garbage. */
10769 memset (&code, '\0', sizeof (gfc_code));
10770 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10771 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10776 code.ext.actual = &a1;
10777 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10778 tmp = gfc_conv_intrinsic_subroutine (&code);
10780 else if (!is_poly_assign && expr2->must_finalize
10781 && expr1->ts.type == BT_CLASS
10782 && expr2->ts.type == BT_CLASS)
10784 /* This case comes about when the scalarizer provides array element
10785 references. Use the vptr copy function, since this does a deep
10786 copy of allocatable components, without which the finalizer call */
10787 tmp = gfc_get_vptr_from_expr (rse.expr);
10788 if (tmp != NULL_TREE)
10790 tree fcn = gfc_vptr_copy_get (tmp);
10791 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10792 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10793 tmp = build_call_expr_loc (input_location,
10795 gfc_build_addr_expr (NULL, rse.expr),
10796 gfc_build_addr_expr (NULL, lse.expr));
10800 /* If nothing else works, do it the old fashioned way! */
10801 if (tmp == NULL_TREE)
10802 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10803 gfc_expr_is_variable (expr2)
10805 || expr2->expr_type == EXPR_ARRAY,
10806 !(l_is_temp || init_flag) && dealloc,
10807 expr1->symtree->n.sym->attr.codimension);
10809 /* Add the pre blocks to the body. */
10810 gfc_add_block_to_block (&body, &rse.pre);
10811 gfc_add_block_to_block (&body, &lse.pre);
10812 gfc_add_expr_to_block (&body, tmp);
10813 /* Add the post blocks to the body. */
10814 gfc_add_block_to_block (&body, &rse.post);
10815 gfc_add_block_to_block (&body, &lse.post);
10817 if (lss == gfc_ss_terminator)
10819 /* F2003: Add the code for reallocation on assignment. */
10820 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10821 && !is_poly_assign)
10822 alloc_scalar_allocatable_for_assignment (&block, string_length,
10825 /* Use the scalar assignment as is. */
10826 gfc_add_block_to_block (&block, &body);
10830 gcc_assert (lse.ss == gfc_ss_terminator
10831 && rse.ss == gfc_ss_terminator);
10835 gfc_trans_scalarized_loop_boundary (&loop, &body);
10837 /* We need to copy the temporary to the actual lhs. */
10838 gfc_init_se (&lse, NULL);
10839 gfc_init_se (&rse, NULL);
10840 gfc_copy_loopinfo_to_se (&lse, &loop);
10841 gfc_copy_loopinfo_to_se (&rse, &loop);
10843 rse.ss = loop.temp_ss;
10846 gfc_conv_tmp_array_ref (&rse);
10847 gfc_conv_expr (&lse, expr1);
10849 gcc_assert (lse.ss == gfc_ss_terminator
10850 && rse.ss == gfc_ss_terminator);
10852 if (expr2->ts.type == BT_CHARACTER)
10853 rse.string_length = string_length;
10855 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10857 gfc_add_expr_to_block (&body, tmp);
10860 /* F2003: Allocate or reallocate lhs of allocatable array. */
10861 if (flag_realloc_lhs
10862 && gfc_is_reallocatable_lhs (expr1)
10864 && !is_runtime_conformable (expr1, expr2))
10866 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10867 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10868 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10869 if (tmp != NULL_TREE)
10870 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10873 if (maybe_workshare)
10874 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10876 /* Generate the copying loops. */
10877 gfc_trans_scalarizing_loops (&loop, &body);
10879 /* Wrap the whole thing up. */
10880 gfc_add_block_to_block (&block, &loop.pre);
10881 gfc_add_block_to_block (&block, &loop.post);
10883 gfc_cleanup_loop (&loop);
10886 return gfc_finish_block (&block);
10890 /* Check whether EXPR is a copyable array. */
10893 copyable_array_p (gfc_expr * expr)
10895 if (expr->expr_type != EXPR_VARIABLE)
10898 /* First check it's an array. */
10899 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10902 if (!gfc_full_array_ref_p (expr->ref, NULL))
10905 /* Next check that it's of a simple enough type. */
10906 switch (expr->ts.type)
10918 return !expr->ts.u.derived->attr.alloc_comp;
10927 /* Translate an assignment. */
10930 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10931 bool dealloc, bool use_vptr_copy, bool may_alias)
10935 /* Special case a single function returning an array. */
10936 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10938 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10943 /* Special case assigning an array to zero. */
10944 if (copyable_array_p (expr1)
10945 && is_zero_initializer_p (expr2))
10947 tmp = gfc_trans_zero_assign (expr1);
10952 /* Special case copying one array to another. */
10953 if (copyable_array_p (expr1)
10954 && copyable_array_p (expr2)
10955 && gfc_compare_types (&expr1->ts, &expr2->ts)
10956 && !gfc_check_dependency (expr1, expr2, 0))
10958 tmp = gfc_trans_array_copy (expr1, expr2);
10963 /* Special case initializing an array from a constant array constructor. */
10964 if (copyable_array_p (expr1)
10965 && expr2->expr_type == EXPR_ARRAY
10966 && gfc_compare_types (&expr1->ts, &expr2->ts))
10968 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10973 if (UNLIMITED_POLY (expr1) && expr1->rank
10974 && expr2->ts.type != BT_CLASS)
10975 use_vptr_copy = true;
10977 /* Fallback to the scalarizer to generate explicit loops. */
10978 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10979 use_vptr_copy, may_alias);
10983 gfc_trans_init_assign (gfc_code * code)
10985 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10989 gfc_trans_assign (gfc_code * code)
10991 return gfc_trans_assignment (code->expr1, code->expr2, false, true);