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)
5206 symbol_attribute attr = gfc_expr_attr (e);
5209 /* If this is a full array or a scalar, the allocatable and pointer
5210 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5212 if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
5214 if (fsym->attr.pointer)
5216 else if (fsym->attr.allocatable)
5222 parmse->force_no_tmp = 1;
5223 if (fsym->attr.contiguous
5224 && !gfc_is_simply_contiguous (e, false, true))
5225 gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
5226 fsym->attr.pointer);
5228 gfc_conv_expr_descriptor (parmse, e);
5230 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5231 parmse->expr = build_fold_indirect_ref_loc (input_location,
5234 /* Unallocated allocatable arrays and unassociated pointer arrays
5235 need their dtype setting if they are argument associated with
5236 assumed rank dummies. */
5237 if (fsym && fsym->as
5238 && (gfc_expr_attr (e).pointer
5239 || gfc_expr_attr (e).allocatable))
5240 set_dtype_for_unallocated (parmse, e);
5242 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5243 the expression type is different from the descriptor type, then
5244 the offset must be found (eg. to a component ref or substring)
5245 and the dtype updated. Assumed type entities are only allowed
5246 to be dummies in Fortran. They therefore lack the decl specific
5247 appendiges and so must be treated differently from other fortran
5248 entities passed to CFI descriptors in the interface decl. */
5249 type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
5252 if (type && DECL_ARTIFICIAL (parmse->expr)
5253 && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
5255 /* Obtain the offset to the data. */
5256 gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
5257 gfc_index_zero_node, true, e);
5259 /* Update the dtype. */
5260 gfc_add_modify (&parmse->pre,
5261 gfc_conv_descriptor_dtype (parmse->expr),
5262 gfc_get_dtype_rank_type (e->rank, type));
5264 else if (type == NULL_TREE
5265 || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)))
5267 /* Make sure that the span is set for expressions where it
5268 might not have been done already. */
5269 tmp = gfc_conv_descriptor_elem_len (parmse->expr);
5270 tmp = fold_convert (gfc_array_index_type, tmp);
5271 gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
5276 gfc_conv_expr (parmse, e);
5278 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5279 parmse->expr = build_fold_indirect_ref_loc (input_location,
5282 parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
5283 parmse->expr, attr);
5286 /* Set the CFI attribute field. */
5287 tmp = gfc_conv_descriptor_attribute (parmse->expr);
5288 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5289 void_type_node, tmp,
5290 build_int_cst (TREE_TYPE (tmp), attribute));
5291 gfc_add_expr_to_block (&parmse->pre, tmp);
5293 /* Now pass the gfc_descriptor by reference. */
5294 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5296 /* Variables to point to the gfc and CFI descriptors. */
5297 gfc_desc_ptr = parmse->expr;
5298 cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
5299 gfc_add_modify (&parmse->pre, cfi_desc_ptr,
5300 build_int_cst (pvoid_type_node, 0));
5302 /* Allocate the CFI descriptor and fill the fields. */
5303 tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
5304 tmp = build_call_expr_loc (input_location,
5305 gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
5306 gfc_add_expr_to_block (&parmse->pre, tmp);
5308 /* The CFI descriptor is passed to the bind_C procedure. */
5309 parmse->expr = cfi_desc_ptr;
5311 /* Free the CFI descriptor. */
5312 gfc_init_block (&block);
5313 cond = fold_build2_loc (input_location, NE_EXPR,
5314 logical_type_node, cfi_desc_ptr,
5315 build_int_cst (TREE_TYPE (cfi_desc_ptr), 0));
5316 tmp = gfc_call_free (cfi_desc_ptr);
5317 gfc_add_expr_to_block (&block, tmp);
5318 tmp = build3_v (COND_EXPR, cond,
5319 gfc_finish_block (&block),
5320 build_empty_stmt (input_location));
5321 gfc_prepend_expr_to_block (&parmse->post, tmp);
5323 /* Transfer values back to gfc descriptor. */
5324 tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5325 tmp = build_call_expr_loc (input_location,
5326 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
5327 gfc_prepend_expr_to_block (&parmse->post, tmp);
5331 /* Generate code for a procedure call. Note can return se->post != NULL.
5332 If se->direct_byref is set then se->expr contains the return parameter.
5333 Return nonzero, if the call has alternate specifiers.
5334 'expr' is only needed for procedure pointer components. */
5337 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
5338 gfc_actual_arglist * args, gfc_expr * expr,
5339 vec<tree, va_gc> *append_args)
5341 gfc_interface_mapping mapping;
5342 vec<tree, va_gc> *arglist;
5343 vec<tree, va_gc> *retargs;
5347 gfc_array_info *info;
5354 vec<tree, va_gc> *stringargs;
5355 vec<tree, va_gc> *optionalargs;
5357 gfc_formal_arglist *formal;
5358 gfc_actual_arglist *arg;
5359 int has_alternate_specifier = 0;
5360 bool need_interface_mapping;
5368 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
5369 gfc_component *comp = NULL;
5376 optionalargs = NULL;
5381 comp = gfc_get_proc_ptr_comp (expr);
5383 bool elemental_proc = (comp
5384 && comp->ts.interface
5385 && comp->ts.interface->attr.elemental)
5386 || (comp && comp->attr.elemental)
5387 || sym->attr.elemental;
5391 if (!elemental_proc)
5393 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
5394 if (se->ss->info->useflags)
5396 gcc_assert ((!comp && gfc_return_by_reference (sym)
5397 && sym->result->attr.dimension)
5398 || (comp && comp->attr.dimension)
5399 || gfc_is_class_array_function (expr));
5400 gcc_assert (se->loop != NULL);
5401 /* Access the previously obtained result. */
5402 gfc_conv_tmp_array_ref (se);
5406 info = &se->ss->info->data.array;
5411 gfc_init_block (&post);
5412 gfc_init_interface_mapping (&mapping);
5415 formal = gfc_sym_get_dummy_args (sym);
5416 need_interface_mapping = sym->attr.dimension ||
5417 (sym->ts.type == BT_CHARACTER
5418 && sym->ts.u.cl->length
5419 && sym->ts.u.cl->length->expr_type
5424 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
5425 need_interface_mapping = comp->attr.dimension ||
5426 (comp->ts.type == BT_CHARACTER
5427 && comp->ts.u.cl->length
5428 && comp->ts.u.cl->length->expr_type
5432 base_object = NULL_TREE;
5433 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5434 is the third and fourth argument to such a function call a value
5435 denoting the number of elements to copy (i.e., most of the time the
5436 length of a deferred length string). */
5437 ulim_copy = (formal == NULL)
5438 && UNLIMITED_POLY (sym)
5439 && comp && (strcmp ("_copy", comp->name) == 0);
5441 /* Evaluate the arguments. */
5442 for (arg = args, argc = 0; arg != NULL;
5443 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
5445 bool finalized = false;
5446 bool non_unity_length_string = false;
5449 fsym = formal ? formal->sym : NULL;
5450 parm_kind = MISSING;
5452 if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
5453 && (!fsym->ts.u.cl->length
5454 || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5455 || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
5456 non_unity_length_string = true;
5458 /* If the procedure requires an explicit interface, the actual
5459 argument is passed according to the corresponding formal
5460 argument. If the corresponding formal argument is a POINTER,
5461 ALLOCATABLE or assumed shape, we do not use g77's calling
5462 convention, and pass the address of the array descriptor
5463 instead. Otherwise we use g77's calling convention, in other words
5464 pass the array data pointer without descriptor. */
5465 bool nodesc_arg = fsym != NULL
5466 && !(fsym->attr.pointer || fsym->attr.allocatable)
5468 && fsym->as->type != AS_ASSUMED_SHAPE
5469 && fsym->as->type != AS_ASSUMED_RANK;
5471 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
5473 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
5475 /* Class array expressions are sometimes coming completely unadorned
5476 with either arrayspec or _data component. Correct that here.
5477 OOP-TODO: Move this to the frontend. */
5478 if (e && e->expr_type == EXPR_VARIABLE
5480 && e->ts.type == BT_CLASS
5481 && (CLASS_DATA (e)->attr.codimension
5482 || CLASS_DATA (e)->attr.dimension))
5484 gfc_typespec temp_ts = e->ts;
5485 gfc_add_class_array_ref (e);
5491 if (se->ignore_optional)
5493 /* Some intrinsics have already been resolved to the correct
5497 else if (arg->label)
5499 has_alternate_specifier = 1;
5504 gfc_init_se (&parmse, NULL);
5506 /* For scalar arguments with VALUE attribute which are passed by
5507 value, pass "0" and a hidden argument gives the optional
5509 if (fsym && fsym->attr.optional && fsym->attr.value
5510 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
5511 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
5513 parmse.expr = fold_convert (gfc_sym_type (fsym),
5515 vec_safe_push (optionalargs, boolean_false_node);
5519 /* Pass a NULL pointer for an absent arg. */
5520 parmse.expr = null_pointer_node;
5521 if (arg->missing_arg_type == BT_CHARACTER)
5522 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5527 else if (arg->expr->expr_type == EXPR_NULL
5528 && fsym && !fsym->attr.pointer
5529 && (fsym->ts.type != BT_CLASS
5530 || !CLASS_DATA (fsym)->attr.class_pointer))
5532 /* Pass a NULL pointer to denote an absent arg. */
5533 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5534 && (fsym->ts.type != BT_CLASS
5535 || !CLASS_DATA (fsym)->attr.allocatable));
5536 gfc_init_se (&parmse, NULL);
5537 parmse.expr = null_pointer_node;
5538 if (arg->missing_arg_type == BT_CHARACTER)
5539 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5541 else if (fsym && fsym->ts.type == BT_CLASS
5542 && e->ts.type == BT_DERIVED)
5544 /* The derived type needs to be converted to a temporary
5546 gfc_init_se (&parmse, se);
5547 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5549 && e->expr_type == EXPR_VARIABLE
5550 && e->symtree->n.sym->attr.optional,
5551 CLASS_DATA (fsym)->attr.class_pointer
5552 || CLASS_DATA (fsym)->attr.allocatable);
5554 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
5556 /* The intrinsic type needs to be converted to a temporary
5557 CLASS object for the unlimited polymorphic formal. */
5558 gfc_init_se (&parmse, se);
5559 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5561 else if (se->ss && se->ss->info->useflags)
5567 /* An elemental function inside a scalarized loop. */
5568 gfc_init_se (&parmse, se);
5569 parm_kind = ELEMENTAL;
5571 /* When no fsym is present, ulim_copy is set and this is a third or
5572 fourth argument, use call-by-value instead of by reference to
5573 hand the length properties to the copy routine (i.e., most of the
5574 time this will be a call to a __copy_character_* routine where the
5575 third and fourth arguments are the lengths of a deferred length
5577 if ((fsym && fsym->attr.value)
5578 || (ulim_copy && (argc == 2 || argc == 3)))
5579 gfc_conv_expr (&parmse, e);
5581 gfc_conv_expr_reference (&parmse, e);
5583 if (e->ts.type == BT_CHARACTER && !e->rank
5584 && e->expr_type == EXPR_FUNCTION)
5585 parmse.expr = build_fold_indirect_ref_loc (input_location,
5588 if (fsym && fsym->ts.type == BT_DERIVED
5589 && gfc_is_class_container_ref (e))
5591 parmse.expr = gfc_class_data_get (parmse.expr);
5593 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5594 && e->symtree->n.sym->attr.optional)
5596 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5597 parmse.expr = build3_loc (input_location, COND_EXPR,
5598 TREE_TYPE (parmse.expr),
5600 fold_convert (TREE_TYPE (parmse.expr),
5601 null_pointer_node));
5605 /* If we are passing an absent array as optional dummy to an
5606 elemental procedure, make sure that we pass NULL when the data
5607 pointer is NULL. We need this extra conditional because of
5608 scalarization which passes arrays elements to the procedure,
5609 ignoring the fact that the array can be absent/unallocated/... */
5610 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5612 tree descriptor_data;
5614 descriptor_data = ss->info->data.array.data;
5615 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5617 fold_convert (TREE_TYPE (descriptor_data),
5618 null_pointer_node));
5620 = fold_build3_loc (input_location, COND_EXPR,
5621 TREE_TYPE (parmse.expr),
5622 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5623 fold_convert (TREE_TYPE (parmse.expr),
5628 /* The scalarizer does not repackage the reference to a class
5629 array - instead it returns a pointer to the data element. */
5630 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5631 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5632 fsym->attr.intent != INTENT_IN
5633 && (CLASS_DATA (fsym)->attr.class_pointer
5634 || CLASS_DATA (fsym)->attr.allocatable),
5636 && e->expr_type == EXPR_VARIABLE
5637 && e->symtree->n.sym->attr.optional,
5638 CLASS_DATA (fsym)->attr.class_pointer
5639 || CLASS_DATA (fsym)->attr.allocatable);
5646 gfc_init_se (&parmse, NULL);
5648 /* Check whether the expression is a scalar or not; we cannot use
5649 e->rank as it can be nonzero for functions arguments. */
5650 argss = gfc_walk_expr (e);
5651 scalar = argss == gfc_ss_terminator;
5653 gfc_free_ss_chain (argss);
5655 /* Special handling for passing scalar polymorphic coarrays;
5656 otherwise one passes "class->_data.data" instead of "&class". */
5657 if (e->rank == 0 && e->ts.type == BT_CLASS
5658 && fsym && fsym->ts.type == BT_CLASS
5659 && CLASS_DATA (fsym)->attr.codimension
5660 && !CLASS_DATA (fsym)->attr.dimension)
5662 gfc_add_class_array_ref (e);
5663 parmse.want_coarray = 1;
5667 /* A scalar or transformational function. */
5670 if (e->expr_type == EXPR_VARIABLE
5671 && e->symtree->n.sym->attr.cray_pointee
5672 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5674 /* The Cray pointer needs to be converted to a pointer to
5675 a type given by the expression. */
5676 gfc_conv_expr (&parmse, e);
5677 type = build_pointer_type (TREE_TYPE (parmse.expr));
5678 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5679 parmse.expr = convert (type, tmp);
5682 else if (sym->attr.is_bind_c && e
5683 && (is_CFI_desc (fsym, NULL)
5684 || non_unity_length_string))
5685 /* Implement F2018, C.12.6.1: paragraph (2). */
5686 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5688 else if (fsym && fsym->attr.value)
5690 if (fsym->ts.type == BT_CHARACTER
5691 && fsym->ts.is_c_interop
5692 && fsym->ns->proc_name != NULL
5693 && fsym->ns->proc_name->attr.is_bind_c)
5696 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5697 if (parmse.expr == NULL)
5698 gfc_conv_expr (&parmse, e);
5702 gfc_conv_expr (&parmse, e);
5703 if (fsym->attr.optional
5704 && fsym->ts.type != BT_CLASS
5705 && fsym->ts.type != BT_DERIVED)
5707 if (e->expr_type != EXPR_VARIABLE
5708 || !e->symtree->n.sym->attr.optional
5710 vec_safe_push (optionalargs, boolean_true_node);
5713 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5714 if (!e->symtree->n.sym->attr.value)
5716 = fold_build3_loc (input_location, COND_EXPR,
5717 TREE_TYPE (parmse.expr),
5719 fold_convert (TREE_TYPE (parmse.expr),
5720 integer_zero_node));
5722 vec_safe_push (optionalargs, tmp);
5728 else if (arg->name && arg->name[0] == '%')
5729 /* Argument list functions %VAL, %LOC and %REF are signalled
5730 through arg->name. */
5731 conv_arglist_function (&parmse, arg->expr, arg->name);
5732 else if ((e->expr_type == EXPR_FUNCTION)
5733 && ((e->value.function.esym
5734 && e->value.function.esym->result->attr.pointer)
5735 || (!e->value.function.esym
5736 && e->symtree->n.sym->attr.pointer))
5737 && fsym && fsym->attr.target)
5739 gfc_conv_expr (&parmse, e);
5740 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5743 else if (e->expr_type == EXPR_FUNCTION
5744 && e->symtree->n.sym->result
5745 && e->symtree->n.sym->result != e->symtree->n.sym
5746 && e->symtree->n.sym->result->attr.proc_pointer)
5748 /* Functions returning procedure pointers. */
5749 gfc_conv_expr (&parmse, e);
5750 if (fsym && fsym->attr.proc_pointer)
5751 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5756 if (e->ts.type == BT_CLASS && fsym
5757 && fsym->ts.type == BT_CLASS
5758 && (!CLASS_DATA (fsym)->as
5759 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5760 && CLASS_DATA (e)->attr.codimension)
5762 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5763 gcc_assert (!CLASS_DATA (fsym)->as);
5764 gfc_add_class_array_ref (e);
5765 parmse.want_coarray = 1;
5766 gfc_conv_expr_reference (&parmse, e);
5767 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5769 && e->expr_type == EXPR_VARIABLE);
5771 else if (e->ts.type == BT_CLASS && fsym
5772 && fsym->ts.type == BT_CLASS
5773 && !CLASS_DATA (fsym)->as
5774 && !CLASS_DATA (e)->as
5775 && strcmp (fsym->ts.u.derived->name,
5776 e->ts.u.derived->name))
5778 type = gfc_typenode_for_spec (&fsym->ts);
5779 var = gfc_create_var (type, fsym->name);
5780 gfc_conv_expr (&parmse, e);
5781 if (fsym->attr.optional
5782 && e->expr_type == EXPR_VARIABLE
5783 && e->symtree->n.sym->attr.optional)
5787 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5788 cond = fold_build2_loc (input_location, NE_EXPR,
5789 logical_type_node, tmp,
5790 fold_convert (TREE_TYPE (tmp),
5791 null_pointer_node));
5792 gfc_start_block (&block);
5793 gfc_add_modify (&block, var,
5794 fold_build1_loc (input_location,
5796 type, parmse.expr));
5797 gfc_add_expr_to_block (&parmse.pre,
5798 fold_build3_loc (input_location,
5799 COND_EXPR, void_type_node,
5800 cond, gfc_finish_block (&block),
5801 build_empty_stmt (input_location)));
5802 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5803 parmse.expr = build3_loc (input_location, COND_EXPR,
5804 TREE_TYPE (parmse.expr),
5806 fold_convert (TREE_TYPE (parmse.expr),
5807 null_pointer_node));
5811 /* Since the internal representation of unlimited
5812 polymorphic expressions includes an extra field
5813 that other class objects do not, a cast to the
5814 formal type does not work. */
5815 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5819 /* Set the _data field. */
5820 tmp = gfc_class_data_get (var);
5821 efield = fold_convert (TREE_TYPE (tmp),
5822 gfc_class_data_get (parmse.expr));
5823 gfc_add_modify (&parmse.pre, tmp, efield);
5825 /* Set the _vptr field. */
5826 tmp = gfc_class_vptr_get (var);
5827 efield = fold_convert (TREE_TYPE (tmp),
5828 gfc_class_vptr_get (parmse.expr));
5829 gfc_add_modify (&parmse.pre, tmp, efield);
5831 /* Set the _len field. */
5832 tmp = gfc_class_len_get (var);
5833 gfc_add_modify (&parmse.pre, tmp,
5834 build_int_cst (TREE_TYPE (tmp), 0));
5838 tmp = fold_build1_loc (input_location,
5841 gfc_add_modify (&parmse.pre, var, tmp);
5844 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5850 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5851 && !fsym->attr.allocatable && !fsym->attr.pointer
5852 && !e->symtree->n.sym->attr.dimension
5853 && !e->symtree->n.sym->attr.pointer
5855 && !e->symtree->n.sym->attr.dummy
5856 /* FIXME - PR 87395 and PR 41453 */
5857 && e->symtree->n.sym->attr.save == SAVE_NONE
5858 && !e->symtree->n.sym->attr.associate_var
5859 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5860 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5862 gfc_conv_expr_reference (&parmse, e, add_clobber);
5864 /* Catch base objects that are not variables. */
5865 if (e->ts.type == BT_CLASS
5866 && e->expr_type != EXPR_VARIABLE
5867 && expr && e == expr->base_expr)
5868 base_object = build_fold_indirect_ref_loc (input_location,
5871 /* A class array element needs converting back to be a
5872 class object, if the formal argument is a class object. */
5873 if (fsym && fsym->ts.type == BT_CLASS
5874 && e->ts.type == BT_CLASS
5875 && ((CLASS_DATA (fsym)->as
5876 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5877 || CLASS_DATA (e)->attr.dimension))
5878 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5879 fsym->attr.intent != INTENT_IN
5880 && (CLASS_DATA (fsym)->attr.class_pointer
5881 || CLASS_DATA (fsym)->attr.allocatable),
5883 && e->expr_type == EXPR_VARIABLE
5884 && e->symtree->n.sym->attr.optional,
5885 CLASS_DATA (fsym)->attr.class_pointer
5886 || CLASS_DATA (fsym)->attr.allocatable);
5888 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5889 allocated on entry, it must be deallocated. */
5890 if (fsym && fsym->attr.intent == INTENT_OUT
5891 && (fsym->attr.allocatable
5892 || (fsym->ts.type == BT_CLASS
5893 && CLASS_DATA (fsym)->attr.allocatable)))
5898 gfc_init_block (&block);
5900 if (e->ts.type == BT_CLASS)
5901 ptr = gfc_class_data_get (ptr);
5903 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5906 gfc_add_expr_to_block (&block, tmp);
5907 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5908 void_type_node, ptr,
5910 gfc_add_expr_to_block (&block, tmp);
5912 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5914 gfc_add_modify (&block, ptr,
5915 fold_convert (TREE_TYPE (ptr),
5916 null_pointer_node));
5917 gfc_add_expr_to_block (&block, tmp);
5919 else if (fsym->ts.type == BT_CLASS)
5922 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5923 tmp = gfc_get_symbol_decl (vtab);
5924 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5925 ptr = gfc_class_vptr_get (parmse.expr);
5926 gfc_add_modify (&block, ptr,
5927 fold_convert (TREE_TYPE (ptr), tmp));
5928 gfc_add_expr_to_block (&block, tmp);
5931 if (fsym->attr.optional
5932 && e->expr_type == EXPR_VARIABLE
5933 && e->symtree->n.sym->attr.optional)
5935 tmp = fold_build3_loc (input_location, COND_EXPR,
5937 gfc_conv_expr_present (e->symtree->n.sym),
5938 gfc_finish_block (&block),
5939 build_empty_stmt (input_location));
5942 tmp = gfc_finish_block (&block);
5944 gfc_add_expr_to_block (&se->pre, tmp);
5947 if (fsym && (fsym->ts.type == BT_DERIVED
5948 || fsym->ts.type == BT_ASSUMED)
5949 && e->ts.type == BT_CLASS
5950 && !CLASS_DATA (e)->attr.dimension
5951 && !CLASS_DATA (e)->attr.codimension)
5953 parmse.expr = gfc_class_data_get (parmse.expr);
5954 /* The result is a class temporary, whose _data component
5955 must be freed to avoid a memory leak. */
5956 if (e->expr_type == EXPR_FUNCTION
5957 && CLASS_DATA (e)->attr.allocatable)
5963 /* Borrow the function symbol to make a call to
5964 gfc_add_finalizer_call and then restore it. */
5965 tmp = e->symtree->n.sym->backend_decl;
5966 e->symtree->n.sym->backend_decl
5967 = TREE_OPERAND (parmse.expr, 0);
5968 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5969 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5970 finalized = gfc_add_finalizer_call (&parmse.post,
5972 gfc_free_expr (var);
5973 e->symtree->n.sym->backend_decl = tmp;
5974 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5976 /* Then free the class _data. */
5977 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5978 tmp = fold_build2_loc (input_location, NE_EXPR,
5981 tmp = build3_v (COND_EXPR, tmp,
5982 gfc_call_free (parmse.expr),
5983 build_empty_stmt (input_location));
5984 gfc_add_expr_to_block (&parmse.post, tmp);
5985 gfc_add_modify (&parmse.post, parmse.expr, zero);
5989 /* Wrap scalar variable in a descriptor. We need to convert
5990 the address of a pointer back to the pointer itself before,
5991 we can assign it to the data field. */
5993 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5994 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5997 if (TREE_CODE (tmp) == ADDR_EXPR)
5998 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5999 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
6001 parmse.expr = gfc_build_addr_expr (NULL_TREE,
6004 else if (fsym && e->expr_type != EXPR_NULL
6005 && ((fsym->attr.pointer
6006 && fsym->attr.flavor != FL_PROCEDURE)
6007 || (fsym->attr.proc_pointer
6008 && !(e->expr_type == EXPR_VARIABLE
6009 && e->symtree->n.sym->attr.dummy))
6010 || (fsym->attr.proc_pointer
6011 && e->expr_type == EXPR_VARIABLE
6012 && gfc_is_proc_ptr_comp (e))
6013 || (fsym->attr.allocatable
6014 && fsym->attr.flavor != FL_PROCEDURE)))
6016 /* Scalar pointer dummy args require an extra level of
6017 indirection. The null pointer already contains
6018 this level of indirection. */
6019 parm_kind = SCALAR_POINTER;
6020 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
6024 else if (e->ts.type == BT_CLASS
6025 && fsym && fsym->ts.type == BT_CLASS
6026 && (CLASS_DATA (fsym)->attr.dimension
6027 || CLASS_DATA (fsym)->attr.codimension))
6029 /* Pass a class array. */
6030 parmse.use_offset = 1;
6031 gfc_conv_expr_descriptor (&parmse, e);
6033 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6034 allocated on entry, it must be deallocated. */
6035 if (fsym->attr.intent == INTENT_OUT
6036 && CLASS_DATA (fsym)->attr.allocatable)
6041 gfc_init_block (&block);
6043 ptr = gfc_class_data_get (ptr);
6045 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
6046 NULL_TREE, NULL_TREE,
6048 GFC_CAF_COARRAY_NOCOARRAY);
6049 gfc_add_expr_to_block (&block, tmp);
6050 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6051 void_type_node, ptr,
6053 gfc_add_expr_to_block (&block, tmp);
6054 gfc_reset_vptr (&block, e);
6056 if (fsym->attr.optional
6057 && e->expr_type == EXPR_VARIABLE
6059 || (e->ref->type == REF_ARRAY
6060 && e->ref->u.ar.type != AR_FULL))
6061 && e->symtree->n.sym->attr.optional)
6063 tmp = fold_build3_loc (input_location, COND_EXPR,
6065 gfc_conv_expr_present (e->symtree->n.sym),
6066 gfc_finish_block (&block),
6067 build_empty_stmt (input_location));
6070 tmp = gfc_finish_block (&block);
6072 gfc_add_expr_to_block (&se->pre, tmp);
6075 /* The conversion does not repackage the reference to a class
6076 array - _data descriptor. */
6077 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
6078 fsym->attr.intent != INTENT_IN
6079 && (CLASS_DATA (fsym)->attr.class_pointer
6080 || CLASS_DATA (fsym)->attr.allocatable),
6082 && e->expr_type == EXPR_VARIABLE
6083 && e->symtree->n.sym->attr.optional,
6084 CLASS_DATA (fsym)->attr.class_pointer
6085 || CLASS_DATA (fsym)->attr.allocatable);
6089 /* If the argument is a function call that may not create
6090 a temporary for the result, we have to check that we
6091 can do it, i.e. that there is no alias between this
6092 argument and another one. */
6093 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
6099 intent = fsym->attr.intent;
6101 intent = INTENT_UNKNOWN;
6103 if (gfc_check_fncall_dependency (e, intent, sym, args,
6105 parmse.force_tmp = 1;
6107 iarg = e->value.function.actual->expr;
6109 /* Temporary needed if aliasing due to host association. */
6110 if (sym->attr.contained
6112 && !sym->attr.implicit_pure
6113 && !sym->attr.use_assoc
6114 && iarg->expr_type == EXPR_VARIABLE
6115 && sym->ns == iarg->symtree->n.sym->ns)
6116 parmse.force_tmp = 1;
6118 /* Ditto within module. */
6119 if (sym->attr.use_assoc
6121 && !sym->attr.implicit_pure
6122 && iarg->expr_type == EXPR_VARIABLE
6123 && sym->module == iarg->symtree->n.sym->module)
6124 parmse.force_tmp = 1;
6127 if (sym->attr.is_bind_c && e
6128 && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
6129 /* Implement F2018, C.12.6.1: paragraph (2). */
6130 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
6132 else if (e->expr_type == EXPR_VARIABLE
6133 && is_subref_array (e)
6134 && !(fsym && fsym->attr.pointer))
6135 /* The actual argument is a component reference to an
6136 array of derived types. In this case, the argument
6137 is converted to a temporary, which is passed and then
6138 written back after the procedure call. */
6139 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6140 fsym ? fsym->attr.intent : INTENT_INOUT,
6141 fsym && fsym->attr.pointer);
6143 else if (gfc_is_class_array_ref (e, NULL)
6144 && fsym && fsym->ts.type == BT_DERIVED)
6145 /* The actual argument is a component reference to an
6146 array of derived types. In this case, the argument
6147 is converted to a temporary, which is passed and then
6148 written back after the procedure call.
6149 OOP-TODO: Insert code so that if the dynamic type is
6150 the same as the declared type, copy-in/copy-out does
6152 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6153 fsym ? fsym->attr.intent : INTENT_INOUT,
6154 fsym && fsym->attr.pointer);
6156 else if (gfc_is_class_array_function (e)
6157 && fsym && fsym->ts.type == BT_DERIVED)
6158 /* See previous comment. For function actual argument,
6159 the write out is not needed so the intent is set as
6162 e->must_finalize = 1;
6163 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6165 fsym && fsym->attr.pointer);
6167 else if (fsym && fsym->attr.contiguous
6168 && !gfc_is_simply_contiguous (e, false, true))
6170 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6171 fsym ? fsym->attr.intent : INTENT_INOUT,
6172 fsym && fsym->attr.pointer);
6175 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
6178 /* Unallocated allocatable arrays and unassociated pointer arrays
6179 need their dtype setting if they are argument associated with
6180 assumed rank dummies. */
6181 if (!sym->attr.is_bind_c && e && fsym && fsym->as
6182 && fsym->as->type == AS_ASSUMED_RANK)
6184 if (gfc_expr_attr (e).pointer
6185 || gfc_expr_attr (e).allocatable)
6186 set_dtype_for_unallocated (&parmse, e);
6187 else if (e->expr_type == EXPR_VARIABLE
6188 && e->symtree->n.sym->attr.dummy
6189 && e->symtree->n.sym->as
6190 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6193 tmp = build_fold_indirect_ref_loc (input_location,
6195 minus_one = build_int_cst (gfc_array_index_type, -1);
6196 gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
6197 gfc_rank_cst[e->rank - 1],
6202 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6203 allocated on entry, it must be deallocated. */
6204 if (fsym && fsym->attr.allocatable
6205 && fsym->attr.intent == INTENT_OUT)
6207 if (fsym->ts.type == BT_DERIVED
6208 && fsym->ts.u.derived->attr.alloc_comp)
6210 // deallocate the components first
6211 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
6212 parmse.expr, e->rank);
6213 if (tmp != NULL_TREE)
6214 gfc_add_expr_to_block (&se->pre, tmp);
6217 tmp = build_fold_indirect_ref_loc (input_location,
6219 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
6220 tmp = gfc_conv_descriptor_data_get (tmp);
6221 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6222 NULL_TREE, NULL_TREE, true,
6224 GFC_CAF_COARRAY_NOCOARRAY);
6225 if (fsym->attr.optional
6226 && e->expr_type == EXPR_VARIABLE
6227 && e->symtree->n.sym->attr.optional)
6228 tmp = fold_build3_loc (input_location, COND_EXPR,
6230 gfc_conv_expr_present (e->symtree->n.sym),
6231 tmp, build_empty_stmt (input_location));
6232 gfc_add_expr_to_block (&se->pre, tmp);
6237 /* The case with fsym->attr.optional is that of a user subroutine
6238 with an interface indicating an optional argument. When we call
6239 an intrinsic subroutine, however, fsym is NULL, but we might still
6240 have an optional argument, so we proceed to the substitution
6242 if (e && (fsym == NULL || fsym->attr.optional))
6244 /* If an optional argument is itself an optional dummy argument,
6245 check its presence and substitute a null if absent. This is
6246 only needed when passing an array to an elemental procedure
6247 as then array elements are accessed - or no NULL pointer is
6248 allowed and a "1" or "0" should be passed if not present.
6249 When passing a non-array-descriptor full array to a
6250 non-array-descriptor dummy, no check is needed. For
6251 array-descriptor actual to array-descriptor dummy, see
6252 PR 41911 for why a check has to be inserted.
6253 fsym == NULL is checked as intrinsics required the descriptor
6254 but do not always set fsym.
6255 Also, it is necessary to pass a NULL pointer to library routines
6256 which usually ignore optional arguments, so they can handle
6257 these themselves. */
6258 if (e->expr_type == EXPR_VARIABLE
6259 && e->symtree->n.sym->attr.optional
6260 && (((e->rank != 0 && elemental_proc)
6261 || e->representation.length || e->ts.type == BT_CHARACTER
6265 && (fsym->as->type == AS_ASSUMED_SHAPE
6266 || fsym->as->type == AS_ASSUMED_RANK
6267 || fsym->as->type == AS_DEFERRED)))))
6268 || se->ignore_optional))
6269 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
6270 e->representation.length);
6275 /* Obtain the character length of an assumed character length
6276 length procedure from the typespec. */
6277 if (fsym->ts.type == BT_CHARACTER
6278 && parmse.string_length == NULL_TREE
6279 && e->ts.type == BT_PROCEDURE
6280 && e->symtree->n.sym->ts.type == BT_CHARACTER
6281 && e->symtree->n.sym->ts.u.cl->length != NULL
6282 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6284 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
6285 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
6289 if (fsym && need_interface_mapping && e)
6290 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
6292 gfc_add_block_to_block (&se->pre, &parmse.pre);
6293 gfc_add_block_to_block (&post, &parmse.post);
6295 /* Allocated allocatable components of derived types must be
6296 deallocated for non-variable scalars, array arguments to elemental
6297 procedures, and array arguments with descriptor to non-elemental
6298 procedures. As bounds information for descriptorless arrays is no
6299 longer available here, they are dealt with in trans-array.c
6300 (gfc_conv_array_parameter). */
6301 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
6302 && e->ts.u.derived->attr.alloc_comp
6303 && (e->rank == 0 || elemental_proc || !nodesc_arg)
6304 && !expr_may_alias_variables (e, elemental_proc))
6307 /* It is known the e returns a structure type with at least one
6308 allocatable component. When e is a function, ensure that the
6309 function is called once only by using a temporary variable. */
6310 if (!DECL_P (parmse.expr))
6311 parmse.expr = gfc_evaluate_now_loc (input_location,
6312 parmse.expr, &se->pre);
6314 if (fsym && fsym->attr.value)
6317 tmp = build_fold_indirect_ref_loc (input_location,
6320 parm_rank = e->rank;
6328 case (SCALAR_POINTER):
6329 tmp = build_fold_indirect_ref_loc (input_location,
6334 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
6336 /* The derived type is passed to gfc_deallocate_alloc_comp.
6337 Therefore, class actuals can be handled correctly but derived
6338 types passed to class formals need the _data component. */
6339 tmp = gfc_class_data_get (tmp);
6340 if (!CLASS_DATA (fsym)->attr.dimension)
6341 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6344 if (e->expr_type == EXPR_OP
6345 && e->value.op.op == INTRINSIC_PARENTHESES
6346 && e->value.op.op1->expr_type == EXPR_VARIABLE)
6349 local_tmp = gfc_evaluate_now (tmp, &se->pre);
6350 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
6352 gfc_add_expr_to_block (&se->post, local_tmp);
6355 if (!finalized && !e->must_finalize)
6357 if ((e->ts.type == BT_CLASS
6358 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
6359 || e->ts.type == BT_DERIVED)
6360 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
6362 else if (e->ts.type == BT_CLASS)
6363 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
6365 gfc_prepend_expr_to_block (&post, tmp);
6369 /* Add argument checking of passing an unallocated/NULL actual to
6370 a nonallocatable/nonpointer dummy. */
6372 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
6374 symbol_attribute attr;
6378 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
6379 attr = gfc_expr_attr (e);
6381 goto end_pointer_check;
6383 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6384 allocatable to an optional dummy, cf. 12.5.2.12. */
6385 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
6386 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6387 goto end_pointer_check;
6391 /* If the actual argument is an optional pointer/allocatable and
6392 the formal argument takes an nonpointer optional value,
6393 it is invalid to pass a non-present argument on, even
6394 though there is no technical reason for this in gfortran.
6395 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6396 tree present, null_ptr, type;
6398 if (attr.allocatable
6399 && (fsym == NULL || !fsym->attr.allocatable))
6400 msg = xasprintf ("Allocatable actual argument '%s' is not "
6401 "allocated or not present",
6402 e->symtree->n.sym->name);
6403 else if (attr.pointer
6404 && (fsym == NULL || !fsym->attr.pointer))
6405 msg = xasprintf ("Pointer actual argument '%s' is not "
6406 "associated or not present",
6407 e->symtree->n.sym->name);
6408 else if (attr.proc_pointer
6409 && (fsym == NULL || !fsym->attr.proc_pointer))
6410 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6411 "associated or not present",
6412 e->symtree->n.sym->name);
6414 goto end_pointer_check;
6416 present = gfc_conv_expr_present (e->symtree->n.sym);
6417 type = TREE_TYPE (present);
6418 present = fold_build2_loc (input_location, EQ_EXPR,
6419 logical_type_node, present,
6421 null_pointer_node));
6422 type = TREE_TYPE (parmse.expr);
6423 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
6424 logical_type_node, parmse.expr,
6426 null_pointer_node));
6427 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6428 logical_type_node, present, null_ptr);
6432 if (attr.allocatable
6433 && (fsym == NULL || !fsym->attr.allocatable))
6434 msg = xasprintf ("Allocatable actual argument '%s' is not "
6435 "allocated", e->symtree->n.sym->name);
6436 else if (attr.pointer
6437 && (fsym == NULL || !fsym->attr.pointer))
6438 msg = xasprintf ("Pointer actual argument '%s' is not "
6439 "associated", e->symtree->n.sym->name);
6440 else if (attr.proc_pointer
6441 && (fsym == NULL || !fsym->attr.proc_pointer))
6442 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6443 "associated", e->symtree->n.sym->name);
6445 goto end_pointer_check;
6449 /* If the argument is passed by value, we need to strip the
6451 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
6452 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6454 cond = fold_build2_loc (input_location, EQ_EXPR,
6455 logical_type_node, tmp,
6456 fold_convert (TREE_TYPE (tmp),
6457 null_pointer_node));
6460 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
6466 /* Deferred length dummies pass the character length by reference
6467 so that the value can be returned. */
6468 if (parmse.string_length && fsym && fsym->ts.deferred)
6470 if (INDIRECT_REF_P (parmse.string_length))
6471 /* In chains of functions/procedure calls the string_length already
6472 is a pointer to the variable holding the length. Therefore
6473 remove the deref on call. */
6474 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
6477 tmp = parmse.string_length;
6478 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
6479 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
6480 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
6484 /* Character strings are passed as two parameters, a length and a
6485 pointer - except for Bind(c) which only passes the pointer.
6486 An unlimited polymorphic formal argument likewise does not
6488 if (parmse.string_length != NULL_TREE
6489 && !sym->attr.is_bind_c
6490 && !(fsym && UNLIMITED_POLY (fsym)))
6491 vec_safe_push (stringargs, parmse.string_length);
6493 /* When calling __copy for character expressions to unlimited
6494 polymorphic entities, the dst argument needs a string length. */
6495 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
6496 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
6497 && arg->next && arg->next->expr
6498 && (arg->next->expr->ts.type == BT_DERIVED
6499 || arg->next->expr->ts.type == BT_CLASS)
6500 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
6501 vec_safe_push (stringargs, parmse.string_length);
6503 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6504 pass the token and the offset as additional arguments. */
6505 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
6506 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6507 && !fsym->attr.allocatable)
6508 || (fsym->ts.type == BT_CLASS
6509 && CLASS_DATA (fsym)->attr.codimension
6510 && !CLASS_DATA (fsym)->attr.allocatable)))
6512 /* Token and offset. */
6513 vec_safe_push (stringargs, null_pointer_node);
6514 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
6515 gcc_assert (fsym->attr.optional);
6517 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
6518 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6519 && !fsym->attr.allocatable)
6520 || (fsym->ts.type == BT_CLASS
6521 && CLASS_DATA (fsym)->attr.codimension
6522 && !CLASS_DATA (fsym)->attr.allocatable)))
6524 tree caf_decl, caf_type;
6527 caf_decl = gfc_get_tree_for_caf_expr (e);
6528 caf_type = TREE_TYPE (caf_decl);
6530 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6531 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
6532 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
6533 tmp = gfc_conv_descriptor_token (caf_decl);
6534 else if (DECL_LANG_SPECIFIC (caf_decl)
6535 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
6536 tmp = GFC_DECL_TOKEN (caf_decl);
6539 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
6540 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
6541 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
6544 vec_safe_push (stringargs, tmp);
6546 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6547 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
6548 offset = build_int_cst (gfc_array_index_type, 0);
6549 else if (DECL_LANG_SPECIFIC (caf_decl)
6550 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
6551 offset = GFC_DECL_CAF_OFFSET (caf_decl);
6552 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
6553 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
6555 offset = build_int_cst (gfc_array_index_type, 0);
6557 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
6558 tmp = gfc_conv_descriptor_data_get (caf_decl);
6561 gcc_assert (POINTER_TYPE_P (caf_type));
6565 tmp2 = fsym->ts.type == BT_CLASS
6566 ? gfc_class_data_get (parmse.expr) : parmse.expr;
6567 if ((fsym->ts.type != BT_CLASS
6568 && (fsym->as->type == AS_ASSUMED_SHAPE
6569 || fsym->as->type == AS_ASSUMED_RANK))
6570 || (fsym->ts.type == BT_CLASS
6571 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6572 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6574 if (fsym->ts.type == BT_CLASS)
6575 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6578 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6579 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6581 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6582 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6584 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6585 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6588 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6591 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6592 gfc_array_index_type,
6593 fold_convert (gfc_array_index_type, tmp2),
6594 fold_convert (gfc_array_index_type, tmp));
6595 offset = fold_build2_loc (input_location, PLUS_EXPR,
6596 gfc_array_index_type, offset, tmp);
6598 vec_safe_push (stringargs, offset);
6601 vec_safe_push (arglist, parmse.expr);
6603 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6607 else if (sym->ts.type == BT_CLASS)
6608 ts = CLASS_DATA (sym)->ts;
6612 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6613 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6614 else if (ts.type == BT_CHARACTER)
6616 if (ts.u.cl->length == NULL)
6618 /* Assumed character length results are not allowed by C418 of the 2003
6619 standard and are trapped in resolve.c; except in the case of SPREAD
6620 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6621 we take the character length of the first argument for the result.
6622 For dummies, we have to look through the formal argument list for
6623 this function and use the character length found there.*/
6625 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6626 else if (!sym->attr.dummy)
6627 cl.backend_decl = (*stringargs)[0];
6630 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6631 for (; formal; formal = formal->next)
6632 if (strcmp (formal->sym->name, sym->name) == 0)
6633 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6635 len = cl.backend_decl;
6641 /* Calculate the length of the returned string. */
6642 gfc_init_se (&parmse, NULL);
6643 if (need_interface_mapping)
6644 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6646 gfc_conv_expr (&parmse, ts.u.cl->length);
6647 gfc_add_block_to_block (&se->pre, &parmse.pre);
6648 gfc_add_block_to_block (&se->post, &parmse.post);
6650 /* TODO: It would be better to have the charlens as
6651 gfc_charlen_type_node already when the interface is
6652 created instead of converting it here (see PR 84615). */
6653 tmp = fold_build2_loc (input_location, MAX_EXPR,
6654 gfc_charlen_type_node,
6655 fold_convert (gfc_charlen_type_node, tmp),
6656 build_zero_cst (gfc_charlen_type_node));
6657 cl.backend_decl = tmp;
6660 /* Set up a charlen structure for it. */
6665 len = cl.backend_decl;
6668 byref = (comp && (comp->attr.dimension
6669 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6670 || (!comp && gfc_return_by_reference (sym));
6673 if (se->direct_byref)
6675 /* Sometimes, too much indirection can be applied; e.g. for
6676 function_result = array_valued_recursive_function. */
6677 if (TREE_TYPE (TREE_TYPE (se->expr))
6678 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6679 && GFC_DESCRIPTOR_TYPE_P
6680 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6681 se->expr = build_fold_indirect_ref_loc (input_location,
6684 /* If the lhs of an assignment x = f(..) is allocatable and
6685 f2003 is allowed, we must do the automatic reallocation.
6686 TODO - deal with intrinsics, without using a temporary. */
6687 if (flag_realloc_lhs
6688 && se->ss && se->ss->loop_chain
6689 && se->ss->loop_chain->is_alloc_lhs
6690 && !expr->value.function.isym
6691 && sym->result->as != NULL)
6693 /* Evaluate the bounds of the result, if known. */
6694 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6697 /* Perform the automatic reallocation. */
6698 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6700 gfc_add_expr_to_block (&se->pre, tmp);
6702 /* Pass the temporary as the first argument. */
6703 result = info->descriptor;
6706 result = build_fold_indirect_ref_loc (input_location,
6708 vec_safe_push (retargs, se->expr);
6710 else if (comp && comp->attr.dimension)
6712 gcc_assert (se->loop && info);
6714 /* Set the type of the array. */
6715 tmp = gfc_typenode_for_spec (&comp->ts);
6716 gcc_assert (se->ss->dimen == se->loop->dimen);
6718 /* Evaluate the bounds of the result, if known. */
6719 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6721 /* If the lhs of an assignment x = f(..) is allocatable and
6722 f2003 is allowed, we must not generate the function call
6723 here but should just send back the results of the mapping.
6724 This is signalled by the function ss being flagged. */
6725 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6727 gfc_free_interface_mapping (&mapping);
6728 return has_alternate_specifier;
6731 /* Create a temporary to store the result. In case the function
6732 returns a pointer, the temporary will be a shallow copy and
6733 mustn't be deallocated. */
6734 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6735 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6736 tmp, NULL_TREE, false,
6737 !comp->attr.pointer, callee_alloc,
6738 &se->ss->info->expr->where);
6740 /* Pass the temporary as the first argument. */
6741 result = info->descriptor;
6742 tmp = gfc_build_addr_expr (NULL_TREE, result);
6743 vec_safe_push (retargs, tmp);
6745 else if (!comp && sym->result->attr.dimension)
6747 gcc_assert (se->loop && info);
6749 /* Set the type of the array. */
6750 tmp = gfc_typenode_for_spec (&ts);
6751 gcc_assert (se->ss->dimen == se->loop->dimen);
6753 /* Evaluate the bounds of the result, if known. */
6754 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6756 /* If the lhs of an assignment x = f(..) is allocatable and
6757 f2003 is allowed, we must not generate the function call
6758 here but should just send back the results of the mapping.
6759 This is signalled by the function ss being flagged. */
6760 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6762 gfc_free_interface_mapping (&mapping);
6763 return has_alternate_specifier;
6766 /* Create a temporary to store the result. In case the function
6767 returns a pointer, the temporary will be a shallow copy and
6768 mustn't be deallocated. */
6769 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6770 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6771 tmp, NULL_TREE, false,
6772 !sym->attr.pointer, callee_alloc,
6773 &se->ss->info->expr->where);
6775 /* Pass the temporary as the first argument. */
6776 result = info->descriptor;
6777 tmp = gfc_build_addr_expr (NULL_TREE, result);
6778 vec_safe_push (retargs, tmp);
6780 else if (ts.type == BT_CHARACTER)
6782 /* Pass the string length. */
6783 type = gfc_get_character_type (ts.kind, ts.u.cl);
6784 type = build_pointer_type (type);
6786 /* Emit a DECL_EXPR for the VLA type. */
6787 tmp = TREE_TYPE (type);
6789 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6791 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6792 DECL_ARTIFICIAL (tmp) = 1;
6793 DECL_IGNORED_P (tmp) = 1;
6794 tmp = fold_build1_loc (input_location, DECL_EXPR,
6795 TREE_TYPE (tmp), tmp);
6796 gfc_add_expr_to_block (&se->pre, tmp);
6799 /* Return an address to a char[0:len-1]* temporary for
6800 character pointers. */
6801 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6802 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6804 var = gfc_create_var (type, "pstr");
6806 if ((!comp && sym->attr.allocatable)
6807 || (comp && comp->attr.allocatable))
6809 gfc_add_modify (&se->pre, var,
6810 fold_convert (TREE_TYPE (var),
6811 null_pointer_node));
6812 tmp = gfc_call_free (var);
6813 gfc_add_expr_to_block (&se->post, tmp);
6816 /* Provide an address expression for the function arguments. */
6817 var = gfc_build_addr_expr (NULL_TREE, var);
6820 var = gfc_conv_string_tmp (se, type, len);
6822 vec_safe_push (retargs, var);
6826 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6828 type = gfc_get_complex_type (ts.kind);
6829 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6830 vec_safe_push (retargs, var);
6833 /* Add the string length to the argument list. */
6834 if (ts.type == BT_CHARACTER && ts.deferred)
6838 tmp = gfc_evaluate_now (len, &se->pre);
6839 TREE_STATIC (tmp) = 1;
6840 gfc_add_modify (&se->pre, tmp,
6841 build_int_cst (TREE_TYPE (tmp), 0));
6842 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6843 vec_safe_push (retargs, tmp);
6845 else if (ts.type == BT_CHARACTER)
6846 vec_safe_push (retargs, len);
6848 gfc_free_interface_mapping (&mapping);
6850 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6851 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6852 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6853 vec_safe_reserve (retargs, arglen);
6855 /* Add the return arguments. */
6856 vec_safe_splice (retargs, arglist);
6858 /* Add the hidden present status for optional+value to the arguments. */
6859 vec_safe_splice (retargs, optionalargs);
6861 /* Add the hidden string length parameters to the arguments. */
6862 vec_safe_splice (retargs, stringargs);
6864 /* We may want to append extra arguments here. This is used e.g. for
6865 calls to libgfortran_matmul_??, which need extra information. */
6866 vec_safe_splice (retargs, append_args);
6870 /* Generate the actual call. */
6871 if (base_object == NULL_TREE)
6872 conv_function_val (se, sym, expr, args);
6874 conv_base_obj_fcn_val (se, base_object, expr);
6876 /* If there are alternate return labels, function type should be
6877 integer. Can't modify the type in place though, since it can be shared
6878 with other functions. For dummy arguments, the typing is done to
6879 this result, even if it has to be repeated for each call. */
6880 if (has_alternate_specifier
6881 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6883 if (!sym->attr.dummy)
6885 TREE_TYPE (sym->backend_decl)
6886 = build_function_type (integer_type_node,
6887 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6888 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6891 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6894 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6895 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6897 /* Allocatable scalar function results must be freed and nullified
6898 after use. This necessitates the creation of a temporary to
6899 hold the result to prevent duplicate calls. */
6900 if (!byref && sym->ts.type != BT_CHARACTER
6901 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6902 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6904 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6905 gfc_add_modify (&se->pre, tmp, se->expr);
6907 tmp = gfc_call_free (tmp);
6908 gfc_add_expr_to_block (&post, tmp);
6909 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6912 /* If we have a pointer function, but we don't want a pointer, e.g.
6915 where f is pointer valued, we have to dereference the result. */
6916 if (!se->want_pointer && !byref
6917 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6918 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6919 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6921 /* f2c calling conventions require a scalar default real function to
6922 return a double precision result. Convert this back to default
6923 real. We only care about the cases that can happen in Fortran 77.
6925 if (flag_f2c && sym->ts.type == BT_REAL
6926 && sym->ts.kind == gfc_default_real_kind
6927 && !sym->attr.always_explicit)
6928 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6930 /* A pure function may still have side-effects - it may modify its
6932 TREE_SIDE_EFFECTS (se->expr) = 1;
6934 if (!sym->attr.pure)
6935 TREE_SIDE_EFFECTS (se->expr) = 1;
6940 /* Add the function call to the pre chain. There is no expression. */
6941 gfc_add_expr_to_block (&se->pre, se->expr);
6942 se->expr = NULL_TREE;
6944 if (!se->direct_byref)
6946 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6948 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6950 /* Check the data pointer hasn't been modified. This would
6951 happen in a function returning a pointer. */
6952 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6953 tmp = fold_build2_loc (input_location, NE_EXPR,
6956 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6959 se->expr = info->descriptor;
6960 /* Bundle in the string length. */
6961 se->string_length = len;
6963 else if (ts.type == BT_CHARACTER)
6965 /* Dereference for character pointer results. */
6966 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6967 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6968 se->expr = build_fold_indirect_ref_loc (input_location, var);
6972 se->string_length = len;
6976 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6977 se->expr = build_fold_indirect_ref_loc (input_location, var);
6982 /* Associate the rhs class object's meta-data with the result, when the
6983 result is a temporary. */
6984 if (args && args->expr && args->expr->ts.type == BT_CLASS
6985 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6986 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6989 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6991 gfc_init_se (&parmse, NULL);
6992 parmse.data_not_needed = 1;
6993 gfc_conv_expr (&parmse, class_expr);
6994 if (!DECL_LANG_SPECIFIC (result))
6995 gfc_allocate_lang_decl (result);
6996 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6997 gfc_free_expr (class_expr);
6998 gcc_assert (parmse.pre.head == NULL_TREE
6999 && parmse.post.head == NULL_TREE);
7002 /* Follow the function call with the argument post block. */
7005 gfc_add_block_to_block (&se->pre, &post);
7007 /* Transformational functions of derived types with allocatable
7008 components must have the result allocatable components copied when the
7009 argument is actually given. */
7010 arg = expr->value.function.actual;
7011 if (result && arg && expr->rank
7012 && expr->value.function.isym
7013 && expr->value.function.isym->transformational
7015 && arg->expr->ts.type == BT_DERIVED
7016 && arg->expr->ts.u.derived->attr.alloc_comp)
7019 /* Copy the allocatable components. We have to use a
7020 temporary here to prevent source allocatable components
7021 from being corrupted. */
7022 tmp2 = gfc_evaluate_now (result, &se->pre);
7023 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
7024 result, tmp2, expr->rank, 0);
7025 gfc_add_expr_to_block (&se->pre, tmp);
7026 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
7028 gfc_add_expr_to_block (&se->pre, tmp);
7030 /* Finally free the temporary's data field. */
7031 tmp = gfc_conv_descriptor_data_get (tmp2);
7032 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
7033 NULL_TREE, NULL_TREE, true,
7034 NULL, GFC_CAF_COARRAY_NOCOARRAY);
7035 gfc_add_expr_to_block (&se->pre, tmp);
7040 /* For a function with a class array result, save the result as
7041 a temporary, set the info fields needed by the scalarizer and
7042 call the finalization function of the temporary. Note that the
7043 nullification of allocatable components needed by the result
7044 is done in gfc_trans_assignment_1. */
7045 if (expr && ((gfc_is_class_array_function (expr)
7046 && se->ss && se->ss->loop)
7047 || gfc_is_alloc_class_scalar_function (expr))
7048 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
7049 && expr->must_finalize)
7054 if (se->ss && se->ss->loop)
7056 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
7057 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
7058 tmp = gfc_class_data_get (se->expr);
7059 info->descriptor = tmp;
7060 info->data = gfc_conv_descriptor_data_get (tmp);
7061 info->offset = gfc_conv_descriptor_offset_get (tmp);
7062 for (n = 0; n < se->ss->loop->dimen; n++)
7064 tree dim = gfc_rank_cst[n];
7065 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
7066 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
7071 /* TODO Eliminate the doubling of temporaries. This
7072 one is necessary to ensure no memory leakage. */
7073 se->expr = gfc_evaluate_now (se->expr, &se->pre);
7074 tmp = gfc_class_data_get (se->expr);
7075 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
7076 CLASS_DATA (expr->value.function.esym->result)->attr);
7079 if ((gfc_is_class_array_function (expr)
7080 || gfc_is_alloc_class_scalar_function (expr))
7081 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
7082 goto no_finalization;
7084 final_fndecl = gfc_class_vtab_final_get (se->expr);
7085 is_final = fold_build2_loc (input_location, NE_EXPR,
7088 fold_convert (TREE_TYPE (final_fndecl),
7089 null_pointer_node));
7090 final_fndecl = build_fold_indirect_ref_loc (input_location,
7092 tmp = build_call_expr_loc (input_location,
7094 gfc_build_addr_expr (NULL, tmp),
7095 gfc_class_vtab_size_get (se->expr),
7096 boolean_false_node);
7097 tmp = fold_build3_loc (input_location, COND_EXPR,
7098 void_type_node, is_final, tmp,
7099 build_empty_stmt (input_location));
7101 if (se->ss && se->ss->loop)
7103 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
7104 tmp = fold_build2_loc (input_location, NE_EXPR,
7107 fold_convert (TREE_TYPE (info->data),
7108 null_pointer_node));
7109 tmp = fold_build3_loc (input_location, COND_EXPR,
7110 void_type_node, tmp,
7111 gfc_call_free (info->data),
7112 build_empty_stmt (input_location));
7113 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
7118 gfc_prepend_expr_to_block (&se->post, tmp);
7119 classdata = gfc_class_data_get (se->expr);
7120 tmp = fold_build2_loc (input_location, NE_EXPR,
7123 fold_convert (TREE_TYPE (classdata),
7124 null_pointer_node));
7125 tmp = fold_build3_loc (input_location, COND_EXPR,
7126 void_type_node, tmp,
7127 gfc_call_free (classdata),
7128 build_empty_stmt (input_location));
7129 gfc_add_expr_to_block (&se->post, tmp);
7134 gfc_add_block_to_block (&se->post, &post);
7137 return has_alternate_specifier;
7141 /* Fill a character string with spaces. */
7144 fill_with_spaces (tree start, tree type, tree size)
7146 stmtblock_t block, loop;
7147 tree i, el, exit_label, cond, tmp;
7149 /* For a simple char type, we can call memset(). */
7150 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
7151 return build_call_expr_loc (input_location,
7152 builtin_decl_explicit (BUILT_IN_MEMSET),
7154 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
7155 lang_hooks.to_target_charset (' ')),
7156 fold_convert (size_type_node, size));
7158 /* Otherwise, we use a loop:
7159 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7163 /* Initialize variables. */
7164 gfc_init_block (&block);
7165 i = gfc_create_var (sizetype, "i");
7166 gfc_add_modify (&block, i, fold_convert (sizetype, size));
7167 el = gfc_create_var (build_pointer_type (type), "el");
7168 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
7169 exit_label = gfc_build_label_decl (NULL_TREE);
7170 TREE_USED (exit_label) = 1;
7174 gfc_init_block (&loop);
7176 /* Exit condition. */
7177 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
7178 build_zero_cst (sizetype));
7179 tmp = build1_v (GOTO_EXPR, exit_label);
7180 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7181 build_empty_stmt (input_location));
7182 gfc_add_expr_to_block (&loop, tmp);
7185 gfc_add_modify (&loop,
7186 fold_build1_loc (input_location, INDIRECT_REF, type, el),
7187 build_int_cst (type, lang_hooks.to_target_charset (' ')));
7189 /* Increment loop variables. */
7190 gfc_add_modify (&loop, i,
7191 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
7192 TYPE_SIZE_UNIT (type)));
7193 gfc_add_modify (&loop, el,
7194 fold_build_pointer_plus_loc (input_location,
7195 el, TYPE_SIZE_UNIT (type)));
7197 /* Making the loop... actually loop! */
7198 tmp = gfc_finish_block (&loop);
7199 tmp = build1_v (LOOP_EXPR, tmp);
7200 gfc_add_expr_to_block (&block, tmp);
7202 /* The exit label. */
7203 tmp = build1_v (LABEL_EXPR, exit_label);
7204 gfc_add_expr_to_block (&block, tmp);
7207 return gfc_finish_block (&block);
7211 /* Generate code to copy a string. */
7214 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
7215 int dkind, tree slength, tree src, int skind)
7217 tree tmp, dlen, slen;
7226 stmtblock_t tempblock;
7228 gcc_assert (dkind == skind);
7230 if (slength != NULL_TREE)
7232 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
7233 ssc = gfc_string_to_single_character (slen, src, skind);
7237 slen = build_one_cst (gfc_charlen_type_node);
7241 if (dlength != NULL_TREE)
7243 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
7244 dsc = gfc_string_to_single_character (dlen, dest, dkind);
7248 dlen = build_one_cst (gfc_charlen_type_node);
7252 /* Assign directly if the types are compatible. */
7253 if (dsc != NULL_TREE && ssc != NULL_TREE
7254 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
7256 gfc_add_modify (block, dsc, ssc);
7260 /* The string copy algorithm below generates code like
7264 if (srclen < destlen)
7266 memmove (dest, src, srclen);
7268 memset (&dest[srclen], ' ', destlen - srclen);
7272 // Truncate if too long.
7273 memmove (dest, src, destlen);
7278 /* Do nothing if the destination length is zero. */
7279 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
7280 build_zero_cst (TREE_TYPE (dlen)));
7282 /* For non-default character kinds, we have to multiply the string
7283 length by the base type size. */
7284 chartype = gfc_get_char_type (dkind);
7285 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
7287 fold_convert (TREE_TYPE (slen),
7288 TYPE_SIZE_UNIT (chartype)));
7289 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
7291 fold_convert (TREE_TYPE (dlen),
7292 TYPE_SIZE_UNIT (chartype)));
7294 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
7295 dest = fold_convert (pvoid_type_node, dest);
7297 dest = gfc_build_addr_expr (pvoid_type_node, dest);
7299 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
7300 src = fold_convert (pvoid_type_node, src);
7302 src = gfc_build_addr_expr (pvoid_type_node, src);
7304 /* Truncate string if source is too long. */
7305 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
7308 /* Copy and pad with spaces. */
7309 tmp3 = build_call_expr_loc (input_location,
7310 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7312 fold_convert (size_type_node, slen));
7314 /* Wstringop-overflow appears at -O3 even though this warning is not
7315 explicitly available in fortran nor can it be switched off. If the
7316 source length is a constant, its negative appears as a very large
7317 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7318 the result of the MINUS_EXPR suppresses this spurious warning. */
7319 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7320 TREE_TYPE(dlen), dlen, slen);
7321 if (slength && TREE_CONSTANT (slength))
7322 tmp = gfc_evaluate_now (tmp, block);
7324 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
7325 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
7327 gfc_init_block (&tempblock);
7328 gfc_add_expr_to_block (&tempblock, tmp3);
7329 gfc_add_expr_to_block (&tempblock, tmp4);
7330 tmp3 = gfc_finish_block (&tempblock);
7332 /* The truncated memmove if the slen >= dlen. */
7333 tmp2 = build_call_expr_loc (input_location,
7334 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7336 fold_convert (size_type_node, dlen));
7338 /* The whole copy_string function is there. */
7339 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
7341 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7342 build_empty_stmt (input_location));
7343 gfc_add_expr_to_block (block, tmp);
7347 /* Translate a statement function.
7348 The value of a statement function reference is obtained by evaluating the
7349 expression using the values of the actual arguments for the values of the
7350 corresponding dummy arguments. */
7353 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
7357 gfc_formal_arglist *fargs;
7358 gfc_actual_arglist *args;
7361 gfc_saved_var *saved_vars;
7367 sym = expr->symtree->n.sym;
7368 args = expr->value.function.actual;
7369 gfc_init_se (&lse, NULL);
7370 gfc_init_se (&rse, NULL);
7373 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
7375 saved_vars = XCNEWVEC (gfc_saved_var, n);
7376 temp_vars = XCNEWVEC (tree, n);
7378 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7379 fargs = fargs->next, n++)
7381 /* Each dummy shall be specified, explicitly or implicitly, to be
7383 gcc_assert (fargs->sym->attr.dimension == 0);
7386 if (fsym->ts.type == BT_CHARACTER)
7388 /* Copy string arguments. */
7391 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
7392 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
7394 /* Create a temporary to hold the value. */
7395 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
7396 fsym->ts.u.cl->backend_decl
7397 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
7399 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
7400 temp_vars[n] = gfc_create_var (type, fsym->name);
7402 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
7404 gfc_conv_expr (&rse, args->expr);
7405 gfc_conv_string_parameter (&rse);
7406 gfc_add_block_to_block (&se->pre, &lse.pre);
7407 gfc_add_block_to_block (&se->pre, &rse.pre);
7409 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
7410 rse.string_length, rse.expr, fsym->ts.kind);
7411 gfc_add_block_to_block (&se->pre, &lse.post);
7412 gfc_add_block_to_block (&se->pre, &rse.post);
7416 /* For everything else, just evaluate the expression. */
7418 /* Create a temporary to hold the value. */
7419 type = gfc_typenode_for_spec (&fsym->ts);
7420 temp_vars[n] = gfc_create_var (type, fsym->name);
7422 gfc_conv_expr (&lse, args->expr);
7424 gfc_add_block_to_block (&se->pre, &lse.pre);
7425 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
7426 gfc_add_block_to_block (&se->pre, &lse.post);
7432 /* Use the temporary variables in place of the real ones. */
7433 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7434 fargs = fargs->next, n++)
7435 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
7437 gfc_conv_expr (se, sym->value);
7439 if (sym->ts.type == BT_CHARACTER)
7441 gfc_conv_const_charlen (sym->ts.u.cl);
7443 /* Force the expression to the correct length. */
7444 if (!INTEGER_CST_P (se->string_length)
7445 || tree_int_cst_lt (se->string_length,
7446 sym->ts.u.cl->backend_decl))
7448 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
7449 tmp = gfc_create_var (type, sym->name);
7450 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
7451 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
7452 sym->ts.kind, se->string_length, se->expr,
7456 se->string_length = sym->ts.u.cl->backend_decl;
7459 /* Restore the original variables. */
7460 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7461 fargs = fargs->next, n++)
7462 gfc_restore_sym (fargs->sym, &saved_vars[n]);
7468 /* Translate a function expression. */
7471 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
7475 if (expr->value.function.isym)
7477 gfc_conv_intrinsic_function (se, expr);
7481 /* expr.value.function.esym is the resolved (specific) function symbol for
7482 most functions. However this isn't set for dummy procedures. */
7483 sym = expr->value.function.esym;
7485 sym = expr->symtree->n.sym;
7487 /* The IEEE_ARITHMETIC functions are caught here. */
7488 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
7489 if (gfc_conv_ieee_arithmetic_function (se, expr))
7492 /* We distinguish statement functions from general functions to improve
7493 runtime performance. */
7494 if (sym->attr.proc == PROC_ST_FUNCTION)
7496 gfc_conv_statement_function (se, expr);
7500 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7505 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7508 is_zero_initializer_p (gfc_expr * expr)
7510 if (expr->expr_type != EXPR_CONSTANT)
7513 /* We ignore constants with prescribed memory representations for now. */
7514 if (expr->representation.string)
7517 switch (expr->ts.type)
7520 return mpz_cmp_si (expr->value.integer, 0) == 0;
7523 return mpfr_zero_p (expr->value.real)
7524 && MPFR_SIGN (expr->value.real) >= 0;
7527 return expr->value.logical == 0;
7530 return mpfr_zero_p (mpc_realref (expr->value.complex))
7531 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
7532 && mpfr_zero_p (mpc_imagref (expr->value.complex))
7533 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
7543 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
7548 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
7549 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
7551 gfc_conv_tmp_array_ref (se);
7555 /* Build a static initializer. EXPR is the expression for the initial value.
7556 The other parameters describe the variable of the component being
7557 initialized. EXPR may be null. */
7560 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
7561 bool array, bool pointer, bool procptr)
7565 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
7566 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7567 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7568 return build_constructor (type, NULL);
7570 if (!(expr || pointer || procptr))
7573 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7574 (these are the only two iso_c_binding derived types that can be
7575 used as initialization expressions). If so, we need to modify
7576 the 'expr' to be that for a (void *). */
7577 if (expr != NULL && expr->ts.type == BT_DERIVED
7578 && expr->ts.is_iso_c && expr->ts.u.derived)
7580 if (TREE_CODE (type) == ARRAY_TYPE)
7581 return build_constructor (type, NULL);
7582 else if (POINTER_TYPE_P (type))
7583 return build_int_cst (type, 0);
7588 if (array && !procptr)
7591 /* Arrays need special handling. */
7593 ctor = gfc_build_null_descriptor (type);
7594 /* Special case assigning an array to zero. */
7595 else if (is_zero_initializer_p (expr))
7596 ctor = build_constructor (type, NULL);
7598 ctor = gfc_conv_array_initializer (type, expr);
7599 TREE_STATIC (ctor) = 1;
7602 else if (pointer || procptr)
7604 if (ts->type == BT_CLASS && !procptr)
7606 gfc_init_se (&se, NULL);
7607 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7608 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7609 TREE_STATIC (se.expr) = 1;
7612 else if (!expr || expr->expr_type == EXPR_NULL)
7613 return fold_convert (type, null_pointer_node);
7616 gfc_init_se (&se, NULL);
7617 se.want_pointer = 1;
7618 gfc_conv_expr (&se, expr);
7619 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7629 gfc_init_se (&se, NULL);
7630 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7631 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7633 gfc_conv_structure (&se, expr, 1);
7634 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7635 TREE_STATIC (se.expr) = 1;
7640 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7641 TREE_STATIC (ctor) = 1;
7646 gfc_init_se (&se, NULL);
7647 gfc_conv_constant (&se, expr);
7648 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7655 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7661 gfc_array_info *lss_array;
7668 gfc_start_block (&block);
7670 /* Initialize the scalarizer. */
7671 gfc_init_loopinfo (&loop);
7673 gfc_init_se (&lse, NULL);
7674 gfc_init_se (&rse, NULL);
7677 rss = gfc_walk_expr (expr);
7678 if (rss == gfc_ss_terminator)
7679 /* The rhs is scalar. Add a ss for the expression. */
7680 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7682 /* Create a SS for the destination. */
7683 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7685 lss_array = &lss->info->data.array;
7686 lss_array->shape = gfc_get_shape (cm->as->rank);
7687 lss_array->descriptor = dest;
7688 lss_array->data = gfc_conv_array_data (dest);
7689 lss_array->offset = gfc_conv_array_offset (dest);
7690 for (n = 0; n < cm->as->rank; n++)
7692 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7693 lss_array->stride[n] = gfc_index_one_node;
7695 mpz_init (lss_array->shape[n]);
7696 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7697 cm->as->lower[n]->value.integer);
7698 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7701 /* Associate the SS with the loop. */
7702 gfc_add_ss_to_loop (&loop, lss);
7703 gfc_add_ss_to_loop (&loop, rss);
7705 /* Calculate the bounds of the scalarization. */
7706 gfc_conv_ss_startstride (&loop);
7708 /* Setup the scalarizing loops. */
7709 gfc_conv_loop_setup (&loop, &expr->where);
7711 /* Setup the gfc_se structures. */
7712 gfc_copy_loopinfo_to_se (&lse, &loop);
7713 gfc_copy_loopinfo_to_se (&rse, &loop);
7716 gfc_mark_ss_chain_used (rss, 1);
7718 gfc_mark_ss_chain_used (lss, 1);
7720 /* Start the scalarized loop body. */
7721 gfc_start_scalarized_body (&loop, &body);
7723 gfc_conv_tmp_array_ref (&lse);
7724 if (cm->ts.type == BT_CHARACTER)
7725 lse.string_length = cm->ts.u.cl->backend_decl;
7727 gfc_conv_expr (&rse, expr);
7729 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7730 gfc_add_expr_to_block (&body, tmp);
7732 gcc_assert (rse.ss == gfc_ss_terminator);
7734 /* Generate the copying loops. */
7735 gfc_trans_scalarizing_loops (&loop, &body);
7737 /* Wrap the whole thing up. */
7738 gfc_add_block_to_block (&block, &loop.pre);
7739 gfc_add_block_to_block (&block, &loop.post);
7741 gcc_assert (lss_array->shape != NULL);
7742 gfc_free_shape (&lss_array->shape, cm->as->rank);
7743 gfc_cleanup_loop (&loop);
7745 return gfc_finish_block (&block);
7750 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7760 gfc_expr *arg = NULL;
7762 gfc_start_block (&block);
7763 gfc_init_se (&se, NULL);
7765 /* Get the descriptor for the expressions. */
7766 se.want_pointer = 0;
7767 gfc_conv_expr_descriptor (&se, expr);
7768 gfc_add_block_to_block (&block, &se.pre);
7769 gfc_add_modify (&block, dest, se.expr);
7771 /* Deal with arrays of derived types with allocatable components. */
7772 if (gfc_bt_struct (cm->ts.type)
7773 && cm->ts.u.derived->attr.alloc_comp)
7774 // TODO: Fix caf_mode
7775 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7778 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7779 && CLASS_DATA(cm)->attr.allocatable)
7781 if (cm->ts.u.derived->attr.alloc_comp)
7782 // TODO: Fix caf_mode
7783 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7788 tmp = TREE_TYPE (dest);
7789 tmp = gfc_duplicate_allocatable (dest, se.expr,
7790 tmp, expr->rank, NULL_TREE);
7794 tmp = gfc_duplicate_allocatable (dest, se.expr,
7795 TREE_TYPE(cm->backend_decl),
7796 cm->as->rank, NULL_TREE);
7798 gfc_add_expr_to_block (&block, tmp);
7799 gfc_add_block_to_block (&block, &se.post);
7801 if (expr->expr_type != EXPR_VARIABLE)
7802 gfc_conv_descriptor_data_set (&block, se.expr,
7805 /* We need to know if the argument of a conversion function is a
7806 variable, so that the correct lower bound can be used. */
7807 if (expr->expr_type == EXPR_FUNCTION
7808 && expr->value.function.isym
7809 && expr->value.function.isym->conversion
7810 && expr->value.function.actual->expr
7811 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7812 arg = expr->value.function.actual->expr;
7814 /* Obtain the array spec of full array references. */
7816 as = gfc_get_full_arrayspec_from_expr (arg);
7818 as = gfc_get_full_arrayspec_from_expr (expr);
7820 /* Shift the lbound and ubound of temporaries to being unity,
7821 rather than zero, based. Always calculate the offset. */
7822 offset = gfc_conv_descriptor_offset_get (dest);
7823 gfc_add_modify (&block, offset, gfc_index_zero_node);
7824 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7826 for (n = 0; n < expr->rank; n++)
7831 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7832 TODO It looks as if gfc_conv_expr_descriptor should return
7833 the correct bounds and that the following should not be
7834 necessary. This would simplify gfc_conv_intrinsic_bound
7836 if (as && as->lower[n])
7839 gfc_init_se (&lbse, NULL);
7840 gfc_conv_expr (&lbse, as->lower[n]);
7841 gfc_add_block_to_block (&block, &lbse.pre);
7842 lbound = gfc_evaluate_now (lbse.expr, &block);
7846 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7847 lbound = gfc_conv_descriptor_lbound_get (tmp,
7851 lbound = gfc_conv_descriptor_lbound_get (dest,
7854 lbound = gfc_index_one_node;
7856 lbound = fold_convert (gfc_array_index_type, lbound);
7858 /* Shift the bounds and set the offset accordingly. */
7859 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7860 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7861 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7862 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7864 gfc_conv_descriptor_ubound_set (&block, dest,
7865 gfc_rank_cst[n], tmp);
7866 gfc_conv_descriptor_lbound_set (&block, dest,
7867 gfc_rank_cst[n], lbound);
7869 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7870 gfc_conv_descriptor_lbound_get (dest,
7872 gfc_conv_descriptor_stride_get (dest,
7874 gfc_add_modify (&block, tmp2, tmp);
7875 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7877 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7882 /* If a conversion expression has a null data pointer
7883 argument, nullify the allocatable component. */
7887 if (arg->symtree->n.sym->attr.allocatable
7888 || arg->symtree->n.sym->attr.pointer)
7890 non_null_expr = gfc_finish_block (&block);
7891 gfc_start_block (&block);
7892 gfc_conv_descriptor_data_set (&block, dest,
7894 null_expr = gfc_finish_block (&block);
7895 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7896 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7897 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7898 return build3_v (COND_EXPR, tmp,
7899 null_expr, non_null_expr);
7903 return gfc_finish_block (&block);
7907 /* Allocate or reallocate scalar component, as necessary. */
7910 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7920 tree lhs_cl_size = NULL_TREE;
7925 if (!expr2 || expr2->rank)
7928 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7930 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7932 char name[GFC_MAX_SYMBOL_LEN+9];
7933 gfc_component *strlen;
7934 /* Use the rhs string length and the lhs element size. */
7935 gcc_assert (expr2->ts.type == BT_CHARACTER);
7936 if (!expr2->ts.u.cl->backend_decl)
7938 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7939 gcc_assert (expr2->ts.u.cl->backend_decl);
7942 size = expr2->ts.u.cl->backend_decl;
7944 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7946 sprintf (name, "_%s_length", cm->name);
7947 strlen = gfc_find_component (sym, name, true, true, NULL);
7948 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7949 gfc_charlen_type_node,
7950 TREE_OPERAND (comp, 0),
7951 strlen->backend_decl, NULL_TREE);
7953 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7954 tmp = TYPE_SIZE_UNIT (tmp);
7955 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7956 TREE_TYPE (tmp), tmp,
7957 fold_convert (TREE_TYPE (tmp), size));
7959 else if (cm->ts.type == BT_CLASS)
7961 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7962 if (expr2->ts.type == BT_DERIVED)
7964 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7965 size = TYPE_SIZE_UNIT (tmp);
7971 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7972 gfc_add_vptr_component (e2vtab);
7973 gfc_add_size_component (e2vtab);
7974 gfc_init_se (&se, NULL);
7975 gfc_conv_expr (&se, e2vtab);
7976 gfc_add_block_to_block (block, &se.pre);
7977 size = fold_convert (size_type_node, se.expr);
7978 gfc_free_expr (e2vtab);
7980 size_in_bytes = size;
7984 /* Otherwise use the length in bytes of the rhs. */
7985 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7986 size_in_bytes = size;
7989 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7990 size_in_bytes, size_one_node);
7992 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7994 tmp = build_call_expr_loc (input_location,
7995 builtin_decl_explicit (BUILT_IN_CALLOC),
7996 2, build_one_cst (size_type_node),
7998 tmp = fold_convert (TREE_TYPE (comp), tmp);
7999 gfc_add_modify (block, comp, tmp);
8003 tmp = build_call_expr_loc (input_location,
8004 builtin_decl_explicit (BUILT_IN_MALLOC),
8006 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
8007 ptr = gfc_class_data_get (comp);
8010 tmp = fold_convert (TREE_TYPE (ptr), tmp);
8011 gfc_add_modify (block, ptr, tmp);
8014 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8015 /* Update the lhs character length. */
8016 gfc_add_modify (block, lhs_cl_size,
8017 fold_convert (TREE_TYPE (lhs_cl_size), size));
8021 /* Assign a single component of a derived type constructor. */
8024 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
8025 gfc_symbol *sym, bool init)
8033 gfc_start_block (&block);
8035 if (cm->attr.pointer || cm->attr.proc_pointer)
8037 /* Only care about pointers here, not about allocatables. */
8038 gfc_init_se (&se, NULL);
8039 /* Pointer component. */
8040 if ((cm->attr.dimension || cm->attr.codimension)
8041 && !cm->attr.proc_pointer)
8043 /* Array pointer. */
8044 if (expr->expr_type == EXPR_NULL)
8045 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8048 se.direct_byref = 1;
8050 gfc_conv_expr_descriptor (&se, expr);
8051 gfc_add_block_to_block (&block, &se.pre);
8052 gfc_add_block_to_block (&block, &se.post);
8057 /* Scalar pointers. */
8058 se.want_pointer = 1;
8059 gfc_conv_expr (&se, expr);
8060 gfc_add_block_to_block (&block, &se.pre);
8062 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8063 && expr->symtree->n.sym->attr.dummy)
8064 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8066 gfc_add_modify (&block, dest,
8067 fold_convert (TREE_TYPE (dest), se.expr));
8068 gfc_add_block_to_block (&block, &se.post);
8071 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
8073 /* NULL initialization for CLASS components. */
8074 tmp = gfc_trans_structure_assign (dest,
8075 gfc_class_initializer (&cm->ts, expr),
8077 gfc_add_expr_to_block (&block, tmp);
8079 else if ((cm->attr.dimension || cm->attr.codimension)
8080 && !cm->attr.proc_pointer)
8082 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8083 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8084 else if (cm->attr.allocatable || cm->attr.pdt_array)
8086 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
8087 gfc_add_expr_to_block (&block, tmp);
8091 tmp = gfc_trans_subarray_assign (dest, cm, expr);
8092 gfc_add_expr_to_block (&block, tmp);
8095 else if (cm->ts.type == BT_CLASS
8096 && CLASS_DATA (cm)->attr.dimension
8097 && CLASS_DATA (cm)->attr.allocatable
8098 && expr->ts.type == BT_DERIVED)
8100 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8101 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8102 tmp = gfc_class_vptr_get (dest);
8103 gfc_add_modify (&block, tmp,
8104 fold_convert (TREE_TYPE (tmp), vtab));
8105 tmp = gfc_class_data_get (dest);
8106 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
8107 gfc_add_expr_to_block (&block, tmp);
8109 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8111 /* NULL initialization for allocatable components. */
8112 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
8113 null_pointer_node));
8115 else if (init && (cm->attr.allocatable
8116 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
8117 && expr->ts.type != BT_CLASS)))
8119 /* Take care about non-array allocatable components here. The alloc_*
8120 routine below is motivated by the alloc_scalar_allocatable_for_
8121 assignment() routine, but with the realloc portions removed and
8123 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
8128 /* The remainder of these instructions follow the if (cm->attr.pointer)
8129 if (!cm->attr.dimension) part above. */
8130 gfc_init_se (&se, NULL);
8131 gfc_conv_expr (&se, expr);
8132 gfc_add_block_to_block (&block, &se.pre);
8134 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8135 && expr->symtree->n.sym->attr.dummy)
8136 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8138 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
8140 tmp = gfc_class_data_get (dest);
8141 tmp = build_fold_indirect_ref_loc (input_location, tmp);
8142 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8143 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8144 gfc_add_modify (&block, gfc_class_vptr_get (dest),
8145 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
8148 tmp = build_fold_indirect_ref_loc (input_location, dest);
8150 /* For deferred strings insert a memcpy. */
8151 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8154 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
8155 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
8157 : expr->ts.u.cl->backend_decl);
8158 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
8159 gfc_add_expr_to_block (&block, tmp);
8162 gfc_add_modify (&block, tmp,
8163 fold_convert (TREE_TYPE (tmp), se.expr));
8164 gfc_add_block_to_block (&block, &se.post);
8166 else if (expr->ts.type == BT_UNION)
8169 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
8170 /* We mark that the entire union should be initialized with a contrived
8171 EXPR_NULL expression at the beginning. */
8172 if (c != NULL && c->n.component == NULL
8173 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
8175 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8176 dest, build_constructor (TREE_TYPE (dest), NULL));
8177 gfc_add_expr_to_block (&block, tmp);
8178 c = gfc_constructor_next (c);
8180 /* The following constructor expression, if any, represents a specific
8181 map intializer, as given by the user. */
8182 if (c != NULL && c->expr != NULL)
8184 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8185 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8186 gfc_add_expr_to_block (&block, tmp);
8189 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
8191 if (expr->expr_type != EXPR_STRUCTURE)
8193 tree dealloc = NULL_TREE;
8194 gfc_init_se (&se, NULL);
8195 gfc_conv_expr (&se, expr);
8196 gfc_add_block_to_block (&block, &se.pre);
8197 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8198 expression in a temporary variable and deallocate the allocatable
8199 components. Then we can the copy the expression to the result. */
8200 if (cm->ts.u.derived->attr.alloc_comp
8201 && expr->expr_type != EXPR_VARIABLE)
8203 se.expr = gfc_evaluate_now (se.expr, &block);
8204 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
8207 gfc_add_modify (&block, dest,
8208 fold_convert (TREE_TYPE (dest), se.expr));
8209 if (cm->ts.u.derived->attr.alloc_comp
8210 && expr->expr_type != EXPR_NULL)
8212 // TODO: Fix caf_mode
8213 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
8214 dest, expr->rank, 0);
8215 gfc_add_expr_to_block (&block, tmp);
8216 if (dealloc != NULL_TREE)
8217 gfc_add_expr_to_block (&block, dealloc);
8219 gfc_add_block_to_block (&block, &se.post);
8223 /* Nested constructors. */
8224 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8225 gfc_add_expr_to_block (&block, tmp);
8228 else if (gfc_deferred_strlen (cm, &tmp))
8232 gcc_assert (strlen);
8233 strlen = fold_build3_loc (input_location, COMPONENT_REF,
8235 TREE_OPERAND (dest, 0),
8238 if (expr->expr_type == EXPR_NULL)
8240 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
8241 gfc_add_modify (&block, dest, tmp);
8242 tmp = build_int_cst (TREE_TYPE (strlen), 0);
8243 gfc_add_modify (&block, strlen, tmp);
8248 gfc_init_se (&se, NULL);
8249 gfc_conv_expr (&se, expr);
8250 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
8251 tmp = build_call_expr_loc (input_location,
8252 builtin_decl_explicit (BUILT_IN_MALLOC),
8254 gfc_add_modify (&block, dest,
8255 fold_convert (TREE_TYPE (dest), tmp));
8256 gfc_add_modify (&block, strlen,
8257 fold_convert (TREE_TYPE (strlen), se.string_length));
8258 tmp = gfc_build_memcpy_call (dest, se.expr, size);
8259 gfc_add_expr_to_block (&block, tmp);
8262 else if (!cm->attr.artificial)
8264 /* Scalar component (excluding deferred parameters). */
8265 gfc_init_se (&se, NULL);
8266 gfc_init_se (&lse, NULL);
8268 gfc_conv_expr (&se, expr);
8269 if (cm->ts.type == BT_CHARACTER)
8270 lse.string_length = cm->ts.u.cl->backend_decl;
8272 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
8273 gfc_add_expr_to_block (&block, tmp);
8275 return gfc_finish_block (&block);
8278 /* Assign a derived type constructor to a variable. */
8281 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
8290 gfc_start_block (&block);
8291 cm = expr->ts.u.derived->components;
8293 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
8294 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8295 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
8299 gfc_init_se (&se, NULL);
8300 gfc_init_se (&lse, NULL);
8301 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
8303 gfc_add_modify (&block, lse.expr,
8304 fold_convert (TREE_TYPE (lse.expr), se.expr));
8306 return gfc_finish_block (&block);
8310 gfc_init_se (&se, NULL);
8312 for (c = gfc_constructor_first (expr->value.constructor);
8313 c; c = gfc_constructor_next (c), cm = cm->next)
8315 /* Skip absent members in default initializers. */
8316 if (!c->expr && !cm->attr.allocatable)
8319 /* Register the component with the caf-lib before it is initialized.
8320 Register only allocatable components, that are not coarray'ed
8321 components (%comp[*]). Only register when the constructor is not the
8323 if (coarray && !cm->attr.codimension
8324 && (cm->attr.allocatable || cm->attr.pointer)
8325 && (!c->expr || c->expr->expr_type == EXPR_NULL))
8327 tree token, desc, size;
8328 bool is_array = cm->ts.type == BT_CLASS
8329 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
8331 field = cm->backend_decl;
8332 field = fold_build3_loc (input_location, COMPONENT_REF,
8333 TREE_TYPE (field), dest, field, NULL_TREE);
8334 if (cm->ts.type == BT_CLASS)
8335 field = gfc_class_data_get (field);
8337 token = is_array ? gfc_conv_descriptor_token (field)
8338 : fold_build3_loc (input_location, COMPONENT_REF,
8339 TREE_TYPE (cm->caf_token), dest,
8340 cm->caf_token, NULL_TREE);
8344 /* The _caf_register routine looks at the rank of the array
8345 descriptor to decide whether the data registered is an array
8347 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
8349 /* When the rank is not known just set a positive rank, which
8350 suffices to recognize the data as array. */
8353 size = build_zero_cst (size_type_node);
8355 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
8356 build_int_cst (signed_char_type_node, rank));
8360 desc = gfc_conv_scalar_to_descriptor (&se, field,
8361 cm->ts.type == BT_CLASS
8362 ? CLASS_DATA (cm)->attr
8364 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
8366 gfc_add_block_to_block (&block, &se.pre);
8367 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
8368 7, size, build_int_cst (
8370 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
8371 gfc_build_addr_expr (pvoid_type_node,
8373 gfc_build_addr_expr (NULL_TREE, desc),
8374 null_pointer_node, null_pointer_node,
8376 gfc_add_expr_to_block (&block, tmp);
8378 field = cm->backend_decl;
8379 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8380 dest, field, NULL_TREE);
8383 gfc_expr *e = gfc_get_null_expr (NULL);
8384 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
8389 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
8390 expr->ts.u.derived, init);
8391 gfc_add_expr_to_block (&block, tmp);
8393 return gfc_finish_block (&block);
8397 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
8398 gfc_component *un, gfc_expr *init)
8400 gfc_constructor *ctor;
8402 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
8405 ctor = gfc_constructor_first (init->value.constructor);
8407 if (ctor == NULL || ctor->expr == NULL)
8410 gcc_assert (init->expr_type == EXPR_STRUCTURE);
8412 /* If we have an 'initialize all' constructor, do it first. */
8413 if (ctor->expr->expr_type == EXPR_NULL)
8415 tree union_type = TREE_TYPE (un->backend_decl);
8416 tree val = build_constructor (union_type, NULL);
8417 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8418 ctor = gfc_constructor_next (ctor);
8421 /* Add the map initializer on top. */
8422 if (ctor != NULL && ctor->expr != NULL)
8424 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
8425 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
8426 TREE_TYPE (un->backend_decl),
8427 un->attr.dimension, un->attr.pointer,
8428 un->attr.proc_pointer);
8429 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8433 /* Build an expression for a constructor. If init is nonzero then
8434 this is part of a static variable initializer. */
8437 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
8444 vec<constructor_elt, va_gc> *v = NULL;
8446 gcc_assert (se->ss == NULL);
8447 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8448 type = gfc_typenode_for_spec (&expr->ts);
8452 /* Create a temporary variable and fill it in. */
8453 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
8454 /* The symtree in expr is NULL, if the code to generate is for
8455 initializing the static members only. */
8456 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
8458 gfc_add_expr_to_block (&se->pre, tmp);
8462 cm = expr->ts.u.derived->components;
8464 for (c = gfc_constructor_first (expr->value.constructor);
8465 c; c = gfc_constructor_next (c), cm = cm->next)
8467 /* Skip absent members in default initializers and allocatable
8468 components. Although the latter have a default initializer
8469 of EXPR_NULL,... by default, the static nullify is not needed
8470 since this is done every time we come into scope. */
8471 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
8474 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
8475 && strcmp (cm->name, "_extends") == 0
8476 && cm->initializer->symtree)
8480 vtabs = cm->initializer->symtree->n.sym;
8481 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
8482 vtab = unshare_expr_without_location (vtab);
8483 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
8485 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
8487 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
8488 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8489 fold_convert (TREE_TYPE (cm->backend_decl),
8492 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
8493 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8494 fold_convert (TREE_TYPE (cm->backend_decl),
8495 integer_zero_node));
8496 else if (cm->ts.type == BT_UNION)
8497 gfc_conv_union_initializer (v, cm, c->expr);
8500 val = gfc_conv_initializer (c->expr, &cm->ts,
8501 TREE_TYPE (cm->backend_decl),
8502 cm->attr.dimension, cm->attr.pointer,
8503 cm->attr.proc_pointer);
8504 val = unshare_expr_without_location (val);
8506 /* Append it to the constructor list. */
8507 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
8511 se->expr = build_constructor (type, v);
8513 TREE_CONSTANT (se->expr) = 1;
8517 /* Translate a substring expression. */
8520 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
8526 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
8528 se->expr = gfc_build_wide_string_const (expr->ts.kind,
8529 expr->value.character.length,
8530 expr->value.character.string);
8532 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
8533 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
8536 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
8540 /* Entry point for expression translation. Evaluates a scalar quantity.
8541 EXPR is the expression to be translated, and SE is the state structure if
8542 called from within the scalarized. */
8545 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
8550 if (ss && ss->info->expr == expr
8551 && (ss->info->type == GFC_SS_SCALAR
8552 || ss->info->type == GFC_SS_REFERENCE))
8554 gfc_ss_info *ss_info;
8557 /* Substitute a scalar expression evaluated outside the scalarization
8559 se->expr = ss_info->data.scalar.value;
8560 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
8561 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8563 se->string_length = ss_info->string_length;
8564 gfc_advance_se_ss_chain (se);
8568 /* We need to convert the expressions for the iso_c_binding derived types.
8569 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8570 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8571 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8572 updated to be an integer with a kind equal to the size of a (void *). */
8573 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8574 && expr->ts.u.derived->attr.is_bind_c)
8576 if (expr->expr_type == EXPR_VARIABLE
8577 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8578 || expr->symtree->n.sym->intmod_sym_id
8579 == ISOCBINDING_NULL_FUNPTR))
8581 /* Set expr_type to EXPR_NULL, which will result in
8582 null_pointer_node being used below. */
8583 expr->expr_type = EXPR_NULL;
8587 /* Update the type/kind of the expression to be what the new
8588 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8589 expr->ts.type = BT_INTEGER;
8590 expr->ts.f90_type = BT_VOID;
8591 expr->ts.kind = gfc_index_integer_kind;
8595 gfc_fix_class_refs (expr);
8597 switch (expr->expr_type)
8600 gfc_conv_expr_op (se, expr);
8604 gfc_conv_function_expr (se, expr);
8608 gfc_conv_constant (se, expr);
8612 gfc_conv_variable (se, expr);
8616 se->expr = null_pointer_node;
8619 case EXPR_SUBSTRING:
8620 gfc_conv_substring_expr (se, expr);
8623 case EXPR_STRUCTURE:
8624 gfc_conv_structure (se, expr, 0);
8628 gfc_conv_array_constructor_expr (se, expr);
8637 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8638 of an assignment. */
8640 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8642 gfc_conv_expr (se, expr);
8643 /* All numeric lvalues should have empty post chains. If not we need to
8644 figure out a way of rewriting an lvalue so that it has no post chain. */
8645 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8648 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8649 numeric expressions. Used for scalar values where inserting cleanup code
8652 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8656 gcc_assert (expr->ts.type != BT_CHARACTER);
8657 gfc_conv_expr (se, expr);
8660 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8661 gfc_add_modify (&se->pre, val, se->expr);
8663 gfc_add_block_to_block (&se->pre, &se->post);
8667 /* Helper to translate an expression and convert it to a particular type. */
8669 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8671 gfc_conv_expr_val (se, expr);
8672 se->expr = convert (type, se->expr);
8676 /* Converts an expression so that it can be passed by reference. Scalar
8680 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8686 if (ss && ss->info->expr == expr
8687 && ss->info->type == GFC_SS_REFERENCE)
8689 /* Returns a reference to the scalar evaluated outside the loop
8691 gfc_conv_expr (se, expr);
8693 if (expr->ts.type == BT_CHARACTER
8694 && expr->expr_type != EXPR_FUNCTION)
8695 gfc_conv_string_parameter (se);
8697 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8702 if (expr->ts.type == BT_CHARACTER)
8704 gfc_conv_expr (se, expr);
8705 gfc_conv_string_parameter (se);
8709 if (expr->expr_type == EXPR_VARIABLE)
8711 se->want_pointer = 1;
8712 gfc_conv_expr (se, expr);
8715 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8716 gfc_add_modify (&se->pre, var, se->expr);
8717 gfc_add_block_to_block (&se->pre, &se->post);
8720 else if (add_clobber && expr->ref == NULL)
8724 /* FIXME: This fails if var is passed by reference, see PR
8726 var = expr->symtree->n.sym->backend_decl;
8727 clobber = build_clobber (TREE_TYPE (var));
8728 gfc_add_modify (&se->pre, var, clobber);
8733 if (expr->expr_type == EXPR_FUNCTION
8734 && ((expr->value.function.esym
8735 && expr->value.function.esym->result->attr.pointer
8736 && !expr->value.function.esym->result->attr.dimension)
8737 || (!expr->value.function.esym && !expr->ref
8738 && expr->symtree->n.sym->attr.pointer
8739 && !expr->symtree->n.sym->attr.dimension)))
8741 se->want_pointer = 1;
8742 gfc_conv_expr (se, expr);
8743 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8744 gfc_add_modify (&se->pre, var, se->expr);
8749 gfc_conv_expr (se, expr);
8751 /* Create a temporary var to hold the value. */
8752 if (TREE_CONSTANT (se->expr))
8754 tree tmp = se->expr;
8755 STRIP_TYPE_NOPS (tmp);
8756 var = build_decl (input_location,
8757 CONST_DECL, NULL, TREE_TYPE (tmp));
8758 DECL_INITIAL (var) = tmp;
8759 TREE_STATIC (var) = 1;
8764 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8765 gfc_add_modify (&se->pre, var, se->expr);
8768 if (!expr->must_finalize)
8769 gfc_add_block_to_block (&se->pre, &se->post);
8771 /* Take the address of that value. */
8772 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8776 /* Get the _len component for an unlimited polymorphic expression. */
8779 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8782 gfc_ref *ref = expr->ref;
8784 gfc_init_se (&se, NULL);
8785 while (ref && ref->next)
8787 gfc_add_len_component (expr);
8788 gfc_conv_expr (&se, expr);
8789 gfc_add_block_to_block (block, &se.pre);
8790 gcc_assert (se.post.head == NULL_TREE);
8793 gfc_free_ref_list (ref->next);
8798 gfc_free_ref_list (expr->ref);
8805 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8806 statement-list outside of the scalarizer-loop. When code is generated, that
8807 depends on the scalarized expression, it is added to RSE.PRE.
8808 Returns le's _vptr tree and when set the len expressions in to_lenp and
8809 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8813 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8814 gfc_expr * re, gfc_se *rse,
8815 tree * to_lenp, tree * from_lenp)
8818 gfc_expr * vptr_expr;
8819 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8820 bool set_vptr = false, temp_rhs = false;
8821 stmtblock_t *pre = block;
8823 /* Create a temporary for complicated expressions. */
8824 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8825 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8827 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8829 gfc_add_modify (&rse->pre, tmp, rse->expr);
8834 /* Get the _vptr for the left-hand side expression. */
8835 gfc_init_se (&se, NULL);
8836 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8837 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8839 /* Care about _len for unlimited polymorphic entities. */
8840 if (UNLIMITED_POLY (vptr_expr)
8841 || (vptr_expr->ts.type == BT_DERIVED
8842 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8843 to_len = trans_get_upoly_len (block, vptr_expr);
8844 gfc_add_vptr_component (vptr_expr);
8848 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8849 se.want_pointer = 1;
8850 gfc_conv_expr (&se, vptr_expr);
8851 gfc_free_expr (vptr_expr);
8852 gfc_add_block_to_block (block, &se.pre);
8853 gcc_assert (se.post.head == NULL_TREE);
8855 STRIP_NOPS (lhs_vptr);
8857 /* Set the _vptr only when the left-hand side of the assignment is a
8861 /* Get the vptr from the rhs expression only, when it is variable.
8862 Functions are expected to be assigned to a temporary beforehand. */
8863 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8864 ? gfc_find_and_cut_at_last_class_ref (re)
8866 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8868 if (to_len != NULL_TREE)
8870 /* Get the _len information from the rhs. */
8871 if (UNLIMITED_POLY (vptr_expr)
8872 || (vptr_expr->ts.type == BT_DERIVED
8873 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8874 from_len = trans_get_upoly_len (block, vptr_expr);
8876 gfc_add_vptr_component (vptr_expr);
8880 if (re->expr_type == EXPR_VARIABLE
8881 && DECL_P (re->symtree->n.sym->backend_decl)
8882 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8883 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8884 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8885 re->symtree->n.sym->backend_decl))))
8888 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8889 re->symtree->n.sym->backend_decl));
8891 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8892 re->symtree->n.sym->backend_decl));
8894 else if (temp_rhs && re->ts.type == BT_CLASS)
8897 se.expr = gfc_class_vptr_get (rse->expr);
8898 if (UNLIMITED_POLY (re))
8899 from_len = gfc_class_len_get (rse->expr);
8901 else if (re->expr_type != EXPR_NULL)
8902 /* Only when rhs is non-NULL use its declared type for vptr
8904 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8906 /* When the rhs is NULL use the vtab of lhs' declared type. */
8907 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8912 gfc_init_se (&se, NULL);
8913 se.want_pointer = 1;
8914 gfc_conv_expr (&se, vptr_expr);
8915 gfc_free_expr (vptr_expr);
8916 gfc_add_block_to_block (block, &se.pre);
8917 gcc_assert (se.post.head == NULL_TREE);
8919 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8922 if (to_len != NULL_TREE)
8924 /* The _len component needs to be set. Figure how to get the
8925 value of the right-hand side. */
8926 if (from_len == NULL_TREE)
8928 if (rse->string_length != NULL_TREE)
8929 from_len = rse->string_length;
8930 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8932 gfc_init_se (&se, NULL);
8933 gfc_conv_expr (&se, re->ts.u.cl->length);
8934 gfc_add_block_to_block (block, &se.pre);
8935 gcc_assert (se.post.head == NULL_TREE);
8936 from_len = gfc_evaluate_now (se.expr, block);
8939 from_len = build_zero_cst (gfc_charlen_type_node);
8941 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8946 /* Return the _len trees only, when requested. */
8950 *from_lenp = from_len;
8955 /* Assign tokens for pointer components. */
8958 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8961 symbol_attribute lhs_attr, rhs_attr;
8962 tree tmp, lhs_tok, rhs_tok;
8963 /* Flag to indicated component refs on the rhs. */
8966 lhs_attr = gfc_caf_attr (expr1);
8967 if (expr2->expr_type != EXPR_NULL)
8969 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8970 if (lhs_attr.codimension && rhs_attr.codimension)
8972 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8973 lhs_tok = build_fold_indirect_ref (lhs_tok);
8976 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8980 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8981 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8984 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8986 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8987 gfc_prepend_expr_to_block (&lse->post, tmp);
8990 else if (lhs_attr.codimension)
8992 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8993 lhs_tok = build_fold_indirect_ref (lhs_tok);
8994 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8995 lhs_tok, null_pointer_node);
8996 gfc_prepend_expr_to_block (&lse->post, tmp);
9001 /* Do everything that is needed for a CLASS function expr2. */
9004 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
9005 gfc_expr *expr1, gfc_expr *expr2)
9007 tree expr1_vptr = NULL_TREE;
9010 gfc_conv_function_expr (rse, expr2);
9011 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
9013 if (expr1->ts.type != BT_CLASS)
9014 rse->expr = gfc_class_data_get (rse->expr);
9017 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
9020 gfc_add_block_to_block (block, &rse->pre);
9021 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
9022 gfc_add_modify (&lse->pre, tmp, rse->expr);
9024 gfc_add_modify (&lse->pre, expr1_vptr,
9025 fold_convert (TREE_TYPE (expr1_vptr),
9026 gfc_class_vptr_get (tmp)));
9027 rse->expr = gfc_class_data_get (tmp);
9035 gfc_trans_pointer_assign (gfc_code * code)
9037 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
9041 /* Generate code for a pointer assignment. */
9044 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
9051 tree expr1_vptr = NULL_TREE;
9052 bool scalar, non_proc_ptr_assign;
9055 gfc_start_block (&block);
9057 gfc_init_se (&lse, NULL);
9059 /* Usually testing whether this is not a proc pointer assignment. */
9060 non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
9061 && expr2->expr_type == EXPR_VARIABLE
9062 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
9064 /* Check whether the expression is a scalar or not; we cannot use
9065 expr1->rank as it can be nonzero for proc pointers. */
9066 ss = gfc_walk_expr (expr1);
9067 scalar = ss == gfc_ss_terminator;
9069 gfc_free_ss_chain (ss);
9071 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
9072 && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
9074 gfc_add_data_component (expr2);
9075 /* The following is required as gfc_add_data_component doesn't
9076 update ts.type if there is a tailing REF_ARRAY. */
9077 expr2->ts.type = BT_DERIVED;
9082 /* Scalar pointers. */
9083 lse.want_pointer = 1;
9084 gfc_conv_expr (&lse, expr1);
9085 gfc_init_se (&rse, NULL);
9086 rse.want_pointer = 1;
9087 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9088 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
9090 gfc_conv_expr (&rse, expr2);
9092 if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
9094 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
9096 lse.expr = gfc_class_data_get (lse.expr);
9099 if (expr1->symtree->n.sym->attr.proc_pointer
9100 && expr1->symtree->n.sym->attr.dummy)
9101 lse.expr = build_fold_indirect_ref_loc (input_location,
9104 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
9105 && expr2->symtree->n.sym->attr.dummy)
9106 rse.expr = build_fold_indirect_ref_loc (input_location,
9109 gfc_add_block_to_block (&block, &lse.pre);
9110 gfc_add_block_to_block (&block, &rse.pre);
9112 /* Check character lengths if character expression. The test is only
9113 really added if -fbounds-check is enabled. Exclude deferred
9114 character length lefthand sides. */
9115 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
9116 && !expr1->ts.deferred
9117 && !expr1->symtree->n.sym->attr.proc_pointer
9118 && !gfc_is_proc_ptr_comp (expr1))
9120 gcc_assert (expr2->ts.type == BT_CHARACTER);
9121 gcc_assert (lse.string_length && rse.string_length);
9122 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9123 lse.string_length, rse.string_length,
9127 /* The assignment to an deferred character length sets the string
9128 length to that of the rhs. */
9129 if (expr1->ts.deferred)
9131 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
9132 gfc_add_modify (&block, lse.string_length,
9133 fold_convert (TREE_TYPE (lse.string_length),
9134 rse.string_length));
9135 else if (lse.string_length != NULL)
9136 gfc_add_modify (&block, lse.string_length,
9137 build_zero_cst (TREE_TYPE (lse.string_length)));
9140 gfc_add_modify (&block, lse.expr,
9141 fold_convert (TREE_TYPE (lse.expr), rse.expr));
9143 /* Also set the tokens for pointer components in derived typed
9145 if (flag_coarray == GFC_FCOARRAY_LIB)
9146 trans_caf_token_assign (&lse, &rse, expr1, expr2);
9148 gfc_add_block_to_block (&block, &rse.post);
9149 gfc_add_block_to_block (&block, &lse.post);
9156 tree strlen_rhs = NULL_TREE;
9158 /* Array pointer. Find the last reference on the LHS and if it is an
9159 array section ref, we're dealing with bounds remapping. In this case,
9160 set it to AR_FULL so that gfc_conv_expr_descriptor does
9161 not see it and process the bounds remapping afterwards explicitly. */
9162 for (remap = expr1->ref; remap; remap = remap->next)
9163 if (!remap->next && remap->type == REF_ARRAY
9164 && remap->u.ar.type == AR_SECTION)
9166 rank_remap = (remap && remap->u.ar.end[0]);
9168 gfc_init_se (&lse, NULL);
9170 lse.descriptor_only = 1;
9171 gfc_conv_expr_descriptor (&lse, expr1);
9172 strlen_lhs = lse.string_length;
9175 if (expr2->expr_type == EXPR_NULL)
9177 /* Just set the data pointer to null. */
9178 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
9180 else if (rank_remap)
9182 /* If we are rank-remapping, just get the RHS's descriptor and
9183 process this later on. */
9184 gfc_init_se (&rse, NULL);
9185 rse.direct_byref = 1;
9186 rse.byref_noassign = 1;
9188 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9189 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
9191 else if (expr2->expr_type == EXPR_FUNCTION)
9193 tree bound[GFC_MAX_DIMENSIONS];
9196 for (i = 0; i < expr2->rank; i++)
9197 bound[i] = NULL_TREE;
9198 tmp = gfc_typenode_for_spec (&expr2->ts);
9199 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
9201 GFC_ARRAY_POINTER_CONT, false);
9202 tmp = gfc_create_var (tmp, "ptrtemp");
9203 rse.descriptor_only = 0;
9205 rse.direct_byref = 1;
9206 gfc_conv_expr_descriptor (&rse, expr2);
9207 strlen_rhs = rse.string_length;
9212 gfc_conv_expr_descriptor (&rse, expr2);
9213 strlen_rhs = rse.string_length;
9214 if (expr1->ts.type == BT_CLASS)
9215 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9220 else if (expr2->expr_type == EXPR_VARIABLE)
9222 /* Assign directly to the LHS's descriptor. */
9223 lse.descriptor_only = 0;
9224 lse.direct_byref = 1;
9225 gfc_conv_expr_descriptor (&lse, expr2);
9226 strlen_rhs = lse.string_length;
9228 if (expr1->ts.type == BT_CLASS)
9230 rse.expr = NULL_TREE;
9231 rse.string_length = NULL_TREE;
9232 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
9238 /* If the target is not a whole array, use the target array
9239 reference for remap. */
9240 for (remap = expr2->ref; remap; remap = remap->next)
9241 if (remap->type == REF_ARRAY
9242 && remap->u.ar.type == AR_FULL
9247 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9249 gfc_init_se (&rse, NULL);
9250 rse.want_pointer = 1;
9251 gfc_conv_function_expr (&rse, expr2);
9252 if (expr1->ts.type != BT_CLASS)
9254 rse.expr = gfc_class_data_get (rse.expr);
9255 gfc_add_modify (&lse.pre, desc, rse.expr);
9256 /* Set the lhs span. */
9257 tmp = TREE_TYPE (rse.expr);
9258 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9259 tmp = fold_convert (gfc_array_index_type, tmp);
9260 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
9264 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9267 gfc_add_block_to_block (&block, &rse.pre);
9268 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
9269 gfc_add_modify (&lse.pre, tmp, rse.expr);
9271 gfc_add_modify (&lse.pre, expr1_vptr,
9272 fold_convert (TREE_TYPE (expr1_vptr),
9273 gfc_class_vptr_get (tmp)));
9274 rse.expr = gfc_class_data_get (tmp);
9275 gfc_add_modify (&lse.pre, desc, rse.expr);
9280 /* Assign to a temporary descriptor and then copy that
9281 temporary to the pointer. */
9282 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
9283 lse.descriptor_only = 0;
9285 lse.direct_byref = 1;
9286 gfc_conv_expr_descriptor (&lse, expr2);
9287 strlen_rhs = lse.string_length;
9288 gfc_add_modify (&lse.pre, desc, tmp);
9291 gfc_add_block_to_block (&block, &lse.pre);
9293 gfc_add_block_to_block (&block, &rse.pre);
9295 /* If we do bounds remapping, update LHS descriptor accordingly. */
9299 gcc_assert (remap->u.ar.dimen == expr1->rank);
9303 /* Do rank remapping. We already have the RHS's descriptor
9304 converted in rse and now have to build the correct LHS
9305 descriptor for it. */
9307 tree dtype, data, span;
9309 tree lbound, ubound;
9312 dtype = gfc_conv_descriptor_dtype (desc);
9313 tmp = gfc_get_dtype (TREE_TYPE (desc));
9314 gfc_add_modify (&block, dtype, tmp);
9316 /* Copy data pointer. */
9317 data = gfc_conv_descriptor_data_get (rse.expr);
9318 gfc_conv_descriptor_data_set (&block, desc, data);
9320 /* Copy the span. */
9321 if (TREE_CODE (rse.expr) == VAR_DECL
9322 && GFC_DECL_PTR_ARRAY_P (rse.expr))
9323 span = gfc_conv_descriptor_span_get (rse.expr);
9326 tmp = TREE_TYPE (rse.expr);
9327 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9328 span = fold_convert (gfc_array_index_type, tmp);
9330 gfc_conv_descriptor_span_set (&block, desc, span);
9332 /* Copy offset but adjust it such that it would correspond
9333 to a lbound of zero. */
9334 offs = gfc_conv_descriptor_offset_get (rse.expr);
9335 for (dim = 0; dim < expr2->rank; ++dim)
9337 stride = gfc_conv_descriptor_stride_get (rse.expr,
9339 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
9341 tmp = fold_build2_loc (input_location, MULT_EXPR,
9342 gfc_array_index_type, stride, lbound);
9343 offs = fold_build2_loc (input_location, PLUS_EXPR,
9344 gfc_array_index_type, offs, tmp);
9346 gfc_conv_descriptor_offset_set (&block, desc, offs);
9348 /* Set the bounds as declared for the LHS and calculate strides as
9349 well as another offset update accordingly. */
9350 stride = gfc_conv_descriptor_stride_get (rse.expr,
9352 for (dim = 0; dim < expr1->rank; ++dim)
9357 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
9359 /* Convert declared bounds. */
9360 gfc_init_se (&lower_se, NULL);
9361 gfc_init_se (&upper_se, NULL);
9362 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
9363 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
9365 gfc_add_block_to_block (&block, &lower_se.pre);
9366 gfc_add_block_to_block (&block, &upper_se.pre);
9368 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
9369 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
9371 lbound = gfc_evaluate_now (lbound, &block);
9372 ubound = gfc_evaluate_now (ubound, &block);
9374 gfc_add_block_to_block (&block, &lower_se.post);
9375 gfc_add_block_to_block (&block, &upper_se.post);
9377 /* Set bounds in descriptor. */
9378 gfc_conv_descriptor_lbound_set (&block, desc,
9379 gfc_rank_cst[dim], lbound);
9380 gfc_conv_descriptor_ubound_set (&block, desc,
9381 gfc_rank_cst[dim], ubound);
9384 stride = gfc_evaluate_now (stride, &block);
9385 gfc_conv_descriptor_stride_set (&block, desc,
9386 gfc_rank_cst[dim], stride);
9388 /* Update offset. */
9389 offs = gfc_conv_descriptor_offset_get (desc);
9390 tmp = fold_build2_loc (input_location, MULT_EXPR,
9391 gfc_array_index_type, lbound, stride);
9392 offs = fold_build2_loc (input_location, MINUS_EXPR,
9393 gfc_array_index_type, offs, tmp);
9394 offs = gfc_evaluate_now (offs, &block);
9395 gfc_conv_descriptor_offset_set (&block, desc, offs);
9397 /* Update stride. */
9398 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
9399 stride = fold_build2_loc (input_location, MULT_EXPR,
9400 gfc_array_index_type, stride, tmp);
9405 /* Bounds remapping. Just shift the lower bounds. */
9407 gcc_assert (expr1->rank == expr2->rank);
9409 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
9413 gcc_assert (!remap->u.ar.end[dim]);
9414 gfc_init_se (&lbound_se, NULL);
9415 if (remap->u.ar.start[dim])
9417 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
9418 gfc_add_block_to_block (&block, &lbound_se.pre);
9421 /* This remap arises from a target that is not a whole
9422 array. The start expressions will be NULL but we need
9423 the lbounds to be one. */
9424 lbound_se.expr = gfc_index_one_node;
9425 gfc_conv_shift_descriptor_lbound (&block, desc,
9426 dim, lbound_se.expr);
9427 gfc_add_block_to_block (&block, &lbound_se.post);
9432 /* If rank remapping was done, check with -fcheck=bounds that
9433 the target is at least as large as the pointer. */
9434 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
9440 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
9441 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
9443 lsize = gfc_evaluate_now (lsize, &block);
9444 rsize = gfc_evaluate_now (rsize, &block);
9445 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
9448 msg = _("Target of rank remapping is too small (%ld < %ld)");
9449 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
9453 if (expr1->ts.type == BT_CHARACTER
9454 && expr1->symtree->n.sym->ts.deferred
9455 && expr1->symtree->n.sym->ts.u.cl->backend_decl
9456 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
9458 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
9459 if (expr2->expr_type != EXPR_NULL)
9460 gfc_add_modify (&block, tmp,
9461 fold_convert (TREE_TYPE (tmp), strlen_rhs));
9463 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
9466 /* Check string lengths if applicable. The check is only really added
9467 to the output code if -fbounds-check is enabled. */
9468 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
9470 gcc_assert (expr2->ts.type == BT_CHARACTER);
9471 gcc_assert (strlen_lhs && strlen_rhs);
9472 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9473 strlen_lhs, strlen_rhs, &block);
9476 gfc_add_block_to_block (&block, &lse.post);
9478 gfc_add_block_to_block (&block, &rse.post);
9481 return gfc_finish_block (&block);
9485 /* Makes sure se is suitable for passing as a function string parameter. */
9486 /* TODO: Need to check all callers of this function. It may be abused. */
9489 gfc_conv_string_parameter (gfc_se * se)
9493 if (TREE_CODE (se->expr) == STRING_CST)
9495 type = TREE_TYPE (TREE_TYPE (se->expr));
9496 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9500 if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
9501 || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
9502 && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
9504 if (TREE_CODE (se->expr) != INDIRECT_REF)
9506 type = TREE_TYPE (se->expr);
9507 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9511 type = gfc_get_character_type_len (gfc_default_character_kind,
9513 type = build_pointer_type (type);
9514 se->expr = gfc_build_addr_expr (type, se->expr);
9518 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
9522 /* Generate code for assignment of scalar variables. Includes character
9523 strings and derived types with allocatable components.
9524 If you know that the LHS has no allocations, set dealloc to false.
9526 DEEP_COPY has no effect if the typespec TS is not a derived type with
9527 allocatable components. Otherwise, if it is set, an explicit copy of each
9528 allocatable component is made. This is necessary as a simple copy of the
9529 whole object would copy array descriptors as is, so that the lhs's
9530 allocatable components would point to the rhs's after the assignment.
9531 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9532 necessary if the rhs is a non-pointer function, as the allocatable components
9533 are not accessible by other means than the function's result after the
9534 function has returned. It is even more subtle when temporaries are involved,
9535 as the two following examples show:
9536 1. When we evaluate an array constructor, a temporary is created. Thus
9537 there is theoretically no alias possible. However, no deep copy is
9538 made for this temporary, so that if the constructor is made of one or
9539 more variable with allocatable components, those components still point
9540 to the variable's: DEEP_COPY should be set for the assignment from the
9541 temporary to the lhs in that case.
9542 2. When assigning a scalar to an array, we evaluate the scalar value out
9543 of the loop, store it into a temporary variable, and assign from that.
9544 In that case, deep copying when assigning to the temporary would be a
9545 waste of resources; however deep copies should happen when assigning from
9546 the temporary to each array element: again DEEP_COPY should be set for
9547 the assignment from the temporary to the lhs. */
9550 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9551 bool deep_copy, bool dealloc, bool in_coarray)
9557 gfc_init_block (&block);
9559 if (ts.type == BT_CHARACTER)
9564 if (lse->string_length != NULL_TREE)
9566 gfc_conv_string_parameter (lse);
9567 gfc_add_block_to_block (&block, &lse->pre);
9568 llen = lse->string_length;
9571 if (rse->string_length != NULL_TREE)
9573 gfc_conv_string_parameter (rse);
9574 gfc_add_block_to_block (&block, &rse->pre);
9575 rlen = rse->string_length;
9578 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9579 rse->expr, ts.kind);
9581 else if (gfc_bt_struct (ts.type)
9582 && (ts.u.derived->attr.alloc_comp
9583 || (deep_copy && ts.u.derived->attr.pdt_type)))
9585 tree tmp_var = NULL_TREE;
9588 /* Are the rhs and the lhs the same? */
9591 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9592 gfc_build_addr_expr (NULL_TREE, lse->expr),
9593 gfc_build_addr_expr (NULL_TREE, rse->expr));
9594 cond = gfc_evaluate_now (cond, &lse->pre);
9597 /* Deallocate the lhs allocated components as long as it is not
9598 the same as the rhs. This must be done following the assignment
9599 to prevent deallocating data that could be used in the rhs
9603 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9604 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9606 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9608 gfc_add_expr_to_block (&lse->post, tmp);
9611 gfc_add_block_to_block (&block, &rse->pre);
9612 gfc_add_block_to_block (&block, &lse->pre);
9614 gfc_add_modify (&block, lse->expr,
9615 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9617 /* Restore pointer address of coarray components. */
9618 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9620 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9621 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9623 gfc_add_expr_to_block (&block, tmp);
9626 /* Do a deep copy if the rhs is a variable, if it is not the
9630 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9631 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9632 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9634 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9636 gfc_add_expr_to_block (&block, tmp);
9639 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9641 gfc_add_block_to_block (&block, &lse->pre);
9642 gfc_add_block_to_block (&block, &rse->pre);
9643 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9644 TREE_TYPE (lse->expr), rse->expr);
9645 gfc_add_modify (&block, lse->expr, tmp);
9649 gfc_add_block_to_block (&block, &lse->pre);
9650 gfc_add_block_to_block (&block, &rse->pre);
9652 gfc_add_modify (&block, lse->expr,
9653 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9656 gfc_add_block_to_block (&block, &lse->post);
9657 gfc_add_block_to_block (&block, &rse->post);
9659 return gfc_finish_block (&block);
9663 /* There are quite a lot of restrictions on the optimisation in using an
9664 array function assign without a temporary. */
9667 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9670 bool seen_array_ref;
9672 gfc_symbol *sym = expr1->symtree->n.sym;
9674 /* Play it safe with class functions assigned to a derived type. */
9675 if (gfc_is_class_array_function (expr2)
9676 && expr1->ts.type == BT_DERIVED)
9679 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9680 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9683 /* Elemental functions are scalarized so that they don't need a
9684 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9685 they would need special treatment in gfc_trans_arrayfunc_assign. */
9686 if (expr2->value.function.esym != NULL
9687 && expr2->value.function.esym->attr.elemental)
9690 /* Need a temporary if rhs is not FULL or a contiguous section. */
9691 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9694 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9695 if (gfc_ref_needs_temporary_p (expr1->ref))
9698 /* Functions returning pointers or allocatables need temporaries. */
9699 c = expr2->value.function.esym
9700 ? (expr2->value.function.esym->attr.pointer
9701 || expr2->value.function.esym->attr.allocatable)
9702 : (expr2->symtree->n.sym->attr.pointer
9703 || expr2->symtree->n.sym->attr.allocatable);
9707 /* Character array functions need temporaries unless the
9708 character lengths are the same. */
9709 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9711 if (expr1->ts.u.cl->length == NULL
9712 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9715 if (expr2->ts.u.cl->length == NULL
9716 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9719 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9720 expr2->ts.u.cl->length->value.integer) != 0)
9724 /* Check that no LHS component references appear during an array
9725 reference. This is needed because we do not have the means to
9726 span any arbitrary stride with an array descriptor. This check
9727 is not needed for the rhs because the function result has to be
9729 seen_array_ref = false;
9730 for (ref = expr1->ref; ref; ref = ref->next)
9732 if (ref->type == REF_ARRAY)
9733 seen_array_ref= true;
9734 else if (ref->type == REF_COMPONENT && seen_array_ref)
9738 /* Check for a dependency. */
9739 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9740 expr2->value.function.esym,
9741 expr2->value.function.actual,
9745 /* If we have reached here with an intrinsic function, we do not
9746 need a temporary except in the particular case that reallocation
9747 on assignment is active and the lhs is allocatable and a target. */
9748 if (expr2->value.function.isym)
9749 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9751 /* If the LHS is a dummy, we need a temporary if it is not
9753 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9756 /* If the lhs has been host_associated, is in common, a pointer or is
9757 a target and the function is not using a RESULT variable, aliasing
9758 can occur and a temporary is needed. */
9759 if ((sym->attr.host_assoc
9760 || sym->attr.in_common
9761 || sym->attr.pointer
9762 || sym->attr.cray_pointee
9763 || sym->attr.target)
9764 && expr2->symtree != NULL
9765 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9768 /* A PURE function can unconditionally be called without a temporary. */
9769 if (expr2->value.function.esym != NULL
9770 && expr2->value.function.esym->attr.pure)
9773 /* Implicit_pure functions are those which could legally be declared
9775 if (expr2->value.function.esym != NULL
9776 && expr2->value.function.esym->attr.implicit_pure)
9779 if (!sym->attr.use_assoc
9780 && !sym->attr.in_common
9781 && !sym->attr.pointer
9782 && !sym->attr.target
9783 && !sym->attr.cray_pointee
9784 && expr2->value.function.esym)
9786 /* A temporary is not needed if the function is not contained and
9787 the variable is local or host associated and not a pointer or
9789 if (!expr2->value.function.esym->attr.contained)
9792 /* A temporary is not needed if the lhs has never been host
9793 associated and the procedure is contained. */
9794 else if (!sym->attr.host_assoc)
9797 /* A temporary is not needed if the variable is local and not
9798 a pointer, a target or a result. */
9800 && expr2->value.function.esym->ns == sym->ns->parent)
9804 /* Default to temporary use. */
9809 /* Provide the loop info so that the lhs descriptor can be built for
9810 reallocatable assignments from extrinsic function calls. */
9813 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9816 /* Signal that the function call should not be made by
9817 gfc_conv_loop_setup. */
9818 se->ss->is_alloc_lhs = 1;
9819 gfc_init_loopinfo (loop);
9820 gfc_add_ss_to_loop (loop, *ss);
9821 gfc_add_ss_to_loop (loop, se->ss);
9822 gfc_conv_ss_startstride (loop);
9823 gfc_conv_loop_setup (loop, where);
9824 gfc_copy_loopinfo_to_se (se, loop);
9825 gfc_add_block_to_block (&se->pre, &loop->pre);
9826 gfc_add_block_to_block (&se->pre, &loop->post);
9827 se->ss->is_alloc_lhs = 0;
9831 /* For assignment to a reallocatable lhs from intrinsic functions,
9832 replace the se.expr (ie. the result) with a temporary descriptor.
9833 Null the data field so that the library allocates space for the
9834 result. Free the data of the original descriptor after the function,
9835 in case it appears in an argument expression and transfer the
9836 result to the original descriptor. */
9839 fcncall_realloc_result (gfc_se *se, int rank)
9848 /* Use the allocation done by the library. Substitute the lhs
9849 descriptor with a copy, whose data field is nulled.*/
9850 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9851 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9852 desc = build_fold_indirect_ref_loc (input_location, desc);
9854 /* Unallocated, the descriptor does not have a dtype. */
9855 tmp = gfc_conv_descriptor_dtype (desc);
9856 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9858 res_desc = gfc_evaluate_now (desc, &se->pre);
9859 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9860 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9862 /* Free the lhs after the function call and copy the result data to
9863 the lhs descriptor. */
9864 tmp = gfc_conv_descriptor_data_get (desc);
9865 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9866 logical_type_node, tmp,
9867 build_int_cst (TREE_TYPE (tmp), 0));
9868 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9869 tmp = gfc_call_free (tmp);
9870 gfc_add_expr_to_block (&se->post, tmp);
9872 tmp = gfc_conv_descriptor_data_get (res_desc);
9873 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9875 /* Check that the shapes are the same between lhs and expression. */
9876 for (n = 0 ; n < rank; n++)
9879 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9880 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9881 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9882 gfc_array_index_type, tmp, tmp1);
9883 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9884 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9885 gfc_array_index_type, tmp, tmp1);
9886 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9887 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9888 gfc_array_index_type, tmp, tmp1);
9889 tmp = fold_build2_loc (input_location, NE_EXPR,
9890 logical_type_node, tmp,
9891 gfc_index_zero_node);
9892 tmp = gfc_evaluate_now (tmp, &se->post);
9893 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9894 logical_type_node, tmp,
9898 /* 'zero_cond' being true is equal to lhs not being allocated or the
9899 shapes being different. */
9900 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9902 /* Now reset the bounds returned from the function call to bounds based
9903 on the lhs lbounds, except where the lhs is not allocated or the shapes
9904 of 'variable and 'expr' are different. Set the offset accordingly. */
9905 offset = gfc_index_zero_node;
9906 for (n = 0 ; n < rank; n++)
9910 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9911 lbound = fold_build3_loc (input_location, COND_EXPR,
9912 gfc_array_index_type, zero_cond,
9913 gfc_index_one_node, lbound);
9914 lbound = gfc_evaluate_now (lbound, &se->post);
9916 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9917 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9918 gfc_array_index_type, tmp, lbound);
9919 gfc_conv_descriptor_lbound_set (&se->post, desc,
9920 gfc_rank_cst[n], lbound);
9921 gfc_conv_descriptor_ubound_set (&se->post, desc,
9922 gfc_rank_cst[n], tmp);
9924 /* Set stride and accumulate the offset. */
9925 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9926 gfc_conv_descriptor_stride_set (&se->post, desc,
9927 gfc_rank_cst[n], tmp);
9928 tmp = fold_build2_loc (input_location, MULT_EXPR,
9929 gfc_array_index_type, lbound, tmp);
9930 offset = fold_build2_loc (input_location, MINUS_EXPR,
9931 gfc_array_index_type, offset, tmp);
9932 offset = gfc_evaluate_now (offset, &se->post);
9935 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9940 /* Try to translate array(:) = func (...), where func is a transformational
9941 array function, without using a temporary. Returns NULL if this isn't the
9945 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9949 gfc_component *comp = NULL;
9952 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9955 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9957 comp = gfc_get_proc_ptr_comp (expr2);
9959 if (!(expr2->value.function.isym
9960 || (comp && comp->attr.dimension)
9961 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9962 && expr2->value.function.esym->result->attr.dimension)))
9965 gfc_init_se (&se, NULL);
9966 gfc_start_block (&se.pre);
9967 se.want_pointer = 1;
9969 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9971 if (expr1->ts.type == BT_DERIVED
9972 && expr1->ts.u.derived->attr.alloc_comp)
9975 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9977 gfc_add_expr_to_block (&se.pre, tmp);
9980 se.direct_byref = 1;
9981 se.ss = gfc_walk_expr (expr2);
9982 gcc_assert (se.ss != gfc_ss_terminator);
9984 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9985 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9986 Clearly, this cannot be done for an allocatable function result, since
9987 the shape of the result is unknown and, in any case, the function must
9988 correctly take care of the reallocation internally. For intrinsic
9989 calls, the array data is freed and the library takes care of allocation.
9990 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9992 if (flag_realloc_lhs
9993 && gfc_is_reallocatable_lhs (expr1)
9994 && !gfc_expr_attr (expr1).codimension
9995 && !gfc_is_coindexed (expr1)
9996 && !(expr2->value.function.esym
9997 && expr2->value.function.esym->result->attr.allocatable))
9999 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10001 if (!expr2->value.function.isym)
10003 ss = gfc_walk_expr (expr1);
10004 gcc_assert (ss != gfc_ss_terminator);
10006 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
10007 ss->is_alloc_lhs = 1;
10010 fcncall_realloc_result (&se, expr1->rank);
10013 gfc_conv_function_expr (&se, expr2);
10014 gfc_add_block_to_block (&se.pre, &se.post);
10017 gfc_cleanup_loop (&loop);
10019 gfc_free_ss_chain (se.ss);
10021 return gfc_finish_block (&se.pre);
10025 /* Try to efficiently translate array(:) = 0. Return NULL if this
10029 gfc_trans_zero_assign (gfc_expr * expr)
10031 tree dest, len, type;
10035 sym = expr->symtree->n.sym;
10036 dest = gfc_get_symbol_decl (sym);
10038 type = TREE_TYPE (dest);
10039 if (POINTER_TYPE_P (type))
10040 type = TREE_TYPE (type);
10041 if (!GFC_ARRAY_TYPE_P (type))
10044 /* Determine the length of the array. */
10045 len = GFC_TYPE_ARRAY_SIZE (type);
10046 if (!len || TREE_CODE (len) != INTEGER_CST)
10049 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
10050 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10051 fold_convert (gfc_array_index_type, tmp));
10053 /* If we are zeroing a local array avoid taking its address by emitting
10055 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
10056 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
10057 dest, build_constructor (TREE_TYPE (dest),
10060 /* Convert arguments to the correct types. */
10061 dest = fold_convert (pvoid_type_node, dest);
10062 len = fold_convert (size_type_node, len);
10064 /* Construct call to __builtin_memset. */
10065 tmp = build_call_expr_loc (input_location,
10066 builtin_decl_explicit (BUILT_IN_MEMSET),
10067 3, dest, integer_zero_node, len);
10068 return fold_convert (void_type_node, tmp);
10072 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10073 that constructs the call to __builtin_memcpy. */
10076 gfc_build_memcpy_call (tree dst, tree src, tree len)
10080 /* Convert arguments to the correct types. */
10081 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
10082 dst = gfc_build_addr_expr (pvoid_type_node, dst);
10084 dst = fold_convert (pvoid_type_node, dst);
10086 if (!POINTER_TYPE_P (TREE_TYPE (src)))
10087 src = gfc_build_addr_expr (pvoid_type_node, src);
10089 src = fold_convert (pvoid_type_node, src);
10091 len = fold_convert (size_type_node, len);
10093 /* Construct call to __builtin_memcpy. */
10094 tmp = build_call_expr_loc (input_location,
10095 builtin_decl_explicit (BUILT_IN_MEMCPY),
10097 return fold_convert (void_type_node, tmp);
10101 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10102 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10103 source/rhs, both are gfc_full_array_ref_p which have been checked for
10107 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
10109 tree dst, dlen, dtype;
10110 tree src, slen, stype;
10113 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10114 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
10116 dtype = TREE_TYPE (dst);
10117 if (POINTER_TYPE_P (dtype))
10118 dtype = TREE_TYPE (dtype);
10119 stype = TREE_TYPE (src);
10120 if (POINTER_TYPE_P (stype))
10121 stype = TREE_TYPE (stype);
10123 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
10126 /* Determine the lengths of the arrays. */
10127 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
10128 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
10130 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10131 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10132 dlen, fold_convert (gfc_array_index_type, tmp));
10134 slen = GFC_TYPE_ARRAY_SIZE (stype);
10135 if (!slen || TREE_CODE (slen) != INTEGER_CST)
10137 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
10138 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10139 slen, fold_convert (gfc_array_index_type, tmp));
10141 /* Sanity check that they are the same. This should always be
10142 the case, as we should already have checked for conformance. */
10143 if (!tree_int_cst_equal (slen, dlen))
10146 return gfc_build_memcpy_call (dst, src, dlen);
10150 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10151 this can't be done. EXPR1 is the destination/lhs for which
10152 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10155 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
10157 unsigned HOST_WIDE_INT nelem;
10163 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
10167 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10168 dtype = TREE_TYPE (dst);
10169 if (POINTER_TYPE_P (dtype))
10170 dtype = TREE_TYPE (dtype);
10171 if (!GFC_ARRAY_TYPE_P (dtype))
10174 /* Determine the lengths of the array. */
10175 len = GFC_TYPE_ARRAY_SIZE (dtype);
10176 if (!len || TREE_CODE (len) != INTEGER_CST)
10179 /* Confirm that the constructor is the same size. */
10180 if (compare_tree_int (len, nelem) != 0)
10183 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10184 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10185 fold_convert (gfc_array_index_type, tmp));
10187 stype = gfc_typenode_for_spec (&expr2->ts);
10188 src = gfc_build_constant_array_constructor (expr2, stype);
10190 return gfc_build_memcpy_call (dst, src, len);
10194 /* Tells whether the expression is to be treated as a variable reference. */
10197 gfc_expr_is_variable (gfc_expr *expr)
10200 gfc_component *comp;
10201 gfc_symbol *func_ifc;
10203 if (expr->expr_type == EXPR_VARIABLE)
10206 arg = gfc_get_noncopying_intrinsic_argument (expr);
10209 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
10210 return gfc_expr_is_variable (arg);
10213 /* A data-pointer-returning function should be considered as a variable
10215 if (expr->expr_type == EXPR_FUNCTION
10216 && expr->ref == NULL)
10218 if (expr->value.function.isym != NULL)
10221 if (expr->value.function.esym != NULL)
10223 func_ifc = expr->value.function.esym;
10228 gcc_assert (expr->symtree);
10229 func_ifc = expr->symtree->n.sym;
10233 gcc_unreachable ();
10236 comp = gfc_get_proc_ptr_comp (expr);
10237 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
10240 func_ifc = comp->ts.interface;
10244 if (expr->expr_type == EXPR_COMPCALL)
10246 gcc_assert (!expr->value.compcall.tbp->is_generic);
10247 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
10254 gcc_assert (func_ifc->attr.function
10255 && func_ifc->result != NULL);
10256 return func_ifc->result->attr.pointer;
10260 /* Is the lhs OK for automatic reallocation? */
10263 is_scalar_reallocatable_lhs (gfc_expr *expr)
10267 /* An allocatable variable with no reference. */
10268 if (expr->symtree->n.sym->attr.allocatable
10272 /* All that can be left are allocatable components. However, we do
10273 not check for allocatable components here because the expression
10274 could be an allocatable component of a pointer component. */
10275 if (expr->symtree->n.sym->ts.type != BT_DERIVED
10276 && expr->symtree->n.sym->ts.type != BT_CLASS)
10279 /* Find an allocatable component ref last. */
10280 for (ref = expr->ref; ref; ref = ref->next)
10281 if (ref->type == REF_COMPONENT
10283 && ref->u.c.component->attr.allocatable)
10290 /* Allocate or reallocate scalar lhs, as necessary. */
10293 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
10294 tree string_length,
10302 tree size_in_bytes;
10308 if (!expr1 || expr1->rank)
10311 if (!expr2 || expr2->rank)
10314 for (ref = expr1->ref; ref; ref = ref->next)
10315 if (ref->type == REF_SUBSTRING)
10318 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10320 /* Since this is a scalar lhs, we can afford to do this. That is,
10321 there is no risk of side effects being repeated. */
10322 gfc_init_se (&lse, NULL);
10323 lse.want_pointer = 1;
10324 gfc_conv_expr (&lse, expr1);
10326 jump_label1 = gfc_build_label_decl (NULL_TREE);
10327 jump_label2 = gfc_build_label_decl (NULL_TREE);
10329 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10330 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
10331 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10333 tmp = build3_v (COND_EXPR, cond,
10334 build1_v (GOTO_EXPR, jump_label1),
10335 build_empty_stmt (input_location));
10336 gfc_add_expr_to_block (block, tmp);
10338 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10340 /* Use the rhs string length and the lhs element size. */
10341 size = string_length;
10342 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
10343 tmp = TYPE_SIZE_UNIT (tmp);
10344 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10345 TREE_TYPE (tmp), tmp,
10346 fold_convert (TREE_TYPE (tmp), size));
10350 /* Otherwise use the length in bytes of the rhs. */
10351 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
10352 size_in_bytes = size;
10355 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10356 size_in_bytes, size_one_node);
10358 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
10360 tree caf_decl, token;
10362 symbol_attribute attr;
10364 gfc_clear_attr (&attr);
10365 gfc_init_se (&caf_se, NULL);
10367 caf_decl = gfc_get_tree_for_caf_expr (expr1);
10368 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
10370 gfc_add_block_to_block (block, &caf_se.pre);
10371 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
10372 gfc_build_addr_expr (NULL_TREE, token),
10373 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
10376 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
10378 tmp = build_call_expr_loc (input_location,
10379 builtin_decl_explicit (BUILT_IN_CALLOC),
10380 2, build_one_cst (size_type_node),
10382 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10383 gfc_add_modify (block, lse.expr, tmp);
10387 tmp = build_call_expr_loc (input_location,
10388 builtin_decl_explicit (BUILT_IN_MALLOC),
10390 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10391 gfc_add_modify (block, lse.expr, tmp);
10394 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10396 /* Deferred characters need checking for lhs and rhs string
10397 length. Other deferred parameter variables will have to
10399 tmp = build1_v (GOTO_EXPR, jump_label2);
10400 gfc_add_expr_to_block (block, tmp);
10402 tmp = build1_v (LABEL_EXPR, jump_label1);
10403 gfc_add_expr_to_block (block, tmp);
10405 /* For a deferred length character, reallocate if lengths of lhs and
10406 rhs are different. */
10407 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10409 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10411 fold_convert (TREE_TYPE (lse.string_length),
10413 /* Jump past the realloc if the lengths are the same. */
10414 tmp = build3_v (COND_EXPR, cond,
10415 build1_v (GOTO_EXPR, jump_label2),
10416 build_empty_stmt (input_location));
10417 gfc_add_expr_to_block (block, tmp);
10418 tmp = build_call_expr_loc (input_location,
10419 builtin_decl_explicit (BUILT_IN_REALLOC),
10420 2, fold_convert (pvoid_type_node, lse.expr),
10422 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10423 gfc_add_modify (block, lse.expr, tmp);
10424 tmp = build1_v (LABEL_EXPR, jump_label2);
10425 gfc_add_expr_to_block (block, tmp);
10427 /* Update the lhs character length. */
10428 size = string_length;
10429 gfc_add_modify (block, lse.string_length,
10430 fold_convert (TREE_TYPE (lse.string_length), size));
10434 /* Check for assignments of the type
10438 to make sure we do not check for reallocation unneccessarily. */
10442 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
10444 gfc_actual_arglist *a;
10447 switch (expr2->expr_type)
10449 case EXPR_VARIABLE:
10450 return gfc_dep_compare_expr (expr1, expr2) == 0;
10452 case EXPR_FUNCTION:
10453 if (expr2->value.function.esym
10454 && expr2->value.function.esym->attr.elemental)
10456 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10459 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10464 else if (expr2->value.function.isym
10465 && expr2->value.function.isym->elemental)
10467 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10470 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10479 switch (expr2->value.op.op)
10481 case INTRINSIC_NOT:
10482 case INTRINSIC_UPLUS:
10483 case INTRINSIC_UMINUS:
10484 case INTRINSIC_PARENTHESES:
10485 return is_runtime_conformable (expr1, expr2->value.op.op1);
10487 case INTRINSIC_PLUS:
10488 case INTRINSIC_MINUS:
10489 case INTRINSIC_TIMES:
10490 case INTRINSIC_DIVIDE:
10491 case INTRINSIC_POWER:
10492 case INTRINSIC_AND:
10494 case INTRINSIC_EQV:
10495 case INTRINSIC_NEQV:
10502 case INTRINSIC_EQ_OS:
10503 case INTRINSIC_NE_OS:
10504 case INTRINSIC_GT_OS:
10505 case INTRINSIC_GE_OS:
10506 case INTRINSIC_LT_OS:
10507 case INTRINSIC_LE_OS:
10509 e1 = expr2->value.op.op1;
10510 e2 = expr2->value.op.op2;
10512 if (e1->rank == 0 && e2->rank > 0)
10513 return is_runtime_conformable (expr1, e2);
10514 else if (e1->rank > 0 && e2->rank == 0)
10515 return is_runtime_conformable (expr1, e1);
10516 else if (e1->rank > 0 && e2->rank > 0)
10517 return is_runtime_conformable (expr1, e1)
10518 && is_runtime_conformable (expr1, e2);
10536 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
10537 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
10538 bool class_realloc)
10540 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
10541 vec<tree, va_gc> *args = NULL;
10543 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
10546 /* Generate allocation of the lhs. */
10552 tmp = gfc_vptr_size_get (vptr);
10553 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10554 ? gfc_class_data_get (lse->expr) : lse->expr;
10555 gfc_init_block (&alloc);
10556 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
10557 tmp = fold_build2_loc (input_location, EQ_EXPR,
10558 logical_type_node, class_han,
10559 build_int_cst (prvoid_type_node, 0));
10560 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10562 PRED_FORTRAN_FAIL_ALLOC),
10563 gfc_finish_block (&alloc),
10564 build_empty_stmt (input_location));
10565 gfc_add_expr_to_block (&lse->pre, tmp);
10568 fcn = gfc_vptr_copy_get (vptr);
10570 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
10571 ? gfc_class_data_get (rse->expr) : rse->expr;
10574 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10575 || INDIRECT_REF_P (tmp)
10576 || (rhs->ts.type == BT_DERIVED
10577 && rhs->ts.u.derived->attr.unlimited_polymorphic
10578 && !rhs->ts.u.derived->attr.pointer
10579 && !rhs->ts.u.derived->attr.allocatable)
10580 || (UNLIMITED_POLY (rhs)
10581 && !CLASS_DATA (rhs)->attr.pointer
10582 && !CLASS_DATA (rhs)->attr.allocatable))
10583 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10585 vec_safe_push (args, tmp);
10586 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10587 ? gfc_class_data_get (lse->expr) : lse->expr;
10588 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10589 || INDIRECT_REF_P (tmp)
10590 || (lhs->ts.type == BT_DERIVED
10591 && lhs->ts.u.derived->attr.unlimited_polymorphic
10592 && !lhs->ts.u.derived->attr.pointer
10593 && !lhs->ts.u.derived->attr.allocatable)
10594 || (UNLIMITED_POLY (lhs)
10595 && !CLASS_DATA (lhs)->attr.pointer
10596 && !CLASS_DATA (lhs)->attr.allocatable))
10597 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10599 vec_safe_push (args, tmp);
10601 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10603 if (to_len != NULL_TREE && !integer_zerop (from_len))
10606 vec_safe_push (args, from_len);
10607 vec_safe_push (args, to_len);
10608 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10610 tmp = fold_build2_loc (input_location, GT_EXPR,
10611 logical_type_node, from_len,
10612 build_zero_cst (TREE_TYPE (from_len)));
10613 return fold_build3_loc (input_location, COND_EXPR,
10614 void_type_node, tmp,
10622 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10623 ? gfc_class_data_get (lse->expr) : lse->expr;
10624 stmtblock_t tblock;
10625 gfc_init_block (&tblock);
10626 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10627 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10628 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10629 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10630 /* When coming from a ptr_copy lhs and rhs are swapped. */
10631 gfc_add_modify_loc (input_location, &tblock, rhst,
10632 fold_convert (TREE_TYPE (rhst), tmp));
10633 return gfc_finish_block (&tblock);
10637 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10638 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10639 init_flag indicates initialization expressions and dealloc that no
10640 deallocate prior assignment is needed (if in doubt, set true).
10641 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10642 routine instead of a pointer assignment. Alias resolution is only done,
10643 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10644 where it is known, that newly allocated memory on the lhs can never be
10645 an alias of the rhs. */
10648 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10649 bool dealloc, bool use_vptr_copy, bool may_alias)
10654 gfc_ss *lss_section;
10661 bool scalar_to_array;
10662 tree string_length;
10664 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10665 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10666 bool is_poly_assign;
10668 /* Assignment of the form lhs = rhs. */
10669 gfc_start_block (&block);
10671 gfc_init_se (&lse, NULL);
10672 gfc_init_se (&rse, NULL);
10674 /* Walk the lhs. */
10675 lss = gfc_walk_expr (expr1);
10676 if (gfc_is_reallocatable_lhs (expr1))
10678 lss->no_bounds_check = 1;
10679 if (!(expr2->expr_type == EXPR_FUNCTION
10680 && expr2->value.function.isym != NULL
10681 && !(expr2->value.function.isym->elemental
10682 || expr2->value.function.isym->conversion)))
10683 lss->is_alloc_lhs = 1;
10686 lss->no_bounds_check = expr1->no_bounds_check;
10690 if ((expr1->ts.type == BT_DERIVED)
10691 && (gfc_is_class_array_function (expr2)
10692 || gfc_is_alloc_class_scalar_function (expr2)))
10693 expr2->must_finalize = 1;
10695 /* Checking whether a class assignment is desired is quite complicated and
10696 needed at two locations, so do it once only before the information is
10698 lhs_attr = gfc_expr_attr (expr1);
10699 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10700 || (lhs_attr.allocatable && !lhs_attr.dimension))
10701 && (expr1->ts.type == BT_CLASS
10702 || gfc_is_class_array_ref (expr1, NULL)
10703 || gfc_is_class_scalar_expr (expr1)
10704 || gfc_is_class_array_ref (expr2, NULL)
10705 || gfc_is_class_scalar_expr (expr2));
10708 /* Only analyze the expressions for coarray properties, when in coarray-lib
10710 if (flag_coarray == GFC_FCOARRAY_LIB)
10712 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10713 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10716 if (lss != gfc_ss_terminator)
10718 /* The assignment needs scalarization. */
10721 /* Find a non-scalar SS from the lhs. */
10722 while (lss_section != gfc_ss_terminator
10723 && lss_section->info->type != GFC_SS_SECTION)
10724 lss_section = lss_section->next;
10726 gcc_assert (lss_section != gfc_ss_terminator);
10728 /* Initialize the scalarizer. */
10729 gfc_init_loopinfo (&loop);
10731 /* Walk the rhs. */
10732 rss = gfc_walk_expr (expr2);
10733 if (rss == gfc_ss_terminator)
10734 /* The rhs is scalar. Add a ss for the expression. */
10735 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10736 /* When doing a class assign, then the handle to the rhs needs to be a
10737 pointer to allow for polymorphism. */
10738 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10739 rss->info->type = GFC_SS_REFERENCE;
10741 rss->no_bounds_check = expr2->no_bounds_check;
10742 /* Associate the SS with the loop. */
10743 gfc_add_ss_to_loop (&loop, lss);
10744 gfc_add_ss_to_loop (&loop, rss);
10746 /* Calculate the bounds of the scalarization. */
10747 gfc_conv_ss_startstride (&loop);
10748 /* Enable loop reversal. */
10749 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10750 loop.reverse[n] = GFC_ENABLE_REVERSE;
10751 /* Resolve any data dependencies in the statement. */
10753 gfc_conv_resolve_dependencies (&loop, lss, rss);
10754 /* Setup the scalarizing loops. */
10755 gfc_conv_loop_setup (&loop, &expr2->where);
10757 /* Setup the gfc_se structures. */
10758 gfc_copy_loopinfo_to_se (&lse, &loop);
10759 gfc_copy_loopinfo_to_se (&rse, &loop);
10762 gfc_mark_ss_chain_used (rss, 1);
10763 if (loop.temp_ss == NULL)
10766 gfc_mark_ss_chain_used (lss, 1);
10770 lse.ss = loop.temp_ss;
10771 gfc_mark_ss_chain_used (lss, 3);
10772 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10775 /* Allow the scalarizer to workshare array assignments. */
10776 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10777 == OMPWS_WORKSHARE_FLAG
10778 && loop.temp_ss == NULL)
10780 maybe_workshare = true;
10781 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10784 /* Start the scalarized loop body. */
10785 gfc_start_scalarized_body (&loop, &body);
10788 gfc_init_block (&body);
10790 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10792 /* Translate the expression. */
10793 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10794 && lhs_caf_attr.codimension;
10795 gfc_conv_expr (&rse, expr2);
10797 /* Deal with the case of a scalar class function assigned to a derived type. */
10798 if (gfc_is_alloc_class_scalar_function (expr2)
10799 && expr1->ts.type == BT_DERIVED)
10801 rse.expr = gfc_class_data_get (rse.expr);
10802 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10805 /* Stabilize a string length for temporaries. */
10806 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10807 && !(VAR_P (rse.string_length)
10808 || TREE_CODE (rse.string_length) == PARM_DECL
10809 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10810 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10811 else if (expr2->ts.type == BT_CHARACTER)
10813 if (expr1->ts.deferred
10814 && gfc_expr_attr (expr1).allocatable
10815 && gfc_check_dependency (expr1, expr2, true))
10816 rse.string_length =
10817 gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
10818 string_length = rse.string_length;
10821 string_length = NULL_TREE;
10825 gfc_conv_tmp_array_ref (&lse);
10826 if (expr2->ts.type == BT_CHARACTER)
10827 lse.string_length = string_length;
10831 gfc_conv_expr (&lse, expr1);
10832 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10834 && gfc_expr_attr (expr1).allocatable
10841 tmp = INDIRECT_REF_P (lse.expr)
10842 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10844 /* We should only get array references here. */
10845 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10846 || TREE_CODE (tmp) == ARRAY_REF);
10848 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10849 or the array itself(ARRAY_REF). */
10850 tmp = TREE_OPERAND (tmp, 0);
10852 /* Provide the address of the array. */
10853 if (TREE_CODE (lse.expr) == ARRAY_REF)
10854 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10856 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10857 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10858 msg = _("Assignment of scalar to unallocated array");
10859 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10860 &expr1->where, msg);
10863 /* Deallocate the lhs parameterized components if required. */
10864 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10865 && !expr1->symtree->n.sym->attr.associate_var)
10867 if (expr1->ts.type == BT_DERIVED
10868 && expr1->ts.u.derived
10869 && expr1->ts.u.derived->attr.pdt_type)
10871 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10873 gfc_add_expr_to_block (&lse.pre, tmp);
10875 else if (expr1->ts.type == BT_CLASS
10876 && CLASS_DATA (expr1)->ts.u.derived
10877 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10879 tmp = gfc_class_data_get (lse.expr);
10880 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10882 gfc_add_expr_to_block (&lse.pre, tmp);
10887 /* Assignments of scalar derived types with allocatable components
10888 to arrays must be done with a deep copy and the rhs temporary
10889 must have its components deallocated afterwards. */
10890 scalar_to_array = (expr2->ts.type == BT_DERIVED
10891 && expr2->ts.u.derived->attr.alloc_comp
10892 && !gfc_expr_is_variable (expr2)
10893 && expr1->rank && !expr2->rank);
10894 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10896 && expr1->ts.u.derived->attr.alloc_comp
10897 && gfc_is_alloc_class_scalar_function (expr2));
10898 if (scalar_to_array && dealloc)
10900 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10901 gfc_prepend_expr_to_block (&loop.post, tmp);
10904 /* When assigning a character function result to a deferred-length variable,
10905 the function call must happen before the (re)allocation of the lhs -
10906 otherwise the character length of the result is not known.
10907 NOTE 1: This relies on having the exact dependence of the length type
10908 parameter available to the caller; gfortran saves it in the .mod files.
10909 NOTE 2: Vector array references generate an index temporary that must
10910 not go outside the loop. Otherwise, variables should not generate
10912 NOTE 3: The concatenation operation generates a temporary pointer,
10913 whose allocation must go to the innermost loop.
10914 NOTE 4: Elemental functions may generate a temporary, too. */
10915 if (flag_realloc_lhs
10916 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10917 && !(lss != gfc_ss_terminator
10918 && rss != gfc_ss_terminator
10919 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10920 || (expr2->expr_type == EXPR_FUNCTION
10921 && expr2->value.function.esym != NULL
10922 && expr2->value.function.esym->attr.elemental)
10923 || (expr2->expr_type == EXPR_FUNCTION
10924 && expr2->value.function.isym != NULL
10925 && expr2->value.function.isym->elemental)
10926 || (expr2->expr_type == EXPR_OP
10927 && expr2->value.op.op == INTRINSIC_CONCAT))))
10928 gfc_add_block_to_block (&block, &rse.pre);
10930 /* Nullify the allocatable components corresponding to those of the lhs
10931 derived type, so that the finalization of the function result does not
10932 affect the lhs of the assignment. Prepend is used to ensure that the
10933 nullification occurs before the call to the finalizer. In the case of
10934 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10935 as part of the deep copy. */
10936 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10937 && (gfc_is_class_array_function (expr2)
10938 || gfc_is_alloc_class_scalar_function (expr2)))
10940 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10941 gfc_prepend_expr_to_block (&rse.post, tmp);
10942 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10943 gfc_add_block_to_block (&loop.post, &rse.post);
10948 if (is_poly_assign)
10949 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10950 use_vptr_copy || (lhs_attr.allocatable
10951 && !lhs_attr.dimension),
10952 flag_realloc_lhs && !lhs_attr.pointer);
10953 else if (flag_coarray == GFC_FCOARRAY_LIB
10954 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10955 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10956 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10958 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10959 allocatable component, because those need to be accessed via the
10960 caf-runtime. No need to check for coindexes here, because resolve
10961 has rewritten those already. */
10963 gfc_actual_arglist a1, a2;
10964 /* Clear the structures to prevent accessing garbage. */
10965 memset (&code, '\0', sizeof (gfc_code));
10966 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10967 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10972 code.ext.actual = &a1;
10973 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10974 tmp = gfc_conv_intrinsic_subroutine (&code);
10976 else if (!is_poly_assign && expr2->must_finalize
10977 && expr1->ts.type == BT_CLASS
10978 && expr2->ts.type == BT_CLASS)
10980 /* This case comes about when the scalarizer provides array element
10981 references. Use the vptr copy function, since this does a deep
10982 copy of allocatable components, without which the finalizer call */
10983 tmp = gfc_get_vptr_from_expr (rse.expr);
10984 if (tmp != NULL_TREE)
10986 tree fcn = gfc_vptr_copy_get (tmp);
10987 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10988 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10989 tmp = build_call_expr_loc (input_location,
10991 gfc_build_addr_expr (NULL, rse.expr),
10992 gfc_build_addr_expr (NULL, lse.expr));
10996 /* If nothing else works, do it the old fashioned way! */
10997 if (tmp == NULL_TREE)
10998 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10999 gfc_expr_is_variable (expr2)
11001 || expr2->expr_type == EXPR_ARRAY,
11002 !(l_is_temp || init_flag) && dealloc,
11003 expr1->symtree->n.sym->attr.codimension);
11005 /* Add the pre blocks to the body. */
11006 gfc_add_block_to_block (&body, &rse.pre);
11007 gfc_add_block_to_block (&body, &lse.pre);
11008 gfc_add_expr_to_block (&body, tmp);
11009 /* Add the post blocks to the body. */
11010 gfc_add_block_to_block (&body, &rse.post);
11011 gfc_add_block_to_block (&body, &lse.post);
11013 if (lss == gfc_ss_terminator)
11015 /* F2003: Add the code for reallocation on assignment. */
11016 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
11017 && !is_poly_assign)
11018 alloc_scalar_allocatable_for_assignment (&block, string_length,
11021 /* Use the scalar assignment as is. */
11022 gfc_add_block_to_block (&block, &body);
11026 gcc_assert (lse.ss == gfc_ss_terminator
11027 && rse.ss == gfc_ss_terminator);
11031 gfc_trans_scalarized_loop_boundary (&loop, &body);
11033 /* We need to copy the temporary to the actual lhs. */
11034 gfc_init_se (&lse, NULL);
11035 gfc_init_se (&rse, NULL);
11036 gfc_copy_loopinfo_to_se (&lse, &loop);
11037 gfc_copy_loopinfo_to_se (&rse, &loop);
11039 rse.ss = loop.temp_ss;
11042 gfc_conv_tmp_array_ref (&rse);
11043 gfc_conv_expr (&lse, expr1);
11045 gcc_assert (lse.ss == gfc_ss_terminator
11046 && rse.ss == gfc_ss_terminator);
11048 if (expr2->ts.type == BT_CHARACTER)
11049 rse.string_length = string_length;
11051 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
11053 gfc_add_expr_to_block (&body, tmp);
11056 /* F2003: Allocate or reallocate lhs of allocatable array. */
11057 if (flag_realloc_lhs
11058 && gfc_is_reallocatable_lhs (expr1)
11060 && !is_runtime_conformable (expr1, expr2))
11062 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
11063 ompws_flags &= ~OMPWS_SCALARIZER_WS;
11064 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
11065 if (tmp != NULL_TREE)
11066 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
11069 if (maybe_workshare)
11070 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
11072 /* Generate the copying loops. */
11073 gfc_trans_scalarizing_loops (&loop, &body);
11075 /* Wrap the whole thing up. */
11076 gfc_add_block_to_block (&block, &loop.pre);
11077 gfc_add_block_to_block (&block, &loop.post);
11079 gfc_cleanup_loop (&loop);
11082 return gfc_finish_block (&block);
11086 /* Check whether EXPR is a copyable array. */
11089 copyable_array_p (gfc_expr * expr)
11091 if (expr->expr_type != EXPR_VARIABLE)
11094 /* First check it's an array. */
11095 if (expr->rank < 1 || !expr->ref || expr->ref->next)
11098 if (!gfc_full_array_ref_p (expr->ref, NULL))
11101 /* Next check that it's of a simple enough type. */
11102 switch (expr->ts.type)
11114 return !expr->ts.u.derived->attr.alloc_comp;
11123 /* Translate an assignment. */
11126 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
11127 bool dealloc, bool use_vptr_copy, bool may_alias)
11131 /* Special case a single function returning an array. */
11132 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
11134 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
11139 /* Special case assigning an array to zero. */
11140 if (copyable_array_p (expr1)
11141 && is_zero_initializer_p (expr2))
11143 tmp = gfc_trans_zero_assign (expr1);
11148 /* Special case copying one array to another. */
11149 if (copyable_array_p (expr1)
11150 && copyable_array_p (expr2)
11151 && gfc_compare_types (&expr1->ts, &expr2->ts)
11152 && !gfc_check_dependency (expr1, expr2, 0))
11154 tmp = gfc_trans_array_copy (expr1, expr2);
11159 /* Special case initializing an array from a constant array constructor. */
11160 if (copyable_array_p (expr1)
11161 && expr2->expr_type == EXPR_ARRAY
11162 && gfc_compare_types (&expr1->ts, &expr2->ts))
11164 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
11169 if (UNLIMITED_POLY (expr1) && expr1->rank
11170 && expr2->ts.type != BT_CLASS)
11171 use_vptr_copy = true;
11173 /* Fallback to the scalarizer to generate explicit loops. */
11174 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
11175 use_vptr_copy, may_alias);
11179 gfc_trans_init_assign (gfc_code * code)
11181 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
11185 gfc_trans_assign (gfc_code * code)
11187 return gfc_trans_assignment (code->expr1, code->expr2, false, true);