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 last class reference in an expression.
476 Return NULL_TREE if no class reference is found. */
479 gfc_get_class_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))
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)))
510 /* Obtain the vptr of the last class reference in an expression.
511 Return NULL_TREE if no class reference is found. */
514 gfc_get_vptr_from_expr (tree expr)
518 tmp = gfc_get_class_from_expr (expr);
520 if (tmp != NULL_TREE)
521 return gfc_class_vptr_get (tmp);
528 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
531 tree tmp, tmp2, type;
533 gfc_conv_descriptor_data_set (block, lhs_desc,
534 gfc_conv_descriptor_data_get (rhs_desc));
535 gfc_conv_descriptor_offset_set (block, lhs_desc,
536 gfc_conv_descriptor_offset_get (rhs_desc));
538 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
539 gfc_conv_descriptor_dtype (rhs_desc));
541 /* Assign the dimension as range-ref. */
542 tmp = gfc_get_descriptor_dimension (lhs_desc);
543 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
545 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
546 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
547 gfc_index_zero_node, NULL_TREE, NULL_TREE);
548 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
549 gfc_index_zero_node, NULL_TREE, NULL_TREE);
550 gfc_add_modify (block, tmp, tmp2);
554 /* Takes a derived type expression and returns the address of a temporary
555 class object of the 'declared' type. If vptr is not NULL, this is
556 used for the temporary class object.
557 optional_alloc_ptr is false when the dummy is neither allocatable
558 nor a pointer; that's only relevant for the optional handling. */
560 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
561 gfc_typespec class_ts, tree vptr, bool optional,
562 bool optional_alloc_ptr)
565 tree cond_optional = NULL_TREE;
572 /* The derived type needs to be converted to a temporary
574 tmp = gfc_typenode_for_spec (&class_ts);
575 var = gfc_create_var (tmp, "class");
578 ctree = gfc_class_vptr_get (var);
580 if (vptr != NULL_TREE)
582 /* Use the dynamic vptr. */
587 /* In this case the vtab corresponds to the derived type and the
588 vptr must point to it. */
589 vtab = gfc_find_derived_vtab (e->ts.u.derived);
591 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
593 gfc_add_modify (&parmse->pre, ctree,
594 fold_convert (TREE_TYPE (ctree), tmp));
596 /* Now set the data field. */
597 ctree = gfc_class_data_get (var);
600 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
602 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
604 /* If there is a ready made pointer to a derived type, use it
605 rather than evaluating the expression again. */
606 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
607 gfc_add_modify (&parmse->pre, ctree, tmp);
609 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
611 /* For an array reference in an elemental procedure call we need
612 to retain the ss to provide the scalarized array reference. */
613 gfc_conv_expr_reference (parmse, e);
614 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
616 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
618 fold_convert (TREE_TYPE (tmp), null_pointer_node));
619 gfc_add_modify (&parmse->pre, ctree, tmp);
623 ss = gfc_walk_expr (e);
624 if (ss == gfc_ss_terminator)
627 gfc_conv_expr_reference (parmse, e);
629 /* Scalar to an assumed-rank array. */
630 if (class_ts.u.derived->components->as)
633 type = get_scalar_to_descriptor_type (parmse->expr,
635 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
636 gfc_get_dtype (type));
638 parmse->expr = build3_loc (input_location, COND_EXPR,
639 TREE_TYPE (parmse->expr),
640 cond_optional, parmse->expr,
641 fold_convert (TREE_TYPE (parmse->expr),
643 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
647 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
649 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
651 fold_convert (TREE_TYPE (tmp),
653 gfc_add_modify (&parmse->pre, ctree, tmp);
659 gfc_init_block (&block);
663 parmse->use_offset = 1;
664 gfc_conv_expr_descriptor (parmse, e);
666 /* Detect any array references with vector subscripts. */
667 for (ref = e->ref; ref; ref = ref->next)
668 if (ref->type == REF_ARRAY
669 && ref->u.ar.type != AR_ELEMENT
670 && ref->u.ar.type != AR_FULL)
672 for (dim = 0; dim < ref->u.ar.dimen; dim++)
673 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
675 if (dim < ref->u.ar.dimen)
679 /* Array references with vector subscripts and non-variable expressions
680 need be converted to a one-based descriptor. */
681 if (ref || e->expr_type != EXPR_VARIABLE)
683 for (dim = 0; dim < e->rank; ++dim)
684 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
688 if (e->rank != class_ts.u.derived->components->as->rank)
690 gcc_assert (class_ts.u.derived->components->as->type
692 class_array_data_assign (&block, ctree, parmse->expr, false);
696 if (gfc_expr_attr (e).codimension)
697 parmse->expr = fold_build1_loc (input_location,
701 gfc_add_modify (&block, ctree, parmse->expr);
706 tmp = gfc_finish_block (&block);
708 gfc_init_block (&block);
709 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
711 tmp = build3_v (COND_EXPR, cond_optional, tmp,
712 gfc_finish_block (&block));
713 gfc_add_expr_to_block (&parmse->pre, tmp);
716 gfc_add_block_to_block (&parmse->pre, &block);
720 if (class_ts.u.derived->components->ts.type == BT_DERIVED
721 && class_ts.u.derived->components->ts.u.derived
722 ->attr.unlimited_polymorphic)
724 /* Take care about initializing the _len component correctly. */
725 ctree = gfc_class_len_get (var);
726 if (UNLIMITED_POLY (e))
731 len = gfc_copy_expr (e);
732 gfc_add_len_component (len);
733 gfc_init_se (&se, NULL);
734 gfc_conv_expr (&se, len);
736 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
737 cond_optional, se.expr,
738 fold_convert (TREE_TYPE (se.expr),
744 tmp = integer_zero_node;
745 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
748 /* Pass the address of the class object. */
749 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
751 if (optional && optional_alloc_ptr)
752 parmse->expr = build3_loc (input_location, COND_EXPR,
753 TREE_TYPE (parmse->expr),
754 cond_optional, parmse->expr,
755 fold_convert (TREE_TYPE (parmse->expr),
760 /* Create a new class container, which is required as scalar coarrays
761 have an array descriptor while normal scalars haven't. Optionally,
762 NULL pointer checks are added if the argument is OPTIONAL. */
765 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
766 gfc_typespec class_ts, bool optional)
768 tree var, ctree, tmp;
773 gfc_init_block (&block);
776 for (ref = e->ref; ref; ref = ref->next)
778 if (ref->type == REF_COMPONENT
779 && ref->u.c.component->ts.type == BT_CLASS)
783 if (class_ref == NULL
784 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
785 tmp = e->symtree->n.sym->backend_decl;
788 /* Remove everything after the last class reference, convert the
789 expression and then recover its tailend once more. */
791 ref = class_ref->next;
792 class_ref->next = NULL;
793 gfc_init_se (&tmpse, NULL);
794 gfc_conv_expr (&tmpse, e);
795 class_ref->next = ref;
799 var = gfc_typenode_for_spec (&class_ts);
800 var = gfc_create_var (var, "class");
802 ctree = gfc_class_vptr_get (var);
803 gfc_add_modify (&block, ctree,
804 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
806 ctree = gfc_class_data_get (var);
807 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
808 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
810 /* Pass the address of the class object. */
811 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
815 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
818 tmp = gfc_finish_block (&block);
820 gfc_init_block (&block);
821 tmp2 = gfc_class_data_get (var);
822 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
824 tmp2 = gfc_finish_block (&block);
826 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
828 gfc_add_expr_to_block (&parmse->pre, tmp);
831 gfc_add_block_to_block (&parmse->pre, &block);
835 /* Takes an intrinsic type expression and returns the address of a temporary
836 class object of the 'declared' type. */
838 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
839 gfc_typespec class_ts)
847 /* The intrinsic type needs to be converted to a temporary
849 tmp = gfc_typenode_for_spec (&class_ts);
850 var = gfc_create_var (tmp, "class");
853 ctree = gfc_class_vptr_get (var);
855 vtab = gfc_find_vtab (&e->ts);
857 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
858 gfc_add_modify (&parmse->pre, ctree,
859 fold_convert (TREE_TYPE (ctree), tmp));
861 /* Now set the data field. */
862 ctree = gfc_class_data_get (var);
863 if (parmse->ss && parmse->ss->info->useflags)
865 /* For an array reference in an elemental procedure call we need
866 to retain the ss to provide the scalarized array reference. */
867 gfc_conv_expr_reference (parmse, e);
868 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
869 gfc_add_modify (&parmse->pre, ctree, tmp);
873 ss = gfc_walk_expr (e);
874 if (ss == gfc_ss_terminator)
877 gfc_conv_expr_reference (parmse, e);
878 if (class_ts.u.derived->components->as
879 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
881 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
883 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
884 TREE_TYPE (ctree), tmp);
887 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
888 gfc_add_modify (&parmse->pre, ctree, tmp);
893 parmse->use_offset = 1;
894 gfc_conv_expr_descriptor (parmse, e);
895 if (class_ts.u.derived->components->as->rank != e->rank)
897 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
898 TREE_TYPE (ctree), parmse->expr);
899 gfc_add_modify (&parmse->pre, ctree, tmp);
902 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
906 gcc_assert (class_ts.type == BT_CLASS);
907 if (class_ts.u.derived->components->ts.type == BT_DERIVED
908 && class_ts.u.derived->components->ts.u.derived
909 ->attr.unlimited_polymorphic)
911 ctree = gfc_class_len_get (var);
912 /* When the actual arg is a char array, then set the _len component of the
913 unlimited polymorphic entity to the length of the string. */
914 if (e->ts.type == BT_CHARACTER)
916 /* Start with parmse->string_length because this seems to be set to a
917 correct value more often. */
918 if (parmse->string_length)
919 tmp = parmse->string_length;
920 /* When the string_length is not yet set, then try the backend_decl of
922 else if (e->ts.u.cl->backend_decl)
923 tmp = e->ts.u.cl->backend_decl;
924 /* If both of the above approaches fail, then try to generate an
925 expression from the input, which is only feasible currently, when the
926 expression can be evaluated to a constant one. */
929 /* Try to simplify the expression. */
930 gfc_simplify_expr (e, 0);
931 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
933 /* Amazingly all data is present to compute the length of a
934 constant string, but the expression is not yet there. */
935 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
936 gfc_charlen_int_kind,
938 mpz_set_ui (e->ts.u.cl->length->value.integer,
939 e->value.character.length);
940 gfc_conv_const_charlen (e->ts.u.cl);
941 e->ts.u.cl->resolved = 1;
942 tmp = e->ts.u.cl->backend_decl;
946 gfc_error ("Cannot compute the length of the char array "
947 "at %L.", &e->where);
952 tmp = integer_zero_node;
954 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
956 else if (class_ts.type == BT_CLASS
957 && class_ts.u.derived->components
958 && class_ts.u.derived->components->ts.u
959 .derived->attr.unlimited_polymorphic)
961 ctree = gfc_class_len_get (var);
962 gfc_add_modify (&parmse->pre, ctree,
963 fold_convert (TREE_TYPE (ctree),
966 /* Pass the address of the class object. */
967 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
971 /* Takes a scalarized class array expression and returns the
972 address of a temporary scalar class object of the 'declared'
974 OOP-TODO: This could be improved by adding code that branched on
975 the dynamic type being the same as the declared type. In this case
976 the original class expression can be passed directly.
977 optional_alloc_ptr is false when the dummy is neither allocatable
978 nor a pointer; that's relevant for the optional handling.
979 Set copyback to true if class container's _data and _vtab pointers
980 might get modified. */
983 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
984 bool elemental, bool copyback, bool optional,
985 bool optional_alloc_ptr)
991 tree cond = NULL_TREE;
992 tree slen = NULL_TREE;
996 bool full_array = false;
998 gfc_init_block (&block);
1001 for (ref = e->ref; ref; ref = ref->next)
1003 if (ref->type == REF_COMPONENT
1004 && ref->u.c.component->ts.type == BT_CLASS)
1007 if (ref->next == NULL)
1011 if ((ref == NULL || class_ref == ref)
1012 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
1013 && (!class_ts.u.derived->components->as
1014 || class_ts.u.derived->components->as->rank != -1))
1017 /* Test for FULL_ARRAY. */
1018 if (e->rank == 0 && gfc_expr_attr (e).codimension
1019 && gfc_expr_attr (e).dimension)
1022 gfc_is_class_array_ref (e, &full_array);
1024 /* The derived type needs to be converted to a temporary
1026 tmp = gfc_typenode_for_spec (&class_ts);
1027 var = gfc_create_var (tmp, "class");
1030 ctree = gfc_class_data_get (var);
1031 if (class_ts.u.derived->components->as
1032 && e->rank != class_ts.u.derived->components->as->rank)
1036 tree type = get_scalar_to_descriptor_type (parmse->expr,
1038 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1039 gfc_get_dtype (type));
1041 tmp = gfc_class_data_get (parmse->expr);
1042 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1043 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1045 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1048 class_array_data_assign (&block, ctree, parmse->expr, false);
1052 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1053 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1054 TREE_TYPE (ctree), parmse->expr);
1055 gfc_add_modify (&block, ctree, parmse->expr);
1058 /* Return the data component, except in the case of scalarized array
1059 references, where nullification of the cannot occur and so there
1061 if (!elemental && full_array && copyback)
1063 if (class_ts.u.derived->components->as
1064 && e->rank != class_ts.u.derived->components->as->rank)
1067 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1068 gfc_conv_descriptor_data_get (ctree));
1070 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1073 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1077 ctree = gfc_class_vptr_get (var);
1079 /* The vptr is the second field of the actual argument.
1080 First we have to find the corresponding class reference. */
1083 if (gfc_is_class_array_function (e)
1084 && parmse->class_vptr != NULL_TREE)
1085 tmp = parmse->class_vptr;
1086 else if (class_ref == NULL
1087 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1089 tmp = e->symtree->n.sym->backend_decl;
1091 if (TREE_CODE (tmp) == FUNCTION_DECL)
1092 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1094 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1095 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1097 slen = build_zero_cst (size_type_node);
1101 /* Remove everything after the last class reference, convert the
1102 expression and then recover its tailend once more. */
1104 ref = class_ref->next;
1105 class_ref->next = NULL;
1106 gfc_init_se (&tmpse, NULL);
1107 gfc_conv_expr (&tmpse, e);
1108 class_ref->next = ref;
1110 slen = tmpse.string_length;
1113 gcc_assert (tmp != NULL_TREE);
1115 /* Dereference if needs be. */
1116 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1117 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1119 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1120 vptr = gfc_class_vptr_get (tmp);
1124 gfc_add_modify (&block, ctree,
1125 fold_convert (TREE_TYPE (ctree), vptr));
1127 /* Return the vptr component, except in the case of scalarized array
1128 references, where the dynamic type cannot change. */
1129 if (!elemental && full_array && copyback)
1130 gfc_add_modify (&parmse->post, vptr,
1131 fold_convert (TREE_TYPE (vptr), ctree));
1133 /* For unlimited polymorphic objects also set the _len component. */
1134 if (class_ts.type == BT_CLASS
1135 && class_ts.u.derived->components
1136 && class_ts.u.derived->components->ts.u
1137 .derived->attr.unlimited_polymorphic)
1139 ctree = gfc_class_len_get (var);
1140 if (UNLIMITED_POLY (e))
1141 tmp = gfc_class_len_get (tmp);
1142 else if (e->ts.type == BT_CHARACTER)
1144 gcc_assert (slen != NULL_TREE);
1148 tmp = build_zero_cst (size_type_node);
1149 gfc_add_modify (&parmse->pre, ctree,
1150 fold_convert (TREE_TYPE (ctree), tmp));
1152 /* Return the len component, except in the case of scalarized array
1153 references, where the dynamic type cannot change. */
1154 if (!elemental && full_array && copyback
1155 && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1156 gfc_add_modify (&parmse->post, tmp,
1157 fold_convert (TREE_TYPE (tmp), ctree));
1164 cond = gfc_conv_expr_present (e->symtree->n.sym);
1165 /* parmse->pre may contain some preparatory instructions for the
1166 temporary array descriptor. Those may only be executed when the
1167 optional argument is set, therefore add parmse->pre's instructions
1168 to block, which is later guarded by an if (optional_arg_given). */
1169 gfc_add_block_to_block (&parmse->pre, &block);
1170 block.head = parmse->pre.head;
1171 parmse->pre.head = NULL_TREE;
1172 tmp = gfc_finish_block (&block);
1174 if (optional_alloc_ptr)
1175 tmp2 = build_empty_stmt (input_location);
1178 gfc_init_block (&block);
1180 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1181 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1182 null_pointer_node));
1183 tmp2 = gfc_finish_block (&block);
1186 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1188 gfc_add_expr_to_block (&parmse->pre, tmp);
1191 gfc_add_block_to_block (&parmse->pre, &block);
1193 /* Pass the address of the class object. */
1194 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1196 if (optional && optional_alloc_ptr)
1197 parmse->expr = build3_loc (input_location, COND_EXPR,
1198 TREE_TYPE (parmse->expr),
1200 fold_convert (TREE_TYPE (parmse->expr),
1201 null_pointer_node));
1205 /* Given a class array declaration and an index, returns the address
1206 of the referenced element. */
1209 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1212 tree data, size, tmp, ctmp, offset, ptr;
1214 data = data_comp != NULL_TREE ? data_comp :
1215 gfc_class_data_get (class_decl);
1216 size = gfc_class_vtab_size_get (class_decl);
1220 tmp = fold_convert (gfc_array_index_type,
1221 gfc_class_len_get (class_decl));
1222 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1223 gfc_array_index_type, size, tmp);
1224 tmp = fold_build2_loc (input_location, GT_EXPR,
1225 logical_type_node, tmp,
1226 build_zero_cst (TREE_TYPE (tmp)));
1227 size = fold_build3_loc (input_location, COND_EXPR,
1228 gfc_array_index_type, tmp, ctmp, size);
1231 offset = fold_build2_loc (input_location, MULT_EXPR,
1232 gfc_array_index_type,
1235 data = gfc_conv_descriptor_data_get (data);
1236 ptr = fold_convert (pvoid_type_node, data);
1237 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1238 return fold_convert (TREE_TYPE (data), ptr);
1242 /* Copies one class expression to another, assuming that if either
1243 'to' or 'from' are arrays they are packed. Should 'from' be
1244 NULL_TREE, the initialization expression for 'to' is used, assuming
1245 that the _vptr is set. */
1248 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1258 vec<tree, va_gc> *args;
1263 bool is_from_desc = false, is_to_class = false;
1266 /* To prevent warnings on uninitialized variables. */
1267 from_len = to_len = NULL_TREE;
1269 if (from != NULL_TREE)
1270 fcn = gfc_class_vtab_copy_get (from);
1272 fcn = gfc_class_vtab_copy_get (to);
1274 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1276 if (from != NULL_TREE)
1278 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1282 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1286 /* Check that from is a class. When the class is part of a coarray,
1287 then from is a common pointer and is to be used as is. */
1288 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1289 ? build_fold_indirect_ref (from) : from;
1291 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1292 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1293 ? gfc_class_data_get (from) : from;
1294 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1298 from_data = gfc_class_vtab_def_init_get (to);
1302 if (from != NULL_TREE && unlimited)
1303 from_len = gfc_class_len_or_zero_get (from);
1305 from_len = build_zero_cst (size_type_node);
1308 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1311 to_data = gfc_class_data_get (to);
1313 to_len = gfc_class_len_get (to);
1316 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1319 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1321 stmtblock_t loopbody;
1325 tree orig_nelems = nelems; /* Needed for bounds check. */
1327 gfc_init_block (&body);
1328 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1329 gfc_array_index_type, nelems,
1330 gfc_index_one_node);
1331 nelems = gfc_evaluate_now (tmp, &body);
1332 index = gfc_create_var (gfc_array_index_type, "S");
1336 from_ref = gfc_get_class_array_ref (index, from, from_data,
1338 vec_safe_push (args, from_ref);
1341 vec_safe_push (args, from_data);
1344 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1347 tmp = gfc_conv_array_data (to);
1348 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1349 to_ref = gfc_build_addr_expr (NULL_TREE,
1350 gfc_build_array_ref (tmp, index, to));
1352 vec_safe_push (args, to_ref);
1354 /* Add bounds check. */
1355 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1358 const char *name = "<<unknown>>";
1362 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1364 from_len = gfc_conv_descriptor_size (from_data, 1);
1365 tmp = fold_build2_loc (input_location, NE_EXPR,
1366 logical_type_node, from_len, orig_nelems);
1367 msg = xasprintf ("Array bound mismatch for dimension %d "
1368 "of array '%s' (%%ld/%%ld)",
1371 gfc_trans_runtime_check (true, false, tmp, &body,
1372 &gfc_current_locus, msg,
1373 fold_convert (long_integer_type_node, orig_nelems),
1374 fold_convert (long_integer_type_node, from_len));
1379 tmp = build_call_vec (fcn_type, fcn, args);
1381 /* Build the body of the loop. */
1382 gfc_init_block (&loopbody);
1383 gfc_add_expr_to_block (&loopbody, tmp);
1385 /* Build the loop and return. */
1386 gfc_init_loopinfo (&loop);
1388 loop.from[0] = gfc_index_zero_node;
1389 loop.loopvar[0] = index;
1390 loop.to[0] = nelems;
1391 gfc_trans_scalarizing_loops (&loop, &loopbody);
1392 gfc_init_block (&ifbody);
1393 gfc_add_block_to_block (&ifbody, &loop.pre);
1394 stdcopy = gfc_finish_block (&ifbody);
1395 /* In initialization mode from_len is a constant zero. */
1396 if (unlimited && !integer_zerop (from_len))
1398 vec_safe_push (args, from_len);
1399 vec_safe_push (args, to_len);
1400 tmp = build_call_vec (fcn_type, fcn, args);
1401 /* Build the body of the loop. */
1402 gfc_init_block (&loopbody);
1403 gfc_add_expr_to_block (&loopbody, tmp);
1405 /* Build the loop and return. */
1406 gfc_init_loopinfo (&loop);
1408 loop.from[0] = gfc_index_zero_node;
1409 loop.loopvar[0] = index;
1410 loop.to[0] = nelems;
1411 gfc_trans_scalarizing_loops (&loop, &loopbody);
1412 gfc_init_block (&ifbody);
1413 gfc_add_block_to_block (&ifbody, &loop.pre);
1414 extcopy = gfc_finish_block (&ifbody);
1416 tmp = fold_build2_loc (input_location, GT_EXPR,
1417 logical_type_node, from_len,
1418 build_zero_cst (TREE_TYPE (from_len)));
1419 tmp = fold_build3_loc (input_location, COND_EXPR,
1420 void_type_node, tmp, extcopy, stdcopy);
1421 gfc_add_expr_to_block (&body, tmp);
1422 tmp = gfc_finish_block (&body);
1426 gfc_add_expr_to_block (&body, stdcopy);
1427 tmp = gfc_finish_block (&body);
1429 gfc_cleanup_loop (&loop);
1433 gcc_assert (!is_from_desc);
1434 vec_safe_push (args, from_data);
1435 vec_safe_push (args, to_data);
1436 stdcopy = build_call_vec (fcn_type, fcn, args);
1438 /* In initialization mode from_len is a constant zero. */
1439 if (unlimited && !integer_zerop (from_len))
1441 vec_safe_push (args, from_len);
1442 vec_safe_push (args, to_len);
1443 extcopy = build_call_vec (fcn_type, fcn, args);
1444 tmp = fold_build2_loc (input_location, GT_EXPR,
1445 logical_type_node, from_len,
1446 build_zero_cst (TREE_TYPE (from_len)));
1447 tmp = fold_build3_loc (input_location, COND_EXPR,
1448 void_type_node, tmp, extcopy, stdcopy);
1454 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1455 if (from == NULL_TREE)
1458 cond = fold_build2_loc (input_location, NE_EXPR,
1460 from_data, null_pointer_node);
1461 tmp = fold_build3_loc (input_location, COND_EXPR,
1462 void_type_node, cond,
1463 tmp, build_empty_stmt (input_location));
1471 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1473 gfc_actual_arglist *actual;
1478 actual = gfc_get_actual_arglist ();
1479 actual->expr = gfc_copy_expr (rhs);
1480 actual->next = gfc_get_actual_arglist ();
1481 actual->next->expr = gfc_copy_expr (lhs);
1482 ppc = gfc_copy_expr (obj);
1483 gfc_add_vptr_component (ppc);
1484 gfc_add_component_ref (ppc, "_copy");
1485 ppc_code = gfc_get_code (EXEC_CALL);
1486 ppc_code->resolved_sym = ppc->symtree->n.sym;
1487 /* Although '_copy' is set to be elemental in class.c, it is
1488 not staying that way. Find out why, sometime.... */
1489 ppc_code->resolved_sym->attr.elemental = 1;
1490 ppc_code->ext.actual = actual;
1491 ppc_code->expr1 = ppc;
1492 /* Since '_copy' is elemental, the scalarizer will take care
1493 of arrays in gfc_trans_call. */
1494 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1495 gfc_free_statements (ppc_code);
1497 if (UNLIMITED_POLY(obj))
1499 /* Check if rhs is non-NULL. */
1501 gfc_init_se (&src, NULL);
1502 gfc_conv_expr (&src, rhs);
1503 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1504 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1505 src.expr, fold_convert (TREE_TYPE (src.expr),
1506 null_pointer_node));
1507 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1508 build_empty_stmt (input_location));
1514 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1515 A MEMCPY is needed to copy the full data from the default initializer
1516 of the dynamic type. */
1519 gfc_trans_class_init_assign (gfc_code *code)
1523 gfc_se dst,src,memsz;
1524 gfc_expr *lhs, *rhs, *sz;
1526 gfc_start_block (&block);
1528 lhs = gfc_copy_expr (code->expr1);
1530 rhs = gfc_copy_expr (code->expr1);
1531 gfc_add_vptr_component (rhs);
1533 /* Make sure that the component backend_decls have been built, which
1534 will not have happened if the derived types concerned have not
1536 gfc_get_derived_type (rhs->ts.u.derived);
1537 gfc_add_def_init_component (rhs);
1538 /* The _def_init is always scalar. */
1541 if (code->expr1->ts.type == BT_CLASS
1542 && CLASS_DATA (code->expr1)->attr.dimension)
1544 gfc_array_spec *tmparr = gfc_get_array_spec ();
1545 *tmparr = *CLASS_DATA (code->expr1)->as;
1546 /* Adding the array ref to the class expression results in correct
1547 indexing to the dynamic type. */
1548 gfc_add_full_array_ref (lhs, tmparr);
1549 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1553 /* Scalar initialization needs the _data component. */
1554 gfc_add_data_component (lhs);
1555 sz = gfc_copy_expr (code->expr1);
1556 gfc_add_vptr_component (sz);
1557 gfc_add_size_component (sz);
1559 gfc_init_se (&dst, NULL);
1560 gfc_init_se (&src, NULL);
1561 gfc_init_se (&memsz, NULL);
1562 gfc_conv_expr (&dst, lhs);
1563 gfc_conv_expr (&src, rhs);
1564 gfc_conv_expr (&memsz, sz);
1565 gfc_add_block_to_block (&block, &src.pre);
1566 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1568 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1570 if (UNLIMITED_POLY(code->expr1))
1572 /* Check if _def_init is non-NULL. */
1573 tree cond = fold_build2_loc (input_location, NE_EXPR,
1574 logical_type_node, src.expr,
1575 fold_convert (TREE_TYPE (src.expr),
1576 null_pointer_node));
1577 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1578 tmp, build_empty_stmt (input_location));
1582 if (code->expr1->symtree->n.sym->attr.optional
1583 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1585 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1586 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1588 build_empty_stmt (input_location));
1591 gfc_add_expr_to_block (&block, tmp);
1593 return gfc_finish_block (&block);
1597 /* End of prototype trans-class.c */
1601 realloc_lhs_warning (bt type, bool array, locus *where)
1603 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1604 gfc_warning (OPT_Wrealloc_lhs,
1605 "Code for reallocating the allocatable array at %L will "
1607 else if (warn_realloc_lhs_all)
1608 gfc_warning (OPT_Wrealloc_lhs_all,
1609 "Code for reallocating the allocatable variable at %L "
1610 "will be added", where);
1614 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1617 /* Copy the scalarization loop variables. */
1620 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1623 dest->loop = src->loop;
1627 /* Initialize a simple expression holder.
1629 Care must be taken when multiple se are created with the same parent.
1630 The child se must be kept in sync. The easiest way is to delay creation
1631 of a child se until after after the previous se has been translated. */
1634 gfc_init_se (gfc_se * se, gfc_se * parent)
1636 memset (se, 0, sizeof (gfc_se));
1637 gfc_init_block (&se->pre);
1638 gfc_init_block (&se->post);
1640 se->parent = parent;
1643 gfc_copy_se_loopvars (se, parent);
1647 /* Advances to the next SS in the chain. Use this rather than setting
1648 se->ss = se->ss->next because all the parents needs to be kept in sync.
1652 gfc_advance_se_ss_chain (gfc_se * se)
1657 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1660 /* Walk down the parent chain. */
1663 /* Simple consistency check. */
1664 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1665 || p->parent->ss->nested_ss == p->ss);
1667 /* If we were in a nested loop, the next scalarized expression can be
1668 on the parent ss' next pointer. Thus we should not take the next
1669 pointer blindly, but rather go up one nest level as long as next
1670 is the end of chain. */
1672 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1682 /* Ensures the result of the expression as either a temporary variable
1683 or a constant so that it can be used repeatedly. */
1686 gfc_make_safe_expr (gfc_se * se)
1690 if (CONSTANT_CLASS_P (se->expr))
1693 /* We need a temporary for this result. */
1694 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1695 gfc_add_modify (&se->pre, var, se->expr);
1700 /* Return an expression which determines if a dummy parameter is present.
1701 Also used for arguments to procedures with multiple entry points. */
1704 gfc_conv_expr_present (gfc_symbol * sym)
1708 gcc_assert (sym->attr.dummy);
1709 decl = gfc_get_symbol_decl (sym);
1711 /* Intrinsic scalars with VALUE attribute which are passed by value
1712 use a hidden argument to denote the present status. */
1713 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1714 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1715 && !sym->attr.dimension)
1717 char name[GFC_MAX_SYMBOL_LEN + 2];
1720 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1722 strcpy (&name[1], sym->name);
1723 tree_name = get_identifier (name);
1725 /* Walk function argument list to find hidden arg. */
1726 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1727 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1728 if (DECL_NAME (cond) == tree_name)
1735 if (TREE_CODE (decl) != PARM_DECL)
1737 /* Array parameters use a temporary descriptor, we want the real
1739 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1740 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1741 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1744 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1745 fold_convert (TREE_TYPE (decl), null_pointer_node));
1747 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1748 as actual argument to denote absent dummies. For array descriptors,
1749 we thus also need to check the array descriptor. For BT_CLASS, it
1750 can also occur for scalars and F2003 due to type->class wrapping and
1751 class->class wrapping. Note further that BT_CLASS always uses an
1752 array descriptor for arrays, also for explicit-shape/assumed-size. */
1754 if (!sym->attr.allocatable
1755 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1756 || (sym->ts.type == BT_CLASS
1757 && !CLASS_DATA (sym)->attr.allocatable
1758 && !CLASS_DATA (sym)->attr.class_pointer))
1759 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1760 || sym->ts.type == BT_CLASS))
1764 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1765 || sym->as->type == AS_ASSUMED_RANK
1766 || sym->attr.codimension))
1767 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1769 tmp = build_fold_indirect_ref_loc (input_location, decl);
1770 if (sym->ts.type == BT_CLASS)
1771 tmp = gfc_class_data_get (tmp);
1772 tmp = gfc_conv_array_data (tmp);
1774 else if (sym->ts.type == BT_CLASS)
1775 tmp = gfc_class_data_get (decl);
1779 if (tmp != NULL_TREE)
1781 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1782 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1783 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1784 logical_type_node, cond, tmp);
1792 /* Converts a missing, dummy argument into a null or zero. */
1795 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1800 present = gfc_conv_expr_present (arg->symtree->n.sym);
1804 /* Create a temporary and convert it to the correct type. */
1805 tmp = gfc_get_int_type (kind);
1806 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1809 /* Test for a NULL value. */
1810 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1811 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1812 tmp = gfc_evaluate_now (tmp, &se->pre);
1813 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1817 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1819 build_zero_cst (TREE_TYPE (se->expr)));
1820 tmp = gfc_evaluate_now (tmp, &se->pre);
1824 if (ts.type == BT_CHARACTER)
1826 tmp = build_int_cst (gfc_charlen_type_node, 0);
1827 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1828 present, se->string_length, tmp);
1829 tmp = gfc_evaluate_now (tmp, &se->pre);
1830 se->string_length = tmp;
1836 /* Get the character length of an expression, looking through gfc_refs
1840 gfc_get_expr_charlen (gfc_expr *e)
1846 gcc_assert (e->expr_type == EXPR_VARIABLE
1847 && e->ts.type == BT_CHARACTER);
1849 length = NULL; /* To silence compiler warning. */
1851 if (is_subref_array (e) && e->ts.u.cl->length)
1854 gfc_init_se (&tmpse, NULL);
1855 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1856 e->ts.u.cl->backend_decl = tmpse.expr;
1860 /* First candidate: if the variable is of type CHARACTER, the
1861 expression's length could be the length of the character
1863 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1864 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1866 /* Look through the reference chain for component references. */
1867 for (r = e->ref; r; r = r->next)
1872 if (r->u.c.component->ts.type == BT_CHARACTER)
1873 length = r->u.c.component->ts.u.cl->backend_decl;
1881 gfc_init_se (&se, NULL);
1882 gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
1884 gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
1885 length = fold_build2_loc (input_location, MINUS_EXPR,
1886 gfc_charlen_type_node,
1888 length = fold_build2_loc (input_location, PLUS_EXPR,
1889 gfc_charlen_type_node, length,
1890 gfc_index_one_node);
1899 gcc_assert (length != NULL);
1904 /* Return for an expression the backend decl of the coarray. */
1907 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1913 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1915 /* Not-implemented diagnostic. */
1916 if (expr->symtree->n.sym->ts.type == BT_CLASS
1917 && UNLIMITED_POLY (expr->symtree->n.sym)
1918 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1919 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1920 "%L is not supported", &expr->where);
1922 for (ref = expr->ref; ref; ref = ref->next)
1923 if (ref->type == REF_COMPONENT)
1925 if (ref->u.c.component->ts.type == BT_CLASS
1926 && UNLIMITED_POLY (ref->u.c.component)
1927 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1928 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1929 "component at %L is not supported", &expr->where);
1932 /* Make sure the backend_decl is present before accessing it. */
1933 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1934 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1935 : expr->symtree->n.sym->backend_decl;
1937 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1939 if (expr->ref && expr->ref->type == REF_ARRAY)
1941 caf_decl = gfc_class_data_get (caf_decl);
1942 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1945 for (ref = expr->ref; ref; ref = ref->next)
1947 if (ref->type == REF_COMPONENT
1948 && strcmp (ref->u.c.component->name, "_data") != 0)
1950 caf_decl = gfc_class_data_get (caf_decl);
1951 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1955 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1959 if (expr->symtree->n.sym->attr.codimension)
1962 /* The following code assumes that the coarray is a component reachable via
1963 only scalar components/variables; the Fortran standard guarantees this. */
1965 for (ref = expr->ref; ref; ref = ref->next)
1966 if (ref->type == REF_COMPONENT)
1968 gfc_component *comp = ref->u.c.component;
1970 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1971 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1972 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1973 TREE_TYPE (comp->backend_decl), caf_decl,
1974 comp->backend_decl, NULL_TREE);
1975 if (comp->ts.type == BT_CLASS)
1977 caf_decl = gfc_class_data_get (caf_decl);
1978 if (CLASS_DATA (comp)->attr.codimension)
1984 if (comp->attr.codimension)
1990 gcc_assert (found && caf_decl);
1995 /* Obtain the Coarray token - and optionally also the offset. */
1998 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1999 tree se_expr, gfc_expr *expr)
2003 /* Coarray token. */
2004 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2006 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
2007 == GFC_ARRAY_ALLOCATABLE
2008 || expr->symtree->n.sym->attr.select_type_temporary);
2009 *token = gfc_conv_descriptor_token (caf_decl);
2011 else if (DECL_LANG_SPECIFIC (caf_decl)
2012 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
2013 *token = GFC_DECL_TOKEN (caf_decl);
2016 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2017 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2018 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2024 /* Offset between the coarray base address and the address wanted. */
2025 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2026 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2027 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2028 *offset = build_int_cst (gfc_array_index_type, 0);
2029 else if (DECL_LANG_SPECIFIC (caf_decl)
2030 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2031 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2032 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2033 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2035 *offset = build_int_cst (gfc_array_index_type, 0);
2037 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2038 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2040 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2041 tmp = gfc_conv_descriptor_data_get (tmp);
2043 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2044 tmp = gfc_conv_descriptor_data_get (se_expr);
2047 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2051 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2052 *offset, fold_convert (gfc_array_index_type, tmp));
2054 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2055 && expr->symtree->n.sym->attr.codimension
2056 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2058 gfc_expr *base_expr = gfc_copy_expr (expr);
2059 gfc_ref *ref = base_expr->ref;
2062 // Iterate through the refs until the last one.
2066 if (ref->type == REF_ARRAY
2067 && ref->u.ar.type != AR_FULL)
2069 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2071 for (i = 0; i < ranksum; ++i)
2073 ref->u.ar.start[i] = NULL;
2074 ref->u.ar.end[i] = NULL;
2076 ref->u.ar.type = AR_FULL;
2078 gfc_init_se (&base_se, NULL);
2079 if (gfc_caf_attr (base_expr).dimension)
2081 gfc_conv_expr_descriptor (&base_se, base_expr);
2082 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2086 gfc_conv_expr (&base_se, base_expr);
2090 gfc_free_expr (base_expr);
2091 gfc_add_block_to_block (&se->pre, &base_se.pre);
2092 gfc_add_block_to_block (&se->post, &base_se.post);
2094 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2095 tmp = gfc_conv_descriptor_data_get (caf_decl);
2098 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2102 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2103 fold_convert (gfc_array_index_type, *offset),
2104 fold_convert (gfc_array_index_type, tmp));
2108 /* Convert the coindex of a coarray into an image index; the result is
2109 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2110 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2113 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2116 tree lbound, ubound, extent, tmp, img_idx;
2120 for (ref = e->ref; ref; ref = ref->next)
2121 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2123 gcc_assert (ref != NULL);
2125 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2127 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2131 img_idx = build_zero_cst (gfc_array_index_type);
2132 extent = build_one_cst (gfc_array_index_type);
2133 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2134 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2136 gfc_init_se (&se, NULL);
2137 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2138 gfc_add_block_to_block (block, &se.pre);
2139 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2140 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2141 TREE_TYPE (lbound), se.expr, lbound);
2142 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2144 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2145 TREE_TYPE (tmp), img_idx, tmp);
2146 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2148 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2149 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2150 extent = fold_build2_loc (input_location, MULT_EXPR,
2151 TREE_TYPE (tmp), extent, tmp);
2155 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2157 gfc_init_se (&se, NULL);
2158 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2159 gfc_add_block_to_block (block, &se.pre);
2160 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2161 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2162 TREE_TYPE (lbound), se.expr, lbound);
2163 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2165 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2167 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2169 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2170 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2171 TREE_TYPE (ubound), ubound, lbound);
2172 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2173 tmp, build_one_cst (TREE_TYPE (tmp)));
2174 extent = fold_build2_loc (input_location, MULT_EXPR,
2175 TREE_TYPE (tmp), extent, tmp);
2178 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2179 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2180 return fold_convert (integer_type_node, img_idx);
2184 /* For each character array constructor subexpression without a ts.u.cl->length,
2185 replace it by its first element (if there aren't any elements, the length
2186 should already be set to zero). */
2189 flatten_array_ctors_without_strlen (gfc_expr* e)
2191 gfc_actual_arglist* arg;
2197 switch (e->expr_type)
2201 flatten_array_ctors_without_strlen (e->value.op.op1);
2202 flatten_array_ctors_without_strlen (e->value.op.op2);
2206 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2210 for (arg = e->value.function.actual; arg; arg = arg->next)
2211 flatten_array_ctors_without_strlen (arg->expr);
2216 /* We've found what we're looking for. */
2217 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2222 gcc_assert (e->value.constructor);
2224 c = gfc_constructor_first (e->value.constructor);
2228 flatten_array_ctors_without_strlen (new_expr);
2229 gfc_replace_expr (e, new_expr);
2233 /* Otherwise, fall through to handle constructor elements. */
2235 case EXPR_STRUCTURE:
2236 for (c = gfc_constructor_first (e->value.constructor);
2237 c; c = gfc_constructor_next (c))
2238 flatten_array_ctors_without_strlen (c->expr);
2248 /* Generate code to initialize a string length variable. Returns the
2249 value. For array constructors, cl->length might be NULL and in this case,
2250 the first element of the constructor is needed. expr is the original
2251 expression so we can access it but can be NULL if this is not needed. */
2254 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2258 gfc_init_se (&se, NULL);
2260 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2263 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2264 "flatten" array constructors by taking their first element; all elements
2265 should be the same length or a cl->length should be present. */
2268 gfc_expr* expr_flat;
2271 expr_flat = gfc_copy_expr (expr);
2272 flatten_array_ctors_without_strlen (expr_flat);
2273 gfc_resolve_expr (expr_flat);
2275 gfc_conv_expr (&se, expr_flat);
2276 gfc_add_block_to_block (pblock, &se.pre);
2277 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2279 gfc_free_expr (expr_flat);
2283 /* Convert cl->length. */
2285 gcc_assert (cl->length);
2287 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2288 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2289 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2290 gfc_add_block_to_block (pblock, &se.pre);
2292 if (cl->backend_decl)
2293 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2295 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2300 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2301 const char *name, locus *where)
2311 type = gfc_get_character_type (kind, ref->u.ss.length);
2312 type = build_pointer_type (type);
2314 gfc_init_se (&start, se);
2315 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2316 gfc_add_block_to_block (&se->pre, &start.pre);
2318 if (integer_onep (start.expr))
2319 gfc_conv_string_parameter (se);
2324 /* Avoid multiple evaluation of substring start. */
2325 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2326 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2328 /* Change the start of the string. */
2329 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
2330 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
2331 && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2334 tmp = build_fold_indirect_ref_loc (input_location,
2336 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2337 se->expr = gfc_build_addr_expr (type, tmp);
2340 /* Length = end + 1 - start. */
2341 gfc_init_se (&end, se);
2342 if (ref->u.ss.end == NULL)
2343 end.expr = se->string_length;
2346 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2347 gfc_add_block_to_block (&se->pre, &end.pre);
2351 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2352 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2354 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2356 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2357 logical_type_node, start.expr,
2360 /* Check lower bound. */
2361 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2363 build_one_cst (TREE_TYPE (start.expr)));
2364 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2365 logical_type_node, nonempty, fault);
2367 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2368 "is less than one", name);
2370 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2371 "is less than one");
2372 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2373 fold_convert (long_integer_type_node,
2377 /* Check upper bound. */
2378 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2379 end.expr, se->string_length);
2380 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2381 logical_type_node, nonempty, fault);
2383 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2384 "exceeds string length (%%ld)", name);
2386 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2387 "exceeds string length (%%ld)");
2388 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2389 fold_convert (long_integer_type_node, end.expr),
2390 fold_convert (long_integer_type_node,
2391 se->string_length));
2395 /* Try to calculate the length from the start and end expressions. */
2397 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2399 HOST_WIDE_INT i_len;
2401 i_len = gfc_mpz_get_hwi (length) + 1;
2405 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2406 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2410 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2411 fold_convert (gfc_charlen_type_node, end.expr),
2412 fold_convert (gfc_charlen_type_node, start.expr));
2413 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2414 build_int_cst (gfc_charlen_type_node, 1), tmp);
2415 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2416 tmp, build_int_cst (gfc_charlen_type_node, 0));
2419 se->string_length = tmp;
2423 /* Convert a derived type component reference. */
2426 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2434 c = ref->u.c.component;
2436 if (c->backend_decl == NULL_TREE
2437 && ref->u.c.sym != NULL)
2438 gfc_get_derived_type (ref->u.c.sym);
2440 field = c->backend_decl;
2441 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2443 context = DECL_FIELD_CONTEXT (field);
2445 /* Components can correspond to fields of different containing
2446 types, as components are created without context, whereas
2447 a concrete use of a component has the type of decl as context.
2448 So, if the type doesn't match, we search the corresponding
2449 FIELD_DECL in the parent type. To not waste too much time
2450 we cache this result in norestrict_decl.
2451 On the other hand, if the context is a UNION or a MAP (a
2452 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2454 if (context != TREE_TYPE (decl)
2455 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2456 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2458 tree f2 = c->norestrict_decl;
2459 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2460 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2461 if (TREE_CODE (f2) == FIELD_DECL
2462 && DECL_NAME (f2) == DECL_NAME (field))
2465 c->norestrict_decl = f2;
2469 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2470 && strcmp ("_data", c->name) == 0)
2472 /* Found a ref to the _data component. Store the associated ref to
2473 the vptr in se->class_vptr. */
2474 se->class_vptr = gfc_class_vptr_get (decl);
2477 se->class_vptr = NULL_TREE;
2479 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2480 decl, field, NULL_TREE);
2484 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2485 strlen () conditional below. */
2486 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2487 && !(c->attr.allocatable && c->ts.deferred)
2488 && !c->attr.pdt_string)
2490 tmp = c->ts.u.cl->backend_decl;
2491 /* Components must always be constant length. */
2492 gcc_assert (tmp && INTEGER_CST_P (tmp));
2493 se->string_length = tmp;
2496 if (gfc_deferred_strlen (c, &field))
2498 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2500 decl, field, NULL_TREE);
2501 se->string_length = tmp;
2504 if (((c->attr.pointer || c->attr.allocatable)
2505 && (!c->attr.dimension && !c->attr.codimension)
2506 && c->ts.type != BT_CHARACTER)
2507 || c->attr.proc_pointer)
2508 se->expr = build_fold_indirect_ref_loc (input_location,
2513 /* This function deals with component references to components of the
2514 parent type for derived type extensions. */
2516 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2524 c = ref->u.c.component;
2526 /* Return if the component is in the parent type. */
2527 for (cmp = dt->components; cmp; cmp = cmp->next)
2528 if (strcmp (c->name, cmp->name) == 0)
2531 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2532 parent.type = REF_COMPONENT;
2534 parent.u.c.sym = dt;
2535 parent.u.c.component = dt->components;
2537 if (dt->backend_decl == NULL)
2538 gfc_get_derived_type (dt);
2540 /* Build the reference and call self. */
2541 gfc_conv_component_ref (se, &parent);
2542 parent.u.c.sym = dt->components->ts.u.derived;
2543 parent.u.c.component = c;
2544 conv_parent_component_references (se, &parent);
2549 conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2551 tree res = se->expr;
2556 res = fold_build1_loc (input_location, REALPART_EXPR,
2557 TREE_TYPE (TREE_TYPE (res)), res);
2561 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2562 TREE_TYPE (TREE_TYPE (res)), res);
2566 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2571 res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2581 /* Return the contents of a variable. Also handles reference/pointer
2582 variables (all Fortran pointer references are implicit). */
2585 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2590 tree parent_decl = NULL_TREE;
2593 bool alternate_entry;
2596 bool first_time = true;
2598 sym = expr->symtree->n.sym;
2599 is_classarray = IS_CLASS_ARRAY (sym);
2603 gfc_ss_info *ss_info = ss->info;
2605 /* Check that something hasn't gone horribly wrong. */
2606 gcc_assert (ss != gfc_ss_terminator);
2607 gcc_assert (ss_info->expr == expr);
2609 /* A scalarized term. We already know the descriptor. */
2610 se->expr = ss_info->data.array.descriptor;
2611 se->string_length = ss_info->string_length;
2612 ref = ss_info->data.array.ref;
2614 gcc_assert (ref->type == REF_ARRAY
2615 && ref->u.ar.type != AR_ELEMENT);
2617 gfc_conv_tmp_array_ref (se);
2621 tree se_expr = NULL_TREE;
2623 se->expr = gfc_get_symbol_decl (sym);
2625 /* Deal with references to a parent results or entries by storing
2626 the current_function_decl and moving to the parent_decl. */
2627 return_value = sym->attr.function && sym->result == sym;
2628 alternate_entry = sym->attr.function && sym->attr.entry
2629 && sym->result == sym;
2630 entry_master = sym->attr.result
2631 && sym->ns->proc_name->attr.entry_master
2632 && !gfc_return_by_reference (sym->ns->proc_name);
2633 if (current_function_decl)
2634 parent_decl = DECL_CONTEXT (current_function_decl);
2636 if ((se->expr == parent_decl && return_value)
2637 || (sym->ns && sym->ns->proc_name
2639 && sym->ns->proc_name->backend_decl == parent_decl
2640 && (alternate_entry || entry_master)))
2645 /* Special case for assigning the return value of a function.
2646 Self recursive functions must have an explicit return value. */
2647 if (return_value && (se->expr == current_function_decl || parent_flag))
2648 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2650 /* Similarly for alternate entry points. */
2651 else if (alternate_entry
2652 && (sym->ns->proc_name->backend_decl == current_function_decl
2655 gfc_entry_list *el = NULL;
2657 for (el = sym->ns->entries; el; el = el->next)
2660 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2665 else if (entry_master
2666 && (sym->ns->proc_name->backend_decl == current_function_decl
2668 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2673 /* Procedure actual arguments. Look out for temporary variables
2674 with the same attributes as function values. */
2675 else if (!sym->attr.temporary
2676 && sym->attr.flavor == FL_PROCEDURE
2677 && se->expr != current_function_decl)
2679 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2681 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2682 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2688 /* Dereference the expression, where needed. Since characters
2689 are entirely different from other types, they are treated
2691 if (sym->ts.type == BT_CHARACTER)
2693 /* Dereference character pointer dummy arguments
2695 if ((sym->attr.pointer || sym->attr.allocatable)
2697 || sym->attr.function
2698 || sym->attr.result))
2699 se->expr = build_fold_indirect_ref_loc (input_location,
2703 else if (!sym->attr.value)
2705 /* Dereference temporaries for class array dummy arguments. */
2706 if (sym->attr.dummy && is_classarray
2707 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2709 if (!se->descriptor_only)
2710 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2712 se->expr = build_fold_indirect_ref_loc (input_location,
2716 /* Dereference non-character scalar dummy arguments. */
2717 if (sym->attr.dummy && !sym->attr.dimension
2718 && !(sym->attr.codimension && sym->attr.allocatable)
2719 && (sym->ts.type != BT_CLASS
2720 || (!CLASS_DATA (sym)->attr.dimension
2721 && !(CLASS_DATA (sym)->attr.codimension
2722 && CLASS_DATA (sym)->attr.allocatable))))
2723 se->expr = build_fold_indirect_ref_loc (input_location,
2726 /* Dereference scalar hidden result. */
2727 if (flag_f2c && sym->ts.type == BT_COMPLEX
2728 && (sym->attr.function || sym->attr.result)
2729 && !sym->attr.dimension && !sym->attr.pointer
2730 && !sym->attr.always_explicit)
2731 se->expr = build_fold_indirect_ref_loc (input_location,
2734 /* Dereference non-character, non-class pointer variables.
2735 These must be dummies, results, or scalars. */
2737 && (sym->attr.pointer || sym->attr.allocatable
2738 || gfc_is_associate_pointer (sym)
2739 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2741 || sym->attr.function
2743 || (!sym->attr.dimension
2744 && (!sym->attr.codimension || !sym->attr.allocatable))))
2745 se->expr = build_fold_indirect_ref_loc (input_location,
2747 /* Now treat the class array pointer variables accordingly. */
2748 else if (sym->ts.type == BT_CLASS
2750 && (CLASS_DATA (sym)->attr.dimension
2751 || CLASS_DATA (sym)->attr.codimension)
2752 && ((CLASS_DATA (sym)->as
2753 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2754 || CLASS_DATA (sym)->attr.allocatable
2755 || CLASS_DATA (sym)->attr.class_pointer))
2756 se->expr = build_fold_indirect_ref_loc (input_location,
2758 /* And the case where a non-dummy, non-result, non-function,
2759 non-allotable and non-pointer classarray is present. This case was
2760 previously covered by the first if, but with introducing the
2761 condition !is_classarray there, that case has to be covered
2763 else if (sym->ts.type == BT_CLASS
2765 && !sym->attr.function
2766 && !sym->attr.result
2767 && (CLASS_DATA (sym)->attr.dimension
2768 || CLASS_DATA (sym)->attr.codimension)
2770 || !CLASS_DATA (sym)->attr.allocatable)
2771 && !CLASS_DATA (sym)->attr.class_pointer)
2772 se->expr = build_fold_indirect_ref_loc (input_location,
2779 /* For character variables, also get the length. */
2780 if (sym->ts.type == BT_CHARACTER)
2782 /* If the character length of an entry isn't set, get the length from
2783 the master function instead. */
2784 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2785 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2787 se->string_length = sym->ts.u.cl->backend_decl;
2788 gcc_assert (se->string_length);
2791 gfc_typespec *ts = &sym->ts;
2797 /* Return the descriptor if that's what we want and this is an array
2798 section reference. */
2799 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2801 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2802 /* Return the descriptor for array pointers and allocations. */
2803 if (se->want_pointer
2804 && ref->next == NULL && (se->descriptor_only))
2807 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2808 /* Return a pointer to an element. */
2812 ts = &ref->u.c.component->ts;
2813 if (first_time && is_classarray && sym->attr.dummy
2814 && se->descriptor_only
2815 && !CLASS_DATA (sym)->attr.allocatable
2816 && !CLASS_DATA (sym)->attr.class_pointer
2817 && CLASS_DATA (sym)->as
2818 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2819 && strcmp ("_data", ref->u.c.component->name) == 0)
2820 /* Skip the first ref of a _data component, because for class
2821 arrays that one is already done by introducing a temporary
2822 array descriptor. */
2825 if (ref->u.c.sym->attr.extension)
2826 conv_parent_component_references (se, ref);
2828 gfc_conv_component_ref (se, ref);
2829 if (!ref->next && ref->u.c.sym->attr.codimension
2830 && se->want_pointer && se->descriptor_only)
2836 gfc_conv_substring (se, ref, expr->ts.kind,
2837 expr->symtree->name, &expr->where);
2841 conv_inquiry (se, ref, expr, ts);
2851 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2853 if (se->want_pointer)
2855 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2856 gfc_conv_string_parameter (se);
2858 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2863 /* Unary ops are easy... Or they would be if ! was a valid op. */
2866 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2871 gcc_assert (expr->ts.type != BT_CHARACTER);
2872 /* Initialize the operand. */
2873 gfc_init_se (&operand, se);
2874 gfc_conv_expr_val (&operand, expr->value.op.op1);
2875 gfc_add_block_to_block (&se->pre, &operand.pre);
2877 type = gfc_typenode_for_spec (&expr->ts);
2879 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2880 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2881 All other unary operators have an equivalent GIMPLE unary operator. */
2882 if (code == TRUTH_NOT_EXPR)
2883 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2884 build_int_cst (type, 0));
2886 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2890 /* Expand power operator to optimal multiplications when a value is raised
2891 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2892 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2893 Programming", 3rd Edition, 1998. */
2895 /* This code is mostly duplicated from expand_powi in the backend.
2896 We establish the "optimal power tree" lookup table with the defined size.
2897 The items in the table are the exponents used to calculate the index
2898 exponents. Any integer n less than the value can get an "addition chain",
2899 with the first node being one. */
2900 #define POWI_TABLE_SIZE 256
2902 /* The table is from builtins.c. */
2903 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2905 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2906 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2907 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2908 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2909 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2910 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2911 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2912 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2913 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2914 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2915 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2916 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2917 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2918 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2919 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2920 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2921 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2922 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2923 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2924 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2925 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2926 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2927 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2928 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2929 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2930 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2931 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2932 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2933 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2934 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2935 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2936 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2939 /* If n is larger than lookup table's max index, we use the "window
2941 #define POWI_WINDOW_SIZE 3
2943 /* Recursive function to expand the power operator. The temporary
2944 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2946 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2953 if (n < POWI_TABLE_SIZE)
2958 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2959 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2963 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2964 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2965 op1 = gfc_conv_powi (se, digit, tmpvar);
2969 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2973 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2974 tmp = gfc_evaluate_now (tmp, &se->pre);
2976 if (n < POWI_TABLE_SIZE)
2983 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2984 return 1. Else return 0 and a call to runtime library functions
2985 will have to be built. */
2987 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2992 tree vartmp[POWI_TABLE_SIZE];
2994 unsigned HOST_WIDE_INT n;
2996 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2998 /* If exponent is too large, we won't expand it anyway, so don't bother
2999 with large integer values. */
3000 if (!wi::fits_shwi_p (wrhs))
3003 m = wrhs.to_shwi ();
3004 /* Use the wide_int's routine to reliably get the absolute value on all
3005 platforms. Then convert it to a HOST_WIDE_INT like above. */
3006 n = wi::abs (wrhs).to_shwi ();
3008 type = TREE_TYPE (lhs);
3009 sgn = tree_int_cst_sgn (rhs);
3011 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
3012 || optimize_size) && (m > 2 || m < -1))
3018 se->expr = gfc_build_const (type, integer_one_node);
3022 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3023 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3025 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3026 lhs, build_int_cst (TREE_TYPE (lhs), -1));
3027 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3028 lhs, build_int_cst (TREE_TYPE (lhs), 1));
3031 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3034 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3035 logical_type_node, tmp, cond);
3036 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3037 tmp, build_int_cst (type, 1),
3038 build_int_cst (type, 0));
3042 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3043 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3044 build_int_cst (type, -1),
3045 build_int_cst (type, 0));
3046 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3047 cond, build_int_cst (type, 1), tmp);
3051 memset (vartmp, 0, sizeof (vartmp));
3055 tmp = gfc_build_const (type, integer_one_node);
3056 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3060 se->expr = gfc_conv_powi (se, n, vartmp);
3066 /* Power op (**). Constant integer exponent has special handling. */
3069 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3071 tree gfc_int4_type_node;
3074 int res_ikind_1, res_ikind_2;
3079 gfc_init_se (&lse, se);
3080 gfc_conv_expr_val (&lse, expr->value.op.op1);
3081 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3082 gfc_add_block_to_block (&se->pre, &lse.pre);
3084 gfc_init_se (&rse, se);
3085 gfc_conv_expr_val (&rse, expr->value.op.op2);
3086 gfc_add_block_to_block (&se->pre, &rse.pre);
3088 if (expr->value.op.op2->ts.type == BT_INTEGER
3089 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3090 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3093 if (INTEGER_CST_P (lse.expr)
3094 && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3096 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3098 int kind, ikind, bit_size;
3100 v = wlhs.to_shwi ();
3103 kind = expr->value.op.op1->ts.kind;
3104 ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3105 bit_size = gfc_integer_kinds[ikind].bit_size;
3109 /* 1**something is always 1. */
3110 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3115 /* (-1)**n is 1 - ((n & 1) << 1) */
3119 type = TREE_TYPE (lse.expr);
3120 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3121 rse.expr, build_int_cst (type, 1));
3122 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3123 tmp, build_int_cst (type, 1));
3124 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3125 build_int_cst (type, 1), tmp);
3129 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3131 /* Here v is +/- 2**e. The further simplification uses
3132 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3133 1<<(4*n), etc., but we have to make sure to return zero
3134 if the number of bits is too large. */
3144 type = TREE_TYPE (lse.expr);
3149 shift = fold_build2_loc (input_location, PLUS_EXPR,
3150 TREE_TYPE (rse.expr),
3151 rse.expr, rse.expr);
3154 /* use popcount for fast log2(w) */
3155 int e = wi::popcount (w-1);
3156 shift = fold_build2_loc (input_location, MULT_EXPR,
3157 TREE_TYPE (rse.expr),
3158 build_int_cst (TREE_TYPE (rse.expr), e),
3162 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3163 build_int_cst (type, 1), shift);
3164 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3165 rse.expr, build_int_cst (type, 0));
3166 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3167 build_int_cst (type, 0));
3168 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3169 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3170 rse.expr, num_bits);
3171 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3172 build_int_cst (type, 0), cond);
3179 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3181 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3182 rse.expr, build_int_cst (type, 1));
3183 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3184 tmp2, build_int_cst (type, 1));
3185 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3186 build_int_cst (type, 1), tmp2);
3187 se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3194 gfc_int4_type_node = gfc_get_int_type (4);
3196 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3197 library routine. But in the end, we have to convert the result back
3198 if this case applies -- with res_ikind_K, we keep track whether operand K
3199 falls into this case. */
3203 kind = expr->value.op.op1->ts.kind;
3204 switch (expr->value.op.op2->ts.type)
3207 ikind = expr->value.op.op2->ts.kind;
3212 rse.expr = convert (gfc_int4_type_node, rse.expr);
3213 res_ikind_2 = ikind;
3235 if (expr->value.op.op1->ts.type == BT_INTEGER)
3237 lse.expr = convert (gfc_int4_type_node, lse.expr);
3264 switch (expr->value.op.op1->ts.type)
3267 if (kind == 3) /* Case 16 was not handled properly above. */
3269 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3273 /* Use builtins for real ** int4. */
3279 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3283 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3287 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3291 /* Use the __builtin_powil() only if real(kind=16) is
3292 actually the C long double type. */
3293 if (!gfc_real16_is_float128)
3294 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3302 /* If we don't have a good builtin for this, go for the
3303 library function. */
3305 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3309 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3318 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3322 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3330 se->expr = build_call_expr_loc (input_location,
3331 fndecl, 2, lse.expr, rse.expr);
3333 /* Convert the result back if it is of wrong integer kind. */
3334 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3336 /* We want the maximum of both operand kinds as result. */
3337 if (res_ikind_1 < res_ikind_2)
3338 res_ikind_1 = res_ikind_2;
3339 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3344 /* Generate code to allocate a string temporary. */
3347 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3352 if (gfc_can_put_var_on_stack (len))
3354 /* Create a temporary variable to hold the result. */
3355 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3356 TREE_TYPE (len), len,
3357 build_int_cst (TREE_TYPE (len), 1));
3358 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3360 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3361 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3363 tmp = build_array_type (TREE_TYPE (type), tmp);
3365 var = gfc_create_var (tmp, "str");
3366 var = gfc_build_addr_expr (type, var);
3370 /* Allocate a temporary to hold the result. */
3371 var = gfc_create_var (type, "pstr");
3372 gcc_assert (POINTER_TYPE_P (type));
3373 tmp = TREE_TYPE (type);
3374 if (TREE_CODE (tmp) == ARRAY_TYPE)
3375 tmp = TREE_TYPE (tmp);
3376 tmp = TYPE_SIZE_UNIT (tmp);
3377 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3378 fold_convert (size_type_node, len),
3379 fold_convert (size_type_node, tmp));
3380 tmp = gfc_call_malloc (&se->pre, type, tmp);
3381 gfc_add_modify (&se->pre, var, tmp);
3383 /* Free the temporary afterwards. */
3384 tmp = gfc_call_free (var);
3385 gfc_add_expr_to_block (&se->post, tmp);
3392 /* Handle a string concatenation operation. A temporary will be allocated to
3396 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3399 tree len, type, var, tmp, fndecl;
3401 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3402 && expr->value.op.op2->ts.type == BT_CHARACTER);
3403 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3405 gfc_init_se (&lse, se);
3406 gfc_conv_expr (&lse, expr->value.op.op1);
3407 gfc_conv_string_parameter (&lse);
3408 gfc_init_se (&rse, se);
3409 gfc_conv_expr (&rse, expr->value.op.op2);
3410 gfc_conv_string_parameter (&rse);
3412 gfc_add_block_to_block (&se->pre, &lse.pre);
3413 gfc_add_block_to_block (&se->pre, &rse.pre);
3415 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3416 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3417 if (len == NULL_TREE)
3419 len = fold_build2_loc (input_location, PLUS_EXPR,
3420 gfc_charlen_type_node,
3421 fold_convert (gfc_charlen_type_node,
3423 fold_convert (gfc_charlen_type_node,
3424 rse.string_length));
3427 type = build_pointer_type (type);
3429 var = gfc_conv_string_tmp (se, type, len);
3431 /* Do the actual concatenation. */
3432 if (expr->ts.kind == 1)
3433 fndecl = gfor_fndecl_concat_string;
3434 else if (expr->ts.kind == 4)
3435 fndecl = gfor_fndecl_concat_string_char4;
3439 tmp = build_call_expr_loc (input_location,
3440 fndecl, 6, len, var, lse.string_length, lse.expr,
3441 rse.string_length, rse.expr);
3442 gfc_add_expr_to_block (&se->pre, tmp);
3444 /* Add the cleanup for the operands. */
3445 gfc_add_block_to_block (&se->pre, &rse.post);
3446 gfc_add_block_to_block (&se->pre, &lse.post);
3449 se->string_length = len;
3452 /* Translates an op expression. Common (binary) cases are handled by this
3453 function, others are passed on. Recursion is used in either case.
3454 We use the fact that (op1.ts == op2.ts) (except for the power
3456 Operators need no special handling for scalarized expressions as long as
3457 they call gfc_conv_simple_val to get their operands.
3458 Character strings get special handling. */
3461 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3463 enum tree_code code;
3472 switch (expr->value.op.op)
3474 case INTRINSIC_PARENTHESES:
3475 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3476 && flag_protect_parens)
3478 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3479 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3484 case INTRINSIC_UPLUS:
3485 gfc_conv_expr (se, expr->value.op.op1);
3488 case INTRINSIC_UMINUS:
3489 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3493 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3496 case INTRINSIC_PLUS:
3500 case INTRINSIC_MINUS:
3504 case INTRINSIC_TIMES:
3508 case INTRINSIC_DIVIDE:
3509 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3510 an integer, we must round towards zero, so we use a
3512 if (expr->ts.type == BT_INTEGER)
3513 code = TRUNC_DIV_EXPR;
3518 case INTRINSIC_POWER:
3519 gfc_conv_power_op (se, expr);
3522 case INTRINSIC_CONCAT:
3523 gfc_conv_concat_op (se, expr);
3527 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3532 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3536 /* EQV and NEQV only work on logicals, but since we represent them
3537 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3539 case INTRINSIC_EQ_OS:
3547 case INTRINSIC_NE_OS:
3548 case INTRINSIC_NEQV:
3555 case INTRINSIC_GT_OS:
3562 case INTRINSIC_GE_OS:
3569 case INTRINSIC_LT_OS:
3576 case INTRINSIC_LE_OS:
3582 case INTRINSIC_USER:
3583 case INTRINSIC_ASSIGN:
3584 /* These should be converted into function calls by the frontend. */
3588 fatal_error (input_location, "Unknown intrinsic op");
3592 /* The only exception to this is **, which is handled separately anyway. */
3593 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3595 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3599 gfc_init_se (&lse, se);
3600 gfc_conv_expr (&lse, expr->value.op.op1);
3601 gfc_add_block_to_block (&se->pre, &lse.pre);
3604 gfc_init_se (&rse, se);
3605 gfc_conv_expr (&rse, expr->value.op.op2);
3606 gfc_add_block_to_block (&se->pre, &rse.pre);
3610 gfc_conv_string_parameter (&lse);
3611 gfc_conv_string_parameter (&rse);
3613 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3614 rse.string_length, rse.expr,
3615 expr->value.op.op1->ts.kind,
3617 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3618 gfc_add_block_to_block (&lse.post, &rse.post);
3621 type = gfc_typenode_for_spec (&expr->ts);
3625 /* The result of logical ops is always logical_type_node. */
3626 tmp = fold_build2_loc (input_location, code, logical_type_node,
3627 lse.expr, rse.expr);
3628 se->expr = convert (type, tmp);
3631 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3633 /* Add the post blocks. */
3634 gfc_add_block_to_block (&se->post, &rse.post);
3635 gfc_add_block_to_block (&se->post, &lse.post);
3638 /* If a string's length is one, we convert it to a single character. */
3641 gfc_string_to_single_character (tree len, tree str, int kind)
3645 || !tree_fits_uhwi_p (len)
3646 || !POINTER_TYPE_P (TREE_TYPE (str)))
3649 if (TREE_INT_CST_LOW (len) == 1)
3651 str = fold_convert (gfc_get_pchar_type (kind), str);
3652 return build_fold_indirect_ref_loc (input_location, str);
3656 && TREE_CODE (str) == ADDR_EXPR
3657 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3658 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3659 && array_ref_low_bound (TREE_OPERAND (str, 0))
3660 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3661 && TREE_INT_CST_LOW (len) > 1
3662 && TREE_INT_CST_LOW (len)
3663 == (unsigned HOST_WIDE_INT)
3664 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3666 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3667 ret = build_fold_indirect_ref_loc (input_location, ret);
3668 if (TREE_CODE (ret) == INTEGER_CST)
3670 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3671 int i, length = TREE_STRING_LENGTH (string_cst);
3672 const char *ptr = TREE_STRING_POINTER (string_cst);
3674 for (i = 1; i < length; i++)
3687 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3690 if (sym->backend_decl)
3692 /* This becomes the nominal_type in
3693 function.c:assign_parm_find_data_types. */
3694 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3695 /* This becomes the passed_type in
3696 function.c:assign_parm_find_data_types. C promotes char to
3697 integer for argument passing. */
3698 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3700 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3705 /* If we have a constant character expression, make it into an
3707 if ((*expr)->expr_type == EXPR_CONSTANT)
3712 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3713 (int)(*expr)->value.character.string[0]);
3714 if ((*expr)->ts.kind != gfc_c_int_kind)
3716 /* The expr needs to be compatible with a C int. If the
3717 conversion fails, then the 2 causes an ICE. */
3718 ts.type = BT_INTEGER;
3719 ts.kind = gfc_c_int_kind;
3720 gfc_convert_type (*expr, &ts, 2);
3723 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3725 if ((*expr)->ref == NULL)
3727 se->expr = gfc_string_to_single_character
3728 (build_int_cst (integer_type_node, 1),
3729 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3731 ((*expr)->symtree->n.sym)),
3736 gfc_conv_variable (se, *expr);
3737 se->expr = gfc_string_to_single_character
3738 (build_int_cst (integer_type_node, 1),
3739 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3747 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3748 if STR is a string literal, otherwise return -1. */
3751 gfc_optimize_len_trim (tree len, tree str, int kind)
3754 && TREE_CODE (str) == ADDR_EXPR
3755 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3756 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3757 && array_ref_low_bound (TREE_OPERAND (str, 0))
3758 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3759 && tree_fits_uhwi_p (len)
3760 && tree_to_uhwi (len) >= 1
3761 && tree_to_uhwi (len)
3762 == (unsigned HOST_WIDE_INT)
3763 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3765 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3766 folded = build_fold_indirect_ref_loc (input_location, folded);
3767 if (TREE_CODE (folded) == INTEGER_CST)
3769 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3770 int length = TREE_STRING_LENGTH (string_cst);
3771 const char *ptr = TREE_STRING_POINTER (string_cst);
3773 for (; length > 0; length--)
3774 if (ptr[length - 1] != ' ')
3783 /* Helper to build a call to memcmp. */
3786 build_memcmp_call (tree s1, tree s2, tree n)
3790 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3791 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3793 s1 = fold_convert (pvoid_type_node, s1);
3795 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3796 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3798 s2 = fold_convert (pvoid_type_node, s2);
3800 n = fold_convert (size_type_node, n);
3802 tmp = build_call_expr_loc (input_location,
3803 builtin_decl_explicit (BUILT_IN_MEMCMP),
3806 return fold_convert (integer_type_node, tmp);
3809 /* Compare two strings. If they are all single characters, the result is the
3810 subtraction of them. Otherwise, we build a library call. */
3813 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3814 enum tree_code code)
3820 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3821 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3823 sc1 = gfc_string_to_single_character (len1, str1, kind);
3824 sc2 = gfc_string_to_single_character (len2, str2, kind);
3826 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3828 /* Deal with single character specially. */
3829 sc1 = fold_convert (integer_type_node, sc1);
3830 sc2 = fold_convert (integer_type_node, sc2);
3831 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3835 if ((code == EQ_EXPR || code == NE_EXPR)
3837 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3839 /* If one string is a string literal with LEN_TRIM longer
3840 than the length of the second string, the strings
3842 int len = gfc_optimize_len_trim (len1, str1, kind);
3843 if (len > 0 && compare_tree_int (len2, len) < 0)
3844 return integer_one_node;
3845 len = gfc_optimize_len_trim (len2, str2, kind);
3846 if (len > 0 && compare_tree_int (len1, len) < 0)
3847 return integer_one_node;
3850 /* We can compare via memcpy if the strings are known to be equal
3851 in length and they are
3853 - kind=4 and the comparison is for (in)equality. */
3855 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3856 && tree_int_cst_equal (len1, len2)
3857 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3862 chartype = gfc_get_char_type (kind);
3863 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3864 fold_convert (TREE_TYPE(len1),
3865 TYPE_SIZE_UNIT(chartype)),
3867 return build_memcmp_call (str1, str2, tmp);
3870 /* Build a call for the comparison. */
3872 fndecl = gfor_fndecl_compare_string;
3874 fndecl = gfor_fndecl_compare_string_char4;
3878 return build_call_expr_loc (input_location, fndecl, 4,
3879 len1, str1, len2, str2);
3883 /* Return the backend_decl for a procedure pointer component. */
3886 get_proc_ptr_comp (gfc_expr *e)
3892 gfc_init_se (&comp_se, NULL);
3893 e2 = gfc_copy_expr (e);
3894 /* We have to restore the expr type later so that gfc_free_expr frees
3895 the exact same thing that was allocated.
3896 TODO: This is ugly. */
3897 old_type = e2->expr_type;
3898 e2->expr_type = EXPR_VARIABLE;
3899 gfc_conv_expr (&comp_se, e2);
3900 e2->expr_type = old_type;
3902 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3906 /* Convert a typebound function reference from a class object. */
3908 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3913 if (!VAR_P (base_object))
3915 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3916 gfc_add_modify (&se->pre, var, base_object);
3918 se->expr = gfc_class_vptr_get (base_object);
3919 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3921 while (ref && ref->next)
3923 gcc_assert (ref && ref->type == REF_COMPONENT);
3924 if (ref->u.c.sym->attr.extension)
3925 conv_parent_component_references (se, ref);
3926 gfc_conv_component_ref (se, ref);
3927 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3932 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
3933 gfc_actual_arglist *actual_args)
3937 if (gfc_is_proc_ptr_comp (expr))
3938 tmp = get_proc_ptr_comp (expr);
3939 else if (sym->attr.dummy)
3941 tmp = gfc_get_symbol_decl (sym);
3942 if (sym->attr.proc_pointer)
3943 tmp = build_fold_indirect_ref_loc (input_location,
3945 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3946 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3950 if (!sym->backend_decl)
3951 sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
3953 TREE_USED (sym->backend_decl) = 1;
3955 tmp = sym->backend_decl;
3957 if (sym->attr.cray_pointee)
3959 /* TODO - make the cray pointee a pointer to a procedure,
3960 assign the pointer to it and use it for the call. This
3962 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3963 gfc_get_symbol_decl (sym->cp_pointer));
3964 tmp = gfc_evaluate_now (tmp, &se->pre);
3967 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3969 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3970 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3977 /* Initialize MAPPING. */
3980 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3982 mapping->syms = NULL;
3983 mapping->charlens = NULL;
3987 /* Free all memory held by MAPPING (but not MAPPING itself). */
3990 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3992 gfc_interface_sym_mapping *sym;
3993 gfc_interface_sym_mapping *nextsym;
3995 gfc_charlen *nextcl;
3997 for (sym = mapping->syms; sym; sym = nextsym)
3999 nextsym = sym->next;
4000 sym->new_sym->n.sym->formal = NULL;
4001 gfc_free_symbol (sym->new_sym->n.sym);
4002 gfc_free_expr (sym->expr);
4003 free (sym->new_sym);
4006 for (cl = mapping->charlens; cl; cl = nextcl)
4009 gfc_free_expr (cl->length);
4015 /* Return a copy of gfc_charlen CL. Add the returned structure to
4016 MAPPING so that it will be freed by gfc_free_interface_mapping. */
4018 static gfc_charlen *
4019 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4022 gfc_charlen *new_charlen;
4024 new_charlen = gfc_get_charlen ();
4025 new_charlen->next = mapping->charlens;
4026 new_charlen->length = gfc_copy_expr (cl->length);
4028 mapping->charlens = new_charlen;
4033 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4034 array variable that can be used as the actual argument for dummy
4035 argument SYM. Add any initialization code to BLOCK. PACKED is as
4036 for gfc_get_nodesc_array_type and DATA points to the first element
4037 in the passed array. */
4040 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4041 gfc_packed packed, tree data)
4046 type = gfc_typenode_for_spec (&sym->ts);
4047 type = gfc_get_nodesc_array_type (type, sym->as, packed,
4048 !sym->attr.target && !sym->attr.pointer
4049 && !sym->attr.proc_pointer);
4051 var = gfc_create_var (type, "ifm");
4052 gfc_add_modify (block, var, fold_convert (type, data));
4058 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4059 and offset of descriptorless array type TYPE given that it has the same
4060 size as DESC. Add any set-up code to BLOCK. */
4063 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4070 offset = gfc_index_zero_node;
4071 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4073 dim = gfc_rank_cst[n];
4074 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4075 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4077 GFC_TYPE_ARRAY_LBOUND (type, n)
4078 = gfc_conv_descriptor_lbound_get (desc, dim);
4079 GFC_TYPE_ARRAY_UBOUND (type, n)
4080 = gfc_conv_descriptor_ubound_get (desc, dim);
4082 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4084 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4085 gfc_array_index_type,
4086 gfc_conv_descriptor_ubound_get (desc, dim),
4087 gfc_conv_descriptor_lbound_get (desc, dim));
4088 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4089 gfc_array_index_type,
4090 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4091 tmp = gfc_evaluate_now (tmp, block);
4092 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4094 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4095 GFC_TYPE_ARRAY_LBOUND (type, n),
4096 GFC_TYPE_ARRAY_STRIDE (type, n));
4097 offset = fold_build2_loc (input_location, MINUS_EXPR,
4098 gfc_array_index_type, offset, tmp);
4100 offset = gfc_evaluate_now (offset, block);
4101 GFC_TYPE_ARRAY_OFFSET (type) = offset;
4105 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4106 in SE. The caller may still use se->expr and se->string_length after
4107 calling this function. */
4110 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4111 gfc_symbol * sym, gfc_se * se,
4114 gfc_interface_sym_mapping *sm;
4118 gfc_symbol *new_sym;
4120 gfc_symtree *new_symtree;
4122 /* Create a new symbol to represent the actual argument. */
4123 new_sym = gfc_new_symbol (sym->name, NULL);
4124 new_sym->ts = sym->ts;
4125 new_sym->as = gfc_copy_array_spec (sym->as);
4126 new_sym->attr.referenced = 1;
4127 new_sym->attr.dimension = sym->attr.dimension;
4128 new_sym->attr.contiguous = sym->attr.contiguous;
4129 new_sym->attr.codimension = sym->attr.codimension;
4130 new_sym->attr.pointer = sym->attr.pointer;
4131 new_sym->attr.allocatable = sym->attr.allocatable;
4132 new_sym->attr.flavor = sym->attr.flavor;
4133 new_sym->attr.function = sym->attr.function;
4135 /* Ensure that the interface is available and that
4136 descriptors are passed for array actual arguments. */
4137 if (sym->attr.flavor == FL_PROCEDURE)
4139 new_sym->formal = expr->symtree->n.sym->formal;
4140 new_sym->attr.always_explicit
4141 = expr->symtree->n.sym->attr.always_explicit;
4144 /* Create a fake symtree for it. */
4146 new_symtree = gfc_new_symtree (&root, sym->name);
4147 new_symtree->n.sym = new_sym;
4148 gcc_assert (new_symtree == root);
4150 /* Create a dummy->actual mapping. */
4151 sm = XCNEW (gfc_interface_sym_mapping);
4152 sm->next = mapping->syms;
4154 sm->new_sym = new_symtree;
4155 sm->expr = gfc_copy_expr (expr);
4158 /* Stabilize the argument's value. */
4159 if (!sym->attr.function && se)
4160 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4162 if (sym->ts.type == BT_CHARACTER)
4164 /* Create a copy of the dummy argument's length. */
4165 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4166 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4168 /* If the length is specified as "*", record the length that
4169 the caller is passing. We should use the callee's length
4170 in all other cases. */
4171 if (!new_sym->ts.u.cl->length && se)
4173 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4174 new_sym->ts.u.cl->backend_decl = se->string_length;
4181 /* Use the passed value as-is if the argument is a function. */
4182 if (sym->attr.flavor == FL_PROCEDURE)
4185 /* If the argument is a pass-by-value scalar, use the value as is. */
4186 else if (!sym->attr.dimension && sym->attr.value)
4189 /* If the argument is either a string or a pointer to a string,
4190 convert it to a boundless character type. */
4191 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4193 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4194 tmp = build_pointer_type (tmp);
4195 if (sym->attr.pointer)
4196 value = build_fold_indirect_ref_loc (input_location,
4200 value = fold_convert (tmp, value);
4203 /* If the argument is a scalar, a pointer to an array or an allocatable,
4205 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4206 value = build_fold_indirect_ref_loc (input_location,
4209 /* For character(*), use the actual argument's descriptor. */
4210 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4211 value = build_fold_indirect_ref_loc (input_location,
4214 /* If the argument is an array descriptor, use it to determine
4215 information about the actual argument's shape. */
4216 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4217 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4219 /* Get the actual argument's descriptor. */
4220 desc = build_fold_indirect_ref_loc (input_location,
4223 /* Create the replacement variable. */
4224 tmp = gfc_conv_descriptor_data_get (desc);
4225 value = gfc_get_interface_mapping_array (&se->pre, sym,
4228 /* Use DESC to work out the upper bounds, strides and offset. */
4229 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4232 /* Otherwise we have a packed array. */
4233 value = gfc_get_interface_mapping_array (&se->pre, sym,
4234 PACKED_FULL, se->expr);
4236 new_sym->backend_decl = value;
4240 /* Called once all dummy argument mappings have been added to MAPPING,
4241 but before the mapping is used to evaluate expressions. Pre-evaluate
4242 the length of each argument, adding any initialization code to PRE and
4243 any finalization code to POST. */
4246 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4247 stmtblock_t * pre, stmtblock_t * post)
4249 gfc_interface_sym_mapping *sym;
4253 for (sym = mapping->syms; sym; sym = sym->next)
4254 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4255 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4257 expr = sym->new_sym->n.sym->ts.u.cl->length;
4258 gfc_apply_interface_mapping_to_expr (mapping, expr);
4259 gfc_init_se (&se, NULL);
4260 gfc_conv_expr (&se, expr);
4261 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4262 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4263 gfc_add_block_to_block (pre, &se.pre);
4264 gfc_add_block_to_block (post, &se.post);
4266 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4271 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4275 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4276 gfc_constructor_base base)
4279 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4281 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4284 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4285 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4286 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4292 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4296 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4301 for (; ref; ref = ref->next)
4305 for (n = 0; n < ref->u.ar.dimen; n++)
4307 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4308 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4309 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4318 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4319 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4325 /* Convert intrinsic function calls into result expressions. */
4328 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4336 arg1 = expr->value.function.actual->expr;
4337 if (expr->value.function.actual->next)
4338 arg2 = expr->value.function.actual->next->expr;
4342 sym = arg1->symtree->n.sym;
4344 if (sym->attr.dummy)
4349 switch (expr->value.function.isym->id)
4352 /* TODO figure out why this condition is necessary. */
4353 if (sym->attr.function
4354 && (arg1->ts.u.cl->length == NULL
4355 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4356 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4359 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4362 case GFC_ISYM_LEN_TRIM:
4363 new_expr = gfc_copy_expr (arg1);
4364 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4369 gfc_replace_expr (arg1, new_expr);
4373 if (!sym->as || sym->as->rank == 0)
4376 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4378 dup = mpz_get_si (arg2->value.integer);
4383 dup = sym->as->rank;
4387 for (; d < dup; d++)
4391 if (!sym->as->upper[d] || !sym->as->lower[d])
4393 gfc_free_expr (new_expr);
4397 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4398 gfc_get_int_expr (gfc_default_integer_kind,
4400 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4402 new_expr = gfc_multiply (new_expr, tmp);
4408 case GFC_ISYM_LBOUND:
4409 case GFC_ISYM_UBOUND:
4410 /* TODO These implementations of lbound and ubound do not limit if
4411 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4413 if (!sym->as || sym->as->rank == 0)
4416 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4417 d = mpz_get_si (arg2->value.integer) - 1;
4421 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4423 if (sym->as->lower[d])
4424 new_expr = gfc_copy_expr (sym->as->lower[d]);
4428 if (sym->as->upper[d])
4429 new_expr = gfc_copy_expr (sym->as->upper[d]);
4437 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4441 gfc_replace_expr (expr, new_expr);
4447 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4448 gfc_interface_mapping * mapping)
4450 gfc_formal_arglist *f;
4451 gfc_actual_arglist *actual;
4453 actual = expr->value.function.actual;
4454 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4456 for (; f && actual; f = f->next, actual = actual->next)
4461 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4464 if (map_expr->symtree->n.sym->attr.dimension)
4469 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4471 for (d = 0; d < as->rank; d++)
4473 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4474 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4477 expr->value.function.esym->as = as;
4480 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4482 expr->value.function.esym->ts.u.cl->length
4483 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4485 gfc_apply_interface_mapping_to_expr (mapping,
4486 expr->value.function.esym->ts.u.cl->length);
4491 /* EXPR is a copy of an expression that appeared in the interface
4492 associated with MAPPING. Walk it recursively looking for references to
4493 dummy arguments that MAPPING maps to actual arguments. Replace each such
4494 reference with a reference to the associated actual argument. */
4497 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4500 gfc_interface_sym_mapping *sym;
4501 gfc_actual_arglist *actual;
4506 /* Copying an expression does not copy its length, so do that here. */
4507 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4509 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4510 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4513 /* Apply the mapping to any references. */
4514 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4516 /* ...and to the expression's symbol, if it has one. */
4517 /* TODO Find out why the condition on expr->symtree had to be moved into
4518 the loop rather than being outside it, as originally. */
4519 for (sym = mapping->syms; sym; sym = sym->next)
4520 if (expr->symtree && sym->old == expr->symtree->n.sym)
4522 if (sym->new_sym->n.sym->backend_decl)
4523 expr->symtree = sym->new_sym;
4525 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4528 /* ...and to subexpressions in expr->value. */
4529 switch (expr->expr_type)
4534 case EXPR_SUBSTRING:
4538 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4539 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4543 for (actual = expr->value.function.actual; actual; actual = actual->next)
4544 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4546 if (expr->value.function.esym == NULL
4547 && expr->value.function.isym != NULL
4548 && expr->value.function.actual
4549 && expr->value.function.actual->expr
4550 && expr->value.function.actual->expr->symtree
4551 && gfc_map_intrinsic_function (expr, mapping))
4554 for (sym = mapping->syms; sym; sym = sym->next)
4555 if (sym->old == expr->value.function.esym)
4557 expr->value.function.esym = sym->new_sym->n.sym;
4558 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4559 expr->value.function.esym->result = sym->new_sym->n.sym;
4564 case EXPR_STRUCTURE:
4565 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4579 /* Evaluate interface expression EXPR using MAPPING. Store the result
4583 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4584 gfc_se * se, gfc_expr * expr)
4586 expr = gfc_copy_expr (expr);
4587 gfc_apply_interface_mapping_to_expr (mapping, expr);
4588 gfc_conv_expr (se, expr);
4589 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4590 gfc_free_expr (expr);
4594 /* Returns a reference to a temporary array into which a component of
4595 an actual argument derived type array is copied and then returned
4596 after the function call. */
4598 gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
4599 sym_intent intent, bool formal_ptr,
4600 const gfc_symbol *fsym, const char *proc_name,
4601 gfc_symbol *sym, bool check_contiguous)
4609 gfc_array_info *info;
4622 pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
4624 if (pass_optional || check_contiguous)
4626 gfc_init_se (&work_se, NULL);
4632 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
4634 /* We will create a temporary array, so let us warn. */
4637 if (fsym && proc_name)
4638 msg = xasprintf ("An array temporary was created for argument "
4639 "'%s' of procedure '%s'", fsym->name, proc_name);
4641 msg = xasprintf ("An array temporary was created");
4643 tmp = build_int_cst (logical_type_node, 1);
4644 gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
4649 gfc_init_se (&lse, NULL);
4650 gfc_init_se (&rse, NULL);
4652 /* Walk the argument expression. */
4653 rss = gfc_walk_expr (expr);
4655 gcc_assert (rss != gfc_ss_terminator);
4657 /* Initialize the scalarizer. */
4658 gfc_init_loopinfo (&loop);
4659 gfc_add_ss_to_loop (&loop, rss);
4661 /* Calculate the bounds of the scalarization. */
4662 gfc_conv_ss_startstride (&loop);
4664 /* Build an ss for the temporary. */
4665 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4666 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4668 base_type = gfc_typenode_for_spec (&expr->ts);
4669 if (GFC_ARRAY_TYPE_P (base_type)
4670 || GFC_DESCRIPTOR_TYPE_P (base_type))
4671 base_type = gfc_get_element_type (base_type);
4673 if (expr->ts.type == BT_CLASS)
4674 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4676 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4677 ? expr->ts.u.cl->backend_decl
4681 parmse->string_length = loop.temp_ss->info->string_length;
4683 /* Associate the SS with the loop. */
4684 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4686 /* Setup the scalarizing loops. */
4687 gfc_conv_loop_setup (&loop, &expr->where);
4689 /* Pass the temporary descriptor back to the caller. */
4690 info = &loop.temp_ss->info->data.array;
4691 parmse->expr = info->descriptor;
4693 /* Setup the gfc_se structures. */
4694 gfc_copy_loopinfo_to_se (&lse, &loop);
4695 gfc_copy_loopinfo_to_se (&rse, &loop);
4698 lse.ss = loop.temp_ss;
4699 gfc_mark_ss_chain_used (rss, 1);
4700 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4702 /* Start the scalarized loop body. */
4703 gfc_start_scalarized_body (&loop, &body);
4705 /* Translate the expression. */
4706 gfc_conv_expr (&rse, expr);
4708 /* Reset the offset for the function call since the loop
4709 is zero based on the data pointer. Note that the temp
4710 comes first in the loop chain since it is added second. */
4711 if (gfc_is_class_array_function (expr))
4713 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4714 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4715 gfc_index_zero_node);
4718 gfc_conv_tmp_array_ref (&lse);
4720 if (intent != INTENT_OUT)
4722 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4723 gfc_add_expr_to_block (&body, tmp);
4724 gcc_assert (rse.ss == gfc_ss_terminator);
4725 gfc_trans_scalarizing_loops (&loop, &body);
4729 /* Make sure that the temporary declaration survives by merging
4730 all the loop declarations into the current context. */
4731 for (n = 0; n < loop.dimen; n++)
4733 gfc_merge_block_scope (&body);
4734 body = loop.code[loop.order[n]];
4736 gfc_merge_block_scope (&body);
4739 /* Add the post block after the second loop, so that any
4740 freeing of allocated memory is done at the right time. */
4741 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4743 /**********Copy the temporary back again.*********/
4745 gfc_init_se (&lse, NULL);
4746 gfc_init_se (&rse, NULL);
4748 /* Walk the argument expression. */
4749 lss = gfc_walk_expr (expr);
4750 rse.ss = loop.temp_ss;
4753 /* Initialize the scalarizer. */
4754 gfc_init_loopinfo (&loop2);
4755 gfc_add_ss_to_loop (&loop2, lss);
4757 dimen = rse.ss->dimen;
4759 /* Skip the write-out loop for this case. */
4760 if (gfc_is_class_array_function (expr))
4761 goto class_array_fcn;
4763 /* Calculate the bounds of the scalarization. */
4764 gfc_conv_ss_startstride (&loop2);
4766 /* Setup the scalarizing loops. */
4767 gfc_conv_loop_setup (&loop2, &expr->where);
4769 gfc_copy_loopinfo_to_se (&lse, &loop2);
4770 gfc_copy_loopinfo_to_se (&rse, &loop2);
4772 gfc_mark_ss_chain_used (lss, 1);
4773 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4775 /* Declare the variable to hold the temporary offset and start the
4776 scalarized loop body. */
4777 offset = gfc_create_var (gfc_array_index_type, NULL);
4778 gfc_start_scalarized_body (&loop2, &body);
4780 /* Build the offsets for the temporary from the loop variables. The
4781 temporary array has lbounds of zero and strides of one in all
4782 dimensions, so this is very simple. The offset is only computed
4783 outside the innermost loop, so the overall transfer could be
4784 optimized further. */
4785 info = &rse.ss->info->data.array;
4787 tmp_index = gfc_index_zero_node;
4788 for (n = dimen - 1; n > 0; n--)
4791 tmp = rse.loop->loopvar[n];
4792 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4793 tmp, rse.loop->from[n]);
4794 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4797 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4798 gfc_array_index_type,
4799 rse.loop->to[n-1], rse.loop->from[n-1]);
4800 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4801 gfc_array_index_type,
4802 tmp_str, gfc_index_one_node);
4804 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4805 gfc_array_index_type, tmp, tmp_str);
4808 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4809 gfc_array_index_type,
4810 tmp_index, rse.loop->from[0]);
4811 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4813 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4814 gfc_array_index_type,
4815 rse.loop->loopvar[0], offset);
4817 /* Now use the offset for the reference. */
4818 tmp = build_fold_indirect_ref_loc (input_location,
4820 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4822 if (expr->ts.type == BT_CHARACTER)
4823 rse.string_length = expr->ts.u.cl->backend_decl;
4825 gfc_conv_expr (&lse, expr);
4827 gcc_assert (lse.ss == gfc_ss_terminator);
4829 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4830 gfc_add_expr_to_block (&body, tmp);
4832 /* Generate the copying loops. */
4833 gfc_trans_scalarizing_loops (&loop2, &body);
4835 /* Wrap the whole thing up by adding the second loop to the post-block
4836 and following it by the post-block of the first loop. In this way,
4837 if the temporary needs freeing, it is done after use! */
4838 if (intent != INTENT_IN)
4840 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4841 gfc_add_block_to_block (&parmse->post, &loop2.post);
4846 gfc_add_block_to_block (&parmse->post, &loop.post);
4848 gfc_cleanup_loop (&loop);
4849 gfc_cleanup_loop (&loop2);
4851 /* Pass the string length to the argument expression. */
4852 if (expr->ts.type == BT_CHARACTER)
4853 parmse->string_length = expr->ts.u.cl->backend_decl;
4855 /* Determine the offset for pointer formal arguments and set the
4859 size = gfc_index_one_node;
4860 offset = gfc_index_zero_node;
4861 for (n = 0; n < dimen; n++)
4863 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4865 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4866 gfc_array_index_type, tmp,
4867 gfc_index_one_node);
4868 gfc_conv_descriptor_ubound_set (&parmse->pre,
4872 gfc_conv_descriptor_lbound_set (&parmse->pre,
4875 gfc_index_one_node);
4876 size = gfc_evaluate_now (size, &parmse->pre);
4877 offset = fold_build2_loc (input_location, MINUS_EXPR,
4878 gfc_array_index_type,
4880 offset = gfc_evaluate_now (offset, &parmse->pre);
4881 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4882 gfc_array_index_type,
4883 rse.loop->to[n], rse.loop->from[n]);
4884 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4885 gfc_array_index_type,
4886 tmp, gfc_index_one_node);
4887 size = fold_build2_loc (input_location, MULT_EXPR,
4888 gfc_array_index_type, size, tmp);
4891 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4895 /* We want either the address for the data or the address of the descriptor,
4896 depending on the mode of passing array arguments. */
4898 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4900 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4902 /* Basically make this into
4913 pointer = parmse->expr;
4920 if (present && !contiguous)
4925 if (pass_optional || check_contiguous)
4928 stmtblock_t else_block;
4929 tree pre_stmts, post_stmts;
4932 tree present_var = NULL_TREE;
4933 tree cont_var = NULL_TREE;
4936 type = TREE_TYPE (parmse->expr);
4937 pointer = gfc_create_var (type, "arg_ptr");
4939 if (check_contiguous)
4941 gfc_se cont_se, array_se;
4942 stmtblock_t if_block, else_block;
4943 tree if_stmt, else_stmt;
4947 cont_var = gfc_create_var (boolean_type_node, "contiguous");
4949 /* If the size is known to be one at compile-time, set
4950 cont_var to true unconditionally. This may look
4951 inelegant, but we're only doing this during
4952 optimization, so the statements will be optimized away,
4953 and this saves complexity here. */
4955 size_set = gfc_array_size (expr, &size);
4956 if (size_set && mpz_cmp_ui (size, 1) == 0)
4958 gfc_add_modify (&se->pre, cont_var,
4959 build_one_cst (boolean_type_node));
4963 /* cont_var = is_contiguous (expr); . */
4964 gfc_init_se (&cont_se, parmse);
4965 gfc_conv_is_contiguous_expr (&cont_se, expr);
4966 gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
4967 gfc_add_modify (&se->pre, cont_var, cont_se.expr);
4968 gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
4974 /* arrayse->expr = descriptor of a. */
4975 gfc_init_se (&array_se, se);
4976 gfc_conv_expr_descriptor (&array_se, expr);
4977 gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
4978 gfc_add_block_to_block (&se->pre, &(&array_se)->post);
4980 /* if_stmt = { pointer = &a[0]; } . */
4981 gfc_init_block (&if_block);
4982 tmp = gfc_conv_array_data (array_se.expr);
4983 tmp = fold_convert (type, tmp);
4984 gfc_add_modify (&if_block, pointer, tmp);
4985 if_stmt = gfc_finish_block (&if_block);
4987 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
4988 gfc_init_block (&else_block);
4989 gfc_add_block_to_block (&else_block, &parmse->pre);
4990 gfc_add_modify (&else_block, pointer, parmse->expr);
4991 else_stmt = gfc_finish_block (&else_block);
4993 /* And put the above into an if statement. */
4994 pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4995 gfc_likely (cont_var,
4996 PRED_FORTRAN_CONTIGUOUS),
4997 if_stmt, else_stmt);
5001 /* pointer = pramse->expr; . */
5002 gfc_add_modify (&parmse->pre, pointer, parmse->expr);
5003 pre_stmts = gfc_finish_block (&parmse->pre);
5008 present_var = gfc_create_var (boolean_type_node, "present");
5010 /* present_var = present(sym); . */
5011 tmp = gfc_conv_expr_present (sym);
5012 tmp = fold_convert (boolean_type_node, tmp);
5013 gfc_add_modify (&se->pre, present_var, tmp);
5015 /* else_stmt = { pointer = NULL; } . */
5016 gfc_init_block (&else_block);
5017 gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
5018 else_stmt = gfc_finish_block (&else_block);
5020 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5021 gfc_likely (present_var,
5022 PRED_FORTRAN_ABSENT_DUMMY),
5023 pre_stmts, else_stmt);
5024 gfc_add_expr_to_block (&se->pre, tmp);
5027 gfc_add_expr_to_block (&se->pre, pre_stmts);
5029 post_stmts = gfc_finish_block (&parmse->post);
5031 /* Put together the post stuff, plus the optional
5033 if (check_contiguous)
5036 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5038 build_zero_cst (boolean_type_node));
5039 tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
5043 tree present_likely = gfc_likely (present_var,
5044 PRED_FORTRAN_ABSENT_DUMMY);
5045 post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5046 boolean_type_node, present_likely,
5054 gcc_assert (pass_optional);
5055 post_cond = present_var;
5058 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5059 post_stmts, build_empty_stmt (input_location));
5060 gfc_add_expr_to_block (&se->post, tmp);
5068 /* Generate the code for argument list functions. */
5071 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5073 /* Pass by value for g77 %VAL(arg), pass the address
5074 indirectly for %LOC, else by reference. Thus %REF
5075 is a "do-nothing" and %LOC is the same as an F95
5077 if (strcmp (name, "%VAL") == 0)
5078 gfc_conv_expr (se, expr);
5079 else if (strcmp (name, "%LOC") == 0)
5081 gfc_conv_expr_reference (se, expr);
5082 se->expr = gfc_build_addr_expr (NULL, se->expr);
5084 else if (strcmp (name, "%REF") == 0)
5085 gfc_conv_expr_reference (se, expr);
5087 gfc_error ("Unknown argument list function at %L", &expr->where);
5091 /* This function tells whether the middle-end representation of the expression
5092 E given as input may point to data otherwise accessible through a variable
5094 It is assumed that the only expressions that may alias are variables,
5095 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5097 This function is used to decide whether freeing an expression's allocatable
5098 components is safe or should be avoided.
5100 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5101 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5102 is necessary because for array constructors, aliasing depends on how
5104 - If E is an array constructor used as argument to an elemental procedure,
5105 the array, which is generated through shallow copy by the scalarizer,
5106 is used directly and can alias the expressions it was copied from.
5107 - If E is an array constructor used as argument to a non-elemental
5108 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5109 the array as in the previous case, but then that array is used
5110 to initialize a new descriptor through deep copy. There is no alias
5111 possible in that case.
5112 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5116 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5120 if (e->expr_type == EXPR_VARIABLE)
5122 else if (e->expr_type == EXPR_FUNCTION)
5124 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5126 if (proc_ifc->result != NULL
5127 && ((proc_ifc->result->ts.type == BT_CLASS
5128 && proc_ifc->result->ts.u.derived->attr.is_class
5129 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
5130 || proc_ifc->result->attr.pointer))
5135 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
5138 for (c = gfc_constructor_first (e->value.constructor);
5139 c; c = gfc_constructor_next (c))
5141 && expr_may_alias_variables (c->expr, array_may_alias))
5148 /* A helper function to set the dtype for unallocated or unassociated
5152 set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
5160 /* TODO Figure out how to handle optional dummies. */
5161 if (e && e->expr_type == EXPR_VARIABLE
5162 && e->symtree->n.sym->attr.optional)
5165 desc = parmse->expr;
5166 if (desc == NULL_TREE)
5169 if (POINTER_TYPE_P (TREE_TYPE (desc)))
5170 desc = build_fold_indirect_ref_loc (input_location, desc);
5172 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5175 gfc_init_block (&block);
5176 tmp = gfc_conv_descriptor_data_get (desc);
5177 cond = fold_build2_loc (input_location, EQ_EXPR,
5178 logical_type_node, tmp,
5179 build_int_cst (TREE_TYPE (tmp), 0));
5180 tmp = gfc_conv_descriptor_dtype (desc);
5181 type = gfc_get_element_type (TREE_TYPE (desc));
5182 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5183 TREE_TYPE (tmp), tmp,
5184 gfc_get_dtype_rank_type (e->rank, type));
5185 gfc_add_expr_to_block (&block, tmp);
5186 cond = build3_v (COND_EXPR, cond,
5187 gfc_finish_block (&block),
5188 build_empty_stmt (input_location));
5189 gfc_add_expr_to_block (&parmse->pre, cond);
5194 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5195 ISO_Fortran_binding array descriptors. */
5198 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
5208 symbol_attribute attr = gfc_expr_attr (e);
5211 /* If this is a full array or a scalar, the allocatable and pointer
5212 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5214 if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
5218 else if (attr.allocatable)
5222 /* If the formal argument is assumed shape and neither a pointer nor
5223 allocatable, it is unconditionally CFI_attribute_other. */
5224 if (fsym->as->type == AS_ASSUMED_SHAPE
5225 && !fsym->attr.pointer && !fsym->attr.allocatable)
5228 cfi_attribute = attribute;
5232 parmse->force_no_tmp = 1;
5233 if (fsym->attr.contiguous
5234 && !gfc_is_simply_contiguous (e, false, true))
5235 gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
5236 fsym->attr.pointer);
5238 gfc_conv_expr_descriptor (parmse, e);
5240 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5241 parmse->expr = build_fold_indirect_ref_loc (input_location,
5244 /* Unallocated allocatable arrays and unassociated pointer arrays
5245 need their dtype setting if they are argument associated with
5246 assumed rank dummies. */
5247 if (fsym && fsym->as
5248 && (gfc_expr_attr (e).pointer
5249 || gfc_expr_attr (e).allocatable))
5250 set_dtype_for_unallocated (parmse, e);
5252 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5253 the expression type is different from the descriptor type, then
5254 the offset must be found (eg. to a component ref or substring)
5255 and the dtype updated. Assumed type entities are only allowed
5256 to be dummies in Fortran. They therefore lack the decl specific
5257 appendiges and so must be treated differently from other fortran
5258 entities passed to CFI descriptors in the interface decl. */
5259 type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
5262 if (type && DECL_ARTIFICIAL (parmse->expr)
5263 && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
5265 /* Obtain the offset to the data. */
5266 gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
5267 gfc_index_zero_node, true, e);
5269 /* Update the dtype. */
5270 gfc_add_modify (&parmse->pre,
5271 gfc_conv_descriptor_dtype (parmse->expr),
5272 gfc_get_dtype_rank_type (e->rank, type));
5274 else if (type == NULL_TREE
5275 || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)))
5277 /* Make sure that the span is set for expressions where it
5278 might not have been done already. */
5279 tmp = gfc_conv_descriptor_elem_len (parmse->expr);
5280 tmp = fold_convert (gfc_array_index_type, tmp);
5281 gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
5286 gfc_conv_expr (parmse, e);
5288 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5289 parmse->expr = build_fold_indirect_ref_loc (input_location,
5292 parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
5293 parmse->expr, attr);
5296 /* Set the CFI attribute field through a temporary value for the
5298 desc_attr = gfc_conv_descriptor_attribute (parmse->expr);
5299 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5300 void_type_node, desc_attr,
5301 build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
5302 gfc_add_expr_to_block (&parmse->pre, tmp);
5304 /* Now pass the gfc_descriptor by reference. */
5305 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5307 /* Variables to point to the gfc and CFI descriptors. */
5308 gfc_desc_ptr = parmse->expr;
5309 cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
5310 gfc_add_modify (&parmse->pre, cfi_desc_ptr,
5311 build_int_cst (pvoid_type_node, 0));
5313 /* Allocate the CFI descriptor and fill the fields. */
5314 tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
5315 tmp = build_call_expr_loc (input_location,
5316 gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
5317 gfc_add_expr_to_block (&parmse->pre, tmp);
5319 /* Now set the gfc descriptor attribute. */
5320 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5321 void_type_node, desc_attr,
5322 build_int_cst (TREE_TYPE (desc_attr), attribute));
5323 gfc_add_expr_to_block (&parmse->pre, tmp);
5325 /* The CFI descriptor is passed to the bind_C procedure. */
5326 parmse->expr = cfi_desc_ptr;
5328 /* Free the CFI descriptor. */
5329 gfc_init_block (&block);
5330 cond = fold_build2_loc (input_location, NE_EXPR,
5331 logical_type_node, cfi_desc_ptr,
5332 build_int_cst (TREE_TYPE (cfi_desc_ptr), 0));
5333 tmp = gfc_call_free (cfi_desc_ptr);
5334 gfc_add_expr_to_block (&block, tmp);
5335 tmp = build3_v (COND_EXPR, cond,
5336 gfc_finish_block (&block),
5337 build_empty_stmt (input_location));
5338 gfc_prepend_expr_to_block (&parmse->post, tmp);
5340 /* Transfer values back to gfc descriptor. */
5341 tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5342 tmp = build_call_expr_loc (input_location,
5343 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
5344 gfc_prepend_expr_to_block (&parmse->post, tmp);
5346 /* Deal with an optional dummy being passed to an optional formal arg
5347 by finishing the pre and post blocks and making their execution
5348 conditional on the dummy being present. */
5349 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5350 && e->symtree->n.sym->attr.optional)
5352 cond = gfc_conv_expr_present (e->symtree->n.sym);
5353 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
5355 build_int_cst (pvoid_type_node, 0));
5356 tmp = build3_v (COND_EXPR, cond,
5357 gfc_finish_block (&parmse->pre), tmp);
5358 gfc_add_expr_to_block (&parmse->pre, tmp);
5359 tmp = build3_v (COND_EXPR, cond,
5360 gfc_finish_block (&parmse->post),
5361 build_empty_stmt (input_location));
5362 gfc_add_expr_to_block (&parmse->post, tmp);
5367 /* Generate code for a procedure call. Note can return se->post != NULL.
5368 If se->direct_byref is set then se->expr contains the return parameter.
5369 Return nonzero, if the call has alternate specifiers.
5370 'expr' is only needed for procedure pointer components. */
5373 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
5374 gfc_actual_arglist * args, gfc_expr * expr,
5375 vec<tree, va_gc> *append_args)
5377 gfc_interface_mapping mapping;
5378 vec<tree, va_gc> *arglist;
5379 vec<tree, va_gc> *retargs;
5383 gfc_array_info *info;
5390 vec<tree, va_gc> *stringargs;
5391 vec<tree, va_gc> *optionalargs;
5393 gfc_formal_arglist *formal;
5394 gfc_actual_arglist *arg;
5395 int has_alternate_specifier = 0;
5396 bool need_interface_mapping;
5404 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
5405 gfc_component *comp = NULL;
5412 optionalargs = NULL;
5417 comp = gfc_get_proc_ptr_comp (expr);
5419 bool elemental_proc = (comp
5420 && comp->ts.interface
5421 && comp->ts.interface->attr.elemental)
5422 || (comp && comp->attr.elemental)
5423 || sym->attr.elemental;
5427 if (!elemental_proc)
5429 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
5430 if (se->ss->info->useflags)
5432 gcc_assert ((!comp && gfc_return_by_reference (sym)
5433 && sym->result->attr.dimension)
5434 || (comp && comp->attr.dimension)
5435 || gfc_is_class_array_function (expr));
5436 gcc_assert (se->loop != NULL);
5437 /* Access the previously obtained result. */
5438 gfc_conv_tmp_array_ref (se);
5442 info = &se->ss->info->data.array;
5447 gfc_init_block (&post);
5448 gfc_init_interface_mapping (&mapping);
5451 formal = gfc_sym_get_dummy_args (sym);
5452 need_interface_mapping = sym->attr.dimension ||
5453 (sym->ts.type == BT_CHARACTER
5454 && sym->ts.u.cl->length
5455 && sym->ts.u.cl->length->expr_type
5460 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
5461 need_interface_mapping = comp->attr.dimension ||
5462 (comp->ts.type == BT_CHARACTER
5463 && comp->ts.u.cl->length
5464 && comp->ts.u.cl->length->expr_type
5468 base_object = NULL_TREE;
5469 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5470 is the third and fourth argument to such a function call a value
5471 denoting the number of elements to copy (i.e., most of the time the
5472 length of a deferred length string). */
5473 ulim_copy = (formal == NULL)
5474 && UNLIMITED_POLY (sym)
5475 && comp && (strcmp ("_copy", comp->name) == 0);
5477 /* Evaluate the arguments. */
5478 for (arg = args, argc = 0; arg != NULL;
5479 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
5481 bool finalized = false;
5482 bool non_unity_length_string = false;
5485 fsym = formal ? formal->sym : NULL;
5486 parm_kind = MISSING;
5488 if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
5489 && (!fsym->ts.u.cl->length
5490 || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5491 || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
5492 non_unity_length_string = true;
5494 /* If the procedure requires an explicit interface, the actual
5495 argument is passed according to the corresponding formal
5496 argument. If the corresponding formal argument is a POINTER,
5497 ALLOCATABLE or assumed shape, we do not use g77's calling
5498 convention, and pass the address of the array descriptor
5499 instead. Otherwise we use g77's calling convention, in other words
5500 pass the array data pointer without descriptor. */
5501 bool nodesc_arg = fsym != NULL
5502 && !(fsym->attr.pointer || fsym->attr.allocatable)
5504 && fsym->as->type != AS_ASSUMED_SHAPE
5505 && fsym->as->type != AS_ASSUMED_RANK;
5507 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
5509 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
5511 /* Class array expressions are sometimes coming completely unadorned
5512 with either arrayspec or _data component. Correct that here.
5513 OOP-TODO: Move this to the frontend. */
5514 if (e && e->expr_type == EXPR_VARIABLE
5516 && e->ts.type == BT_CLASS
5517 && (CLASS_DATA (e)->attr.codimension
5518 || CLASS_DATA (e)->attr.dimension))
5520 gfc_typespec temp_ts = e->ts;
5521 gfc_add_class_array_ref (e);
5527 if (se->ignore_optional)
5529 /* Some intrinsics have already been resolved to the correct
5533 else if (arg->label)
5535 has_alternate_specifier = 1;
5540 gfc_init_se (&parmse, NULL);
5542 /* For scalar arguments with VALUE attribute which are passed by
5543 value, pass "0" and a hidden argument gives the optional
5545 if (fsym && fsym->attr.optional && fsym->attr.value
5546 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
5547 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
5549 parmse.expr = fold_convert (gfc_sym_type (fsym),
5551 vec_safe_push (optionalargs, boolean_false_node);
5555 /* Pass a NULL pointer for an absent arg. */
5556 parmse.expr = null_pointer_node;
5557 if (arg->missing_arg_type == BT_CHARACTER)
5558 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5563 else if (arg->expr->expr_type == EXPR_NULL
5564 && fsym && !fsym->attr.pointer
5565 && (fsym->ts.type != BT_CLASS
5566 || !CLASS_DATA (fsym)->attr.class_pointer))
5568 /* Pass a NULL pointer to denote an absent arg. */
5569 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5570 && (fsym->ts.type != BT_CLASS
5571 || !CLASS_DATA (fsym)->attr.allocatable));
5572 gfc_init_se (&parmse, NULL);
5573 parmse.expr = null_pointer_node;
5574 if (arg->missing_arg_type == BT_CHARACTER)
5575 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5577 else if (fsym && fsym->ts.type == BT_CLASS
5578 && e->ts.type == BT_DERIVED)
5580 /* The derived type needs to be converted to a temporary
5582 gfc_init_se (&parmse, se);
5583 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5585 && e->expr_type == EXPR_VARIABLE
5586 && e->symtree->n.sym->attr.optional,
5587 CLASS_DATA (fsym)->attr.class_pointer
5588 || CLASS_DATA (fsym)->attr.allocatable);
5590 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
5592 /* The intrinsic type needs to be converted to a temporary
5593 CLASS object for the unlimited polymorphic formal. */
5594 gfc_init_se (&parmse, se);
5595 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5597 else if (se->ss && se->ss->info->useflags)
5603 /* An elemental function inside a scalarized loop. */
5604 gfc_init_se (&parmse, se);
5605 parm_kind = ELEMENTAL;
5607 /* When no fsym is present, ulim_copy is set and this is a third or
5608 fourth argument, use call-by-value instead of by reference to
5609 hand the length properties to the copy routine (i.e., most of the
5610 time this will be a call to a __copy_character_* routine where the
5611 third and fourth arguments are the lengths of a deferred length
5613 if ((fsym && fsym->attr.value)
5614 || (ulim_copy && (argc == 2 || argc == 3)))
5615 gfc_conv_expr (&parmse, e);
5617 gfc_conv_expr_reference (&parmse, e);
5619 if (e->ts.type == BT_CHARACTER && !e->rank
5620 && e->expr_type == EXPR_FUNCTION)
5621 parmse.expr = build_fold_indirect_ref_loc (input_location,
5624 if (fsym && fsym->ts.type == BT_DERIVED
5625 && gfc_is_class_container_ref (e))
5627 parmse.expr = gfc_class_data_get (parmse.expr);
5629 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5630 && e->symtree->n.sym->attr.optional)
5632 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5633 parmse.expr = build3_loc (input_location, COND_EXPR,
5634 TREE_TYPE (parmse.expr),
5636 fold_convert (TREE_TYPE (parmse.expr),
5637 null_pointer_node));
5641 /* If we are passing an absent array as optional dummy to an
5642 elemental procedure, make sure that we pass NULL when the data
5643 pointer is NULL. We need this extra conditional because of
5644 scalarization which passes arrays elements to the procedure,
5645 ignoring the fact that the array can be absent/unallocated/... */
5646 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5648 tree descriptor_data;
5650 descriptor_data = ss->info->data.array.data;
5651 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5653 fold_convert (TREE_TYPE (descriptor_data),
5654 null_pointer_node));
5656 = fold_build3_loc (input_location, COND_EXPR,
5657 TREE_TYPE (parmse.expr),
5658 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5659 fold_convert (TREE_TYPE (parmse.expr),
5664 /* The scalarizer does not repackage the reference to a class
5665 array - instead it returns a pointer to the data element. */
5666 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5667 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5668 fsym->attr.intent != INTENT_IN
5669 && (CLASS_DATA (fsym)->attr.class_pointer
5670 || CLASS_DATA (fsym)->attr.allocatable),
5672 && e->expr_type == EXPR_VARIABLE
5673 && e->symtree->n.sym->attr.optional,
5674 CLASS_DATA (fsym)->attr.class_pointer
5675 || CLASS_DATA (fsym)->attr.allocatable);
5682 gfc_init_se (&parmse, NULL);
5684 /* Check whether the expression is a scalar or not; we cannot use
5685 e->rank as it can be nonzero for functions arguments. */
5686 argss = gfc_walk_expr (e);
5687 scalar = argss == gfc_ss_terminator;
5689 gfc_free_ss_chain (argss);
5691 /* Special handling for passing scalar polymorphic coarrays;
5692 otherwise one passes "class->_data.data" instead of "&class". */
5693 if (e->rank == 0 && e->ts.type == BT_CLASS
5694 && fsym && fsym->ts.type == BT_CLASS
5695 && CLASS_DATA (fsym)->attr.codimension
5696 && !CLASS_DATA (fsym)->attr.dimension)
5698 gfc_add_class_array_ref (e);
5699 parmse.want_coarray = 1;
5703 /* A scalar or transformational function. */
5706 if (e->expr_type == EXPR_VARIABLE
5707 && e->symtree->n.sym->attr.cray_pointee
5708 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5710 /* The Cray pointer needs to be converted to a pointer to
5711 a type given by the expression. */
5712 gfc_conv_expr (&parmse, e);
5713 type = build_pointer_type (TREE_TYPE (parmse.expr));
5714 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5715 parmse.expr = convert (type, tmp);
5718 else if (sym->attr.is_bind_c && e
5719 && (is_CFI_desc (fsym, NULL)
5720 || non_unity_length_string))
5721 /* Implement F2018, C.12.6.1: paragraph (2). */
5722 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5724 else if (fsym && fsym->attr.value)
5726 if (fsym->ts.type == BT_CHARACTER
5727 && fsym->ts.is_c_interop
5728 && fsym->ns->proc_name != NULL
5729 && fsym->ns->proc_name->attr.is_bind_c)
5732 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5733 if (parmse.expr == NULL)
5734 gfc_conv_expr (&parmse, e);
5738 gfc_conv_expr (&parmse, e);
5739 if (fsym->attr.optional
5740 && fsym->ts.type != BT_CLASS
5741 && fsym->ts.type != BT_DERIVED)
5743 if (e->expr_type != EXPR_VARIABLE
5744 || !e->symtree->n.sym->attr.optional
5746 vec_safe_push (optionalargs, boolean_true_node);
5749 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5750 if (!e->symtree->n.sym->attr.value)
5752 = fold_build3_loc (input_location, COND_EXPR,
5753 TREE_TYPE (parmse.expr),
5755 fold_convert (TREE_TYPE (parmse.expr),
5756 integer_zero_node));
5758 vec_safe_push (optionalargs, tmp);
5764 else if (arg->name && arg->name[0] == '%')
5765 /* Argument list functions %VAL, %LOC and %REF are signalled
5766 through arg->name. */
5767 conv_arglist_function (&parmse, arg->expr, arg->name);
5768 else if ((e->expr_type == EXPR_FUNCTION)
5769 && ((e->value.function.esym
5770 && e->value.function.esym->result->attr.pointer)
5771 || (!e->value.function.esym
5772 && e->symtree->n.sym->attr.pointer))
5773 && fsym && fsym->attr.target)
5775 gfc_conv_expr (&parmse, e);
5776 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5779 else if (e->expr_type == EXPR_FUNCTION
5780 && e->symtree->n.sym->result
5781 && e->symtree->n.sym->result != e->symtree->n.sym
5782 && e->symtree->n.sym->result->attr.proc_pointer)
5784 /* Functions returning procedure pointers. */
5785 gfc_conv_expr (&parmse, e);
5786 if (fsym && fsym->attr.proc_pointer)
5787 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5792 if (e->ts.type == BT_CLASS && fsym
5793 && fsym->ts.type == BT_CLASS
5794 && (!CLASS_DATA (fsym)->as
5795 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5796 && CLASS_DATA (e)->attr.codimension)
5798 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5799 gcc_assert (!CLASS_DATA (fsym)->as);
5800 gfc_add_class_array_ref (e);
5801 parmse.want_coarray = 1;
5802 gfc_conv_expr_reference (&parmse, e);
5803 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5805 && e->expr_type == EXPR_VARIABLE);
5807 else if (e->ts.type == BT_CLASS && fsym
5808 && fsym->ts.type == BT_CLASS
5809 && !CLASS_DATA (fsym)->as
5810 && !CLASS_DATA (e)->as
5811 && strcmp (fsym->ts.u.derived->name,
5812 e->ts.u.derived->name))
5814 type = gfc_typenode_for_spec (&fsym->ts);
5815 var = gfc_create_var (type, fsym->name);
5816 gfc_conv_expr (&parmse, e);
5817 if (fsym->attr.optional
5818 && e->expr_type == EXPR_VARIABLE
5819 && e->symtree->n.sym->attr.optional)
5823 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5824 cond = fold_build2_loc (input_location, NE_EXPR,
5825 logical_type_node, tmp,
5826 fold_convert (TREE_TYPE (tmp),
5827 null_pointer_node));
5828 gfc_start_block (&block);
5829 gfc_add_modify (&block, var,
5830 fold_build1_loc (input_location,
5832 type, parmse.expr));
5833 gfc_add_expr_to_block (&parmse.pre,
5834 fold_build3_loc (input_location,
5835 COND_EXPR, void_type_node,
5836 cond, gfc_finish_block (&block),
5837 build_empty_stmt (input_location)));
5838 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5839 parmse.expr = build3_loc (input_location, COND_EXPR,
5840 TREE_TYPE (parmse.expr),
5842 fold_convert (TREE_TYPE (parmse.expr),
5843 null_pointer_node));
5847 /* Since the internal representation of unlimited
5848 polymorphic expressions includes an extra field
5849 that other class objects do not, a cast to the
5850 formal type does not work. */
5851 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5855 /* Set the _data field. */
5856 tmp = gfc_class_data_get (var);
5857 efield = fold_convert (TREE_TYPE (tmp),
5858 gfc_class_data_get (parmse.expr));
5859 gfc_add_modify (&parmse.pre, tmp, efield);
5861 /* Set the _vptr field. */
5862 tmp = gfc_class_vptr_get (var);
5863 efield = fold_convert (TREE_TYPE (tmp),
5864 gfc_class_vptr_get (parmse.expr));
5865 gfc_add_modify (&parmse.pre, tmp, efield);
5867 /* Set the _len field. */
5868 tmp = gfc_class_len_get (var);
5869 gfc_add_modify (&parmse.pre, tmp,
5870 build_int_cst (TREE_TYPE (tmp), 0));
5874 tmp = fold_build1_loc (input_location,
5877 gfc_add_modify (&parmse.pre, var, tmp);
5880 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5886 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5887 && !fsym->attr.allocatable && !fsym->attr.pointer
5888 && !e->symtree->n.sym->attr.dimension
5889 && !e->symtree->n.sym->attr.pointer
5891 && !e->symtree->n.sym->attr.dummy
5892 /* FIXME - PR 87395 and PR 41453 */
5893 && e->symtree->n.sym->attr.save == SAVE_NONE
5894 && !e->symtree->n.sym->attr.associate_var
5895 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5896 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5898 gfc_conv_expr_reference (&parmse, e, add_clobber);
5900 /* Catch base objects that are not variables. */
5901 if (e->ts.type == BT_CLASS
5902 && e->expr_type != EXPR_VARIABLE
5903 && expr && e == expr->base_expr)
5904 base_object = build_fold_indirect_ref_loc (input_location,
5907 /* A class array element needs converting back to be a
5908 class object, if the formal argument is a class object. */
5909 if (fsym && fsym->ts.type == BT_CLASS
5910 && e->ts.type == BT_CLASS
5911 && ((CLASS_DATA (fsym)->as
5912 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5913 || CLASS_DATA (e)->attr.dimension))
5914 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5915 fsym->attr.intent != INTENT_IN
5916 && (CLASS_DATA (fsym)->attr.class_pointer
5917 || CLASS_DATA (fsym)->attr.allocatable),
5919 && e->expr_type == EXPR_VARIABLE
5920 && e->symtree->n.sym->attr.optional,
5921 CLASS_DATA (fsym)->attr.class_pointer
5922 || CLASS_DATA (fsym)->attr.allocatable);
5924 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5925 allocated on entry, it must be deallocated. */
5926 if (fsym && fsym->attr.intent == INTENT_OUT
5927 && (fsym->attr.allocatable
5928 || (fsym->ts.type == BT_CLASS
5929 && CLASS_DATA (fsym)->attr.allocatable)))
5934 gfc_init_block (&block);
5936 if (e->ts.type == BT_CLASS)
5937 ptr = gfc_class_data_get (ptr);
5939 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5942 gfc_add_expr_to_block (&block, tmp);
5943 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5944 void_type_node, ptr,
5946 gfc_add_expr_to_block (&block, tmp);
5948 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5950 gfc_add_modify (&block, ptr,
5951 fold_convert (TREE_TYPE (ptr),
5952 null_pointer_node));
5953 gfc_add_expr_to_block (&block, tmp);
5955 else if (fsym->ts.type == BT_CLASS)
5958 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5959 tmp = gfc_get_symbol_decl (vtab);
5960 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5961 ptr = gfc_class_vptr_get (parmse.expr);
5962 gfc_add_modify (&block, ptr,
5963 fold_convert (TREE_TYPE (ptr), tmp));
5964 gfc_add_expr_to_block (&block, tmp);
5967 if (fsym->attr.optional
5968 && e->expr_type == EXPR_VARIABLE
5969 && e->symtree->n.sym->attr.optional)
5971 tmp = fold_build3_loc (input_location, COND_EXPR,
5973 gfc_conv_expr_present (e->symtree->n.sym),
5974 gfc_finish_block (&block),
5975 build_empty_stmt (input_location));
5978 tmp = gfc_finish_block (&block);
5980 gfc_add_expr_to_block (&se->pre, tmp);
5983 if (fsym && (fsym->ts.type == BT_DERIVED
5984 || fsym->ts.type == BT_ASSUMED)
5985 && e->ts.type == BT_CLASS
5986 && !CLASS_DATA (e)->attr.dimension
5987 && !CLASS_DATA (e)->attr.codimension)
5989 parmse.expr = gfc_class_data_get (parmse.expr);
5990 /* The result is a class temporary, whose _data component
5991 must be freed to avoid a memory leak. */
5992 if (e->expr_type == EXPR_FUNCTION
5993 && CLASS_DATA (e)->attr.allocatable)
5999 /* Borrow the function symbol to make a call to
6000 gfc_add_finalizer_call and then restore it. */
6001 tmp = e->symtree->n.sym->backend_decl;
6002 e->symtree->n.sym->backend_decl
6003 = TREE_OPERAND (parmse.expr, 0);
6004 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
6005 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
6006 finalized = gfc_add_finalizer_call (&parmse.post,
6008 gfc_free_expr (var);
6009 e->symtree->n.sym->backend_decl = tmp;
6010 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
6012 /* Then free the class _data. */
6013 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
6014 tmp = fold_build2_loc (input_location, NE_EXPR,
6017 tmp = build3_v (COND_EXPR, tmp,
6018 gfc_call_free (parmse.expr),
6019 build_empty_stmt (input_location));
6020 gfc_add_expr_to_block (&parmse.post, tmp);
6021 gfc_add_modify (&parmse.post, parmse.expr, zero);
6025 /* Wrap scalar variable in a descriptor. We need to convert
6026 the address of a pointer back to the pointer itself before,
6027 we can assign it to the data field. */
6029 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
6030 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
6033 if (TREE_CODE (tmp) == ADDR_EXPR)
6034 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6035 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
6037 parmse.expr = gfc_build_addr_expr (NULL_TREE,
6040 else if (fsym && e->expr_type != EXPR_NULL
6041 && ((fsym->attr.pointer
6042 && fsym->attr.flavor != FL_PROCEDURE)
6043 || (fsym->attr.proc_pointer
6044 && !(e->expr_type == EXPR_VARIABLE
6045 && e->symtree->n.sym->attr.dummy))
6046 || (fsym->attr.proc_pointer
6047 && e->expr_type == EXPR_VARIABLE
6048 && gfc_is_proc_ptr_comp (e))
6049 || (fsym->attr.allocatable
6050 && fsym->attr.flavor != FL_PROCEDURE)))
6052 /* Scalar pointer dummy args require an extra level of
6053 indirection. The null pointer already contains
6054 this level of indirection. */
6055 parm_kind = SCALAR_POINTER;
6056 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6060 else if (e->ts.type == BT_CLASS
6061 && fsym && fsym->ts.type == BT_CLASS
6062 && (CLASS_DATA (fsym)->attr.dimension
6063 || CLASS_DATA (fsym)->attr.codimension))
6065 /* Pass a class array. */
6066 parmse.use_offset = 1;
6067 gfc_conv_expr_descriptor (&parmse, e);
6069 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6070 allocated on entry, it must be deallocated. */
6071 if (fsym->attr.intent == INTENT_OUT
6072 && CLASS_DATA (fsym)->attr.allocatable)
6077 gfc_init_block (&block);
6079 ptr = gfc_class_data_get (ptr);
6081 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
6082 NULL_TREE, NULL_TREE,
6084 GFC_CAF_COARRAY_NOCOARRAY);
6085 gfc_add_expr_to_block (&block, tmp);
6086 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6087 void_type_node, ptr,
6089 gfc_add_expr_to_block (&block, tmp);
6090 gfc_reset_vptr (&block, e);
6092 if (fsym->attr.optional
6093 && e->expr_type == EXPR_VARIABLE
6095 || (e->ref->type == REF_ARRAY
6096 && e->ref->u.ar.type != AR_FULL))
6097 && e->symtree->n.sym->attr.optional)
6099 tmp = fold_build3_loc (input_location, COND_EXPR,
6101 gfc_conv_expr_present (e->symtree->n.sym),
6102 gfc_finish_block (&block),
6103 build_empty_stmt (input_location));
6106 tmp = gfc_finish_block (&block);
6108 gfc_add_expr_to_block (&se->pre, tmp);
6111 /* The conversion does not repackage the reference to a class
6112 array - _data descriptor. */
6113 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
6114 fsym->attr.intent != INTENT_IN
6115 && (CLASS_DATA (fsym)->attr.class_pointer
6116 || CLASS_DATA (fsym)->attr.allocatable),
6118 && e->expr_type == EXPR_VARIABLE
6119 && e->symtree->n.sym->attr.optional,
6120 CLASS_DATA (fsym)->attr.class_pointer
6121 || CLASS_DATA (fsym)->attr.allocatable);
6125 /* If the argument is a function call that may not create
6126 a temporary for the result, we have to check that we
6127 can do it, i.e. that there is no alias between this
6128 argument and another one. */
6129 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
6135 intent = fsym->attr.intent;
6137 intent = INTENT_UNKNOWN;
6139 if (gfc_check_fncall_dependency (e, intent, sym, args,
6141 parmse.force_tmp = 1;
6143 iarg = e->value.function.actual->expr;
6145 /* Temporary needed if aliasing due to host association. */
6146 if (sym->attr.contained
6148 && !sym->attr.implicit_pure
6149 && !sym->attr.use_assoc
6150 && iarg->expr_type == EXPR_VARIABLE
6151 && sym->ns == iarg->symtree->n.sym->ns)
6152 parmse.force_tmp = 1;
6154 /* Ditto within module. */
6155 if (sym->attr.use_assoc
6157 && !sym->attr.implicit_pure
6158 && iarg->expr_type == EXPR_VARIABLE
6159 && sym->module == iarg->symtree->n.sym->module)
6160 parmse.force_tmp = 1;
6163 if (sym->attr.is_bind_c && e
6164 && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
6165 /* Implement F2018, C.12.6.1: paragraph (2). */
6166 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
6168 else if (e->expr_type == EXPR_VARIABLE
6169 && is_subref_array (e)
6170 && !(fsym && fsym->attr.pointer))
6171 /* The actual argument is a component reference to an
6172 array of derived types. In this case, the argument
6173 is converted to a temporary, which is passed and then
6174 written back after the procedure call. */
6175 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6176 fsym ? fsym->attr.intent : INTENT_INOUT,
6177 fsym && fsym->attr.pointer);
6179 else if (gfc_is_class_array_ref (e, NULL)
6180 && fsym && fsym->ts.type == BT_DERIVED)
6181 /* The actual argument is a component reference to an
6182 array of derived types. In this case, the argument
6183 is converted to a temporary, which is passed and then
6184 written back after the procedure call.
6185 OOP-TODO: Insert code so that if the dynamic type is
6186 the same as the declared type, copy-in/copy-out does
6188 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6189 fsym ? fsym->attr.intent : INTENT_INOUT,
6190 fsym && fsym->attr.pointer);
6192 else if (gfc_is_class_array_function (e)
6193 && fsym && fsym->ts.type == BT_DERIVED)
6194 /* See previous comment. For function actual argument,
6195 the write out is not needed so the intent is set as
6198 e->must_finalize = 1;
6199 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6201 fsym && fsym->attr.pointer);
6203 else if (fsym && fsym->attr.contiguous
6204 && !gfc_is_simply_contiguous (e, false, true))
6206 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6207 fsym ? fsym->attr.intent : INTENT_INOUT,
6208 fsym && fsym->attr.pointer);
6211 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
6214 /* Unallocated allocatable arrays and unassociated pointer arrays
6215 need their dtype setting if they are argument associated with
6216 assumed rank dummies. */
6217 if (!sym->attr.is_bind_c && e && fsym && fsym->as
6218 && fsym->as->type == AS_ASSUMED_RANK)
6220 if (gfc_expr_attr (e).pointer
6221 || gfc_expr_attr (e).allocatable)
6222 set_dtype_for_unallocated (&parmse, e);
6223 else if (e->expr_type == EXPR_VARIABLE
6224 && e->symtree->n.sym->attr.dummy
6225 && e->symtree->n.sym->as
6226 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6229 tmp = build_fold_indirect_ref_loc (input_location,
6231 minus_one = build_int_cst (gfc_array_index_type, -1);
6232 gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
6233 gfc_rank_cst[e->rank - 1],
6238 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6239 allocated on entry, it must be deallocated. */
6240 if (fsym && fsym->attr.allocatable
6241 && fsym->attr.intent == INTENT_OUT)
6243 if (fsym->ts.type == BT_DERIVED
6244 && fsym->ts.u.derived->attr.alloc_comp)
6246 // deallocate the components first
6247 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
6248 parmse.expr, e->rank);
6249 if (tmp != NULL_TREE)
6250 gfc_add_expr_to_block (&se->pre, tmp);
6253 tmp = build_fold_indirect_ref_loc (input_location,
6255 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
6256 tmp = gfc_conv_descriptor_data_get (tmp);
6257 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6258 NULL_TREE, NULL_TREE, true,
6260 GFC_CAF_COARRAY_NOCOARRAY);
6261 if (fsym->attr.optional
6262 && e->expr_type == EXPR_VARIABLE
6263 && e->symtree->n.sym->attr.optional)
6264 tmp = fold_build3_loc (input_location, COND_EXPR,
6266 gfc_conv_expr_present (e->symtree->n.sym),
6267 tmp, build_empty_stmt (input_location));
6268 gfc_add_expr_to_block (&se->pre, tmp);
6273 /* The case with fsym->attr.optional is that of a user subroutine
6274 with an interface indicating an optional argument. When we call
6275 an intrinsic subroutine, however, fsym is NULL, but we might still
6276 have an optional argument, so we proceed to the substitution
6278 if (e && (fsym == NULL || fsym->attr.optional))
6280 /* If an optional argument is itself an optional dummy argument,
6281 check its presence and substitute a null if absent. This is
6282 only needed when passing an array to an elemental procedure
6283 as then array elements are accessed - or no NULL pointer is
6284 allowed and a "1" or "0" should be passed if not present.
6285 When passing a non-array-descriptor full array to a
6286 non-array-descriptor dummy, no check is needed. For
6287 array-descriptor actual to array-descriptor dummy, see
6288 PR 41911 for why a check has to be inserted.
6289 fsym == NULL is checked as intrinsics required the descriptor
6290 but do not always set fsym.
6291 Also, it is necessary to pass a NULL pointer to library routines
6292 which usually ignore optional arguments, so they can handle
6293 these themselves. */
6294 if (e->expr_type == EXPR_VARIABLE
6295 && e->symtree->n.sym->attr.optional
6296 && (((e->rank != 0 && elemental_proc)
6297 || e->representation.length || e->ts.type == BT_CHARACTER
6301 && (fsym->as->type == AS_ASSUMED_SHAPE
6302 || fsym->as->type == AS_ASSUMED_RANK
6303 || fsym->as->type == AS_DEFERRED)))))
6304 || se->ignore_optional))
6305 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
6306 e->representation.length);
6311 /* Obtain the character length of an assumed character length
6312 length procedure from the typespec. */
6313 if (fsym->ts.type == BT_CHARACTER
6314 && parmse.string_length == NULL_TREE
6315 && e->ts.type == BT_PROCEDURE
6316 && e->symtree->n.sym->ts.type == BT_CHARACTER
6317 && e->symtree->n.sym->ts.u.cl->length != NULL
6318 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6320 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
6321 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
6325 if (fsym && need_interface_mapping && e)
6326 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
6328 gfc_add_block_to_block (&se->pre, &parmse.pre);
6329 gfc_add_block_to_block (&post, &parmse.post);
6331 /* Allocated allocatable components of derived types must be
6332 deallocated for non-variable scalars, array arguments to elemental
6333 procedures, and array arguments with descriptor to non-elemental
6334 procedures. As bounds information for descriptorless arrays is no
6335 longer available here, they are dealt with in trans-array.c
6336 (gfc_conv_array_parameter). */
6337 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
6338 && e->ts.u.derived->attr.alloc_comp
6339 && (e->rank == 0 || elemental_proc || !nodesc_arg)
6340 && !expr_may_alias_variables (e, elemental_proc))
6343 /* It is known the e returns a structure type with at least one
6344 allocatable component. When e is a function, ensure that the
6345 function is called once only by using a temporary variable. */
6346 if (!DECL_P (parmse.expr))
6347 parmse.expr = gfc_evaluate_now_loc (input_location,
6348 parmse.expr, &se->pre);
6350 if (fsym && fsym->attr.value)
6353 tmp = build_fold_indirect_ref_loc (input_location,
6356 parm_rank = e->rank;
6364 case (SCALAR_POINTER):
6365 tmp = build_fold_indirect_ref_loc (input_location,
6370 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
6372 /* The derived type is passed to gfc_deallocate_alloc_comp.
6373 Therefore, class actuals can be handled correctly but derived
6374 types passed to class formals need the _data component. */
6375 tmp = gfc_class_data_get (tmp);
6376 if (!CLASS_DATA (fsym)->attr.dimension)
6377 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6380 if (e->expr_type == EXPR_OP
6381 && e->value.op.op == INTRINSIC_PARENTHESES
6382 && e->value.op.op1->expr_type == EXPR_VARIABLE)
6385 local_tmp = gfc_evaluate_now (tmp, &se->pre);
6386 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
6388 gfc_add_expr_to_block (&se->post, local_tmp);
6391 if (!finalized && !e->must_finalize)
6393 if ((e->ts.type == BT_CLASS
6394 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
6395 || e->ts.type == BT_DERIVED)
6396 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
6398 else if (e->ts.type == BT_CLASS)
6399 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
6401 gfc_prepend_expr_to_block (&post, tmp);
6405 /* Add argument checking of passing an unallocated/NULL actual to
6406 a nonallocatable/nonpointer dummy. */
6408 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
6410 symbol_attribute attr;
6414 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
6415 attr = gfc_expr_attr (e);
6417 goto end_pointer_check;
6419 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6420 allocatable to an optional dummy, cf. 12.5.2.12. */
6421 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
6422 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6423 goto end_pointer_check;
6427 /* If the actual argument is an optional pointer/allocatable and
6428 the formal argument takes an nonpointer optional value,
6429 it is invalid to pass a non-present argument on, even
6430 though there is no technical reason for this in gfortran.
6431 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6432 tree present, null_ptr, type;
6434 if (attr.allocatable
6435 && (fsym == NULL || !fsym->attr.allocatable))
6436 msg = xasprintf ("Allocatable actual argument '%s' is not "
6437 "allocated or not present",
6438 e->symtree->n.sym->name);
6439 else if (attr.pointer
6440 && (fsym == NULL || !fsym->attr.pointer))
6441 msg = xasprintf ("Pointer actual argument '%s' is not "
6442 "associated or not present",
6443 e->symtree->n.sym->name);
6444 else if (attr.proc_pointer
6445 && (fsym == NULL || !fsym->attr.proc_pointer))
6446 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6447 "associated or not present",
6448 e->symtree->n.sym->name);
6450 goto end_pointer_check;
6452 present = gfc_conv_expr_present (e->symtree->n.sym);
6453 type = TREE_TYPE (present);
6454 present = fold_build2_loc (input_location, EQ_EXPR,
6455 logical_type_node, present,
6457 null_pointer_node));
6458 type = TREE_TYPE (parmse.expr);
6459 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
6460 logical_type_node, parmse.expr,
6462 null_pointer_node));
6463 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6464 logical_type_node, present, null_ptr);
6468 if (attr.allocatable
6469 && (fsym == NULL || !fsym->attr.allocatable))
6470 msg = xasprintf ("Allocatable actual argument '%s' is not "
6471 "allocated", e->symtree->n.sym->name);
6472 else if (attr.pointer
6473 && (fsym == NULL || !fsym->attr.pointer))
6474 msg = xasprintf ("Pointer actual argument '%s' is not "
6475 "associated", e->symtree->n.sym->name);
6476 else if (attr.proc_pointer
6477 && (fsym == NULL || !fsym->attr.proc_pointer))
6478 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6479 "associated", e->symtree->n.sym->name);
6481 goto end_pointer_check;
6485 /* If the argument is passed by value, we need to strip the
6487 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
6488 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6490 cond = fold_build2_loc (input_location, EQ_EXPR,
6491 logical_type_node, tmp,
6492 fold_convert (TREE_TYPE (tmp),
6493 null_pointer_node));
6496 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
6502 /* Deferred length dummies pass the character length by reference
6503 so that the value can be returned. */
6504 if (parmse.string_length && fsym && fsym->ts.deferred)
6506 if (INDIRECT_REF_P (parmse.string_length))
6507 /* In chains of functions/procedure calls the string_length already
6508 is a pointer to the variable holding the length. Therefore
6509 remove the deref on call. */
6510 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
6513 tmp = parmse.string_length;
6514 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
6515 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
6516 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
6520 /* Character strings are passed as two parameters, a length and a
6521 pointer - except for Bind(c) which only passes the pointer.
6522 An unlimited polymorphic formal argument likewise does not
6524 if (parmse.string_length != NULL_TREE
6525 && !sym->attr.is_bind_c
6526 && !(fsym && UNLIMITED_POLY (fsym)))
6527 vec_safe_push (stringargs, parmse.string_length);
6529 /* When calling __copy for character expressions to unlimited
6530 polymorphic entities, the dst argument needs a string length. */
6531 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
6532 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
6533 && arg->next && arg->next->expr
6534 && (arg->next->expr->ts.type == BT_DERIVED
6535 || arg->next->expr->ts.type == BT_CLASS)
6536 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
6537 vec_safe_push (stringargs, parmse.string_length);
6539 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6540 pass the token and the offset as additional arguments. */
6541 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
6542 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6543 && !fsym->attr.allocatable)
6544 || (fsym->ts.type == BT_CLASS
6545 && CLASS_DATA (fsym)->attr.codimension
6546 && !CLASS_DATA (fsym)->attr.allocatable)))
6548 /* Token and offset. */
6549 vec_safe_push (stringargs, null_pointer_node);
6550 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
6551 gcc_assert (fsym->attr.optional);
6553 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
6554 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6555 && !fsym->attr.allocatable)
6556 || (fsym->ts.type == BT_CLASS
6557 && CLASS_DATA (fsym)->attr.codimension
6558 && !CLASS_DATA (fsym)->attr.allocatable)))
6560 tree caf_decl, caf_type;
6563 caf_decl = gfc_get_tree_for_caf_expr (e);
6564 caf_type = TREE_TYPE (caf_decl);
6566 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6567 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
6568 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
6569 tmp = gfc_conv_descriptor_token (caf_decl);
6570 else if (DECL_LANG_SPECIFIC (caf_decl)
6571 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
6572 tmp = GFC_DECL_TOKEN (caf_decl);
6575 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
6576 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
6577 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
6580 vec_safe_push (stringargs, tmp);
6582 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6583 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
6584 offset = build_int_cst (gfc_array_index_type, 0);
6585 else if (DECL_LANG_SPECIFIC (caf_decl)
6586 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
6587 offset = GFC_DECL_CAF_OFFSET (caf_decl);
6588 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
6589 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
6591 offset = build_int_cst (gfc_array_index_type, 0);
6593 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
6594 tmp = gfc_conv_descriptor_data_get (caf_decl);
6597 gcc_assert (POINTER_TYPE_P (caf_type));
6601 tmp2 = fsym->ts.type == BT_CLASS
6602 ? gfc_class_data_get (parmse.expr) : parmse.expr;
6603 if ((fsym->ts.type != BT_CLASS
6604 && (fsym->as->type == AS_ASSUMED_SHAPE
6605 || fsym->as->type == AS_ASSUMED_RANK))
6606 || (fsym->ts.type == BT_CLASS
6607 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6608 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6610 if (fsym->ts.type == BT_CLASS)
6611 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6614 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6615 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6617 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6618 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6620 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6621 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6624 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6627 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6628 gfc_array_index_type,
6629 fold_convert (gfc_array_index_type, tmp2),
6630 fold_convert (gfc_array_index_type, tmp));
6631 offset = fold_build2_loc (input_location, PLUS_EXPR,
6632 gfc_array_index_type, offset, tmp);
6634 vec_safe_push (stringargs, offset);
6637 vec_safe_push (arglist, parmse.expr);
6639 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6643 else if (sym->ts.type == BT_CLASS)
6644 ts = CLASS_DATA (sym)->ts;
6648 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6649 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6650 else if (ts.type == BT_CHARACTER)
6652 if (ts.u.cl->length == NULL)
6654 /* Assumed character length results are not allowed by C418 of the 2003
6655 standard and are trapped in resolve.c; except in the case of SPREAD
6656 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6657 we take the character length of the first argument for the result.
6658 For dummies, we have to look through the formal argument list for
6659 this function and use the character length found there.*/
6661 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6662 else if (!sym->attr.dummy)
6663 cl.backend_decl = (*stringargs)[0];
6666 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6667 for (; formal; formal = formal->next)
6668 if (strcmp (formal->sym->name, sym->name) == 0)
6669 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6671 len = cl.backend_decl;
6677 /* Calculate the length of the returned string. */
6678 gfc_init_se (&parmse, NULL);
6679 if (need_interface_mapping)
6680 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6682 gfc_conv_expr (&parmse, ts.u.cl->length);
6683 gfc_add_block_to_block (&se->pre, &parmse.pre);
6684 gfc_add_block_to_block (&se->post, &parmse.post);
6686 /* TODO: It would be better to have the charlens as
6687 gfc_charlen_type_node already when the interface is
6688 created instead of converting it here (see PR 84615). */
6689 tmp = fold_build2_loc (input_location, MAX_EXPR,
6690 gfc_charlen_type_node,
6691 fold_convert (gfc_charlen_type_node, tmp),
6692 build_zero_cst (gfc_charlen_type_node));
6693 cl.backend_decl = tmp;
6696 /* Set up a charlen structure for it. */
6701 len = cl.backend_decl;
6704 byref = (comp && (comp->attr.dimension
6705 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6706 || (!comp && gfc_return_by_reference (sym));
6709 if (se->direct_byref)
6711 /* Sometimes, too much indirection can be applied; e.g. for
6712 function_result = array_valued_recursive_function. */
6713 if (TREE_TYPE (TREE_TYPE (se->expr))
6714 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6715 && GFC_DESCRIPTOR_TYPE_P
6716 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6717 se->expr = build_fold_indirect_ref_loc (input_location,
6720 /* If the lhs of an assignment x = f(..) is allocatable and
6721 f2003 is allowed, we must do the automatic reallocation.
6722 TODO - deal with intrinsics, without using a temporary. */
6723 if (flag_realloc_lhs
6724 && se->ss && se->ss->loop_chain
6725 && se->ss->loop_chain->is_alloc_lhs
6726 && !expr->value.function.isym
6727 && sym->result->as != NULL)
6729 /* Evaluate the bounds of the result, if known. */
6730 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6733 /* Perform the automatic reallocation. */
6734 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6736 gfc_add_expr_to_block (&se->pre, tmp);
6738 /* Pass the temporary as the first argument. */
6739 result = info->descriptor;
6742 result = build_fold_indirect_ref_loc (input_location,
6744 vec_safe_push (retargs, se->expr);
6746 else if (comp && comp->attr.dimension)
6748 gcc_assert (se->loop && info);
6750 /* Set the type of the array. */
6751 tmp = gfc_typenode_for_spec (&comp->ts);
6752 gcc_assert (se->ss->dimen == se->loop->dimen);
6754 /* Evaluate the bounds of the result, if known. */
6755 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6757 /* If the lhs of an assignment x = f(..) is allocatable and
6758 f2003 is allowed, we must not generate the function call
6759 here but should just send back the results of the mapping.
6760 This is signalled by the function ss being flagged. */
6761 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6763 gfc_free_interface_mapping (&mapping);
6764 return has_alternate_specifier;
6767 /* Create a temporary to store the result. In case the function
6768 returns a pointer, the temporary will be a shallow copy and
6769 mustn't be deallocated. */
6770 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6771 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6772 tmp, NULL_TREE, false,
6773 !comp->attr.pointer, callee_alloc,
6774 &se->ss->info->expr->where);
6776 /* Pass the temporary as the first argument. */
6777 result = info->descriptor;
6778 tmp = gfc_build_addr_expr (NULL_TREE, result);
6779 vec_safe_push (retargs, tmp);
6781 else if (!comp && sym->result->attr.dimension)
6783 gcc_assert (se->loop && info);
6785 /* Set the type of the array. */
6786 tmp = gfc_typenode_for_spec (&ts);
6787 gcc_assert (se->ss->dimen == se->loop->dimen);
6789 /* Evaluate the bounds of the result, if known. */
6790 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6792 /* If the lhs of an assignment x = f(..) is allocatable and
6793 f2003 is allowed, we must not generate the function call
6794 here but should just send back the results of the mapping.
6795 This is signalled by the function ss being flagged. */
6796 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6798 gfc_free_interface_mapping (&mapping);
6799 return has_alternate_specifier;
6802 /* Create a temporary to store the result. In case the function
6803 returns a pointer, the temporary will be a shallow copy and
6804 mustn't be deallocated. */
6805 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6806 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6807 tmp, NULL_TREE, false,
6808 !sym->attr.pointer, callee_alloc,
6809 &se->ss->info->expr->where);
6811 /* Pass the temporary as the first argument. */
6812 result = info->descriptor;
6813 tmp = gfc_build_addr_expr (NULL_TREE, result);
6814 vec_safe_push (retargs, tmp);
6816 else if (ts.type == BT_CHARACTER)
6818 /* Pass the string length. */
6819 type = gfc_get_character_type (ts.kind, ts.u.cl);
6820 type = build_pointer_type (type);
6822 /* Emit a DECL_EXPR for the VLA type. */
6823 tmp = TREE_TYPE (type);
6825 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6827 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6828 DECL_ARTIFICIAL (tmp) = 1;
6829 DECL_IGNORED_P (tmp) = 1;
6830 tmp = fold_build1_loc (input_location, DECL_EXPR,
6831 TREE_TYPE (tmp), tmp);
6832 gfc_add_expr_to_block (&se->pre, tmp);
6835 /* Return an address to a char[0:len-1]* temporary for
6836 character pointers. */
6837 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6838 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6840 var = gfc_create_var (type, "pstr");
6842 if ((!comp && sym->attr.allocatable)
6843 || (comp && comp->attr.allocatable))
6845 gfc_add_modify (&se->pre, var,
6846 fold_convert (TREE_TYPE (var),
6847 null_pointer_node));
6848 tmp = gfc_call_free (var);
6849 gfc_add_expr_to_block (&se->post, tmp);
6852 /* Provide an address expression for the function arguments. */
6853 var = gfc_build_addr_expr (NULL_TREE, var);
6856 var = gfc_conv_string_tmp (se, type, len);
6858 vec_safe_push (retargs, var);
6862 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6864 type = gfc_get_complex_type (ts.kind);
6865 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6866 vec_safe_push (retargs, var);
6869 /* Add the string length to the argument list. */
6870 if (ts.type == BT_CHARACTER && ts.deferred)
6874 tmp = gfc_evaluate_now (len, &se->pre);
6875 TREE_STATIC (tmp) = 1;
6876 gfc_add_modify (&se->pre, tmp,
6877 build_int_cst (TREE_TYPE (tmp), 0));
6878 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6879 vec_safe_push (retargs, tmp);
6881 else if (ts.type == BT_CHARACTER)
6882 vec_safe_push (retargs, len);
6884 gfc_free_interface_mapping (&mapping);
6886 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6887 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6888 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6889 vec_safe_reserve (retargs, arglen);
6891 /* Add the return arguments. */
6892 vec_safe_splice (retargs, arglist);
6894 /* Add the hidden present status for optional+value to the arguments. */
6895 vec_safe_splice (retargs, optionalargs);
6897 /* Add the hidden string length parameters to the arguments. */
6898 vec_safe_splice (retargs, stringargs);
6900 /* We may want to append extra arguments here. This is used e.g. for
6901 calls to libgfortran_matmul_??, which need extra information. */
6902 vec_safe_splice (retargs, append_args);
6906 /* Generate the actual call. */
6907 if (base_object == NULL_TREE)
6908 conv_function_val (se, sym, expr, args);
6910 conv_base_obj_fcn_val (se, base_object, expr);
6912 /* If there are alternate return labels, function type should be
6913 integer. Can't modify the type in place though, since it can be shared
6914 with other functions. For dummy arguments, the typing is done to
6915 this result, even if it has to be repeated for each call. */
6916 if (has_alternate_specifier
6917 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6919 if (!sym->attr.dummy)
6921 TREE_TYPE (sym->backend_decl)
6922 = build_function_type (integer_type_node,
6923 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6924 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6927 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6930 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6931 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6933 /* Allocatable scalar function results must be freed and nullified
6934 after use. This necessitates the creation of a temporary to
6935 hold the result to prevent duplicate calls. */
6936 if (!byref && sym->ts.type != BT_CHARACTER
6937 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6938 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6940 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6941 gfc_add_modify (&se->pre, tmp, se->expr);
6943 tmp = gfc_call_free (tmp);
6944 gfc_add_expr_to_block (&post, tmp);
6945 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6948 /* If we have a pointer function, but we don't want a pointer, e.g.
6951 where f is pointer valued, we have to dereference the result. */
6952 if (!se->want_pointer && !byref
6953 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6954 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6955 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6957 /* f2c calling conventions require a scalar default real function to
6958 return a double precision result. Convert this back to default
6959 real. We only care about the cases that can happen in Fortran 77.
6961 if (flag_f2c && sym->ts.type == BT_REAL
6962 && sym->ts.kind == gfc_default_real_kind
6963 && !sym->attr.always_explicit)
6964 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6966 /* A pure function may still have side-effects - it may modify its
6968 TREE_SIDE_EFFECTS (se->expr) = 1;
6970 if (!sym->attr.pure)
6971 TREE_SIDE_EFFECTS (se->expr) = 1;
6976 /* Add the function call to the pre chain. There is no expression. */
6977 gfc_add_expr_to_block (&se->pre, se->expr);
6978 se->expr = NULL_TREE;
6980 if (!se->direct_byref)
6982 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6984 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6986 /* Check the data pointer hasn't been modified. This would
6987 happen in a function returning a pointer. */
6988 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6989 tmp = fold_build2_loc (input_location, NE_EXPR,
6992 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6995 se->expr = info->descriptor;
6996 /* Bundle in the string length. */
6997 se->string_length = len;
6999 else if (ts.type == BT_CHARACTER)
7001 /* Dereference for character pointer results. */
7002 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
7003 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
7004 se->expr = build_fold_indirect_ref_loc (input_location, var);
7008 se->string_length = len;
7012 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
7013 se->expr = build_fold_indirect_ref_loc (input_location, var);
7018 /* Associate the rhs class object's meta-data with the result, when the
7019 result is a temporary. */
7020 if (args && args->expr && args->expr->ts.type == BT_CLASS
7021 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
7022 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
7025 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
7027 gfc_init_se (&parmse, NULL);
7028 parmse.data_not_needed = 1;
7029 gfc_conv_expr (&parmse, class_expr);
7030 if (!DECL_LANG_SPECIFIC (result))
7031 gfc_allocate_lang_decl (result);
7032 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
7033 gfc_free_expr (class_expr);
7034 gcc_assert (parmse.pre.head == NULL_TREE
7035 && parmse.post.head == NULL_TREE);
7038 /* Follow the function call with the argument post block. */
7041 gfc_add_block_to_block (&se->pre, &post);
7043 /* Transformational functions of derived types with allocatable
7044 components must have the result allocatable components copied when the
7045 argument is actually given. */
7046 arg = expr->value.function.actual;
7047 if (result && arg && expr->rank
7048 && expr->value.function.isym
7049 && expr->value.function.isym->transformational
7051 && arg->expr->ts.type == BT_DERIVED
7052 && arg->expr->ts.u.derived->attr.alloc_comp)
7055 /* Copy the allocatable components. We have to use a
7056 temporary here to prevent source allocatable components
7057 from being corrupted. */
7058 tmp2 = gfc_evaluate_now (result, &se->pre);
7059 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
7060 result, tmp2, expr->rank, 0);
7061 gfc_add_expr_to_block (&se->pre, tmp);
7062 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
7064 gfc_add_expr_to_block (&se->pre, tmp);
7066 /* Finally free the temporary's data field. */
7067 tmp = gfc_conv_descriptor_data_get (tmp2);
7068 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7069 NULL_TREE, NULL_TREE, true,
7070 NULL, GFC_CAF_COARRAY_NOCOARRAY);
7071 gfc_add_expr_to_block (&se->pre, tmp);
7076 /* For a function with a class array result, save the result as
7077 a temporary, set the info fields needed by the scalarizer and
7078 call the finalization function of the temporary. Note that the
7079 nullification of allocatable components needed by the result
7080 is done in gfc_trans_assignment_1. */
7081 if (expr && ((gfc_is_class_array_function (expr)
7082 && se->ss && se->ss->loop)
7083 || gfc_is_alloc_class_scalar_function (expr))
7084 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
7085 && expr->must_finalize)
7090 if (se->ss && se->ss->loop)
7092 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
7093 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
7094 tmp = gfc_class_data_get (se->expr);
7095 info->descriptor = tmp;
7096 info->data = gfc_conv_descriptor_data_get (tmp);
7097 info->offset = gfc_conv_descriptor_offset_get (tmp);
7098 for (n = 0; n < se->ss->loop->dimen; n++)
7100 tree dim = gfc_rank_cst[n];
7101 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
7102 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
7107 /* TODO Eliminate the doubling of temporaries. This
7108 one is necessary to ensure no memory leakage. */
7109 se->expr = gfc_evaluate_now (se->expr, &se->pre);
7110 tmp = gfc_class_data_get (se->expr);
7111 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
7112 CLASS_DATA (expr->value.function.esym->result)->attr);
7115 if ((gfc_is_class_array_function (expr)
7116 || gfc_is_alloc_class_scalar_function (expr))
7117 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
7118 goto no_finalization;
7120 final_fndecl = gfc_class_vtab_final_get (se->expr);
7121 is_final = fold_build2_loc (input_location, NE_EXPR,
7124 fold_convert (TREE_TYPE (final_fndecl),
7125 null_pointer_node));
7126 final_fndecl = build_fold_indirect_ref_loc (input_location,
7128 tmp = build_call_expr_loc (input_location,
7130 gfc_build_addr_expr (NULL, tmp),
7131 gfc_class_vtab_size_get (se->expr),
7132 boolean_false_node);
7133 tmp = fold_build3_loc (input_location, COND_EXPR,
7134 void_type_node, is_final, tmp,
7135 build_empty_stmt (input_location));
7137 if (se->ss && se->ss->loop)
7139 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
7140 tmp = fold_build2_loc (input_location, NE_EXPR,
7143 fold_convert (TREE_TYPE (info->data),
7144 null_pointer_node));
7145 tmp = fold_build3_loc (input_location, COND_EXPR,
7146 void_type_node, tmp,
7147 gfc_call_free (info->data),
7148 build_empty_stmt (input_location));
7149 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
7154 gfc_prepend_expr_to_block (&se->post, tmp);
7155 classdata = gfc_class_data_get (se->expr);
7156 tmp = fold_build2_loc (input_location, NE_EXPR,
7159 fold_convert (TREE_TYPE (classdata),
7160 null_pointer_node));
7161 tmp = fold_build3_loc (input_location, COND_EXPR,
7162 void_type_node, tmp,
7163 gfc_call_free (classdata),
7164 build_empty_stmt (input_location));
7165 gfc_add_expr_to_block (&se->post, tmp);
7170 gfc_add_block_to_block (&se->post, &post);
7173 return has_alternate_specifier;
7177 /* Fill a character string with spaces. */
7180 fill_with_spaces (tree start, tree type, tree size)
7182 stmtblock_t block, loop;
7183 tree i, el, exit_label, cond, tmp;
7185 /* For a simple char type, we can call memset(). */
7186 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
7187 return build_call_expr_loc (input_location,
7188 builtin_decl_explicit (BUILT_IN_MEMSET),
7190 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
7191 lang_hooks.to_target_charset (' ')),
7192 fold_convert (size_type_node, size));
7194 /* Otherwise, we use a loop:
7195 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7199 /* Initialize variables. */
7200 gfc_init_block (&block);
7201 i = gfc_create_var (sizetype, "i");
7202 gfc_add_modify (&block, i, fold_convert (sizetype, size));
7203 el = gfc_create_var (build_pointer_type (type), "el");
7204 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
7205 exit_label = gfc_build_label_decl (NULL_TREE);
7206 TREE_USED (exit_label) = 1;
7210 gfc_init_block (&loop);
7212 /* Exit condition. */
7213 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
7214 build_zero_cst (sizetype));
7215 tmp = build1_v (GOTO_EXPR, exit_label);
7216 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7217 build_empty_stmt (input_location));
7218 gfc_add_expr_to_block (&loop, tmp);
7221 gfc_add_modify (&loop,
7222 fold_build1_loc (input_location, INDIRECT_REF, type, el),
7223 build_int_cst (type, lang_hooks.to_target_charset (' ')));
7225 /* Increment loop variables. */
7226 gfc_add_modify (&loop, i,
7227 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
7228 TYPE_SIZE_UNIT (type)));
7229 gfc_add_modify (&loop, el,
7230 fold_build_pointer_plus_loc (input_location,
7231 el, TYPE_SIZE_UNIT (type)));
7233 /* Making the loop... actually loop! */
7234 tmp = gfc_finish_block (&loop);
7235 tmp = build1_v (LOOP_EXPR, tmp);
7236 gfc_add_expr_to_block (&block, tmp);
7238 /* The exit label. */
7239 tmp = build1_v (LABEL_EXPR, exit_label);
7240 gfc_add_expr_to_block (&block, tmp);
7243 return gfc_finish_block (&block);
7247 /* Generate code to copy a string. */
7250 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
7251 int dkind, tree slength, tree src, int skind)
7253 tree tmp, dlen, slen;
7262 stmtblock_t tempblock;
7264 gcc_assert (dkind == skind);
7266 if (slength != NULL_TREE)
7268 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
7269 ssc = gfc_string_to_single_character (slen, src, skind);
7273 slen = build_one_cst (gfc_charlen_type_node);
7277 if (dlength != NULL_TREE)
7279 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
7280 dsc = gfc_string_to_single_character (dlen, dest, dkind);
7284 dlen = build_one_cst (gfc_charlen_type_node);
7288 /* Assign directly if the types are compatible. */
7289 if (dsc != NULL_TREE && ssc != NULL_TREE
7290 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
7292 gfc_add_modify (block, dsc, ssc);
7296 /* The string copy algorithm below generates code like
7300 if (srclen < destlen)
7302 memmove (dest, src, srclen);
7304 memset (&dest[srclen], ' ', destlen - srclen);
7308 // Truncate if too long.
7309 memmove (dest, src, destlen);
7314 /* Do nothing if the destination length is zero. */
7315 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
7316 build_zero_cst (TREE_TYPE (dlen)));
7318 /* For non-default character kinds, we have to multiply the string
7319 length by the base type size. */
7320 chartype = gfc_get_char_type (dkind);
7321 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
7323 fold_convert (TREE_TYPE (slen),
7324 TYPE_SIZE_UNIT (chartype)));
7325 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
7327 fold_convert (TREE_TYPE (dlen),
7328 TYPE_SIZE_UNIT (chartype)));
7330 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
7331 dest = fold_convert (pvoid_type_node, dest);
7333 dest = gfc_build_addr_expr (pvoid_type_node, dest);
7335 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
7336 src = fold_convert (pvoid_type_node, src);
7338 src = gfc_build_addr_expr (pvoid_type_node, src);
7340 /* Truncate string if source is too long. */
7341 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
7344 /* Copy and pad with spaces. */
7345 tmp3 = build_call_expr_loc (input_location,
7346 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7348 fold_convert (size_type_node, slen));
7350 /* Wstringop-overflow appears at -O3 even though this warning is not
7351 explicitly available in fortran nor can it be switched off. If the
7352 source length is a constant, its negative appears as a very large
7353 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7354 the result of the MINUS_EXPR suppresses this spurious warning. */
7355 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7356 TREE_TYPE(dlen), dlen, slen);
7357 if (slength && TREE_CONSTANT (slength))
7358 tmp = gfc_evaluate_now (tmp, block);
7360 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
7361 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
7363 gfc_init_block (&tempblock);
7364 gfc_add_expr_to_block (&tempblock, tmp3);
7365 gfc_add_expr_to_block (&tempblock, tmp4);
7366 tmp3 = gfc_finish_block (&tempblock);
7368 /* The truncated memmove if the slen >= dlen. */
7369 tmp2 = build_call_expr_loc (input_location,
7370 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7372 fold_convert (size_type_node, dlen));
7374 /* The whole copy_string function is there. */
7375 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
7377 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7378 build_empty_stmt (input_location));
7379 gfc_add_expr_to_block (block, tmp);
7383 /* Translate a statement function.
7384 The value of a statement function reference is obtained by evaluating the
7385 expression using the values of the actual arguments for the values of the
7386 corresponding dummy arguments. */
7389 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
7393 gfc_formal_arglist *fargs;
7394 gfc_actual_arglist *args;
7397 gfc_saved_var *saved_vars;
7403 sym = expr->symtree->n.sym;
7404 args = expr->value.function.actual;
7405 gfc_init_se (&lse, NULL);
7406 gfc_init_se (&rse, NULL);
7409 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
7411 saved_vars = XCNEWVEC (gfc_saved_var, n);
7412 temp_vars = XCNEWVEC (tree, n);
7414 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7415 fargs = fargs->next, n++)
7417 /* Each dummy shall be specified, explicitly or implicitly, to be
7419 gcc_assert (fargs->sym->attr.dimension == 0);
7422 if (fsym->ts.type == BT_CHARACTER)
7424 /* Copy string arguments. */
7427 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
7428 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
7430 /* Create a temporary to hold the value. */
7431 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
7432 fsym->ts.u.cl->backend_decl
7433 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
7435 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
7436 temp_vars[n] = gfc_create_var (type, fsym->name);
7438 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
7440 gfc_conv_expr (&rse, args->expr);
7441 gfc_conv_string_parameter (&rse);
7442 gfc_add_block_to_block (&se->pre, &lse.pre);
7443 gfc_add_block_to_block (&se->pre, &rse.pre);
7445 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
7446 rse.string_length, rse.expr, fsym->ts.kind);
7447 gfc_add_block_to_block (&se->pre, &lse.post);
7448 gfc_add_block_to_block (&se->pre, &rse.post);
7452 /* For everything else, just evaluate the expression. */
7454 /* Create a temporary to hold the value. */
7455 type = gfc_typenode_for_spec (&fsym->ts);
7456 temp_vars[n] = gfc_create_var (type, fsym->name);
7458 gfc_conv_expr (&lse, args->expr);
7460 gfc_add_block_to_block (&se->pre, &lse.pre);
7461 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
7462 gfc_add_block_to_block (&se->pre, &lse.post);
7468 /* Use the temporary variables in place of the real ones. */
7469 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7470 fargs = fargs->next, n++)
7471 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
7473 gfc_conv_expr (se, sym->value);
7475 if (sym->ts.type == BT_CHARACTER)
7477 gfc_conv_const_charlen (sym->ts.u.cl);
7479 /* Force the expression to the correct length. */
7480 if (!INTEGER_CST_P (se->string_length)
7481 || tree_int_cst_lt (se->string_length,
7482 sym->ts.u.cl->backend_decl))
7484 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
7485 tmp = gfc_create_var (type, sym->name);
7486 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
7487 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
7488 sym->ts.kind, se->string_length, se->expr,
7492 se->string_length = sym->ts.u.cl->backend_decl;
7495 /* Restore the original variables. */
7496 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7497 fargs = fargs->next, n++)
7498 gfc_restore_sym (fargs->sym, &saved_vars[n]);
7504 /* Translate a function expression. */
7507 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
7511 if (expr->value.function.isym)
7513 gfc_conv_intrinsic_function (se, expr);
7517 /* expr.value.function.esym is the resolved (specific) function symbol for
7518 most functions. However this isn't set for dummy procedures. */
7519 sym = expr->value.function.esym;
7521 sym = expr->symtree->n.sym;
7523 /* The IEEE_ARITHMETIC functions are caught here. */
7524 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
7525 if (gfc_conv_ieee_arithmetic_function (se, expr))
7528 /* We distinguish statement functions from general functions to improve
7529 runtime performance. */
7530 if (sym->attr.proc == PROC_ST_FUNCTION)
7532 gfc_conv_statement_function (se, expr);
7536 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7541 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7544 is_zero_initializer_p (gfc_expr * expr)
7546 if (expr->expr_type != EXPR_CONSTANT)
7549 /* We ignore constants with prescribed memory representations for now. */
7550 if (expr->representation.string)
7553 switch (expr->ts.type)
7556 return mpz_cmp_si (expr->value.integer, 0) == 0;
7559 return mpfr_zero_p (expr->value.real)
7560 && MPFR_SIGN (expr->value.real) >= 0;
7563 return expr->value.logical == 0;
7566 return mpfr_zero_p (mpc_realref (expr->value.complex))
7567 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
7568 && mpfr_zero_p (mpc_imagref (expr->value.complex))
7569 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
7579 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
7584 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
7585 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
7587 gfc_conv_tmp_array_ref (se);
7591 /* Build a static initializer. EXPR is the expression for the initial value.
7592 The other parameters describe the variable of the component being
7593 initialized. EXPR may be null. */
7596 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
7597 bool array, bool pointer, bool procptr)
7601 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
7602 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7603 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7604 return build_constructor (type, NULL);
7606 if (!(expr || pointer || procptr))
7609 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7610 (these are the only two iso_c_binding derived types that can be
7611 used as initialization expressions). If so, we need to modify
7612 the 'expr' to be that for a (void *). */
7613 if (expr != NULL && expr->ts.type == BT_DERIVED
7614 && expr->ts.is_iso_c && expr->ts.u.derived)
7616 if (TREE_CODE (type) == ARRAY_TYPE)
7617 return build_constructor (type, NULL);
7618 else if (POINTER_TYPE_P (type))
7619 return build_int_cst (type, 0);
7624 if (array && !procptr)
7627 /* Arrays need special handling. */
7629 ctor = gfc_build_null_descriptor (type);
7630 /* Special case assigning an array to zero. */
7631 else if (is_zero_initializer_p (expr))
7632 ctor = build_constructor (type, NULL);
7634 ctor = gfc_conv_array_initializer (type, expr);
7635 TREE_STATIC (ctor) = 1;
7638 else if (pointer || procptr)
7640 if (ts->type == BT_CLASS && !procptr)
7642 gfc_init_se (&se, NULL);
7643 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7644 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7645 TREE_STATIC (se.expr) = 1;
7648 else if (!expr || expr->expr_type == EXPR_NULL)
7649 return fold_convert (type, null_pointer_node);
7652 gfc_init_se (&se, NULL);
7653 se.want_pointer = 1;
7654 gfc_conv_expr (&se, expr);
7655 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7665 gfc_init_se (&se, NULL);
7666 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7667 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7669 gfc_conv_structure (&se, expr, 1);
7670 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7671 TREE_STATIC (se.expr) = 1;
7676 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7677 TREE_STATIC (ctor) = 1;
7682 gfc_init_se (&se, NULL);
7683 gfc_conv_constant (&se, expr);
7684 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7691 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7697 gfc_array_info *lss_array;
7704 gfc_start_block (&block);
7706 /* Initialize the scalarizer. */
7707 gfc_init_loopinfo (&loop);
7709 gfc_init_se (&lse, NULL);
7710 gfc_init_se (&rse, NULL);
7713 rss = gfc_walk_expr (expr);
7714 if (rss == gfc_ss_terminator)
7715 /* The rhs is scalar. Add a ss for the expression. */
7716 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7718 /* Create a SS for the destination. */
7719 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7721 lss_array = &lss->info->data.array;
7722 lss_array->shape = gfc_get_shape (cm->as->rank);
7723 lss_array->descriptor = dest;
7724 lss_array->data = gfc_conv_array_data (dest);
7725 lss_array->offset = gfc_conv_array_offset (dest);
7726 for (n = 0; n < cm->as->rank; n++)
7728 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7729 lss_array->stride[n] = gfc_index_one_node;
7731 mpz_init (lss_array->shape[n]);
7732 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7733 cm->as->lower[n]->value.integer);
7734 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7737 /* Associate the SS with the loop. */
7738 gfc_add_ss_to_loop (&loop, lss);
7739 gfc_add_ss_to_loop (&loop, rss);
7741 /* Calculate the bounds of the scalarization. */
7742 gfc_conv_ss_startstride (&loop);
7744 /* Setup the scalarizing loops. */
7745 gfc_conv_loop_setup (&loop, &expr->where);
7747 /* Setup the gfc_se structures. */
7748 gfc_copy_loopinfo_to_se (&lse, &loop);
7749 gfc_copy_loopinfo_to_se (&rse, &loop);
7752 gfc_mark_ss_chain_used (rss, 1);
7754 gfc_mark_ss_chain_used (lss, 1);
7756 /* Start the scalarized loop body. */
7757 gfc_start_scalarized_body (&loop, &body);
7759 gfc_conv_tmp_array_ref (&lse);
7760 if (cm->ts.type == BT_CHARACTER)
7761 lse.string_length = cm->ts.u.cl->backend_decl;
7763 gfc_conv_expr (&rse, expr);
7765 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7766 gfc_add_expr_to_block (&body, tmp);
7768 gcc_assert (rse.ss == gfc_ss_terminator);
7770 /* Generate the copying loops. */
7771 gfc_trans_scalarizing_loops (&loop, &body);
7773 /* Wrap the whole thing up. */
7774 gfc_add_block_to_block (&block, &loop.pre);
7775 gfc_add_block_to_block (&block, &loop.post);
7777 gcc_assert (lss_array->shape != NULL);
7778 gfc_free_shape (&lss_array->shape, cm->as->rank);
7779 gfc_cleanup_loop (&loop);
7781 return gfc_finish_block (&block);
7786 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7796 gfc_expr *arg = NULL;
7798 gfc_start_block (&block);
7799 gfc_init_se (&se, NULL);
7801 /* Get the descriptor for the expressions. */
7802 se.want_pointer = 0;
7803 gfc_conv_expr_descriptor (&se, expr);
7804 gfc_add_block_to_block (&block, &se.pre);
7805 gfc_add_modify (&block, dest, se.expr);
7807 /* Deal with arrays of derived types with allocatable components. */
7808 if (gfc_bt_struct (cm->ts.type)
7809 && cm->ts.u.derived->attr.alloc_comp)
7810 // TODO: Fix caf_mode
7811 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7814 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7815 && CLASS_DATA(cm)->attr.allocatable)
7817 if (cm->ts.u.derived->attr.alloc_comp)
7818 // TODO: Fix caf_mode
7819 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7824 tmp = TREE_TYPE (dest);
7825 tmp = gfc_duplicate_allocatable (dest, se.expr,
7826 tmp, expr->rank, NULL_TREE);
7830 tmp = gfc_duplicate_allocatable (dest, se.expr,
7831 TREE_TYPE(cm->backend_decl),
7832 cm->as->rank, NULL_TREE);
7834 gfc_add_expr_to_block (&block, tmp);
7835 gfc_add_block_to_block (&block, &se.post);
7837 if (expr->expr_type != EXPR_VARIABLE)
7838 gfc_conv_descriptor_data_set (&block, se.expr,
7841 /* We need to know if the argument of a conversion function is a
7842 variable, so that the correct lower bound can be used. */
7843 if (expr->expr_type == EXPR_FUNCTION
7844 && expr->value.function.isym
7845 && expr->value.function.isym->conversion
7846 && expr->value.function.actual->expr
7847 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7848 arg = expr->value.function.actual->expr;
7850 /* Obtain the array spec of full array references. */
7852 as = gfc_get_full_arrayspec_from_expr (arg);
7854 as = gfc_get_full_arrayspec_from_expr (expr);
7856 /* Shift the lbound and ubound of temporaries to being unity,
7857 rather than zero, based. Always calculate the offset. */
7858 offset = gfc_conv_descriptor_offset_get (dest);
7859 gfc_add_modify (&block, offset, gfc_index_zero_node);
7860 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7862 for (n = 0; n < expr->rank; n++)
7867 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7868 TODO It looks as if gfc_conv_expr_descriptor should return
7869 the correct bounds and that the following should not be
7870 necessary. This would simplify gfc_conv_intrinsic_bound
7872 if (as && as->lower[n])
7875 gfc_init_se (&lbse, NULL);
7876 gfc_conv_expr (&lbse, as->lower[n]);
7877 gfc_add_block_to_block (&block, &lbse.pre);
7878 lbound = gfc_evaluate_now (lbse.expr, &block);
7882 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7883 lbound = gfc_conv_descriptor_lbound_get (tmp,
7887 lbound = gfc_conv_descriptor_lbound_get (dest,
7890 lbound = gfc_index_one_node;
7892 lbound = fold_convert (gfc_array_index_type, lbound);
7894 /* Shift the bounds and set the offset accordingly. */
7895 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7896 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7897 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7898 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7900 gfc_conv_descriptor_ubound_set (&block, dest,
7901 gfc_rank_cst[n], tmp);
7902 gfc_conv_descriptor_lbound_set (&block, dest,
7903 gfc_rank_cst[n], lbound);
7905 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7906 gfc_conv_descriptor_lbound_get (dest,
7908 gfc_conv_descriptor_stride_get (dest,
7910 gfc_add_modify (&block, tmp2, tmp);
7911 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7913 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7918 /* If a conversion expression has a null data pointer
7919 argument, nullify the allocatable component. */
7923 if (arg->symtree->n.sym->attr.allocatable
7924 || arg->symtree->n.sym->attr.pointer)
7926 non_null_expr = gfc_finish_block (&block);
7927 gfc_start_block (&block);
7928 gfc_conv_descriptor_data_set (&block, dest,
7930 null_expr = gfc_finish_block (&block);
7931 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7932 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7933 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7934 return build3_v (COND_EXPR, tmp,
7935 null_expr, non_null_expr);
7939 return gfc_finish_block (&block);
7943 /* Allocate or reallocate scalar component, as necessary. */
7946 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7956 tree lhs_cl_size = NULL_TREE;
7961 if (!expr2 || expr2->rank)
7964 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7966 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7968 char name[GFC_MAX_SYMBOL_LEN+9];
7969 gfc_component *strlen;
7970 /* Use the rhs string length and the lhs element size. */
7971 gcc_assert (expr2->ts.type == BT_CHARACTER);
7972 if (!expr2->ts.u.cl->backend_decl)
7974 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7975 gcc_assert (expr2->ts.u.cl->backend_decl);
7978 size = expr2->ts.u.cl->backend_decl;
7980 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7982 sprintf (name, "_%s_length", cm->name);
7983 strlen = gfc_find_component (sym, name, true, true, NULL);
7984 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7985 gfc_charlen_type_node,
7986 TREE_OPERAND (comp, 0),
7987 strlen->backend_decl, NULL_TREE);
7989 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7990 tmp = TYPE_SIZE_UNIT (tmp);
7991 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7992 TREE_TYPE (tmp), tmp,
7993 fold_convert (TREE_TYPE (tmp), size));
7995 else if (cm->ts.type == BT_CLASS)
7997 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7998 if (expr2->ts.type == BT_DERIVED)
8000 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
8001 size = TYPE_SIZE_UNIT (tmp);
8007 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
8008 gfc_add_vptr_component (e2vtab);
8009 gfc_add_size_component (e2vtab);
8010 gfc_init_se (&se, NULL);
8011 gfc_conv_expr (&se, e2vtab);
8012 gfc_add_block_to_block (block, &se.pre);
8013 size = fold_convert (size_type_node, se.expr);
8014 gfc_free_expr (e2vtab);
8016 size_in_bytes = size;
8020 /* Otherwise use the length in bytes of the rhs. */
8021 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
8022 size_in_bytes = size;
8025 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
8026 size_in_bytes, size_one_node);
8028 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
8030 tmp = build_call_expr_loc (input_location,
8031 builtin_decl_explicit (BUILT_IN_CALLOC),
8032 2, build_one_cst (size_type_node),
8034 tmp = fold_convert (TREE_TYPE (comp), tmp);
8035 gfc_add_modify (block, comp, tmp);
8039 tmp = build_call_expr_loc (input_location,
8040 builtin_decl_explicit (BUILT_IN_MALLOC),
8042 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
8043 ptr = gfc_class_data_get (comp);
8046 tmp = fold_convert (TREE_TYPE (ptr), tmp);
8047 gfc_add_modify (block, ptr, tmp);
8050 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8051 /* Update the lhs character length. */
8052 gfc_add_modify (block, lhs_cl_size,
8053 fold_convert (TREE_TYPE (lhs_cl_size), size));
8057 /* Assign a single component of a derived type constructor. */
8060 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
8061 gfc_symbol *sym, bool init)
8069 gfc_start_block (&block);
8071 if (cm->attr.pointer || cm->attr.proc_pointer)
8073 /* Only care about pointers here, not about allocatables. */
8074 gfc_init_se (&se, NULL);
8075 /* Pointer component. */
8076 if ((cm->attr.dimension || cm->attr.codimension)
8077 && !cm->attr.proc_pointer)
8079 /* Array pointer. */
8080 if (expr->expr_type == EXPR_NULL)
8081 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8084 se.direct_byref = 1;
8086 gfc_conv_expr_descriptor (&se, expr);
8087 gfc_add_block_to_block (&block, &se.pre);
8088 gfc_add_block_to_block (&block, &se.post);
8093 /* Scalar pointers. */
8094 se.want_pointer = 1;
8095 gfc_conv_expr (&se, expr);
8096 gfc_add_block_to_block (&block, &se.pre);
8098 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8099 && expr->symtree->n.sym->attr.dummy)
8100 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8102 gfc_add_modify (&block, dest,
8103 fold_convert (TREE_TYPE (dest), se.expr));
8104 gfc_add_block_to_block (&block, &se.post);
8107 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
8109 /* NULL initialization for CLASS components. */
8110 tmp = gfc_trans_structure_assign (dest,
8111 gfc_class_initializer (&cm->ts, expr),
8113 gfc_add_expr_to_block (&block, tmp);
8115 else if ((cm->attr.dimension || cm->attr.codimension)
8116 && !cm->attr.proc_pointer)
8118 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8119 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8120 else if (cm->attr.allocatable || cm->attr.pdt_array)
8122 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
8123 gfc_add_expr_to_block (&block, tmp);
8127 tmp = gfc_trans_subarray_assign (dest, cm, expr);
8128 gfc_add_expr_to_block (&block, tmp);
8131 else if (cm->ts.type == BT_CLASS
8132 && CLASS_DATA (cm)->attr.dimension
8133 && CLASS_DATA (cm)->attr.allocatable
8134 && expr->ts.type == BT_DERIVED)
8136 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8137 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8138 tmp = gfc_class_vptr_get (dest);
8139 gfc_add_modify (&block, tmp,
8140 fold_convert (TREE_TYPE (tmp), vtab));
8141 tmp = gfc_class_data_get (dest);
8142 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
8143 gfc_add_expr_to_block (&block, tmp);
8145 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8147 /* NULL initialization for allocatable components. */
8148 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
8149 null_pointer_node));
8151 else if (init && (cm->attr.allocatable
8152 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
8153 && expr->ts.type != BT_CLASS)))
8155 /* Take care about non-array allocatable components here. The alloc_*
8156 routine below is motivated by the alloc_scalar_allocatable_for_
8157 assignment() routine, but with the realloc portions removed and
8159 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
8164 /* The remainder of these instructions follow the if (cm->attr.pointer)
8165 if (!cm->attr.dimension) part above. */
8166 gfc_init_se (&se, NULL);
8167 gfc_conv_expr (&se, expr);
8168 gfc_add_block_to_block (&block, &se.pre);
8170 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8171 && expr->symtree->n.sym->attr.dummy)
8172 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8174 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
8176 tmp = gfc_class_data_get (dest);
8177 tmp = build_fold_indirect_ref_loc (input_location, tmp);
8178 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8179 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8180 gfc_add_modify (&block, gfc_class_vptr_get (dest),
8181 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
8184 tmp = build_fold_indirect_ref_loc (input_location, dest);
8186 /* For deferred strings insert a memcpy. */
8187 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8190 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
8191 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
8193 : expr->ts.u.cl->backend_decl);
8194 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
8195 gfc_add_expr_to_block (&block, tmp);
8198 gfc_add_modify (&block, tmp,
8199 fold_convert (TREE_TYPE (tmp), se.expr));
8200 gfc_add_block_to_block (&block, &se.post);
8202 else if (expr->ts.type == BT_UNION)
8205 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
8206 /* We mark that the entire union should be initialized with a contrived
8207 EXPR_NULL expression at the beginning. */
8208 if (c != NULL && c->n.component == NULL
8209 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
8211 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8212 dest, build_constructor (TREE_TYPE (dest), NULL));
8213 gfc_add_expr_to_block (&block, tmp);
8214 c = gfc_constructor_next (c);
8216 /* The following constructor expression, if any, represents a specific
8217 map intializer, as given by the user. */
8218 if (c != NULL && c->expr != NULL)
8220 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8221 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8222 gfc_add_expr_to_block (&block, tmp);
8225 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
8227 if (expr->expr_type != EXPR_STRUCTURE)
8229 tree dealloc = NULL_TREE;
8230 gfc_init_se (&se, NULL);
8231 gfc_conv_expr (&se, expr);
8232 gfc_add_block_to_block (&block, &se.pre);
8233 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8234 expression in a temporary variable and deallocate the allocatable
8235 components. Then we can the copy the expression to the result. */
8236 if (cm->ts.u.derived->attr.alloc_comp
8237 && expr->expr_type != EXPR_VARIABLE)
8239 se.expr = gfc_evaluate_now (se.expr, &block);
8240 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
8243 gfc_add_modify (&block, dest,
8244 fold_convert (TREE_TYPE (dest), se.expr));
8245 if (cm->ts.u.derived->attr.alloc_comp
8246 && expr->expr_type != EXPR_NULL)
8248 // TODO: Fix caf_mode
8249 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
8250 dest, expr->rank, 0);
8251 gfc_add_expr_to_block (&block, tmp);
8252 if (dealloc != NULL_TREE)
8253 gfc_add_expr_to_block (&block, dealloc);
8255 gfc_add_block_to_block (&block, &se.post);
8259 /* Nested constructors. */
8260 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8261 gfc_add_expr_to_block (&block, tmp);
8264 else if (gfc_deferred_strlen (cm, &tmp))
8268 gcc_assert (strlen);
8269 strlen = fold_build3_loc (input_location, COMPONENT_REF,
8271 TREE_OPERAND (dest, 0),
8274 if (expr->expr_type == EXPR_NULL)
8276 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
8277 gfc_add_modify (&block, dest, tmp);
8278 tmp = build_int_cst (TREE_TYPE (strlen), 0);
8279 gfc_add_modify (&block, strlen, tmp);
8284 gfc_init_se (&se, NULL);
8285 gfc_conv_expr (&se, expr);
8286 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
8287 tmp = build_call_expr_loc (input_location,
8288 builtin_decl_explicit (BUILT_IN_MALLOC),
8290 gfc_add_modify (&block, dest,
8291 fold_convert (TREE_TYPE (dest), tmp));
8292 gfc_add_modify (&block, strlen,
8293 fold_convert (TREE_TYPE (strlen), se.string_length));
8294 tmp = gfc_build_memcpy_call (dest, se.expr, size);
8295 gfc_add_expr_to_block (&block, tmp);
8298 else if (!cm->attr.artificial)
8300 /* Scalar component (excluding deferred parameters). */
8301 gfc_init_se (&se, NULL);
8302 gfc_init_se (&lse, NULL);
8304 gfc_conv_expr (&se, expr);
8305 if (cm->ts.type == BT_CHARACTER)
8306 lse.string_length = cm->ts.u.cl->backend_decl;
8308 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
8309 gfc_add_expr_to_block (&block, tmp);
8311 return gfc_finish_block (&block);
8314 /* Assign a derived type constructor to a variable. */
8317 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
8326 gfc_start_block (&block);
8327 cm = expr->ts.u.derived->components;
8329 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
8330 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8331 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
8335 gfc_init_se (&se, NULL);
8336 gfc_init_se (&lse, NULL);
8337 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
8339 gfc_add_modify (&block, lse.expr,
8340 fold_convert (TREE_TYPE (lse.expr), se.expr));
8342 return gfc_finish_block (&block);
8346 gfc_init_se (&se, NULL);
8348 for (c = gfc_constructor_first (expr->value.constructor);
8349 c; c = gfc_constructor_next (c), cm = cm->next)
8351 /* Skip absent members in default initializers. */
8352 if (!c->expr && !cm->attr.allocatable)
8355 /* Register the component with the caf-lib before it is initialized.
8356 Register only allocatable components, that are not coarray'ed
8357 components (%comp[*]). Only register when the constructor is not the
8359 if (coarray && !cm->attr.codimension
8360 && (cm->attr.allocatable || cm->attr.pointer)
8361 && (!c->expr || c->expr->expr_type == EXPR_NULL))
8363 tree token, desc, size;
8364 bool is_array = cm->ts.type == BT_CLASS
8365 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
8367 field = cm->backend_decl;
8368 field = fold_build3_loc (input_location, COMPONENT_REF,
8369 TREE_TYPE (field), dest, field, NULL_TREE);
8370 if (cm->ts.type == BT_CLASS)
8371 field = gfc_class_data_get (field);
8373 token = is_array ? gfc_conv_descriptor_token (field)
8374 : fold_build3_loc (input_location, COMPONENT_REF,
8375 TREE_TYPE (cm->caf_token), dest,
8376 cm->caf_token, NULL_TREE);
8380 /* The _caf_register routine looks at the rank of the array
8381 descriptor to decide whether the data registered is an array
8383 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
8385 /* When the rank is not known just set a positive rank, which
8386 suffices to recognize the data as array. */
8389 size = build_zero_cst (size_type_node);
8391 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
8392 build_int_cst (signed_char_type_node, rank));
8396 desc = gfc_conv_scalar_to_descriptor (&se, field,
8397 cm->ts.type == BT_CLASS
8398 ? CLASS_DATA (cm)->attr
8400 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
8402 gfc_add_block_to_block (&block, &se.pre);
8403 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
8404 7, size, build_int_cst (
8406 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
8407 gfc_build_addr_expr (pvoid_type_node,
8409 gfc_build_addr_expr (NULL_TREE, desc),
8410 null_pointer_node, null_pointer_node,
8412 gfc_add_expr_to_block (&block, tmp);
8414 field = cm->backend_decl;
8415 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8416 dest, field, NULL_TREE);
8419 gfc_expr *e = gfc_get_null_expr (NULL);
8420 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
8425 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
8426 expr->ts.u.derived, init);
8427 gfc_add_expr_to_block (&block, tmp);
8429 return gfc_finish_block (&block);
8433 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
8434 gfc_component *un, gfc_expr *init)
8436 gfc_constructor *ctor;
8438 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
8441 ctor = gfc_constructor_first (init->value.constructor);
8443 if (ctor == NULL || ctor->expr == NULL)
8446 gcc_assert (init->expr_type == EXPR_STRUCTURE);
8448 /* If we have an 'initialize all' constructor, do it first. */
8449 if (ctor->expr->expr_type == EXPR_NULL)
8451 tree union_type = TREE_TYPE (un->backend_decl);
8452 tree val = build_constructor (union_type, NULL);
8453 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8454 ctor = gfc_constructor_next (ctor);
8457 /* Add the map initializer on top. */
8458 if (ctor != NULL && ctor->expr != NULL)
8460 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
8461 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
8462 TREE_TYPE (un->backend_decl),
8463 un->attr.dimension, un->attr.pointer,
8464 un->attr.proc_pointer);
8465 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8469 /* Build an expression for a constructor. If init is nonzero then
8470 this is part of a static variable initializer. */
8473 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
8480 vec<constructor_elt, va_gc> *v = NULL;
8482 gcc_assert (se->ss == NULL);
8483 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8484 type = gfc_typenode_for_spec (&expr->ts);
8488 /* Create a temporary variable and fill it in. */
8489 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
8490 /* The symtree in expr is NULL, if the code to generate is for
8491 initializing the static members only. */
8492 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
8494 gfc_add_expr_to_block (&se->pre, tmp);
8498 cm = expr->ts.u.derived->components;
8500 for (c = gfc_constructor_first (expr->value.constructor);
8501 c; c = gfc_constructor_next (c), cm = cm->next)
8503 /* Skip absent members in default initializers and allocatable
8504 components. Although the latter have a default initializer
8505 of EXPR_NULL,... by default, the static nullify is not needed
8506 since this is done every time we come into scope. */
8507 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
8510 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
8511 && strcmp (cm->name, "_extends") == 0
8512 && cm->initializer->symtree)
8516 vtabs = cm->initializer->symtree->n.sym;
8517 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
8518 vtab = unshare_expr_without_location (vtab);
8519 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
8521 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
8523 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
8524 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8525 fold_convert (TREE_TYPE (cm->backend_decl),
8528 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
8529 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8530 fold_convert (TREE_TYPE (cm->backend_decl),
8531 integer_zero_node));
8532 else if (cm->ts.type == BT_UNION)
8533 gfc_conv_union_initializer (v, cm, c->expr);
8536 val = gfc_conv_initializer (c->expr, &cm->ts,
8537 TREE_TYPE (cm->backend_decl),
8538 cm->attr.dimension, cm->attr.pointer,
8539 cm->attr.proc_pointer);
8540 val = unshare_expr_without_location (val);
8542 /* Append it to the constructor list. */
8543 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
8547 se->expr = build_constructor (type, v);
8549 TREE_CONSTANT (se->expr) = 1;
8553 /* Translate a substring expression. */
8556 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
8562 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
8564 se->expr = gfc_build_wide_string_const (expr->ts.kind,
8565 expr->value.character.length,
8566 expr->value.character.string);
8568 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
8569 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
8572 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
8576 /* Entry point for expression translation. Evaluates a scalar quantity.
8577 EXPR is the expression to be translated, and SE is the state structure if
8578 called from within the scalarized. */
8581 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
8586 if (ss && ss->info->expr == expr
8587 && (ss->info->type == GFC_SS_SCALAR
8588 || ss->info->type == GFC_SS_REFERENCE))
8590 gfc_ss_info *ss_info;
8593 /* Substitute a scalar expression evaluated outside the scalarization
8595 se->expr = ss_info->data.scalar.value;
8596 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
8597 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8599 se->string_length = ss_info->string_length;
8600 gfc_advance_se_ss_chain (se);
8604 /* We need to convert the expressions for the iso_c_binding derived types.
8605 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8606 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8607 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8608 updated to be an integer with a kind equal to the size of a (void *). */
8609 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8610 && expr->ts.u.derived->attr.is_bind_c)
8612 if (expr->expr_type == EXPR_VARIABLE
8613 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8614 || expr->symtree->n.sym->intmod_sym_id
8615 == ISOCBINDING_NULL_FUNPTR))
8617 /* Set expr_type to EXPR_NULL, which will result in
8618 null_pointer_node being used below. */
8619 expr->expr_type = EXPR_NULL;
8623 /* Update the type/kind of the expression to be what the new
8624 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8625 expr->ts.type = BT_INTEGER;
8626 expr->ts.f90_type = BT_VOID;
8627 expr->ts.kind = gfc_index_integer_kind;
8631 gfc_fix_class_refs (expr);
8633 switch (expr->expr_type)
8636 gfc_conv_expr_op (se, expr);
8640 gfc_conv_function_expr (se, expr);
8644 gfc_conv_constant (se, expr);
8648 gfc_conv_variable (se, expr);
8652 se->expr = null_pointer_node;
8655 case EXPR_SUBSTRING:
8656 gfc_conv_substring_expr (se, expr);
8659 case EXPR_STRUCTURE:
8660 gfc_conv_structure (se, expr, 0);
8664 gfc_conv_array_constructor_expr (se, expr);
8673 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8674 of an assignment. */
8676 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8678 gfc_conv_expr (se, expr);
8679 /* All numeric lvalues should have empty post chains. If not we need to
8680 figure out a way of rewriting an lvalue so that it has no post chain. */
8681 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8684 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8685 numeric expressions. Used for scalar values where inserting cleanup code
8688 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8692 gcc_assert (expr->ts.type != BT_CHARACTER);
8693 gfc_conv_expr (se, expr);
8696 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8697 gfc_add_modify (&se->pre, val, se->expr);
8699 gfc_add_block_to_block (&se->pre, &se->post);
8703 /* Helper to translate an expression and convert it to a particular type. */
8705 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8707 gfc_conv_expr_val (se, expr);
8708 se->expr = convert (type, se->expr);
8712 /* Converts an expression so that it can be passed by reference. Scalar
8716 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8722 if (ss && ss->info->expr == expr
8723 && ss->info->type == GFC_SS_REFERENCE)
8725 /* Returns a reference to the scalar evaluated outside the loop
8727 gfc_conv_expr (se, expr);
8729 if (expr->ts.type == BT_CHARACTER
8730 && expr->expr_type != EXPR_FUNCTION)
8731 gfc_conv_string_parameter (se);
8733 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8738 if (expr->ts.type == BT_CHARACTER)
8740 gfc_conv_expr (se, expr);
8741 gfc_conv_string_parameter (se);
8745 if (expr->expr_type == EXPR_VARIABLE)
8747 se->want_pointer = 1;
8748 gfc_conv_expr (se, expr);
8751 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8752 gfc_add_modify (&se->pre, var, se->expr);
8753 gfc_add_block_to_block (&se->pre, &se->post);
8756 else if (add_clobber && expr->ref == NULL)
8760 /* FIXME: This fails if var is passed by reference, see PR
8762 var = expr->symtree->n.sym->backend_decl;
8763 clobber = build_clobber (TREE_TYPE (var));
8764 gfc_add_modify (&se->pre, var, clobber);
8769 if (expr->expr_type == EXPR_FUNCTION
8770 && ((expr->value.function.esym
8771 && expr->value.function.esym->result->attr.pointer
8772 && !expr->value.function.esym->result->attr.dimension)
8773 || (!expr->value.function.esym && !expr->ref
8774 && expr->symtree->n.sym->attr.pointer
8775 && !expr->symtree->n.sym->attr.dimension)))
8777 se->want_pointer = 1;
8778 gfc_conv_expr (se, expr);
8779 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8780 gfc_add_modify (&se->pre, var, se->expr);
8785 gfc_conv_expr (se, expr);
8787 /* Create a temporary var to hold the value. */
8788 if (TREE_CONSTANT (se->expr))
8790 tree tmp = se->expr;
8791 STRIP_TYPE_NOPS (tmp);
8792 var = build_decl (input_location,
8793 CONST_DECL, NULL, TREE_TYPE (tmp));
8794 DECL_INITIAL (var) = tmp;
8795 TREE_STATIC (var) = 1;
8800 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8801 gfc_add_modify (&se->pre, var, se->expr);
8804 if (!expr->must_finalize)
8805 gfc_add_block_to_block (&se->pre, &se->post);
8807 /* Take the address of that value. */
8808 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8812 /* Get the _len component for an unlimited polymorphic expression. */
8815 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8818 gfc_ref *ref = expr->ref;
8820 gfc_init_se (&se, NULL);
8821 while (ref && ref->next)
8823 gfc_add_len_component (expr);
8824 gfc_conv_expr (&se, expr);
8825 gfc_add_block_to_block (block, &se.pre);
8826 gcc_assert (se.post.head == NULL_TREE);
8829 gfc_free_ref_list (ref->next);
8834 gfc_free_ref_list (expr->ref);
8841 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8842 statement-list outside of the scalarizer-loop. When code is generated, that
8843 depends on the scalarized expression, it is added to RSE.PRE.
8844 Returns le's _vptr tree and when set the len expressions in to_lenp and
8845 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8849 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8850 gfc_expr * re, gfc_se *rse,
8851 tree * to_lenp, tree * from_lenp)
8854 gfc_expr * vptr_expr;
8855 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8856 bool set_vptr = false, temp_rhs = false;
8857 stmtblock_t *pre = block;
8859 /* Create a temporary for complicated expressions. */
8860 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8861 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8863 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8865 gfc_add_modify (&rse->pre, tmp, rse->expr);
8870 /* Get the _vptr for the left-hand side expression. */
8871 gfc_init_se (&se, NULL);
8872 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8873 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8875 /* Care about _len for unlimited polymorphic entities. */
8876 if (UNLIMITED_POLY (vptr_expr)
8877 || (vptr_expr->ts.type == BT_DERIVED
8878 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8879 to_len = trans_get_upoly_len (block, vptr_expr);
8880 gfc_add_vptr_component (vptr_expr);
8884 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8885 se.want_pointer = 1;
8886 gfc_conv_expr (&se, vptr_expr);
8887 gfc_free_expr (vptr_expr);
8888 gfc_add_block_to_block (block, &se.pre);
8889 gcc_assert (se.post.head == NULL_TREE);
8891 STRIP_NOPS (lhs_vptr);
8893 /* Set the _vptr only when the left-hand side of the assignment is a
8897 /* Get the vptr from the rhs expression only, when it is variable.
8898 Functions are expected to be assigned to a temporary beforehand. */
8899 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8900 ? gfc_find_and_cut_at_last_class_ref (re)
8902 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8904 if (to_len != NULL_TREE)
8906 /* Get the _len information from the rhs. */
8907 if (UNLIMITED_POLY (vptr_expr)
8908 || (vptr_expr->ts.type == BT_DERIVED
8909 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8910 from_len = trans_get_upoly_len (block, vptr_expr);
8912 gfc_add_vptr_component (vptr_expr);
8916 if (re->expr_type == EXPR_VARIABLE
8917 && DECL_P (re->symtree->n.sym->backend_decl)
8918 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8919 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8920 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8921 re->symtree->n.sym->backend_decl))))
8924 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8925 re->symtree->n.sym->backend_decl));
8927 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8928 re->symtree->n.sym->backend_decl));
8930 else if (temp_rhs && re->ts.type == BT_CLASS)
8933 se.expr = gfc_class_vptr_get (rse->expr);
8934 if (UNLIMITED_POLY (re))
8935 from_len = gfc_class_len_get (rse->expr);
8937 else if (re->expr_type != EXPR_NULL)
8938 /* Only when rhs is non-NULL use its declared type for vptr
8940 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8942 /* When the rhs is NULL use the vtab of lhs' declared type. */
8943 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8948 gfc_init_se (&se, NULL);
8949 se.want_pointer = 1;
8950 gfc_conv_expr (&se, vptr_expr);
8951 gfc_free_expr (vptr_expr);
8952 gfc_add_block_to_block (block, &se.pre);
8953 gcc_assert (se.post.head == NULL_TREE);
8955 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8958 if (to_len != NULL_TREE)
8960 /* The _len component needs to be set. Figure how to get the
8961 value of the right-hand side. */
8962 if (from_len == NULL_TREE)
8964 if (rse->string_length != NULL_TREE)
8965 from_len = rse->string_length;
8966 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8968 gfc_init_se (&se, NULL);
8969 gfc_conv_expr (&se, re->ts.u.cl->length);
8970 gfc_add_block_to_block (block, &se.pre);
8971 gcc_assert (se.post.head == NULL_TREE);
8972 from_len = gfc_evaluate_now (se.expr, block);
8975 from_len = build_zero_cst (gfc_charlen_type_node);
8977 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8982 /* Return the _len trees only, when requested. */
8986 *from_lenp = from_len;
8991 /* Assign tokens for pointer components. */
8994 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8997 symbol_attribute lhs_attr, rhs_attr;
8998 tree tmp, lhs_tok, rhs_tok;
8999 /* Flag to indicated component refs on the rhs. */
9002 lhs_attr = gfc_caf_attr (expr1);
9003 if (expr2->expr_type != EXPR_NULL)
9005 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
9006 if (lhs_attr.codimension && rhs_attr.codimension)
9008 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
9009 lhs_tok = build_fold_indirect_ref (lhs_tok);
9012 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
9016 caf_decl = gfc_get_tree_for_caf_expr (expr2);
9017 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
9020 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
9022 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
9023 gfc_prepend_expr_to_block (&lse->post, tmp);
9026 else if (lhs_attr.codimension)
9028 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
9029 lhs_tok = build_fold_indirect_ref (lhs_tok);
9030 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
9031 lhs_tok, null_pointer_node);
9032 gfc_prepend_expr_to_block (&lse->post, tmp);
9037 /* Do everything that is needed for a CLASS function expr2. */
9040 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
9041 gfc_expr *expr1, gfc_expr *expr2)
9043 tree expr1_vptr = NULL_TREE;
9046 gfc_conv_function_expr (rse, expr2);
9047 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
9049 if (expr1->ts.type != BT_CLASS)
9050 rse->expr = gfc_class_data_get (rse->expr);
9053 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
9056 gfc_add_block_to_block (block, &rse->pre);
9057 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
9058 gfc_add_modify (&lse->pre, tmp, rse->expr);
9060 gfc_add_modify (&lse->pre, expr1_vptr,
9061 fold_convert (TREE_TYPE (expr1_vptr),
9062 gfc_class_vptr_get (tmp)));
9063 rse->expr = gfc_class_data_get (tmp);
9071 gfc_trans_pointer_assign (gfc_code * code)
9073 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
9077 /* Generate code for a pointer assignment. */
9080 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
9087 tree expr1_vptr = NULL_TREE;
9088 bool scalar, non_proc_ptr_assign;
9091 gfc_start_block (&block);
9093 gfc_init_se (&lse, NULL);
9095 /* Usually testing whether this is not a proc pointer assignment. */
9096 non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
9097 && expr2->expr_type == EXPR_VARIABLE
9098 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
9100 /* Check whether the expression is a scalar or not; we cannot use
9101 expr1->rank as it can be nonzero for proc pointers. */
9102 ss = gfc_walk_expr (expr1);
9103 scalar = ss == gfc_ss_terminator;
9105 gfc_free_ss_chain (ss);
9107 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
9108 && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
9110 gfc_add_data_component (expr2);
9111 /* The following is required as gfc_add_data_component doesn't
9112 update ts.type if there is a tailing REF_ARRAY. */
9113 expr2->ts.type = BT_DERIVED;
9118 /* Scalar pointers. */
9119 lse.want_pointer = 1;
9120 gfc_conv_expr (&lse, expr1);
9121 gfc_init_se (&rse, NULL);
9122 rse.want_pointer = 1;
9123 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9124 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
9126 gfc_conv_expr (&rse, expr2);
9128 if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
9130 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
9132 lse.expr = gfc_class_data_get (lse.expr);
9135 if (expr1->symtree->n.sym->attr.proc_pointer
9136 && expr1->symtree->n.sym->attr.dummy)
9137 lse.expr = build_fold_indirect_ref_loc (input_location,
9140 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
9141 && expr2->symtree->n.sym->attr.dummy)
9142 rse.expr = build_fold_indirect_ref_loc (input_location,
9145 gfc_add_block_to_block (&block, &lse.pre);
9146 gfc_add_block_to_block (&block, &rse.pre);
9148 /* Check character lengths if character expression. The test is only
9149 really added if -fbounds-check is enabled. Exclude deferred
9150 character length lefthand sides. */
9151 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
9152 && !expr1->ts.deferred
9153 && !expr1->symtree->n.sym->attr.proc_pointer
9154 && !gfc_is_proc_ptr_comp (expr1))
9156 gcc_assert (expr2->ts.type == BT_CHARACTER);
9157 gcc_assert (lse.string_length && rse.string_length);
9158 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9159 lse.string_length, rse.string_length,
9163 /* The assignment to an deferred character length sets the string
9164 length to that of the rhs. */
9165 if (expr1->ts.deferred)
9167 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
9168 gfc_add_modify (&block, lse.string_length,
9169 fold_convert (TREE_TYPE (lse.string_length),
9170 rse.string_length));
9171 else if (lse.string_length != NULL)
9172 gfc_add_modify (&block, lse.string_length,
9173 build_zero_cst (TREE_TYPE (lse.string_length)));
9176 gfc_add_modify (&block, lse.expr,
9177 fold_convert (TREE_TYPE (lse.expr), rse.expr));
9179 /* Also set the tokens for pointer components in derived typed
9181 if (flag_coarray == GFC_FCOARRAY_LIB)
9182 trans_caf_token_assign (&lse, &rse, expr1, expr2);
9184 gfc_add_block_to_block (&block, &rse.post);
9185 gfc_add_block_to_block (&block, &lse.post);
9192 tree strlen_rhs = NULL_TREE;
9194 /* Array pointer. Find the last reference on the LHS and if it is an
9195 array section ref, we're dealing with bounds remapping. In this case,
9196 set it to AR_FULL so that gfc_conv_expr_descriptor does
9197 not see it and process the bounds remapping afterwards explicitly. */
9198 for (remap = expr1->ref; remap; remap = remap->next)
9199 if (!remap->next && remap->type == REF_ARRAY
9200 && remap->u.ar.type == AR_SECTION)
9202 rank_remap = (remap && remap->u.ar.end[0]);
9204 gfc_init_se (&lse, NULL);
9206 lse.descriptor_only = 1;
9207 gfc_conv_expr_descriptor (&lse, expr1);
9208 strlen_lhs = lse.string_length;
9211 if (expr2->expr_type == EXPR_NULL)
9213 /* Just set the data pointer to null. */
9214 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
9216 else if (rank_remap)
9218 /* If we are rank-remapping, just get the RHS's descriptor and
9219 process this later on. */
9220 gfc_init_se (&rse, NULL);
9221 rse.direct_byref = 1;
9222 rse.byref_noassign = 1;
9224 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9225 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
9227 else if (expr2->expr_type == EXPR_FUNCTION)
9229 tree bound[GFC_MAX_DIMENSIONS];
9232 for (i = 0; i < expr2->rank; i++)
9233 bound[i] = NULL_TREE;
9234 tmp = gfc_typenode_for_spec (&expr2->ts);
9235 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
9237 GFC_ARRAY_POINTER_CONT, false);
9238 tmp = gfc_create_var (tmp, "ptrtemp");
9239 rse.descriptor_only = 0;
9241 rse.direct_byref = 1;
9242 gfc_conv_expr_descriptor (&rse, expr2);
9243 strlen_rhs = rse.string_length;
9248 gfc_conv_expr_descriptor (&rse, expr2);
9249 strlen_rhs = rse.string_length;
9250 if (expr1->ts.type == BT_CLASS)
9251 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9256 else if (expr2->expr_type == EXPR_VARIABLE)
9258 /* Assign directly to the LHS's descriptor. */
9259 lse.descriptor_only = 0;
9260 lse.direct_byref = 1;
9261 gfc_conv_expr_descriptor (&lse, expr2);
9262 strlen_rhs = lse.string_length;
9264 if (expr1->ts.type == BT_CLASS)
9266 rse.expr = NULL_TREE;
9267 rse.string_length = NULL_TREE;
9268 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
9274 /* If the target is not a whole array, use the target array
9275 reference for remap. */
9276 for (remap = expr2->ref; remap; remap = remap->next)
9277 if (remap->type == REF_ARRAY
9278 && remap->u.ar.type == AR_FULL
9283 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9285 gfc_init_se (&rse, NULL);
9286 rse.want_pointer = 1;
9287 gfc_conv_function_expr (&rse, expr2);
9288 if (expr1->ts.type != BT_CLASS)
9290 rse.expr = gfc_class_data_get (rse.expr);
9291 gfc_add_modify (&lse.pre, desc, rse.expr);
9292 /* Set the lhs span. */
9293 tmp = TREE_TYPE (rse.expr);
9294 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9295 tmp = fold_convert (gfc_array_index_type, tmp);
9296 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
9300 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9303 gfc_add_block_to_block (&block, &rse.pre);
9304 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
9305 gfc_add_modify (&lse.pre, tmp, rse.expr);
9307 gfc_add_modify (&lse.pre, expr1_vptr,
9308 fold_convert (TREE_TYPE (expr1_vptr),
9309 gfc_class_vptr_get (tmp)));
9310 rse.expr = gfc_class_data_get (tmp);
9311 gfc_add_modify (&lse.pre, desc, rse.expr);
9316 /* Assign to a temporary descriptor and then copy that
9317 temporary to the pointer. */
9318 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
9319 lse.descriptor_only = 0;
9321 lse.direct_byref = 1;
9322 gfc_conv_expr_descriptor (&lse, expr2);
9323 strlen_rhs = lse.string_length;
9324 gfc_add_modify (&lse.pre, desc, tmp);
9327 gfc_add_block_to_block (&block, &lse.pre);
9329 gfc_add_block_to_block (&block, &rse.pre);
9331 /* If we do bounds remapping, update LHS descriptor accordingly. */
9335 gcc_assert (remap->u.ar.dimen == expr1->rank);
9339 /* Do rank remapping. We already have the RHS's descriptor
9340 converted in rse and now have to build the correct LHS
9341 descriptor for it. */
9343 tree dtype, data, span;
9345 tree lbound, ubound;
9348 dtype = gfc_conv_descriptor_dtype (desc);
9349 tmp = gfc_get_dtype (TREE_TYPE (desc));
9350 gfc_add_modify (&block, dtype, tmp);
9352 /* Copy data pointer. */
9353 data = gfc_conv_descriptor_data_get (rse.expr);
9354 gfc_conv_descriptor_data_set (&block, desc, data);
9356 /* Copy the span. */
9357 if (TREE_CODE (rse.expr) == VAR_DECL
9358 && GFC_DECL_PTR_ARRAY_P (rse.expr))
9359 span = gfc_conv_descriptor_span_get (rse.expr);
9362 tmp = TREE_TYPE (rse.expr);
9363 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9364 span = fold_convert (gfc_array_index_type, tmp);
9366 gfc_conv_descriptor_span_set (&block, desc, span);
9368 /* Copy offset but adjust it such that it would correspond
9369 to a lbound of zero. */
9370 offs = gfc_conv_descriptor_offset_get (rse.expr);
9371 for (dim = 0; dim < expr2->rank; ++dim)
9373 stride = gfc_conv_descriptor_stride_get (rse.expr,
9375 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
9377 tmp = fold_build2_loc (input_location, MULT_EXPR,
9378 gfc_array_index_type, stride, lbound);
9379 offs = fold_build2_loc (input_location, PLUS_EXPR,
9380 gfc_array_index_type, offs, tmp);
9382 gfc_conv_descriptor_offset_set (&block, desc, offs);
9384 /* Set the bounds as declared for the LHS and calculate strides as
9385 well as another offset update accordingly. */
9386 stride = gfc_conv_descriptor_stride_get (rse.expr,
9388 for (dim = 0; dim < expr1->rank; ++dim)
9393 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
9395 /* Convert declared bounds. */
9396 gfc_init_se (&lower_se, NULL);
9397 gfc_init_se (&upper_se, NULL);
9398 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
9399 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
9401 gfc_add_block_to_block (&block, &lower_se.pre);
9402 gfc_add_block_to_block (&block, &upper_se.pre);
9404 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
9405 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
9407 lbound = gfc_evaluate_now (lbound, &block);
9408 ubound = gfc_evaluate_now (ubound, &block);
9410 gfc_add_block_to_block (&block, &lower_se.post);
9411 gfc_add_block_to_block (&block, &upper_se.post);
9413 /* Set bounds in descriptor. */
9414 gfc_conv_descriptor_lbound_set (&block, desc,
9415 gfc_rank_cst[dim], lbound);
9416 gfc_conv_descriptor_ubound_set (&block, desc,
9417 gfc_rank_cst[dim], ubound);
9420 stride = gfc_evaluate_now (stride, &block);
9421 gfc_conv_descriptor_stride_set (&block, desc,
9422 gfc_rank_cst[dim], stride);
9424 /* Update offset. */
9425 offs = gfc_conv_descriptor_offset_get (desc);
9426 tmp = fold_build2_loc (input_location, MULT_EXPR,
9427 gfc_array_index_type, lbound, stride);
9428 offs = fold_build2_loc (input_location, MINUS_EXPR,
9429 gfc_array_index_type, offs, tmp);
9430 offs = gfc_evaluate_now (offs, &block);
9431 gfc_conv_descriptor_offset_set (&block, desc, offs);
9433 /* Update stride. */
9434 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
9435 stride = fold_build2_loc (input_location, MULT_EXPR,
9436 gfc_array_index_type, stride, tmp);
9441 /* Bounds remapping. Just shift the lower bounds. */
9443 gcc_assert (expr1->rank == expr2->rank);
9445 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
9449 gcc_assert (!remap->u.ar.end[dim]);
9450 gfc_init_se (&lbound_se, NULL);
9451 if (remap->u.ar.start[dim])
9453 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
9454 gfc_add_block_to_block (&block, &lbound_se.pre);
9457 /* This remap arises from a target that is not a whole
9458 array. The start expressions will be NULL but we need
9459 the lbounds to be one. */
9460 lbound_se.expr = gfc_index_one_node;
9461 gfc_conv_shift_descriptor_lbound (&block, desc,
9462 dim, lbound_se.expr);
9463 gfc_add_block_to_block (&block, &lbound_se.post);
9468 /* If rank remapping was done, check with -fcheck=bounds that
9469 the target is at least as large as the pointer. */
9470 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
9476 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
9477 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
9479 lsize = gfc_evaluate_now (lsize, &block);
9480 rsize = gfc_evaluate_now (rsize, &block);
9481 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
9484 msg = _("Target of rank remapping is too small (%ld < %ld)");
9485 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
9489 if (expr1->ts.type == BT_CHARACTER
9490 && expr1->symtree->n.sym->ts.deferred
9491 && expr1->symtree->n.sym->ts.u.cl->backend_decl
9492 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
9494 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
9495 if (expr2->expr_type != EXPR_NULL)
9496 gfc_add_modify (&block, tmp,
9497 fold_convert (TREE_TYPE (tmp), strlen_rhs));
9499 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
9502 /* Check string lengths if applicable. The check is only really added
9503 to the output code if -fbounds-check is enabled. */
9504 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
9506 gcc_assert (expr2->ts.type == BT_CHARACTER);
9507 gcc_assert (strlen_lhs && strlen_rhs);
9508 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9509 strlen_lhs, strlen_rhs, &block);
9512 gfc_add_block_to_block (&block, &lse.post);
9514 gfc_add_block_to_block (&block, &rse.post);
9517 return gfc_finish_block (&block);
9521 /* Makes sure se is suitable for passing as a function string parameter. */
9522 /* TODO: Need to check all callers of this function. It may be abused. */
9525 gfc_conv_string_parameter (gfc_se * se)
9529 if (TREE_CODE (se->expr) == STRING_CST)
9531 type = TREE_TYPE (TREE_TYPE (se->expr));
9532 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9536 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
9537 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
9538 && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
9540 if (TREE_CODE (se->expr) != INDIRECT_REF)
9542 type = TREE_TYPE (se->expr);
9543 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9547 type = gfc_get_character_type_len (gfc_default_character_kind,
9549 type = build_pointer_type (type);
9550 se->expr = gfc_build_addr_expr (type, se->expr);
9554 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
9558 /* Generate code for assignment of scalar variables. Includes character
9559 strings and derived types with allocatable components.
9560 If you know that the LHS has no allocations, set dealloc to false.
9562 DEEP_COPY has no effect if the typespec TS is not a derived type with
9563 allocatable components. Otherwise, if it is set, an explicit copy of each
9564 allocatable component is made. This is necessary as a simple copy of the
9565 whole object would copy array descriptors as is, so that the lhs's
9566 allocatable components would point to the rhs's after the assignment.
9567 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9568 necessary if the rhs is a non-pointer function, as the allocatable components
9569 are not accessible by other means than the function's result after the
9570 function has returned. It is even more subtle when temporaries are involved,
9571 as the two following examples show:
9572 1. When we evaluate an array constructor, a temporary is created. Thus
9573 there is theoretically no alias possible. However, no deep copy is
9574 made for this temporary, so that if the constructor is made of one or
9575 more variable with allocatable components, those components still point
9576 to the variable's: DEEP_COPY should be set for the assignment from the
9577 temporary to the lhs in that case.
9578 2. When assigning a scalar to an array, we evaluate the scalar value out
9579 of the loop, store it into a temporary variable, and assign from that.
9580 In that case, deep copying when assigning to the temporary would be a
9581 waste of resources; however deep copies should happen when assigning from
9582 the temporary to each array element: again DEEP_COPY should be set for
9583 the assignment from the temporary to the lhs. */
9586 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9587 bool deep_copy, bool dealloc, bool in_coarray)
9593 gfc_init_block (&block);
9595 if (ts.type == BT_CHARACTER)
9600 if (lse->string_length != NULL_TREE)
9602 gfc_conv_string_parameter (lse);
9603 gfc_add_block_to_block (&block, &lse->pre);
9604 llen = lse->string_length;
9607 if (rse->string_length != NULL_TREE)
9609 gfc_conv_string_parameter (rse);
9610 gfc_add_block_to_block (&block, &rse->pre);
9611 rlen = rse->string_length;
9614 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9615 rse->expr, ts.kind);
9617 else if (gfc_bt_struct (ts.type)
9618 && (ts.u.derived->attr.alloc_comp
9619 || (deep_copy && ts.u.derived->attr.pdt_type)))
9621 tree tmp_var = NULL_TREE;
9624 /* Are the rhs and the lhs the same? */
9627 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9628 gfc_build_addr_expr (NULL_TREE, lse->expr),
9629 gfc_build_addr_expr (NULL_TREE, rse->expr));
9630 cond = gfc_evaluate_now (cond, &lse->pre);
9633 /* Deallocate the lhs allocated components as long as it is not
9634 the same as the rhs. This must be done following the assignment
9635 to prevent deallocating data that could be used in the rhs
9639 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9640 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9642 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9644 gfc_add_expr_to_block (&lse->post, tmp);
9647 gfc_add_block_to_block (&block, &rse->pre);
9648 gfc_add_block_to_block (&block, &lse->pre);
9650 gfc_add_modify (&block, lse->expr,
9651 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9653 /* Restore pointer address of coarray components. */
9654 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9656 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9657 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9659 gfc_add_expr_to_block (&block, tmp);
9662 /* Do a deep copy if the rhs is a variable, if it is not the
9666 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9667 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9668 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9670 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9672 gfc_add_expr_to_block (&block, tmp);
9675 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9677 gfc_add_block_to_block (&block, &lse->pre);
9678 gfc_add_block_to_block (&block, &rse->pre);
9679 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9680 TREE_TYPE (lse->expr), rse->expr);
9681 gfc_add_modify (&block, lse->expr, tmp);
9685 gfc_add_block_to_block (&block, &lse->pre);
9686 gfc_add_block_to_block (&block, &rse->pre);
9688 gfc_add_modify (&block, lse->expr,
9689 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9692 gfc_add_block_to_block (&block, &lse->post);
9693 gfc_add_block_to_block (&block, &rse->post);
9695 return gfc_finish_block (&block);
9699 /* There are quite a lot of restrictions on the optimisation in using an
9700 array function assign without a temporary. */
9703 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9706 bool seen_array_ref;
9708 gfc_symbol *sym = expr1->symtree->n.sym;
9710 /* Play it safe with class functions assigned to a derived type. */
9711 if (gfc_is_class_array_function (expr2)
9712 && expr1->ts.type == BT_DERIVED)
9715 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9716 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9719 /* Elemental functions are scalarized so that they don't need a
9720 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9721 they would need special treatment in gfc_trans_arrayfunc_assign. */
9722 if (expr2->value.function.esym != NULL
9723 && expr2->value.function.esym->attr.elemental)
9726 /* Need a temporary if rhs is not FULL or a contiguous section. */
9727 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9730 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9731 if (gfc_ref_needs_temporary_p (expr1->ref))
9734 /* Functions returning pointers or allocatables need temporaries. */
9735 c = expr2->value.function.esym
9736 ? (expr2->value.function.esym->attr.pointer
9737 || expr2->value.function.esym->attr.allocatable)
9738 : (expr2->symtree->n.sym->attr.pointer
9739 || expr2->symtree->n.sym->attr.allocatable);
9743 /* Character array functions need temporaries unless the
9744 character lengths are the same. */
9745 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9747 if (expr1->ts.u.cl->length == NULL
9748 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9751 if (expr2->ts.u.cl->length == NULL
9752 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9755 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9756 expr2->ts.u.cl->length->value.integer) != 0)
9760 /* Check that no LHS component references appear during an array
9761 reference. This is needed because we do not have the means to
9762 span any arbitrary stride with an array descriptor. This check
9763 is not needed for the rhs because the function result has to be
9765 seen_array_ref = false;
9766 for (ref = expr1->ref; ref; ref = ref->next)
9768 if (ref->type == REF_ARRAY)
9769 seen_array_ref= true;
9770 else if (ref->type == REF_COMPONENT && seen_array_ref)
9774 /* Check for a dependency. */
9775 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9776 expr2->value.function.esym,
9777 expr2->value.function.actual,
9781 /* If we have reached here with an intrinsic function, we do not
9782 need a temporary except in the particular case that reallocation
9783 on assignment is active and the lhs is allocatable and a target. */
9784 if (expr2->value.function.isym)
9785 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9787 /* If the LHS is a dummy, we need a temporary if it is not
9789 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9792 /* If the lhs has been host_associated, is in common, a pointer or is
9793 a target and the function is not using a RESULT variable, aliasing
9794 can occur and a temporary is needed. */
9795 if ((sym->attr.host_assoc
9796 || sym->attr.in_common
9797 || sym->attr.pointer
9798 || sym->attr.cray_pointee
9799 || sym->attr.target)
9800 && expr2->symtree != NULL
9801 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9804 /* A PURE function can unconditionally be called without a temporary. */
9805 if (expr2->value.function.esym != NULL
9806 && expr2->value.function.esym->attr.pure)
9809 /* Implicit_pure functions are those which could legally be declared
9811 if (expr2->value.function.esym != NULL
9812 && expr2->value.function.esym->attr.implicit_pure)
9815 if (!sym->attr.use_assoc
9816 && !sym->attr.in_common
9817 && !sym->attr.pointer
9818 && !sym->attr.target
9819 && !sym->attr.cray_pointee
9820 && expr2->value.function.esym)
9822 /* A temporary is not needed if the function is not contained and
9823 the variable is local or host associated and not a pointer or
9825 if (!expr2->value.function.esym->attr.contained)
9828 /* A temporary is not needed if the lhs has never been host
9829 associated and the procedure is contained. */
9830 else if (!sym->attr.host_assoc)
9833 /* A temporary is not needed if the variable is local and not
9834 a pointer, a target or a result. */
9836 && expr2->value.function.esym->ns == sym->ns->parent)
9840 /* Default to temporary use. */
9845 /* Provide the loop info so that the lhs descriptor can be built for
9846 reallocatable assignments from extrinsic function calls. */
9849 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9852 /* Signal that the function call should not be made by
9853 gfc_conv_loop_setup. */
9854 se->ss->is_alloc_lhs = 1;
9855 gfc_init_loopinfo (loop);
9856 gfc_add_ss_to_loop (loop, *ss);
9857 gfc_add_ss_to_loop (loop, se->ss);
9858 gfc_conv_ss_startstride (loop);
9859 gfc_conv_loop_setup (loop, where);
9860 gfc_copy_loopinfo_to_se (se, loop);
9861 gfc_add_block_to_block (&se->pre, &loop->pre);
9862 gfc_add_block_to_block (&se->pre, &loop->post);
9863 se->ss->is_alloc_lhs = 0;
9867 /* For assignment to a reallocatable lhs from intrinsic functions,
9868 replace the se.expr (ie. the result) with a temporary descriptor.
9869 Null the data field so that the library allocates space for the
9870 result. Free the data of the original descriptor after the function,
9871 in case it appears in an argument expression and transfer the
9872 result to the original descriptor. */
9875 fcncall_realloc_result (gfc_se *se, int rank)
9884 /* Use the allocation done by the library. Substitute the lhs
9885 descriptor with a copy, whose data field is nulled.*/
9886 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9887 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9888 desc = build_fold_indirect_ref_loc (input_location, desc);
9890 /* Unallocated, the descriptor does not have a dtype. */
9891 tmp = gfc_conv_descriptor_dtype (desc);
9892 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9894 res_desc = gfc_evaluate_now (desc, &se->pre);
9895 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9896 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9898 /* Free the lhs after the function call and copy the result data to
9899 the lhs descriptor. */
9900 tmp = gfc_conv_descriptor_data_get (desc);
9901 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9902 logical_type_node, tmp,
9903 build_int_cst (TREE_TYPE (tmp), 0));
9904 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9905 tmp = gfc_call_free (tmp);
9906 gfc_add_expr_to_block (&se->post, tmp);
9908 tmp = gfc_conv_descriptor_data_get (res_desc);
9909 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9911 /* Check that the shapes are the same between lhs and expression. */
9912 for (n = 0 ; n < rank; n++)
9915 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9916 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9917 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9918 gfc_array_index_type, tmp, tmp1);
9919 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9920 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9921 gfc_array_index_type, tmp, tmp1);
9922 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9923 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9924 gfc_array_index_type, tmp, tmp1);
9925 tmp = fold_build2_loc (input_location, NE_EXPR,
9926 logical_type_node, tmp,
9927 gfc_index_zero_node);
9928 tmp = gfc_evaluate_now (tmp, &se->post);
9929 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9930 logical_type_node, tmp,
9934 /* 'zero_cond' being true is equal to lhs not being allocated or the
9935 shapes being different. */
9936 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9938 /* Now reset the bounds returned from the function call to bounds based
9939 on the lhs lbounds, except where the lhs is not allocated or the shapes
9940 of 'variable and 'expr' are different. Set the offset accordingly. */
9941 offset = gfc_index_zero_node;
9942 for (n = 0 ; n < rank; n++)
9946 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9947 lbound = fold_build3_loc (input_location, COND_EXPR,
9948 gfc_array_index_type, zero_cond,
9949 gfc_index_one_node, lbound);
9950 lbound = gfc_evaluate_now (lbound, &se->post);
9952 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9953 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9954 gfc_array_index_type, tmp, lbound);
9955 gfc_conv_descriptor_lbound_set (&se->post, desc,
9956 gfc_rank_cst[n], lbound);
9957 gfc_conv_descriptor_ubound_set (&se->post, desc,
9958 gfc_rank_cst[n], tmp);
9960 /* Set stride and accumulate the offset. */
9961 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9962 gfc_conv_descriptor_stride_set (&se->post, desc,
9963 gfc_rank_cst[n], tmp);
9964 tmp = fold_build2_loc (input_location, MULT_EXPR,
9965 gfc_array_index_type, lbound, tmp);
9966 offset = fold_build2_loc (input_location, MINUS_EXPR,
9967 gfc_array_index_type, offset, tmp);
9968 offset = gfc_evaluate_now (offset, &se->post);
9971 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9976 /* Try to translate array(:) = func (...), where func is a transformational
9977 array function, without using a temporary. Returns NULL if this isn't the
9981 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9985 gfc_component *comp = NULL;
9988 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9991 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9993 comp = gfc_get_proc_ptr_comp (expr2);
9995 if (!(expr2->value.function.isym
9996 || (comp && comp->attr.dimension)
9997 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9998 && expr2->value.function.esym->result->attr.dimension)))
10001 gfc_init_se (&se, NULL);
10002 gfc_start_block (&se.pre);
10003 se.want_pointer = 1;
10005 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
10007 if (expr1->ts.type == BT_DERIVED
10008 && expr1->ts.u.derived->attr.alloc_comp)
10011 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
10013 gfc_add_expr_to_block (&se.pre, tmp);
10016 se.direct_byref = 1;
10017 se.ss = gfc_walk_expr (expr2);
10018 gcc_assert (se.ss != gfc_ss_terminator);
10020 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
10021 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
10022 Clearly, this cannot be done for an allocatable function result, since
10023 the shape of the result is unknown and, in any case, the function must
10024 correctly take care of the reallocation internally. For intrinsic
10025 calls, the array data is freed and the library takes care of allocation.
10026 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
10028 if (flag_realloc_lhs
10029 && gfc_is_reallocatable_lhs (expr1)
10030 && !gfc_expr_attr (expr1).codimension
10031 && !gfc_is_coindexed (expr1)
10032 && !(expr2->value.function.esym
10033 && expr2->value.function.esym->result->attr.allocatable))
10035 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10037 if (!expr2->value.function.isym)
10039 ss = gfc_walk_expr (expr1);
10040 gcc_assert (ss != gfc_ss_terminator);
10042 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
10043 ss->is_alloc_lhs = 1;
10046 fcncall_realloc_result (&se, expr1->rank);
10049 gfc_conv_function_expr (&se, expr2);
10050 gfc_add_block_to_block (&se.pre, &se.post);
10053 gfc_cleanup_loop (&loop);
10055 gfc_free_ss_chain (se.ss);
10057 return gfc_finish_block (&se.pre);
10061 /* Try to efficiently translate array(:) = 0. Return NULL if this
10065 gfc_trans_zero_assign (gfc_expr * expr)
10067 tree dest, len, type;
10071 sym = expr->symtree->n.sym;
10072 dest = gfc_get_symbol_decl (sym);
10074 type = TREE_TYPE (dest);
10075 if (POINTER_TYPE_P (type))
10076 type = TREE_TYPE (type);
10077 if (!GFC_ARRAY_TYPE_P (type))
10080 /* Determine the length of the array. */
10081 len = GFC_TYPE_ARRAY_SIZE (type);
10082 if (!len || TREE_CODE (len) != INTEGER_CST)
10085 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
10086 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10087 fold_convert (gfc_array_index_type, tmp));
10089 /* If we are zeroing a local array avoid taking its address by emitting
10091 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
10092 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
10093 dest, build_constructor (TREE_TYPE (dest),
10096 /* Convert arguments to the correct types. */
10097 dest = fold_convert (pvoid_type_node, dest);
10098 len = fold_convert (size_type_node, len);
10100 /* Construct call to __builtin_memset. */
10101 tmp = build_call_expr_loc (input_location,
10102 builtin_decl_explicit (BUILT_IN_MEMSET),
10103 3, dest, integer_zero_node, len);
10104 return fold_convert (void_type_node, tmp);
10108 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10109 that constructs the call to __builtin_memcpy. */
10112 gfc_build_memcpy_call (tree dst, tree src, tree len)
10116 /* Convert arguments to the correct types. */
10117 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
10118 dst = gfc_build_addr_expr (pvoid_type_node, dst);
10120 dst = fold_convert (pvoid_type_node, dst);
10122 if (!POINTER_TYPE_P (TREE_TYPE (src)))
10123 src = gfc_build_addr_expr (pvoid_type_node, src);
10125 src = fold_convert (pvoid_type_node, src);
10127 len = fold_convert (size_type_node, len);
10129 /* Construct call to __builtin_memcpy. */
10130 tmp = build_call_expr_loc (input_location,
10131 builtin_decl_explicit (BUILT_IN_MEMCPY),
10133 return fold_convert (void_type_node, tmp);
10137 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10138 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10139 source/rhs, both are gfc_full_array_ref_p which have been checked for
10143 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
10145 tree dst, dlen, dtype;
10146 tree src, slen, stype;
10149 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10150 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
10152 dtype = TREE_TYPE (dst);
10153 if (POINTER_TYPE_P (dtype))
10154 dtype = TREE_TYPE (dtype);
10155 stype = TREE_TYPE (src);
10156 if (POINTER_TYPE_P (stype))
10157 stype = TREE_TYPE (stype);
10159 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
10162 /* Determine the lengths of the arrays. */
10163 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
10164 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
10166 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10167 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10168 dlen, fold_convert (gfc_array_index_type, tmp));
10170 slen = GFC_TYPE_ARRAY_SIZE (stype);
10171 if (!slen || TREE_CODE (slen) != INTEGER_CST)
10173 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
10174 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10175 slen, fold_convert (gfc_array_index_type, tmp));
10177 /* Sanity check that they are the same. This should always be
10178 the case, as we should already have checked for conformance. */
10179 if (!tree_int_cst_equal (slen, dlen))
10182 return gfc_build_memcpy_call (dst, src, dlen);
10186 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10187 this can't be done. EXPR1 is the destination/lhs for which
10188 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10191 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
10193 unsigned HOST_WIDE_INT nelem;
10199 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
10203 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10204 dtype = TREE_TYPE (dst);
10205 if (POINTER_TYPE_P (dtype))
10206 dtype = TREE_TYPE (dtype);
10207 if (!GFC_ARRAY_TYPE_P (dtype))
10210 /* Determine the lengths of the array. */
10211 len = GFC_TYPE_ARRAY_SIZE (dtype);
10212 if (!len || TREE_CODE (len) != INTEGER_CST)
10215 /* Confirm that the constructor is the same size. */
10216 if (compare_tree_int (len, nelem) != 0)
10219 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10220 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10221 fold_convert (gfc_array_index_type, tmp));
10223 stype = gfc_typenode_for_spec (&expr2->ts);
10224 src = gfc_build_constant_array_constructor (expr2, stype);
10226 return gfc_build_memcpy_call (dst, src, len);
10230 /* Tells whether the expression is to be treated as a variable reference. */
10233 gfc_expr_is_variable (gfc_expr *expr)
10236 gfc_component *comp;
10237 gfc_symbol *func_ifc;
10239 if (expr->expr_type == EXPR_VARIABLE)
10242 arg = gfc_get_noncopying_intrinsic_argument (expr);
10245 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
10246 return gfc_expr_is_variable (arg);
10249 /* A data-pointer-returning function should be considered as a variable
10251 if (expr->expr_type == EXPR_FUNCTION
10252 && expr->ref == NULL)
10254 if (expr->value.function.isym != NULL)
10257 if (expr->value.function.esym != NULL)
10259 func_ifc = expr->value.function.esym;
10264 gcc_assert (expr->symtree);
10265 func_ifc = expr->symtree->n.sym;
10269 gcc_unreachable ();
10272 comp = gfc_get_proc_ptr_comp (expr);
10273 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
10276 func_ifc = comp->ts.interface;
10280 if (expr->expr_type == EXPR_COMPCALL)
10282 gcc_assert (!expr->value.compcall.tbp->is_generic);
10283 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
10290 gcc_assert (func_ifc->attr.function
10291 && func_ifc->result != NULL);
10292 return func_ifc->result->attr.pointer;
10296 /* Is the lhs OK for automatic reallocation? */
10299 is_scalar_reallocatable_lhs (gfc_expr *expr)
10303 /* An allocatable variable with no reference. */
10304 if (expr->symtree->n.sym->attr.allocatable
10308 /* All that can be left are allocatable components. However, we do
10309 not check for allocatable components here because the expression
10310 could be an allocatable component of a pointer component. */
10311 if (expr->symtree->n.sym->ts.type != BT_DERIVED
10312 && expr->symtree->n.sym->ts.type != BT_CLASS)
10315 /* Find an allocatable component ref last. */
10316 for (ref = expr->ref; ref; ref = ref->next)
10317 if (ref->type == REF_COMPONENT
10319 && ref->u.c.component->attr.allocatable)
10326 /* Allocate or reallocate scalar lhs, as necessary. */
10329 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
10330 tree string_length,
10338 tree size_in_bytes;
10344 if (!expr1 || expr1->rank)
10347 if (!expr2 || expr2->rank)
10350 for (ref = expr1->ref; ref; ref = ref->next)
10351 if (ref->type == REF_SUBSTRING)
10354 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10356 /* Since this is a scalar lhs, we can afford to do this. That is,
10357 there is no risk of side effects being repeated. */
10358 gfc_init_se (&lse, NULL);
10359 lse.want_pointer = 1;
10360 gfc_conv_expr (&lse, expr1);
10362 jump_label1 = gfc_build_label_decl (NULL_TREE);
10363 jump_label2 = gfc_build_label_decl (NULL_TREE);
10365 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10366 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
10367 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10369 tmp = build3_v (COND_EXPR, cond,
10370 build1_v (GOTO_EXPR, jump_label1),
10371 build_empty_stmt (input_location));
10372 gfc_add_expr_to_block (block, tmp);
10374 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10376 /* Use the rhs string length and the lhs element size. */
10377 size = string_length;
10378 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
10379 tmp = TYPE_SIZE_UNIT (tmp);
10380 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10381 TREE_TYPE (tmp), tmp,
10382 fold_convert (TREE_TYPE (tmp), size));
10386 /* Otherwise use the length in bytes of the rhs. */
10387 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
10388 size_in_bytes = size;
10391 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10392 size_in_bytes, size_one_node);
10394 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
10396 tree caf_decl, token;
10398 symbol_attribute attr;
10400 gfc_clear_attr (&attr);
10401 gfc_init_se (&caf_se, NULL);
10403 caf_decl = gfc_get_tree_for_caf_expr (expr1);
10404 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
10406 gfc_add_block_to_block (block, &caf_se.pre);
10407 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
10408 gfc_build_addr_expr (NULL_TREE, token),
10409 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
10412 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
10414 tmp = build_call_expr_loc (input_location,
10415 builtin_decl_explicit (BUILT_IN_CALLOC),
10416 2, build_one_cst (size_type_node),
10418 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10419 gfc_add_modify (block, lse.expr, tmp);
10423 tmp = build_call_expr_loc (input_location,
10424 builtin_decl_explicit (BUILT_IN_MALLOC),
10426 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10427 gfc_add_modify (block, lse.expr, tmp);
10430 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10432 /* Deferred characters need checking for lhs and rhs string
10433 length. Other deferred parameter variables will have to
10435 tmp = build1_v (GOTO_EXPR, jump_label2);
10436 gfc_add_expr_to_block (block, tmp);
10438 tmp = build1_v (LABEL_EXPR, jump_label1);
10439 gfc_add_expr_to_block (block, tmp);
10441 /* For a deferred length character, reallocate if lengths of lhs and
10442 rhs are different. */
10443 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10445 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10447 fold_convert (TREE_TYPE (lse.string_length),
10449 /* Jump past the realloc if the lengths are the same. */
10450 tmp = build3_v (COND_EXPR, cond,
10451 build1_v (GOTO_EXPR, jump_label2),
10452 build_empty_stmt (input_location));
10453 gfc_add_expr_to_block (block, tmp);
10454 tmp = build_call_expr_loc (input_location,
10455 builtin_decl_explicit (BUILT_IN_REALLOC),
10456 2, fold_convert (pvoid_type_node, lse.expr),
10458 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10459 gfc_add_modify (block, lse.expr, tmp);
10460 tmp = build1_v (LABEL_EXPR, jump_label2);
10461 gfc_add_expr_to_block (block, tmp);
10463 /* Update the lhs character length. */
10464 size = string_length;
10465 gfc_add_modify (block, lse.string_length,
10466 fold_convert (TREE_TYPE (lse.string_length), size));
10470 /* Check for assignments of the type
10474 to make sure we do not check for reallocation unneccessarily. */
10478 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
10480 gfc_actual_arglist *a;
10483 switch (expr2->expr_type)
10485 case EXPR_VARIABLE:
10486 return gfc_dep_compare_expr (expr1, expr2) == 0;
10488 case EXPR_FUNCTION:
10489 if (expr2->value.function.esym
10490 && expr2->value.function.esym->attr.elemental)
10492 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10495 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10500 else if (expr2->value.function.isym
10501 && expr2->value.function.isym->elemental)
10503 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10506 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10515 switch (expr2->value.op.op)
10517 case INTRINSIC_NOT:
10518 case INTRINSIC_UPLUS:
10519 case INTRINSIC_UMINUS:
10520 case INTRINSIC_PARENTHESES:
10521 return is_runtime_conformable (expr1, expr2->value.op.op1);
10523 case INTRINSIC_PLUS:
10524 case INTRINSIC_MINUS:
10525 case INTRINSIC_TIMES:
10526 case INTRINSIC_DIVIDE:
10527 case INTRINSIC_POWER:
10528 case INTRINSIC_AND:
10530 case INTRINSIC_EQV:
10531 case INTRINSIC_NEQV:
10538 case INTRINSIC_EQ_OS:
10539 case INTRINSIC_NE_OS:
10540 case INTRINSIC_GT_OS:
10541 case INTRINSIC_GE_OS:
10542 case INTRINSIC_LT_OS:
10543 case INTRINSIC_LE_OS:
10545 e1 = expr2->value.op.op1;
10546 e2 = expr2->value.op.op2;
10548 if (e1->rank == 0 && e2->rank > 0)
10549 return is_runtime_conformable (expr1, e2);
10550 else if (e1->rank > 0 && e2->rank == 0)
10551 return is_runtime_conformable (expr1, e1);
10552 else if (e1->rank > 0 && e2->rank > 0)
10553 return is_runtime_conformable (expr1, e1)
10554 && is_runtime_conformable (expr1, e2);
10572 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
10573 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
10574 bool class_realloc)
10576 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
10577 vec<tree, va_gc> *args = NULL;
10579 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
10582 /* Generate allocation of the lhs. */
10588 tmp = gfc_vptr_size_get (vptr);
10589 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10590 ? gfc_class_data_get (lse->expr) : lse->expr;
10591 gfc_init_block (&alloc);
10592 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
10593 tmp = fold_build2_loc (input_location, EQ_EXPR,
10594 logical_type_node, class_han,
10595 build_int_cst (prvoid_type_node, 0));
10596 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10598 PRED_FORTRAN_FAIL_ALLOC),
10599 gfc_finish_block (&alloc),
10600 build_empty_stmt (input_location));
10601 gfc_add_expr_to_block (&lse->pre, tmp);
10604 fcn = gfc_vptr_copy_get (vptr);
10606 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
10607 ? gfc_class_data_get (rse->expr) : rse->expr;
10610 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10611 || INDIRECT_REF_P (tmp)
10612 || (rhs->ts.type == BT_DERIVED
10613 && rhs->ts.u.derived->attr.unlimited_polymorphic
10614 && !rhs->ts.u.derived->attr.pointer
10615 && !rhs->ts.u.derived->attr.allocatable)
10616 || (UNLIMITED_POLY (rhs)
10617 && !CLASS_DATA (rhs)->attr.pointer
10618 && !CLASS_DATA (rhs)->attr.allocatable))
10619 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10621 vec_safe_push (args, tmp);
10622 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10623 ? gfc_class_data_get (lse->expr) : lse->expr;
10624 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10625 || INDIRECT_REF_P (tmp)
10626 || (lhs->ts.type == BT_DERIVED
10627 && lhs->ts.u.derived->attr.unlimited_polymorphic
10628 && !lhs->ts.u.derived->attr.pointer
10629 && !lhs->ts.u.derived->attr.allocatable)
10630 || (UNLIMITED_POLY (lhs)
10631 && !CLASS_DATA (lhs)->attr.pointer
10632 && !CLASS_DATA (lhs)->attr.allocatable))
10633 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10635 vec_safe_push (args, tmp);
10637 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10639 if (to_len != NULL_TREE && !integer_zerop (from_len))
10642 vec_safe_push (args, from_len);
10643 vec_safe_push (args, to_len);
10644 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10646 tmp = fold_build2_loc (input_location, GT_EXPR,
10647 logical_type_node, from_len,
10648 build_zero_cst (TREE_TYPE (from_len)));
10649 return fold_build3_loc (input_location, COND_EXPR,
10650 void_type_node, tmp,
10658 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10659 ? gfc_class_data_get (lse->expr) : lse->expr;
10660 stmtblock_t tblock;
10661 gfc_init_block (&tblock);
10662 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10663 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10664 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10665 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10666 /* When coming from a ptr_copy lhs and rhs are swapped. */
10667 gfc_add_modify_loc (input_location, &tblock, rhst,
10668 fold_convert (TREE_TYPE (rhst), tmp));
10669 return gfc_finish_block (&tblock);
10673 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10674 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10675 init_flag indicates initialization expressions and dealloc that no
10676 deallocate prior assignment is needed (if in doubt, set true).
10677 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10678 routine instead of a pointer assignment. Alias resolution is only done,
10679 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10680 where it is known, that newly allocated memory on the lhs can never be
10681 an alias of the rhs. */
10684 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10685 bool dealloc, bool use_vptr_copy, bool may_alias)
10690 gfc_ss *lss_section;
10697 bool scalar_to_array;
10698 tree string_length;
10700 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10701 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10702 bool is_poly_assign;
10704 /* Assignment of the form lhs = rhs. */
10705 gfc_start_block (&block);
10707 gfc_init_se (&lse, NULL);
10708 gfc_init_se (&rse, NULL);
10710 /* Walk the lhs. */
10711 lss = gfc_walk_expr (expr1);
10712 if (gfc_is_reallocatable_lhs (expr1))
10714 lss->no_bounds_check = 1;
10715 if (!(expr2->expr_type == EXPR_FUNCTION
10716 && expr2->value.function.isym != NULL
10717 && !(expr2->value.function.isym->elemental
10718 || expr2->value.function.isym->conversion)))
10719 lss->is_alloc_lhs = 1;
10722 lss->no_bounds_check = expr1->no_bounds_check;
10726 if ((expr1->ts.type == BT_DERIVED)
10727 && (gfc_is_class_array_function (expr2)
10728 || gfc_is_alloc_class_scalar_function (expr2)))
10729 expr2->must_finalize = 1;
10731 /* Checking whether a class assignment is desired is quite complicated and
10732 needed at two locations, so do it once only before the information is
10734 lhs_attr = gfc_expr_attr (expr1);
10735 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10736 || (lhs_attr.allocatable && !lhs_attr.dimension))
10737 && (expr1->ts.type == BT_CLASS
10738 || gfc_is_class_array_ref (expr1, NULL)
10739 || gfc_is_class_scalar_expr (expr1)
10740 || gfc_is_class_array_ref (expr2, NULL)
10741 || gfc_is_class_scalar_expr (expr2));
10744 /* Only analyze the expressions for coarray properties, when in coarray-lib
10746 if (flag_coarray == GFC_FCOARRAY_LIB)
10748 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10749 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10752 if (lss != gfc_ss_terminator)
10754 /* The assignment needs scalarization. */
10757 /* Find a non-scalar SS from the lhs. */
10758 while (lss_section != gfc_ss_terminator
10759 && lss_section->info->type != GFC_SS_SECTION)
10760 lss_section = lss_section->next;
10762 gcc_assert (lss_section != gfc_ss_terminator);
10764 /* Initialize the scalarizer. */
10765 gfc_init_loopinfo (&loop);
10767 /* Walk the rhs. */
10768 rss = gfc_walk_expr (expr2);
10769 if (rss == gfc_ss_terminator)
10770 /* The rhs is scalar. Add a ss for the expression. */
10771 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10772 /* When doing a class assign, then the handle to the rhs needs to be a
10773 pointer to allow for polymorphism. */
10774 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10775 rss->info->type = GFC_SS_REFERENCE;
10777 rss->no_bounds_check = expr2->no_bounds_check;
10778 /* Associate the SS with the loop. */
10779 gfc_add_ss_to_loop (&loop, lss);
10780 gfc_add_ss_to_loop (&loop, rss);
10782 /* Calculate the bounds of the scalarization. */
10783 gfc_conv_ss_startstride (&loop);
10784 /* Enable loop reversal. */
10785 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10786 loop.reverse[n] = GFC_ENABLE_REVERSE;
10787 /* Resolve any data dependencies in the statement. */
10789 gfc_conv_resolve_dependencies (&loop, lss, rss);
10790 /* Setup the scalarizing loops. */
10791 gfc_conv_loop_setup (&loop, &expr2->where);
10793 /* Setup the gfc_se structures. */
10794 gfc_copy_loopinfo_to_se (&lse, &loop);
10795 gfc_copy_loopinfo_to_se (&rse, &loop);
10798 gfc_mark_ss_chain_used (rss, 1);
10799 if (loop.temp_ss == NULL)
10802 gfc_mark_ss_chain_used (lss, 1);
10806 lse.ss = loop.temp_ss;
10807 gfc_mark_ss_chain_used (lss, 3);
10808 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10811 /* Allow the scalarizer to workshare array assignments. */
10812 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10813 == OMPWS_WORKSHARE_FLAG
10814 && loop.temp_ss == NULL)
10816 maybe_workshare = true;
10817 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10820 /* Start the scalarized loop body. */
10821 gfc_start_scalarized_body (&loop, &body);
10824 gfc_init_block (&body);
10826 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10828 /* Translate the expression. */
10829 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10830 && lhs_caf_attr.codimension;
10831 gfc_conv_expr (&rse, expr2);
10833 /* Deal with the case of a scalar class function assigned to a derived type. */
10834 if (gfc_is_alloc_class_scalar_function (expr2)
10835 && expr1->ts.type == BT_DERIVED)
10837 rse.expr = gfc_class_data_get (rse.expr);
10838 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10841 /* Stabilize a string length for temporaries. */
10842 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10843 && !(VAR_P (rse.string_length)
10844 || TREE_CODE (rse.string_length) == PARM_DECL
10845 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10846 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10847 else if (expr2->ts.type == BT_CHARACTER)
10849 if (expr1->ts.deferred
10850 && gfc_expr_attr (expr1).allocatable
10851 && gfc_check_dependency (expr1, expr2, true))
10852 rse.string_length =
10853 gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
10854 string_length = rse.string_length;
10857 string_length = NULL_TREE;
10861 gfc_conv_tmp_array_ref (&lse);
10862 if (expr2->ts.type == BT_CHARACTER)
10863 lse.string_length = string_length;
10867 gfc_conv_expr (&lse, expr1);
10868 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10870 && gfc_expr_attr (expr1).allocatable
10877 tmp = INDIRECT_REF_P (lse.expr)
10878 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10880 /* We should only get array references here. */
10881 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10882 || TREE_CODE (tmp) == ARRAY_REF);
10884 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10885 or the array itself(ARRAY_REF). */
10886 tmp = TREE_OPERAND (tmp, 0);
10888 /* Provide the address of the array. */
10889 if (TREE_CODE (lse.expr) == ARRAY_REF)
10890 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10892 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10893 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10894 msg = _("Assignment of scalar to unallocated array");
10895 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10896 &expr1->where, msg);
10899 /* Deallocate the lhs parameterized components if required. */
10900 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10901 && !expr1->symtree->n.sym->attr.associate_var)
10903 if (expr1->ts.type == BT_DERIVED
10904 && expr1->ts.u.derived
10905 && expr1->ts.u.derived->attr.pdt_type)
10907 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10909 gfc_add_expr_to_block (&lse.pre, tmp);
10911 else if (expr1->ts.type == BT_CLASS
10912 && CLASS_DATA (expr1)->ts.u.derived
10913 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10915 tmp = gfc_class_data_get (lse.expr);
10916 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10918 gfc_add_expr_to_block (&lse.pre, tmp);
10923 /* Assignments of scalar derived types with allocatable components
10924 to arrays must be done with a deep copy and the rhs temporary
10925 must have its components deallocated afterwards. */
10926 scalar_to_array = (expr2->ts.type == BT_DERIVED
10927 && expr2->ts.u.derived->attr.alloc_comp
10928 && !gfc_expr_is_variable (expr2)
10929 && expr1->rank && !expr2->rank);
10930 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10932 && expr1->ts.u.derived->attr.alloc_comp
10933 && gfc_is_alloc_class_scalar_function (expr2));
10934 if (scalar_to_array && dealloc)
10936 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10937 gfc_prepend_expr_to_block (&loop.post, tmp);
10940 /* When assigning a character function result to a deferred-length variable,
10941 the function call must happen before the (re)allocation of the lhs -
10942 otherwise the character length of the result is not known.
10943 NOTE 1: This relies on having the exact dependence of the length type
10944 parameter available to the caller; gfortran saves it in the .mod files.
10945 NOTE 2: Vector array references generate an index temporary that must
10946 not go outside the loop. Otherwise, variables should not generate
10948 NOTE 3: The concatenation operation generates a temporary pointer,
10949 whose allocation must go to the innermost loop.
10950 NOTE 4: Elemental functions may generate a temporary, too. */
10951 if (flag_realloc_lhs
10952 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10953 && !(lss != gfc_ss_terminator
10954 && rss != gfc_ss_terminator
10955 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10956 || (expr2->expr_type == EXPR_FUNCTION
10957 && expr2->value.function.esym != NULL
10958 && expr2->value.function.esym->attr.elemental)
10959 || (expr2->expr_type == EXPR_FUNCTION
10960 && expr2->value.function.isym != NULL
10961 && expr2->value.function.isym->elemental)
10962 || (expr2->expr_type == EXPR_OP
10963 && expr2->value.op.op == INTRINSIC_CONCAT))))
10964 gfc_add_block_to_block (&block, &rse.pre);
10966 /* Nullify the allocatable components corresponding to those of the lhs
10967 derived type, so that the finalization of the function result does not
10968 affect the lhs of the assignment. Prepend is used to ensure that the
10969 nullification occurs before the call to the finalizer. In the case of
10970 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10971 as part of the deep copy. */
10972 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10973 && (gfc_is_class_array_function (expr2)
10974 || gfc_is_alloc_class_scalar_function (expr2)))
10976 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10977 gfc_prepend_expr_to_block (&rse.post, tmp);
10978 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10979 gfc_add_block_to_block (&loop.post, &rse.post);
10984 if (is_poly_assign)
10985 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10986 use_vptr_copy || (lhs_attr.allocatable
10987 && !lhs_attr.dimension),
10988 flag_realloc_lhs && !lhs_attr.pointer);
10989 else if (flag_coarray == GFC_FCOARRAY_LIB
10990 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10991 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10992 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10994 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10995 allocatable component, because those need to be accessed via the
10996 caf-runtime. No need to check for coindexes here, because resolve
10997 has rewritten those already. */
10999 gfc_actual_arglist a1, a2;
11000 /* Clear the structures to prevent accessing garbage. */
11001 memset (&code, '\0', sizeof (gfc_code));
11002 memset (&a1, '\0', sizeof (gfc_actual_arglist));
11003 memset (&a2, '\0', sizeof (gfc_actual_arglist));
11008 code.ext.actual = &a1;
11009 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
11010 tmp = gfc_conv_intrinsic_subroutine (&code);
11012 else if (!is_poly_assign && expr2->must_finalize
11013 && expr1->ts.type == BT_CLASS
11014 && expr2->ts.type == BT_CLASS)
11016 /* This case comes about when the scalarizer provides array element
11017 references. Use the vptr copy function, since this does a deep
11018 copy of allocatable components, without which the finalizer call */
11019 tmp = gfc_get_vptr_from_expr (rse.expr);
11020 if (tmp != NULL_TREE)
11022 tree fcn = gfc_vptr_copy_get (tmp);
11023 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
11024 fcn = build_fold_indirect_ref_loc (input_location, fcn);
11025 tmp = build_call_expr_loc (input_location,
11027 gfc_build_addr_expr (NULL, rse.expr),
11028 gfc_build_addr_expr (NULL, lse.expr));
11032 /* If nothing else works, do it the old fashioned way! */
11033 if (tmp == NULL_TREE)
11034 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
11035 gfc_expr_is_variable (expr2)
11037 || expr2->expr_type == EXPR_ARRAY,
11038 !(l_is_temp || init_flag) && dealloc,
11039 expr1->symtree->n.sym->attr.codimension);
11041 /* Add the pre blocks to the body. */
11042 gfc_add_block_to_block (&body, &rse.pre);
11043 gfc_add_block_to_block (&body, &lse.pre);
11044 gfc_add_expr_to_block (&body, tmp);
11045 /* Add the post blocks to the body. */
11046 gfc_add_block_to_block (&body, &rse.post);
11047 gfc_add_block_to_block (&body, &lse.post);
11049 if (lss == gfc_ss_terminator)
11051 /* F2003: Add the code for reallocation on assignment. */
11052 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
11053 && !is_poly_assign)
11054 alloc_scalar_allocatable_for_assignment (&block, string_length,
11057 /* Use the scalar assignment as is. */
11058 gfc_add_block_to_block (&block, &body);
11062 gcc_assert (lse.ss == gfc_ss_terminator
11063 && rse.ss == gfc_ss_terminator);
11067 gfc_trans_scalarized_loop_boundary (&loop, &body);
11069 /* We need to copy the temporary to the actual lhs. */
11070 gfc_init_se (&lse, NULL);
11071 gfc_init_se (&rse, NULL);
11072 gfc_copy_loopinfo_to_se (&lse, &loop);
11073 gfc_copy_loopinfo_to_se (&rse, &loop);
11075 rse.ss = loop.temp_ss;
11078 gfc_conv_tmp_array_ref (&rse);
11079 gfc_conv_expr (&lse, expr1);
11081 gcc_assert (lse.ss == gfc_ss_terminator
11082 && rse.ss == gfc_ss_terminator);
11084 if (expr2->ts.type == BT_CHARACTER)
11085 rse.string_length = string_length;
11087 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
11089 gfc_add_expr_to_block (&body, tmp);
11092 /* F2003: Allocate or reallocate lhs of allocatable array. */
11093 if (flag_realloc_lhs
11094 && gfc_is_reallocatable_lhs (expr1)
11096 && !is_runtime_conformable (expr1, expr2))
11098 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
11099 ompws_flags &= ~OMPWS_SCALARIZER_WS;
11100 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
11101 if (tmp != NULL_TREE)
11102 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
11105 if (maybe_workshare)
11106 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
11108 /* Generate the copying loops. */
11109 gfc_trans_scalarizing_loops (&loop, &body);
11111 /* Wrap the whole thing up. */
11112 gfc_add_block_to_block (&block, &loop.pre);
11113 gfc_add_block_to_block (&block, &loop.post);
11115 gfc_cleanup_loop (&loop);
11118 return gfc_finish_block (&block);
11122 /* Check whether EXPR is a copyable array. */
11125 copyable_array_p (gfc_expr * expr)
11127 if (expr->expr_type != EXPR_VARIABLE)
11130 /* First check it's an array. */
11131 if (expr->rank < 1 || !expr->ref || expr->ref->next)
11134 if (!gfc_full_array_ref_p (expr->ref, NULL))
11137 /* Next check that it's of a simple enough type. */
11138 switch (expr->ts.type)
11150 return !expr->ts.u.derived->attr.alloc_comp;
11159 /* Translate an assignment. */
11162 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
11163 bool dealloc, bool use_vptr_copy, bool may_alias)
11167 /* Special case a single function returning an array. */
11168 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
11170 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
11175 /* Special case assigning an array to zero. */
11176 if (copyable_array_p (expr1)
11177 && is_zero_initializer_p (expr2))
11179 tmp = gfc_trans_zero_assign (expr1);
11184 /* Special case copying one array to another. */
11185 if (copyable_array_p (expr1)
11186 && copyable_array_p (expr2)
11187 && gfc_compare_types (&expr1->ts, &expr2->ts)
11188 && !gfc_check_dependency (expr1, expr2, 0))
11190 tmp = gfc_trans_array_copy (expr1, expr2);
11195 /* Special case initializing an array from a constant array constructor. */
11196 if (copyable_array_p (expr1)
11197 && expr2->expr_type == EXPR_ARRAY
11198 && gfc_compare_types (&expr1->ts, &expr2->ts))
11200 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
11205 if (UNLIMITED_POLY (expr1) && expr1->rank
11206 && expr2->ts.type != BT_CLASS)
11207 use_vptr_copy = true;
11209 /* Fallback to the scalarizer to generate explicit loops. */
11210 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
11211 use_vptr_copy, may_alias);
11215 gfc_trans_init_assign (gfc_code * code)
11217 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
11221 gfc_trans_assign (gfc_code * code)
11223 return gfc_trans_assignment (code->expr1, code->expr2, false, true);