1 /* Expression translation
2 Copyright (C) 2002-2019 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
26 #include "coretypes.h"
31 #include "stringpool.h"
32 #include "diagnostic-core.h" /* For fatal_error. */
33 #include "fold-const.h"
34 #include "langhooks.h"
36 #include "constructor.h"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
45 /* Convert a scalar to an array descriptor. To be used for assumed-rank
49 get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
51 enum gfc_array_kind akind;
54 akind = GFC_ARRAY_POINTER_CONT;
55 else if (attr.allocatable)
56 akind = GFC_ARRAY_ALLOCATABLE;
58 akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
60 if (POINTER_TYPE_P (TREE_TYPE (scalar)))
61 scalar = TREE_TYPE (scalar);
62 return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
63 akind, !(attr.pointer || attr.target));
67 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
69 tree desc, type, etype;
71 type = get_scalar_to_descriptor_type (scalar, attr);
72 etype = TREE_TYPE (scalar);
73 desc = gfc_create_var (type, "desc");
74 DECL_ARTIFICIAL (desc) = 1;
76 if (CONSTANT_CLASS_P (scalar))
79 tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
80 gfc_add_modify (&se->pre, tmp, scalar);
83 if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
84 scalar = gfc_build_addr_expr (NULL_TREE, scalar);
85 else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
86 etype = TREE_TYPE (etype);
87 gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
88 gfc_get_dtype_rank_type (0, etype));
89 gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
91 /* Copy pointer address back - but only if it could have changed and
92 if the actual argument is a pointer and not, e.g., NULL(). */
93 if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
94 gfc_add_modify (&se->post, scalar,
95 fold_convert (TREE_TYPE (scalar),
96 gfc_conv_descriptor_data_get (desc)));
101 /* Get the coarray token from the ultimate array or component ref.
102 Returns a NULL_TREE, when the ref object is not allocatable or pointer. */
105 gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
107 gfc_symbol *sym = expr->symtree->n.sym;
108 bool is_coarray = sym->attr.codimension;
109 gfc_expr *caf_expr = gfc_copy_expr (expr);
110 gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL;
114 if (ref->type == REF_COMPONENT
115 && (ref->u.c.component->attr.allocatable
116 || ref->u.c.component->attr.pointer)
117 && (is_coarray || ref->u.c.component->attr.codimension))
122 if (last_caf_ref == NULL)
125 tree comp = last_caf_ref->u.c.component->caf_token, caf;
127 bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
128 if (comp == NULL_TREE && comp_ref)
130 gfc_init_se (&se, outerse);
131 gfc_free_ref_list (last_caf_ref->next);
132 last_caf_ref->next = NULL;
133 caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank;
134 se.want_pointer = comp_ref;
135 gfc_conv_expr (&se, caf_expr);
136 gfc_add_block_to_block (&outerse->pre, &se.pre);
138 if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref)
139 se.expr = TREE_OPERAND (se.expr, 0);
140 gfc_free_expr (caf_expr);
143 caf = fold_build3_loc (input_location, COMPONENT_REF,
144 TREE_TYPE (comp), se.expr, comp, NULL_TREE);
146 caf = gfc_conv_descriptor_token (se.expr);
147 return gfc_build_addr_expr (NULL_TREE, caf);
151 /* This is the seed for an eventual trans-class.c
153 The following parameters should not be used directly since they might
154 in future implementations. Use the corresponding APIs. */
155 #define CLASS_DATA_FIELD 0
156 #define CLASS_VPTR_FIELD 1
157 #define CLASS_LEN_FIELD 2
158 #define VTABLE_HASH_FIELD 0
159 #define VTABLE_SIZE_FIELD 1
160 #define VTABLE_EXTENDS_FIELD 2
161 #define VTABLE_DEF_INIT_FIELD 3
162 #define VTABLE_COPY_FIELD 4
163 #define VTABLE_FINAL_FIELD 5
164 #define VTABLE_DEALLOCATE_FIELD 6
168 gfc_class_set_static_fields (tree decl, tree vptr, tree data)
172 vec<constructor_elt, va_gc> *init = NULL;
174 field = TYPE_FIELDS (TREE_TYPE (decl));
175 tmp = gfc_advance_chain (field, CLASS_DATA_FIELD);
176 CONSTRUCTOR_APPEND_ELT (init, tmp, data);
178 tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD);
179 CONSTRUCTOR_APPEND_ELT (init, tmp, vptr);
181 return build_constructor (TREE_TYPE (decl), init);
186 gfc_class_data_get (tree decl)
189 if (POINTER_TYPE_P (TREE_TYPE (decl)))
190 decl = build_fold_indirect_ref_loc (input_location, decl);
191 data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
193 return fold_build3_loc (input_location, COMPONENT_REF,
194 TREE_TYPE (data), decl, data,
200 gfc_class_vptr_get (tree decl)
203 /* For class arrays decl may be a temporary descriptor handle, the vptr is
204 then available through the saved descriptor. */
205 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
206 && GFC_DECL_SAVED_DESCRIPTOR (decl))
207 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
208 if (POINTER_TYPE_P (TREE_TYPE (decl)))
209 decl = build_fold_indirect_ref_loc (input_location, decl);
210 vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
212 return fold_build3_loc (input_location, COMPONENT_REF,
213 TREE_TYPE (vptr), decl, vptr,
219 gfc_class_len_get (tree decl)
222 /* For class arrays decl may be a temporary descriptor handle, the len is
223 then available through the saved descriptor. */
224 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
225 && GFC_DECL_SAVED_DESCRIPTOR (decl))
226 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
227 if (POINTER_TYPE_P (TREE_TYPE (decl)))
228 decl = build_fold_indirect_ref_loc (input_location, decl);
229 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
231 return fold_build3_loc (input_location, COMPONENT_REF,
232 TREE_TYPE (len), decl, len,
237 /* Try to get the _len component of a class. When the class is not unlimited
238 poly, i.e. no _len field exists, then return a zero node. */
241 gfc_class_len_or_zero_get (tree decl)
244 /* For class arrays decl may be a temporary descriptor handle, the vptr is
245 then available through the saved descriptor. */
246 if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
247 && GFC_DECL_SAVED_DESCRIPTOR (decl))
248 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
249 if (POINTER_TYPE_P (TREE_TYPE (decl)))
250 decl = build_fold_indirect_ref_loc (input_location, decl);
251 len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
253 return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
254 TREE_TYPE (len), decl, len,
256 : build_zero_cst (gfc_charlen_type_node);
260 /* Get the specified FIELD from the VPTR. */
263 vptr_field_get (tree vptr, int fieldno)
266 vptr = build_fold_indirect_ref_loc (input_location, vptr);
267 field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)),
269 field = fold_build3_loc (input_location, COMPONENT_REF,
270 TREE_TYPE (field), vptr, field,
277 /* Get the field from the class' vptr. */
280 class_vtab_field_get (tree decl, int fieldno)
283 vptr = gfc_class_vptr_get (decl);
284 return vptr_field_get (vptr, fieldno);
288 /* Define a macro for creating the class_vtab_* and vptr_* accessors in
290 #define VTAB_GET_FIELD_GEN(name, field) tree \
291 gfc_class_vtab_## name ##_get (tree cl) \
293 return class_vtab_field_get (cl, field); \
297 gfc_vptr_## name ##_get (tree vptr) \
299 return vptr_field_get (vptr, field); \
302 VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD)
303 VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD)
304 VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
305 VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
306 VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
307 VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
310 /* The size field is returned as an array index type. Therefore treat
311 it and only it specially. */
314 gfc_class_vtab_size_get (tree cl)
317 size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD);
318 /* Always return size as an array index type. */
319 size = fold_convert (gfc_array_index_type, size);
325 gfc_vptr_size_get (tree vptr)
328 size = vptr_field_get (vptr, VTABLE_SIZE_FIELD);
329 /* Always return size as an array index type. */
330 size = fold_convert (gfc_array_index_type, size);
336 #undef CLASS_DATA_FIELD
337 #undef CLASS_VPTR_FIELD
338 #undef CLASS_LEN_FIELD
339 #undef VTABLE_HASH_FIELD
340 #undef VTABLE_SIZE_FIELD
341 #undef VTABLE_EXTENDS_FIELD
342 #undef VTABLE_DEF_INIT_FIELD
343 #undef VTABLE_COPY_FIELD
344 #undef VTABLE_FINAL_FIELD
347 /* Search for the last _class ref in the chain of references of this
348 expression and cut the chain there. Albeit this routine is similiar
349 to class.c::gfc_add_component_ref (), is there a significant
350 difference: gfc_add_component_ref () concentrates on an array ref to
351 be the last ref in the chain. This routine is oblivious to the kind
352 of refs following. */
355 gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
358 gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
360 /* Find the last class reference. */
363 for (ref = e->ref; ref; ref = ref->next)
365 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
368 if (ref->type == REF_COMPONENT
369 && ref->u.c.component->ts.type == BT_CLASS)
371 /* Component to the right of a part reference with nonzero rank
372 must not have the ALLOCATABLE attribute. If attempts are
373 made to reference such a component reference, an error results
374 followed by an ICE. */
375 if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
380 if (ref->next == NULL)
384 /* Remove and store all subsequent references after the
388 tail = class_ref->next;
389 class_ref->next = NULL;
391 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
398 base_expr = gfc_expr_to_initialize (e);
400 base_expr = gfc_copy_expr (e);
402 /* Restore the original tail expression. */
405 gfc_free_ref_list (class_ref->next);
406 class_ref->next = tail;
408 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
410 gfc_free_ref_list (e->ref);
417 /* Reset the vptr to the declared type, e.g. after deallocation. */
420 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
427 /* Evaluate the expression and obtain the vptr from it. */
428 gfc_init_se (&se, NULL);
430 gfc_conv_expr_descriptor (&se, e);
432 gfc_conv_expr (&se, e);
433 gfc_add_block_to_block (block, &se.pre);
434 vptr = gfc_get_vptr_from_expr (se.expr);
436 /* If a vptr is not found, we can do nothing more. */
437 if (vptr == NULL_TREE)
440 if (UNLIMITED_POLY (e))
441 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
444 /* Return the vptr to the address of the declared type. */
445 vtab = gfc_find_derived_vtab (e->ts.u.derived);
446 vtable = vtab->backend_decl;
447 if (vtable == NULL_TREE)
448 vtable = gfc_get_symbol_decl (vtab);
449 vtable = gfc_build_addr_expr (NULL, vtable);
450 vtable = fold_convert (TREE_TYPE (vptr), vtable);
451 gfc_add_modify (block, vptr, vtable);
456 /* Reset the len for unlimited polymorphic objects. */
459 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
463 e = gfc_find_and_cut_at_last_class_ref (expr);
466 gfc_add_len_component (e);
467 gfc_init_se (&se_len, NULL);
468 gfc_conv_expr (&se_len, e);
469 gfc_add_modify (block, se_len.expr,
470 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
475 /* Obtain the vptr of the last class reference in an expression.
476 Return NULL_TREE if no class reference is found. */
479 gfc_get_vptr_from_expr (tree expr)
484 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
486 type = TREE_TYPE (tmp);
489 if (GFC_CLASS_TYPE_P (type))
490 return gfc_class_vptr_get (tmp);
491 if (type != TYPE_CANONICAL (type))
492 type = TYPE_CANONICAL (type);
496 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
500 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
501 tmp = build_fold_indirect_ref_loc (input_location, tmp);
503 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
504 return gfc_class_vptr_get (tmp);
511 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
514 tree tmp, tmp2, type;
516 gfc_conv_descriptor_data_set (block, lhs_desc,
517 gfc_conv_descriptor_data_get (rhs_desc));
518 gfc_conv_descriptor_offset_set (block, lhs_desc,
519 gfc_conv_descriptor_offset_get (rhs_desc));
521 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
522 gfc_conv_descriptor_dtype (rhs_desc));
524 /* Assign the dimension as range-ref. */
525 tmp = gfc_get_descriptor_dimension (lhs_desc);
526 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
528 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
529 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
530 gfc_index_zero_node, NULL_TREE, NULL_TREE);
531 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
532 gfc_index_zero_node, NULL_TREE, NULL_TREE);
533 gfc_add_modify (block, tmp, tmp2);
537 /* Takes a derived type expression and returns the address of a temporary
538 class object of the 'declared' type. If vptr is not NULL, this is
539 used for the temporary class object.
540 optional_alloc_ptr is false when the dummy is neither allocatable
541 nor a pointer; that's only relevant for the optional handling. */
543 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
544 gfc_typespec class_ts, tree vptr, bool optional,
545 bool optional_alloc_ptr)
548 tree cond_optional = NULL_TREE;
555 /* The derived type needs to be converted to a temporary
557 tmp = gfc_typenode_for_spec (&class_ts);
558 var = gfc_create_var (tmp, "class");
561 ctree = gfc_class_vptr_get (var);
563 if (vptr != NULL_TREE)
565 /* Use the dynamic vptr. */
570 /* In this case the vtab corresponds to the derived type and the
571 vptr must point to it. */
572 vtab = gfc_find_derived_vtab (e->ts.u.derived);
574 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
576 gfc_add_modify (&parmse->pre, ctree,
577 fold_convert (TREE_TYPE (ctree), tmp));
579 /* Now set the data field. */
580 ctree = gfc_class_data_get (var);
583 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
585 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
587 /* If there is a ready made pointer to a derived type, use it
588 rather than evaluating the expression again. */
589 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
590 gfc_add_modify (&parmse->pre, ctree, tmp);
592 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
594 /* For an array reference in an elemental procedure call we need
595 to retain the ss to provide the scalarized array reference. */
596 gfc_conv_expr_reference (parmse, e);
597 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
599 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
601 fold_convert (TREE_TYPE (tmp), null_pointer_node));
602 gfc_add_modify (&parmse->pre, ctree, tmp);
606 ss = gfc_walk_expr (e);
607 if (ss == gfc_ss_terminator)
610 gfc_conv_expr_reference (parmse, e);
612 /* Scalar to an assumed-rank array. */
613 if (class_ts.u.derived->components->as)
616 type = get_scalar_to_descriptor_type (parmse->expr,
618 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
619 gfc_get_dtype (type));
621 parmse->expr = build3_loc (input_location, COND_EXPR,
622 TREE_TYPE (parmse->expr),
623 cond_optional, parmse->expr,
624 fold_convert (TREE_TYPE (parmse->expr),
626 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
630 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
632 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
634 fold_convert (TREE_TYPE (tmp),
636 gfc_add_modify (&parmse->pre, ctree, tmp);
642 gfc_init_block (&block);
646 parmse->use_offset = 1;
647 gfc_conv_expr_descriptor (parmse, e);
649 /* Detect any array references with vector subscripts. */
650 for (ref = e->ref; ref; ref = ref->next)
651 if (ref->type == REF_ARRAY
652 && ref->u.ar.type != AR_ELEMENT
653 && ref->u.ar.type != AR_FULL)
655 for (dim = 0; dim < ref->u.ar.dimen; dim++)
656 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
658 if (dim < ref->u.ar.dimen)
662 /* Array references with vector subscripts and non-variable expressions
663 need be converted to a one-based descriptor. */
664 if (ref || e->expr_type != EXPR_VARIABLE)
666 for (dim = 0; dim < e->rank; ++dim)
667 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
671 if (e->rank != class_ts.u.derived->components->as->rank)
673 gcc_assert (class_ts.u.derived->components->as->type
675 class_array_data_assign (&block, ctree, parmse->expr, false);
679 if (gfc_expr_attr (e).codimension)
680 parmse->expr = fold_build1_loc (input_location,
684 gfc_add_modify (&block, ctree, parmse->expr);
689 tmp = gfc_finish_block (&block);
691 gfc_init_block (&block);
692 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
694 tmp = build3_v (COND_EXPR, cond_optional, tmp,
695 gfc_finish_block (&block));
696 gfc_add_expr_to_block (&parmse->pre, tmp);
699 gfc_add_block_to_block (&parmse->pre, &block);
703 if (class_ts.u.derived->components->ts.type == BT_DERIVED
704 && class_ts.u.derived->components->ts.u.derived
705 ->attr.unlimited_polymorphic)
707 /* Take care about initializing the _len component correctly. */
708 ctree = gfc_class_len_get (var);
709 if (UNLIMITED_POLY (e))
714 len = gfc_copy_expr (e);
715 gfc_add_len_component (len);
716 gfc_init_se (&se, NULL);
717 gfc_conv_expr (&se, len);
719 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
720 cond_optional, se.expr,
721 fold_convert (TREE_TYPE (se.expr),
727 tmp = integer_zero_node;
728 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
731 /* Pass the address of the class object. */
732 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
734 if (optional && optional_alloc_ptr)
735 parmse->expr = build3_loc (input_location, COND_EXPR,
736 TREE_TYPE (parmse->expr),
737 cond_optional, parmse->expr,
738 fold_convert (TREE_TYPE (parmse->expr),
743 /* Create a new class container, which is required as scalar coarrays
744 have an array descriptor while normal scalars haven't. Optionally,
745 NULL pointer checks are added if the argument is OPTIONAL. */
748 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
749 gfc_typespec class_ts, bool optional)
751 tree var, ctree, tmp;
756 gfc_init_block (&block);
759 for (ref = e->ref; ref; ref = ref->next)
761 if (ref->type == REF_COMPONENT
762 && ref->u.c.component->ts.type == BT_CLASS)
766 if (class_ref == NULL
767 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
768 tmp = e->symtree->n.sym->backend_decl;
771 /* Remove everything after the last class reference, convert the
772 expression and then recover its tailend once more. */
774 ref = class_ref->next;
775 class_ref->next = NULL;
776 gfc_init_se (&tmpse, NULL);
777 gfc_conv_expr (&tmpse, e);
778 class_ref->next = ref;
782 var = gfc_typenode_for_spec (&class_ts);
783 var = gfc_create_var (var, "class");
785 ctree = gfc_class_vptr_get (var);
786 gfc_add_modify (&block, ctree,
787 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
789 ctree = gfc_class_data_get (var);
790 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
791 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
793 /* Pass the address of the class object. */
794 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
798 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
801 tmp = gfc_finish_block (&block);
803 gfc_init_block (&block);
804 tmp2 = gfc_class_data_get (var);
805 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
807 tmp2 = gfc_finish_block (&block);
809 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
811 gfc_add_expr_to_block (&parmse->pre, tmp);
814 gfc_add_block_to_block (&parmse->pre, &block);
818 /* Takes an intrinsic type expression and returns the address of a temporary
819 class object of the 'declared' type. */
821 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
822 gfc_typespec class_ts)
830 /* The intrinsic type needs to be converted to a temporary
832 tmp = gfc_typenode_for_spec (&class_ts);
833 var = gfc_create_var (tmp, "class");
836 ctree = gfc_class_vptr_get (var);
838 vtab = gfc_find_vtab (&e->ts);
840 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
841 gfc_add_modify (&parmse->pre, ctree,
842 fold_convert (TREE_TYPE (ctree), tmp));
844 /* Now set the data field. */
845 ctree = gfc_class_data_get (var);
846 if (parmse->ss && parmse->ss->info->useflags)
848 /* For an array reference in an elemental procedure call we need
849 to retain the ss to provide the scalarized array reference. */
850 gfc_conv_expr_reference (parmse, e);
851 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
852 gfc_add_modify (&parmse->pre, ctree, tmp);
856 ss = gfc_walk_expr (e);
857 if (ss == gfc_ss_terminator)
860 gfc_conv_expr_reference (parmse, e);
861 if (class_ts.u.derived->components->as
862 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
864 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
866 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
867 TREE_TYPE (ctree), tmp);
870 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
871 gfc_add_modify (&parmse->pre, ctree, tmp);
876 parmse->use_offset = 1;
877 gfc_conv_expr_descriptor (parmse, e);
878 if (class_ts.u.derived->components->as->rank != e->rank)
880 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
881 TREE_TYPE (ctree), parmse->expr);
882 gfc_add_modify (&parmse->pre, ctree, tmp);
885 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
889 gcc_assert (class_ts.type == BT_CLASS);
890 if (class_ts.u.derived->components->ts.type == BT_DERIVED
891 && class_ts.u.derived->components->ts.u.derived
892 ->attr.unlimited_polymorphic)
894 ctree = gfc_class_len_get (var);
895 /* When the actual arg is a char array, then set the _len component of the
896 unlimited polymorphic entity to the length of the string. */
897 if (e->ts.type == BT_CHARACTER)
899 /* Start with parmse->string_length because this seems to be set to a
900 correct value more often. */
901 if (parmse->string_length)
902 tmp = parmse->string_length;
903 /* When the string_length is not yet set, then try the backend_decl of
905 else if (e->ts.u.cl->backend_decl)
906 tmp = e->ts.u.cl->backend_decl;
907 /* If both of the above approaches fail, then try to generate an
908 expression from the input, which is only feasible currently, when the
909 expression can be evaluated to a constant one. */
912 /* Try to simplify the expression. */
913 gfc_simplify_expr (e, 0);
914 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
916 /* Amazingly all data is present to compute the length of a
917 constant string, but the expression is not yet there. */
918 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
919 gfc_charlen_int_kind,
921 mpz_set_ui (e->ts.u.cl->length->value.integer,
922 e->value.character.length);
923 gfc_conv_const_charlen (e->ts.u.cl);
924 e->ts.u.cl->resolved = 1;
925 tmp = e->ts.u.cl->backend_decl;
929 gfc_error ("Cannot compute the length of the char array "
930 "at %L.", &e->where);
935 tmp = integer_zero_node;
937 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
939 else if (class_ts.type == BT_CLASS
940 && class_ts.u.derived->components
941 && class_ts.u.derived->components->ts.u
942 .derived->attr.unlimited_polymorphic)
944 ctree = gfc_class_len_get (var);
945 gfc_add_modify (&parmse->pre, ctree,
946 fold_convert (TREE_TYPE (ctree),
949 /* Pass the address of the class object. */
950 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
954 /* Takes a scalarized class array expression and returns the
955 address of a temporary scalar class object of the 'declared'
957 OOP-TODO: This could be improved by adding code that branched on
958 the dynamic type being the same as the declared type. In this case
959 the original class expression can be passed directly.
960 optional_alloc_ptr is false when the dummy is neither allocatable
961 nor a pointer; that's relevant for the optional handling.
962 Set copyback to true if class container's _data and _vtab pointers
963 might get modified. */
966 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
967 bool elemental, bool copyback, bool optional,
968 bool optional_alloc_ptr)
974 tree cond = NULL_TREE;
975 tree slen = NULL_TREE;
979 bool full_array = false;
981 gfc_init_block (&block);
984 for (ref = e->ref; ref; ref = ref->next)
986 if (ref->type == REF_COMPONENT
987 && ref->u.c.component->ts.type == BT_CLASS)
990 if (ref->next == NULL)
994 if ((ref == NULL || class_ref == ref)
995 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
996 && (!class_ts.u.derived->components->as
997 || class_ts.u.derived->components->as->rank != -1))
1000 /* Test for FULL_ARRAY. */
1001 if (e->rank == 0 && gfc_expr_attr (e).codimension
1002 && gfc_expr_attr (e).dimension)
1005 gfc_is_class_array_ref (e, &full_array);
1007 /* The derived type needs to be converted to a temporary
1009 tmp = gfc_typenode_for_spec (&class_ts);
1010 var = gfc_create_var (tmp, "class");
1013 ctree = gfc_class_data_get (var);
1014 if (class_ts.u.derived->components->as
1015 && e->rank != class_ts.u.derived->components->as->rank)
1019 tree type = get_scalar_to_descriptor_type (parmse->expr,
1021 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1022 gfc_get_dtype (type));
1024 tmp = gfc_class_data_get (parmse->expr);
1025 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1026 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1028 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1031 class_array_data_assign (&block, ctree, parmse->expr, false);
1035 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1036 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1037 TREE_TYPE (ctree), parmse->expr);
1038 gfc_add_modify (&block, ctree, parmse->expr);
1041 /* Return the data component, except in the case of scalarized array
1042 references, where nullification of the cannot occur and so there
1044 if (!elemental && full_array && copyback)
1046 if (class_ts.u.derived->components->as
1047 && e->rank != class_ts.u.derived->components->as->rank)
1050 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1051 gfc_conv_descriptor_data_get (ctree));
1053 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1056 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1060 ctree = gfc_class_vptr_get (var);
1062 /* The vptr is the second field of the actual argument.
1063 First we have to find the corresponding class reference. */
1066 if (gfc_is_class_array_function (e)
1067 && parmse->class_vptr != NULL_TREE)
1068 tmp = parmse->class_vptr;
1069 else if (class_ref == NULL
1070 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1072 tmp = e->symtree->n.sym->backend_decl;
1074 if (TREE_CODE (tmp) == FUNCTION_DECL)
1075 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1077 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1078 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1080 slen = build_zero_cst (size_type_node);
1084 /* Remove everything after the last class reference, convert the
1085 expression and then recover its tailend once more. */
1087 ref = class_ref->next;
1088 class_ref->next = NULL;
1089 gfc_init_se (&tmpse, NULL);
1090 gfc_conv_expr (&tmpse, e);
1091 class_ref->next = ref;
1093 slen = tmpse.string_length;
1096 gcc_assert (tmp != NULL_TREE);
1098 /* Dereference if needs be. */
1099 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1100 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1102 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1103 vptr = gfc_class_vptr_get (tmp);
1107 gfc_add_modify (&block, ctree,
1108 fold_convert (TREE_TYPE (ctree), vptr));
1110 /* Return the vptr component, except in the case of scalarized array
1111 references, where the dynamic type cannot change. */
1112 if (!elemental && full_array && copyback)
1113 gfc_add_modify (&parmse->post, vptr,
1114 fold_convert (TREE_TYPE (vptr), ctree));
1116 /* For unlimited polymorphic objects also set the _len component. */
1117 if (class_ts.type == BT_CLASS
1118 && class_ts.u.derived->components
1119 && class_ts.u.derived->components->ts.u
1120 .derived->attr.unlimited_polymorphic)
1122 ctree = gfc_class_len_get (var);
1123 if (UNLIMITED_POLY (e))
1124 tmp = gfc_class_len_get (tmp);
1125 else if (e->ts.type == BT_CHARACTER)
1127 gcc_assert (slen != NULL_TREE);
1131 tmp = build_zero_cst (size_type_node);
1132 gfc_add_modify (&parmse->pre, ctree,
1133 fold_convert (TREE_TYPE (ctree), tmp));
1135 /* Return the len component, except in the case of scalarized array
1136 references, where the dynamic type cannot change. */
1137 if (!elemental && full_array && copyback
1138 && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1139 gfc_add_modify (&parmse->post, tmp,
1140 fold_convert (TREE_TYPE (tmp), ctree));
1147 cond = gfc_conv_expr_present (e->symtree->n.sym);
1148 /* parmse->pre may contain some preparatory instructions for the
1149 temporary array descriptor. Those may only be executed when the
1150 optional argument is set, therefore add parmse->pre's instructions
1151 to block, which is later guarded by an if (optional_arg_given). */
1152 gfc_add_block_to_block (&parmse->pre, &block);
1153 block.head = parmse->pre.head;
1154 parmse->pre.head = NULL_TREE;
1155 tmp = gfc_finish_block (&block);
1157 if (optional_alloc_ptr)
1158 tmp2 = build_empty_stmt (input_location);
1161 gfc_init_block (&block);
1163 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1164 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1165 null_pointer_node));
1166 tmp2 = gfc_finish_block (&block);
1169 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1171 gfc_add_expr_to_block (&parmse->pre, tmp);
1174 gfc_add_block_to_block (&parmse->pre, &block);
1176 /* Pass the address of the class object. */
1177 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1179 if (optional && optional_alloc_ptr)
1180 parmse->expr = build3_loc (input_location, COND_EXPR,
1181 TREE_TYPE (parmse->expr),
1183 fold_convert (TREE_TYPE (parmse->expr),
1184 null_pointer_node));
1188 /* Given a class array declaration and an index, returns the address
1189 of the referenced element. */
1192 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1195 tree data, size, tmp, ctmp, offset, ptr;
1197 data = data_comp != NULL_TREE ? data_comp :
1198 gfc_class_data_get (class_decl);
1199 size = gfc_class_vtab_size_get (class_decl);
1203 tmp = fold_convert (gfc_array_index_type,
1204 gfc_class_len_get (class_decl));
1205 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1206 gfc_array_index_type, size, tmp);
1207 tmp = fold_build2_loc (input_location, GT_EXPR,
1208 logical_type_node, tmp,
1209 build_zero_cst (TREE_TYPE (tmp)));
1210 size = fold_build3_loc (input_location, COND_EXPR,
1211 gfc_array_index_type, tmp, ctmp, size);
1214 offset = fold_build2_loc (input_location, MULT_EXPR,
1215 gfc_array_index_type,
1218 data = gfc_conv_descriptor_data_get (data);
1219 ptr = fold_convert (pvoid_type_node, data);
1220 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1221 return fold_convert (TREE_TYPE (data), ptr);
1225 /* Copies one class expression to another, assuming that if either
1226 'to' or 'from' are arrays they are packed. Should 'from' be
1227 NULL_TREE, the initialization expression for 'to' is used, assuming
1228 that the _vptr is set. */
1231 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1241 vec<tree, va_gc> *args;
1246 bool is_from_desc = false, is_to_class = false;
1249 /* To prevent warnings on uninitialized variables. */
1250 from_len = to_len = NULL_TREE;
1252 if (from != NULL_TREE)
1253 fcn = gfc_class_vtab_copy_get (from);
1255 fcn = gfc_class_vtab_copy_get (to);
1257 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1259 if (from != NULL_TREE)
1261 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1265 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1269 /* Check that from is a class. When the class is part of a coarray,
1270 then from is a common pointer and is to be used as is. */
1271 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1272 ? build_fold_indirect_ref (from) : from;
1274 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1275 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1276 ? gfc_class_data_get (from) : from;
1277 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1281 from_data = gfc_class_vtab_def_init_get (to);
1285 if (from != NULL_TREE && unlimited)
1286 from_len = gfc_class_len_or_zero_get (from);
1288 from_len = build_zero_cst (size_type_node);
1291 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1294 to_data = gfc_class_data_get (to);
1296 to_len = gfc_class_len_get (to);
1299 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1302 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1304 stmtblock_t loopbody;
1308 tree orig_nelems = nelems; /* Needed for bounds check. */
1310 gfc_init_block (&body);
1311 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1312 gfc_array_index_type, nelems,
1313 gfc_index_one_node);
1314 nelems = gfc_evaluate_now (tmp, &body);
1315 index = gfc_create_var (gfc_array_index_type, "S");
1319 from_ref = gfc_get_class_array_ref (index, from, from_data,
1321 vec_safe_push (args, from_ref);
1324 vec_safe_push (args, from_data);
1327 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1330 tmp = gfc_conv_array_data (to);
1331 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1332 to_ref = gfc_build_addr_expr (NULL_TREE,
1333 gfc_build_array_ref (tmp, index, to));
1335 vec_safe_push (args, to_ref);
1337 /* Add bounds check. */
1338 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1341 const char *name = "<<unknown>>";
1345 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1347 from_len = gfc_conv_descriptor_size (from_data, 1);
1348 tmp = fold_build2_loc (input_location, NE_EXPR,
1349 logical_type_node, from_len, orig_nelems);
1350 msg = xasprintf ("Array bound mismatch for dimension %d "
1351 "of array '%s' (%%ld/%%ld)",
1354 gfc_trans_runtime_check (true, false, tmp, &body,
1355 &gfc_current_locus, msg,
1356 fold_convert (long_integer_type_node, orig_nelems),
1357 fold_convert (long_integer_type_node, from_len));
1362 tmp = build_call_vec (fcn_type, fcn, args);
1364 /* Build the body of the loop. */
1365 gfc_init_block (&loopbody);
1366 gfc_add_expr_to_block (&loopbody, tmp);
1368 /* Build the loop and return. */
1369 gfc_init_loopinfo (&loop);
1371 loop.from[0] = gfc_index_zero_node;
1372 loop.loopvar[0] = index;
1373 loop.to[0] = nelems;
1374 gfc_trans_scalarizing_loops (&loop, &loopbody);
1375 gfc_init_block (&ifbody);
1376 gfc_add_block_to_block (&ifbody, &loop.pre);
1377 stdcopy = gfc_finish_block (&ifbody);
1378 /* In initialization mode from_len is a constant zero. */
1379 if (unlimited && !integer_zerop (from_len))
1381 vec_safe_push (args, from_len);
1382 vec_safe_push (args, to_len);
1383 tmp = build_call_vec (fcn_type, fcn, args);
1384 /* Build the body of the loop. */
1385 gfc_init_block (&loopbody);
1386 gfc_add_expr_to_block (&loopbody, tmp);
1388 /* Build the loop and return. */
1389 gfc_init_loopinfo (&loop);
1391 loop.from[0] = gfc_index_zero_node;
1392 loop.loopvar[0] = index;
1393 loop.to[0] = nelems;
1394 gfc_trans_scalarizing_loops (&loop, &loopbody);
1395 gfc_init_block (&ifbody);
1396 gfc_add_block_to_block (&ifbody, &loop.pre);
1397 extcopy = gfc_finish_block (&ifbody);
1399 tmp = fold_build2_loc (input_location, GT_EXPR,
1400 logical_type_node, from_len,
1401 build_zero_cst (TREE_TYPE (from_len)));
1402 tmp = fold_build3_loc (input_location, COND_EXPR,
1403 void_type_node, tmp, extcopy, stdcopy);
1404 gfc_add_expr_to_block (&body, tmp);
1405 tmp = gfc_finish_block (&body);
1409 gfc_add_expr_to_block (&body, stdcopy);
1410 tmp = gfc_finish_block (&body);
1412 gfc_cleanup_loop (&loop);
1416 gcc_assert (!is_from_desc);
1417 vec_safe_push (args, from_data);
1418 vec_safe_push (args, to_data);
1419 stdcopy = build_call_vec (fcn_type, fcn, args);
1421 /* In initialization mode from_len is a constant zero. */
1422 if (unlimited && !integer_zerop (from_len))
1424 vec_safe_push (args, from_len);
1425 vec_safe_push (args, to_len);
1426 extcopy = build_call_vec (fcn_type, fcn, args);
1427 tmp = fold_build2_loc (input_location, GT_EXPR,
1428 logical_type_node, from_len,
1429 build_zero_cst (TREE_TYPE (from_len)));
1430 tmp = fold_build3_loc (input_location, COND_EXPR,
1431 void_type_node, tmp, extcopy, stdcopy);
1437 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1438 if (from == NULL_TREE)
1441 cond = fold_build2_loc (input_location, NE_EXPR,
1443 from_data, null_pointer_node);
1444 tmp = fold_build3_loc (input_location, COND_EXPR,
1445 void_type_node, cond,
1446 tmp, build_empty_stmt (input_location));
1454 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1456 gfc_actual_arglist *actual;
1461 actual = gfc_get_actual_arglist ();
1462 actual->expr = gfc_copy_expr (rhs);
1463 actual->next = gfc_get_actual_arglist ();
1464 actual->next->expr = gfc_copy_expr (lhs);
1465 ppc = gfc_copy_expr (obj);
1466 gfc_add_vptr_component (ppc);
1467 gfc_add_component_ref (ppc, "_copy");
1468 ppc_code = gfc_get_code (EXEC_CALL);
1469 ppc_code->resolved_sym = ppc->symtree->n.sym;
1470 /* Although '_copy' is set to be elemental in class.c, it is
1471 not staying that way. Find out why, sometime.... */
1472 ppc_code->resolved_sym->attr.elemental = 1;
1473 ppc_code->ext.actual = actual;
1474 ppc_code->expr1 = ppc;
1475 /* Since '_copy' is elemental, the scalarizer will take care
1476 of arrays in gfc_trans_call. */
1477 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1478 gfc_free_statements (ppc_code);
1480 if (UNLIMITED_POLY(obj))
1482 /* Check if rhs is non-NULL. */
1484 gfc_init_se (&src, NULL);
1485 gfc_conv_expr (&src, rhs);
1486 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1487 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1488 src.expr, fold_convert (TREE_TYPE (src.expr),
1489 null_pointer_node));
1490 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1491 build_empty_stmt (input_location));
1497 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1498 A MEMCPY is needed to copy the full data from the default initializer
1499 of the dynamic type. */
1502 gfc_trans_class_init_assign (gfc_code *code)
1506 gfc_se dst,src,memsz;
1507 gfc_expr *lhs, *rhs, *sz;
1509 gfc_start_block (&block);
1511 lhs = gfc_copy_expr (code->expr1);
1513 rhs = gfc_copy_expr (code->expr1);
1514 gfc_add_vptr_component (rhs);
1516 /* Make sure that the component backend_decls have been built, which
1517 will not have happened if the derived types concerned have not
1519 gfc_get_derived_type (rhs->ts.u.derived);
1520 gfc_add_def_init_component (rhs);
1521 /* The _def_init is always scalar. */
1524 if (code->expr1->ts.type == BT_CLASS
1525 && CLASS_DATA (code->expr1)->attr.dimension)
1527 gfc_array_spec *tmparr = gfc_get_array_spec ();
1528 *tmparr = *CLASS_DATA (code->expr1)->as;
1529 /* Adding the array ref to the class expression results in correct
1530 indexing to the dynamic type. */
1531 gfc_add_full_array_ref (lhs, tmparr);
1532 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1536 /* Scalar initialization needs the _data component. */
1537 gfc_add_data_component (lhs);
1538 sz = gfc_copy_expr (code->expr1);
1539 gfc_add_vptr_component (sz);
1540 gfc_add_size_component (sz);
1542 gfc_init_se (&dst, NULL);
1543 gfc_init_se (&src, NULL);
1544 gfc_init_se (&memsz, NULL);
1545 gfc_conv_expr (&dst, lhs);
1546 gfc_conv_expr (&src, rhs);
1547 gfc_conv_expr (&memsz, sz);
1548 gfc_add_block_to_block (&block, &src.pre);
1549 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1551 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1553 if (UNLIMITED_POLY(code->expr1))
1555 /* Check if _def_init is non-NULL. */
1556 tree cond = fold_build2_loc (input_location, NE_EXPR,
1557 logical_type_node, src.expr,
1558 fold_convert (TREE_TYPE (src.expr),
1559 null_pointer_node));
1560 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1561 tmp, build_empty_stmt (input_location));
1565 if (code->expr1->symtree->n.sym->attr.optional
1566 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1568 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1569 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1571 build_empty_stmt (input_location));
1574 gfc_add_expr_to_block (&block, tmp);
1576 return gfc_finish_block (&block);
1580 /* End of prototype trans-class.c */
1584 realloc_lhs_warning (bt type, bool array, locus *where)
1586 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1587 gfc_warning (OPT_Wrealloc_lhs,
1588 "Code for reallocating the allocatable array at %L will "
1590 else if (warn_realloc_lhs_all)
1591 gfc_warning (OPT_Wrealloc_lhs_all,
1592 "Code for reallocating the allocatable variable at %L "
1593 "will be added", where);
1597 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1600 /* Copy the scalarization loop variables. */
1603 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1606 dest->loop = src->loop;
1610 /* Initialize a simple expression holder.
1612 Care must be taken when multiple se are created with the same parent.
1613 The child se must be kept in sync. The easiest way is to delay creation
1614 of a child se until after after the previous se has been translated. */
1617 gfc_init_se (gfc_se * se, gfc_se * parent)
1619 memset (se, 0, sizeof (gfc_se));
1620 gfc_init_block (&se->pre);
1621 gfc_init_block (&se->post);
1623 se->parent = parent;
1626 gfc_copy_se_loopvars (se, parent);
1630 /* Advances to the next SS in the chain. Use this rather than setting
1631 se->ss = se->ss->next because all the parents needs to be kept in sync.
1635 gfc_advance_se_ss_chain (gfc_se * se)
1640 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1643 /* Walk down the parent chain. */
1646 /* Simple consistency check. */
1647 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1648 || p->parent->ss->nested_ss == p->ss);
1650 /* If we were in a nested loop, the next scalarized expression can be
1651 on the parent ss' next pointer. Thus we should not take the next
1652 pointer blindly, but rather go up one nest level as long as next
1653 is the end of chain. */
1655 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1665 /* Ensures the result of the expression as either a temporary variable
1666 or a constant so that it can be used repeatedly. */
1669 gfc_make_safe_expr (gfc_se * se)
1673 if (CONSTANT_CLASS_P (se->expr))
1676 /* We need a temporary for this result. */
1677 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1678 gfc_add_modify (&se->pre, var, se->expr);
1683 /* Return an expression which determines if a dummy parameter is present.
1684 Also used for arguments to procedures with multiple entry points. */
1687 gfc_conv_expr_present (gfc_symbol * sym)
1691 gcc_assert (sym->attr.dummy);
1692 decl = gfc_get_symbol_decl (sym);
1694 /* Intrinsic scalars with VALUE attribute which are passed by value
1695 use a hidden argument to denote the present status. */
1696 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1697 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1698 && !sym->attr.dimension)
1700 char name[GFC_MAX_SYMBOL_LEN + 2];
1703 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1705 strcpy (&name[1], sym->name);
1706 tree_name = get_identifier (name);
1708 /* Walk function argument list to find hidden arg. */
1709 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1710 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1711 if (DECL_NAME (cond) == tree_name)
1718 if (TREE_CODE (decl) != PARM_DECL)
1720 /* Array parameters use a temporary descriptor, we want the real
1722 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1723 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1724 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1727 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1728 fold_convert (TREE_TYPE (decl), null_pointer_node));
1730 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1731 as actual argument to denote absent dummies. For array descriptors,
1732 we thus also need to check the array descriptor. For BT_CLASS, it
1733 can also occur for scalars and F2003 due to type->class wrapping and
1734 class->class wrapping. Note further that BT_CLASS always uses an
1735 array descriptor for arrays, also for explicit-shape/assumed-size. */
1737 if (!sym->attr.allocatable
1738 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1739 || (sym->ts.type == BT_CLASS
1740 && !CLASS_DATA (sym)->attr.allocatable
1741 && !CLASS_DATA (sym)->attr.class_pointer))
1742 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1743 || sym->ts.type == BT_CLASS))
1747 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1748 || sym->as->type == AS_ASSUMED_RANK
1749 || sym->attr.codimension))
1750 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1752 tmp = build_fold_indirect_ref_loc (input_location, decl);
1753 if (sym->ts.type == BT_CLASS)
1754 tmp = gfc_class_data_get (tmp);
1755 tmp = gfc_conv_array_data (tmp);
1757 else if (sym->ts.type == BT_CLASS)
1758 tmp = gfc_class_data_get (decl);
1762 if (tmp != NULL_TREE)
1764 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1765 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1766 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1767 logical_type_node, cond, tmp);
1775 /* Converts a missing, dummy argument into a null or zero. */
1778 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1783 present = gfc_conv_expr_present (arg->symtree->n.sym);
1787 /* Create a temporary and convert it to the correct type. */
1788 tmp = gfc_get_int_type (kind);
1789 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1792 /* Test for a NULL value. */
1793 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1794 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1795 tmp = gfc_evaluate_now (tmp, &se->pre);
1796 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1800 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1802 build_zero_cst (TREE_TYPE (se->expr)));
1803 tmp = gfc_evaluate_now (tmp, &se->pre);
1807 if (ts.type == BT_CHARACTER)
1809 tmp = build_int_cst (gfc_charlen_type_node, 0);
1810 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1811 present, se->string_length, tmp);
1812 tmp = gfc_evaluate_now (tmp, &se->pre);
1813 se->string_length = tmp;
1819 /* Get the character length of an expression, looking through gfc_refs
1823 gfc_get_expr_charlen (gfc_expr *e)
1829 gcc_assert (e->expr_type == EXPR_VARIABLE
1830 && e->ts.type == BT_CHARACTER);
1832 length = NULL; /* To silence compiler warning. */
1834 if (is_subref_array (e) && e->ts.u.cl->length)
1837 gfc_init_se (&tmpse, NULL);
1838 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1839 e->ts.u.cl->backend_decl = tmpse.expr;
1843 /* First candidate: if the variable is of type CHARACTER, the
1844 expression's length could be the length of the character
1846 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1847 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1849 /* Look through the reference chain for component references. */
1850 for (r = e->ref; r; r = r->next)
1855 if (r->u.c.component->ts.type == BT_CHARACTER)
1856 length = r->u.c.component->ts.u.cl->backend_decl;
1864 gfc_init_se (&se, NULL);
1865 gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node);
1867 gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node);
1868 length = fold_build2_loc (input_location, MINUS_EXPR,
1869 gfc_charlen_type_node,
1871 length = fold_build2_loc (input_location, PLUS_EXPR,
1872 gfc_charlen_type_node, length,
1873 gfc_index_one_node);
1882 gcc_assert (length != NULL);
1887 /* Return for an expression the backend decl of the coarray. */
1890 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1896 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1898 /* Not-implemented diagnostic. */
1899 if (expr->symtree->n.sym->ts.type == BT_CLASS
1900 && UNLIMITED_POLY (expr->symtree->n.sym)
1901 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1902 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1903 "%L is not supported", &expr->where);
1905 for (ref = expr->ref; ref; ref = ref->next)
1906 if (ref->type == REF_COMPONENT)
1908 if (ref->u.c.component->ts.type == BT_CLASS
1909 && UNLIMITED_POLY (ref->u.c.component)
1910 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1911 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1912 "component at %L is not supported", &expr->where);
1915 /* Make sure the backend_decl is present before accessing it. */
1916 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1917 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1918 : expr->symtree->n.sym->backend_decl;
1920 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1922 if (expr->ref && expr->ref->type == REF_ARRAY)
1924 caf_decl = gfc_class_data_get (caf_decl);
1925 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1928 for (ref = expr->ref; ref; ref = ref->next)
1930 if (ref->type == REF_COMPONENT
1931 && strcmp (ref->u.c.component->name, "_data") != 0)
1933 caf_decl = gfc_class_data_get (caf_decl);
1934 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1938 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1942 if (expr->symtree->n.sym->attr.codimension)
1945 /* The following code assumes that the coarray is a component reachable via
1946 only scalar components/variables; the Fortran standard guarantees this. */
1948 for (ref = expr->ref; ref; ref = ref->next)
1949 if (ref->type == REF_COMPONENT)
1951 gfc_component *comp = ref->u.c.component;
1953 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1954 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1955 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1956 TREE_TYPE (comp->backend_decl), caf_decl,
1957 comp->backend_decl, NULL_TREE);
1958 if (comp->ts.type == BT_CLASS)
1960 caf_decl = gfc_class_data_get (caf_decl);
1961 if (CLASS_DATA (comp)->attr.codimension)
1967 if (comp->attr.codimension)
1973 gcc_assert (found && caf_decl);
1978 /* Obtain the Coarray token - and optionally also the offset. */
1981 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1982 tree se_expr, gfc_expr *expr)
1986 /* Coarray token. */
1987 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1989 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1990 == GFC_ARRAY_ALLOCATABLE
1991 || expr->symtree->n.sym->attr.select_type_temporary);
1992 *token = gfc_conv_descriptor_token (caf_decl);
1994 else if (DECL_LANG_SPECIFIC (caf_decl)
1995 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1996 *token = GFC_DECL_TOKEN (caf_decl);
1999 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
2000 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
2001 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
2007 /* Offset between the coarray base address and the address wanted. */
2008 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
2009 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
2010 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
2011 *offset = build_int_cst (gfc_array_index_type, 0);
2012 else if (DECL_LANG_SPECIFIC (caf_decl)
2013 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
2014 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2015 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2016 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2018 *offset = build_int_cst (gfc_array_index_type, 0);
2020 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2021 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2023 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2024 tmp = gfc_conv_descriptor_data_get (tmp);
2026 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2027 tmp = gfc_conv_descriptor_data_get (se_expr);
2030 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2034 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2035 *offset, fold_convert (gfc_array_index_type, tmp));
2037 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2038 && expr->symtree->n.sym->attr.codimension
2039 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2041 gfc_expr *base_expr = gfc_copy_expr (expr);
2042 gfc_ref *ref = base_expr->ref;
2045 // Iterate through the refs until the last one.
2049 if (ref->type == REF_ARRAY
2050 && ref->u.ar.type != AR_FULL)
2052 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2054 for (i = 0; i < ranksum; ++i)
2056 ref->u.ar.start[i] = NULL;
2057 ref->u.ar.end[i] = NULL;
2059 ref->u.ar.type = AR_FULL;
2061 gfc_init_se (&base_se, NULL);
2062 if (gfc_caf_attr (base_expr).dimension)
2064 gfc_conv_expr_descriptor (&base_se, base_expr);
2065 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2069 gfc_conv_expr (&base_se, base_expr);
2073 gfc_free_expr (base_expr);
2074 gfc_add_block_to_block (&se->pre, &base_se.pre);
2075 gfc_add_block_to_block (&se->post, &base_se.post);
2077 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2078 tmp = gfc_conv_descriptor_data_get (caf_decl);
2081 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2085 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2086 fold_convert (gfc_array_index_type, *offset),
2087 fold_convert (gfc_array_index_type, tmp));
2091 /* Convert the coindex of a coarray into an image index; the result is
2092 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2093 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2096 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2099 tree lbound, ubound, extent, tmp, img_idx;
2103 for (ref = e->ref; ref; ref = ref->next)
2104 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2106 gcc_assert (ref != NULL);
2108 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2110 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2114 img_idx = build_zero_cst (gfc_array_index_type);
2115 extent = build_one_cst (gfc_array_index_type);
2116 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2117 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2119 gfc_init_se (&se, NULL);
2120 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2121 gfc_add_block_to_block (block, &se.pre);
2122 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2123 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2124 TREE_TYPE (lbound), se.expr, lbound);
2125 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2127 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2128 TREE_TYPE (tmp), img_idx, tmp);
2129 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2131 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2132 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2133 extent = fold_build2_loc (input_location, MULT_EXPR,
2134 TREE_TYPE (tmp), extent, tmp);
2138 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2140 gfc_init_se (&se, NULL);
2141 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2142 gfc_add_block_to_block (block, &se.pre);
2143 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2144 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2145 TREE_TYPE (lbound), se.expr, lbound);
2146 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2148 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2150 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2152 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2153 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2154 TREE_TYPE (ubound), ubound, lbound);
2155 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2156 tmp, build_one_cst (TREE_TYPE (tmp)));
2157 extent = fold_build2_loc (input_location, MULT_EXPR,
2158 TREE_TYPE (tmp), extent, tmp);
2161 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2162 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2163 return fold_convert (integer_type_node, img_idx);
2167 /* For each character array constructor subexpression without a ts.u.cl->length,
2168 replace it by its first element (if there aren't any elements, the length
2169 should already be set to zero). */
2172 flatten_array_ctors_without_strlen (gfc_expr* e)
2174 gfc_actual_arglist* arg;
2180 switch (e->expr_type)
2184 flatten_array_ctors_without_strlen (e->value.op.op1);
2185 flatten_array_ctors_without_strlen (e->value.op.op2);
2189 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2193 for (arg = e->value.function.actual; arg; arg = arg->next)
2194 flatten_array_ctors_without_strlen (arg->expr);
2199 /* We've found what we're looking for. */
2200 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2205 gcc_assert (e->value.constructor);
2207 c = gfc_constructor_first (e->value.constructor);
2211 flatten_array_ctors_without_strlen (new_expr);
2212 gfc_replace_expr (e, new_expr);
2216 /* Otherwise, fall through to handle constructor elements. */
2218 case EXPR_STRUCTURE:
2219 for (c = gfc_constructor_first (e->value.constructor);
2220 c; c = gfc_constructor_next (c))
2221 flatten_array_ctors_without_strlen (c->expr);
2231 /* Generate code to initialize a string length variable. Returns the
2232 value. For array constructors, cl->length might be NULL and in this case,
2233 the first element of the constructor is needed. expr is the original
2234 expression so we can access it but can be NULL if this is not needed. */
2237 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2241 gfc_init_se (&se, NULL);
2243 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2246 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2247 "flatten" array constructors by taking their first element; all elements
2248 should be the same length or a cl->length should be present. */
2251 gfc_expr* expr_flat;
2254 expr_flat = gfc_copy_expr (expr);
2255 flatten_array_ctors_without_strlen (expr_flat);
2256 gfc_resolve_expr (expr_flat);
2258 gfc_conv_expr (&se, expr_flat);
2259 gfc_add_block_to_block (pblock, &se.pre);
2260 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2262 gfc_free_expr (expr_flat);
2266 /* Convert cl->length. */
2268 gcc_assert (cl->length);
2270 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2271 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2272 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2273 gfc_add_block_to_block (pblock, &se.pre);
2275 if (cl->backend_decl)
2276 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2278 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2283 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2284 const char *name, locus *where)
2294 type = gfc_get_character_type (kind, ref->u.ss.length);
2295 type = build_pointer_type (type);
2297 gfc_init_se (&start, se);
2298 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2299 gfc_add_block_to_block (&se->pre, &start.pre);
2301 if (integer_onep (start.expr))
2302 gfc_conv_string_parameter (se);
2307 /* Avoid multiple evaluation of substring start. */
2308 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2309 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2311 /* Change the start of the string. */
2312 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2315 tmp = build_fold_indirect_ref_loc (input_location,
2317 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2318 se->expr = gfc_build_addr_expr (type, tmp);
2321 /* Length = end + 1 - start. */
2322 gfc_init_se (&end, se);
2323 if (ref->u.ss.end == NULL)
2324 end.expr = se->string_length;
2327 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2328 gfc_add_block_to_block (&se->pre, &end.pre);
2332 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2333 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2335 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2337 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2338 logical_type_node, start.expr,
2341 /* Check lower bound. */
2342 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2344 build_one_cst (TREE_TYPE (start.expr)));
2345 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2346 logical_type_node, nonempty, fault);
2348 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2349 "is less than one", name);
2351 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2352 "is less than one");
2353 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2354 fold_convert (long_integer_type_node,
2358 /* Check upper bound. */
2359 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2360 end.expr, se->string_length);
2361 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2362 logical_type_node, nonempty, fault);
2364 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2365 "exceeds string length (%%ld)", name);
2367 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2368 "exceeds string length (%%ld)");
2369 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2370 fold_convert (long_integer_type_node, end.expr),
2371 fold_convert (long_integer_type_node,
2372 se->string_length));
2376 /* Try to calculate the length from the start and end expressions. */
2378 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2380 HOST_WIDE_INT i_len;
2382 i_len = gfc_mpz_get_hwi (length) + 1;
2386 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2387 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2391 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2392 fold_convert (gfc_charlen_type_node, end.expr),
2393 fold_convert (gfc_charlen_type_node, start.expr));
2394 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2395 build_int_cst (gfc_charlen_type_node, 1), tmp);
2396 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2397 tmp, build_int_cst (gfc_charlen_type_node, 0));
2400 se->string_length = tmp;
2404 /* Convert a derived type component reference. */
2407 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2415 c = ref->u.c.component;
2417 if (c->backend_decl == NULL_TREE
2418 && ref->u.c.sym != NULL)
2419 gfc_get_derived_type (ref->u.c.sym);
2421 field = c->backend_decl;
2422 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2424 context = DECL_FIELD_CONTEXT (field);
2426 /* Components can correspond to fields of different containing
2427 types, as components are created without context, whereas
2428 a concrete use of a component has the type of decl as context.
2429 So, if the type doesn't match, we search the corresponding
2430 FIELD_DECL in the parent type. To not waste too much time
2431 we cache this result in norestrict_decl.
2432 On the other hand, if the context is a UNION or a MAP (a
2433 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2435 if (context != TREE_TYPE (decl)
2436 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2437 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2439 tree f2 = c->norestrict_decl;
2440 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2441 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2442 if (TREE_CODE (f2) == FIELD_DECL
2443 && DECL_NAME (f2) == DECL_NAME (field))
2446 c->norestrict_decl = f2;
2450 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2451 && strcmp ("_data", c->name) == 0)
2453 /* Found a ref to the _data component. Store the associated ref to
2454 the vptr in se->class_vptr. */
2455 se->class_vptr = gfc_class_vptr_get (decl);
2458 se->class_vptr = NULL_TREE;
2460 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2461 decl, field, NULL_TREE);
2465 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2466 strlen () conditional below. */
2467 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2468 && !(c->attr.allocatable && c->ts.deferred)
2469 && !c->attr.pdt_string)
2471 tmp = c->ts.u.cl->backend_decl;
2472 /* Components must always be constant length. */
2473 gcc_assert (tmp && INTEGER_CST_P (tmp));
2474 se->string_length = tmp;
2477 if (gfc_deferred_strlen (c, &field))
2479 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2481 decl, field, NULL_TREE);
2482 se->string_length = tmp;
2485 if (((c->attr.pointer || c->attr.allocatable)
2486 && (!c->attr.dimension && !c->attr.codimension)
2487 && c->ts.type != BT_CHARACTER)
2488 || c->attr.proc_pointer)
2489 se->expr = build_fold_indirect_ref_loc (input_location,
2494 /* This function deals with component references to components of the
2495 parent type for derived type extensions. */
2497 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2505 c = ref->u.c.component;
2507 /* Return if the component is in the parent type. */
2508 for (cmp = dt->components; cmp; cmp = cmp->next)
2509 if (strcmp (c->name, cmp->name) == 0)
2512 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2513 parent.type = REF_COMPONENT;
2515 parent.u.c.sym = dt;
2516 parent.u.c.component = dt->components;
2518 if (dt->backend_decl == NULL)
2519 gfc_get_derived_type (dt);
2521 /* Build the reference and call self. */
2522 gfc_conv_component_ref (se, &parent);
2523 parent.u.c.sym = dt->components->ts.u.derived;
2524 parent.u.c.component = c;
2525 conv_parent_component_references (se, &parent);
2530 conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2532 tree res = se->expr;
2537 res = fold_build1_loc (input_location, REALPART_EXPR,
2538 TREE_TYPE (TREE_TYPE (res)), res);
2542 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2543 TREE_TYPE (TREE_TYPE (res)), res);
2547 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2552 res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2562 /* Return the contents of a variable. Also handles reference/pointer
2563 variables (all Fortran pointer references are implicit). */
2566 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2571 tree parent_decl = NULL_TREE;
2574 bool alternate_entry;
2577 bool first_time = true;
2579 sym = expr->symtree->n.sym;
2580 is_classarray = IS_CLASS_ARRAY (sym);
2584 gfc_ss_info *ss_info = ss->info;
2586 /* Check that something hasn't gone horribly wrong. */
2587 gcc_assert (ss != gfc_ss_terminator);
2588 gcc_assert (ss_info->expr == expr);
2590 /* A scalarized term. We already know the descriptor. */
2591 se->expr = ss_info->data.array.descriptor;
2592 se->string_length = ss_info->string_length;
2593 ref = ss_info->data.array.ref;
2595 gcc_assert (ref->type == REF_ARRAY
2596 && ref->u.ar.type != AR_ELEMENT);
2598 gfc_conv_tmp_array_ref (se);
2602 tree se_expr = NULL_TREE;
2604 se->expr = gfc_get_symbol_decl (sym);
2606 /* Deal with references to a parent results or entries by storing
2607 the current_function_decl and moving to the parent_decl. */
2608 return_value = sym->attr.function && sym->result == sym;
2609 alternate_entry = sym->attr.function && sym->attr.entry
2610 && sym->result == sym;
2611 entry_master = sym->attr.result
2612 && sym->ns->proc_name->attr.entry_master
2613 && !gfc_return_by_reference (sym->ns->proc_name);
2614 if (current_function_decl)
2615 parent_decl = DECL_CONTEXT (current_function_decl);
2617 if ((se->expr == parent_decl && return_value)
2618 || (sym->ns && sym->ns->proc_name
2620 && sym->ns->proc_name->backend_decl == parent_decl
2621 && (alternate_entry || entry_master)))
2626 /* Special case for assigning the return value of a function.
2627 Self recursive functions must have an explicit return value. */
2628 if (return_value && (se->expr == current_function_decl || parent_flag))
2629 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2631 /* Similarly for alternate entry points. */
2632 else if (alternate_entry
2633 && (sym->ns->proc_name->backend_decl == current_function_decl
2636 gfc_entry_list *el = NULL;
2638 for (el = sym->ns->entries; el; el = el->next)
2641 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2646 else if (entry_master
2647 && (sym->ns->proc_name->backend_decl == current_function_decl
2649 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2654 /* Procedure actual arguments. Look out for temporary variables
2655 with the same attributes as function values. */
2656 else if (!sym->attr.temporary
2657 && sym->attr.flavor == FL_PROCEDURE
2658 && se->expr != current_function_decl)
2660 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2662 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2663 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2669 /* Dereference the expression, where needed. Since characters
2670 are entirely different from other types, they are treated
2672 if (sym->ts.type == BT_CHARACTER)
2674 /* Dereference character pointer dummy arguments
2676 if ((sym->attr.pointer || sym->attr.allocatable)
2678 || sym->attr.function
2679 || sym->attr.result))
2680 se->expr = build_fold_indirect_ref_loc (input_location,
2684 else if (!sym->attr.value)
2686 /* Dereference temporaries for class array dummy arguments. */
2687 if (sym->attr.dummy && is_classarray
2688 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2690 if (!se->descriptor_only)
2691 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2693 se->expr = build_fold_indirect_ref_loc (input_location,
2697 /* Dereference non-character scalar dummy arguments. */
2698 if (sym->attr.dummy && !sym->attr.dimension
2699 && !(sym->attr.codimension && sym->attr.allocatable)
2700 && (sym->ts.type != BT_CLASS
2701 || (!CLASS_DATA (sym)->attr.dimension
2702 && !(CLASS_DATA (sym)->attr.codimension
2703 && CLASS_DATA (sym)->attr.allocatable))))
2704 se->expr = build_fold_indirect_ref_loc (input_location,
2707 /* Dereference scalar hidden result. */
2708 if (flag_f2c && sym->ts.type == BT_COMPLEX
2709 && (sym->attr.function || sym->attr.result)
2710 && !sym->attr.dimension && !sym->attr.pointer
2711 && !sym->attr.always_explicit)
2712 se->expr = build_fold_indirect_ref_loc (input_location,
2715 /* Dereference non-character, non-class pointer variables.
2716 These must be dummies, results, or scalars. */
2718 && (sym->attr.pointer || sym->attr.allocatable
2719 || gfc_is_associate_pointer (sym)
2720 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2722 || sym->attr.function
2724 || (!sym->attr.dimension
2725 && (!sym->attr.codimension || !sym->attr.allocatable))))
2726 se->expr = build_fold_indirect_ref_loc (input_location,
2728 /* Now treat the class array pointer variables accordingly. */
2729 else if (sym->ts.type == BT_CLASS
2731 && (CLASS_DATA (sym)->attr.dimension
2732 || CLASS_DATA (sym)->attr.codimension)
2733 && ((CLASS_DATA (sym)->as
2734 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2735 || CLASS_DATA (sym)->attr.allocatable
2736 || CLASS_DATA (sym)->attr.class_pointer))
2737 se->expr = build_fold_indirect_ref_loc (input_location,
2739 /* And the case where a non-dummy, non-result, non-function,
2740 non-allotable and non-pointer classarray is present. This case was
2741 previously covered by the first if, but with introducing the
2742 condition !is_classarray there, that case has to be covered
2744 else if (sym->ts.type == BT_CLASS
2746 && !sym->attr.function
2747 && !sym->attr.result
2748 && (CLASS_DATA (sym)->attr.dimension
2749 || CLASS_DATA (sym)->attr.codimension)
2751 || !CLASS_DATA (sym)->attr.allocatable)
2752 && !CLASS_DATA (sym)->attr.class_pointer)
2753 se->expr = build_fold_indirect_ref_loc (input_location,
2760 /* For character variables, also get the length. */
2761 if (sym->ts.type == BT_CHARACTER)
2763 /* If the character length of an entry isn't set, get the length from
2764 the master function instead. */
2765 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2766 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2768 se->string_length = sym->ts.u.cl->backend_decl;
2769 gcc_assert (se->string_length);
2772 gfc_typespec *ts = &sym->ts;
2778 /* Return the descriptor if that's what we want and this is an array
2779 section reference. */
2780 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2782 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2783 /* Return the descriptor for array pointers and allocations. */
2784 if (se->want_pointer
2785 && ref->next == NULL && (se->descriptor_only))
2788 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2789 /* Return a pointer to an element. */
2793 ts = &ref->u.c.component->ts;
2794 if (first_time && is_classarray && sym->attr.dummy
2795 && se->descriptor_only
2796 && !CLASS_DATA (sym)->attr.allocatable
2797 && !CLASS_DATA (sym)->attr.class_pointer
2798 && CLASS_DATA (sym)->as
2799 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2800 && strcmp ("_data", ref->u.c.component->name) == 0)
2801 /* Skip the first ref of a _data component, because for class
2802 arrays that one is already done by introducing a temporary
2803 array descriptor. */
2806 if (ref->u.c.sym->attr.extension)
2807 conv_parent_component_references (se, ref);
2809 gfc_conv_component_ref (se, ref);
2810 if (!ref->next && ref->u.c.sym->attr.codimension
2811 && se->want_pointer && se->descriptor_only)
2817 gfc_conv_substring (se, ref, expr->ts.kind,
2818 expr->symtree->name, &expr->where);
2822 conv_inquiry (se, ref, expr, ts);
2832 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2834 if (se->want_pointer)
2836 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2837 gfc_conv_string_parameter (se);
2839 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2844 /* Unary ops are easy... Or they would be if ! was a valid op. */
2847 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2852 gcc_assert (expr->ts.type != BT_CHARACTER);
2853 /* Initialize the operand. */
2854 gfc_init_se (&operand, se);
2855 gfc_conv_expr_val (&operand, expr->value.op.op1);
2856 gfc_add_block_to_block (&se->pre, &operand.pre);
2858 type = gfc_typenode_for_spec (&expr->ts);
2860 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2861 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2862 All other unary operators have an equivalent GIMPLE unary operator. */
2863 if (code == TRUTH_NOT_EXPR)
2864 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2865 build_int_cst (type, 0));
2867 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2871 /* Expand power operator to optimal multiplications when a value is raised
2872 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2873 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2874 Programming", 3rd Edition, 1998. */
2876 /* This code is mostly duplicated from expand_powi in the backend.
2877 We establish the "optimal power tree" lookup table with the defined size.
2878 The items in the table are the exponents used to calculate the index
2879 exponents. Any integer n less than the value can get an "addition chain",
2880 with the first node being one. */
2881 #define POWI_TABLE_SIZE 256
2883 /* The table is from builtins.c. */
2884 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2886 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2887 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2888 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2889 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2890 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2891 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2892 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2893 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2894 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2895 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2896 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2897 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2898 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2899 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2900 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2901 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2902 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2903 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2904 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2905 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2906 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2907 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2908 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2909 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2910 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2911 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2912 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2913 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2914 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2915 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2916 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2917 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2920 /* If n is larger than lookup table's max index, we use the "window
2922 #define POWI_WINDOW_SIZE 3
2924 /* Recursive function to expand the power operator. The temporary
2925 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2927 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2934 if (n < POWI_TABLE_SIZE)
2939 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2940 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2944 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2945 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2946 op1 = gfc_conv_powi (se, digit, tmpvar);
2950 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2954 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2955 tmp = gfc_evaluate_now (tmp, &se->pre);
2957 if (n < POWI_TABLE_SIZE)
2964 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2965 return 1. Else return 0 and a call to runtime library functions
2966 will have to be built. */
2968 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2973 tree vartmp[POWI_TABLE_SIZE];
2975 unsigned HOST_WIDE_INT n;
2977 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2979 /* If exponent is too large, we won't expand it anyway, so don't bother
2980 with large integer values. */
2981 if (!wi::fits_shwi_p (wrhs))
2984 m = wrhs.to_shwi ();
2985 /* Use the wide_int's routine to reliably get the absolute value on all
2986 platforms. Then convert it to a HOST_WIDE_INT like above. */
2987 n = wi::abs (wrhs).to_shwi ();
2989 type = TREE_TYPE (lhs);
2990 sgn = tree_int_cst_sgn (rhs);
2992 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2993 || optimize_size) && (m > 2 || m < -1))
2999 se->expr = gfc_build_const (type, integer_one_node);
3003 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
3004 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
3006 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3007 lhs, build_int_cst (TREE_TYPE (lhs), -1));
3008 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3009 lhs, build_int_cst (TREE_TYPE (lhs), 1));
3012 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3015 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3016 logical_type_node, tmp, cond);
3017 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3018 tmp, build_int_cst (type, 1),
3019 build_int_cst (type, 0));
3023 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3024 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3025 build_int_cst (type, -1),
3026 build_int_cst (type, 0));
3027 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3028 cond, build_int_cst (type, 1), tmp);
3032 memset (vartmp, 0, sizeof (vartmp));
3036 tmp = gfc_build_const (type, integer_one_node);
3037 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3041 se->expr = gfc_conv_powi (se, n, vartmp);
3047 /* Power op (**). Constant integer exponent has special handling. */
3050 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3052 tree gfc_int4_type_node;
3055 int res_ikind_1, res_ikind_2;
3060 gfc_init_se (&lse, se);
3061 gfc_conv_expr_val (&lse, expr->value.op.op1);
3062 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3063 gfc_add_block_to_block (&se->pre, &lse.pre);
3065 gfc_init_se (&rse, se);
3066 gfc_conv_expr_val (&rse, expr->value.op.op2);
3067 gfc_add_block_to_block (&se->pre, &rse.pre);
3069 if (expr->value.op.op2->ts.type == BT_INTEGER
3070 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3071 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3074 if (INTEGER_CST_P (lse.expr)
3075 && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE)
3077 wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr);
3079 int kind, ikind, bit_size;
3081 v = wlhs.to_shwi ();
3084 kind = expr->value.op.op1->ts.kind;
3085 ikind = gfc_validate_kind (BT_INTEGER, kind, false);
3086 bit_size = gfc_integer_kinds[ikind].bit_size;
3090 /* 1**something is always 1. */
3091 se->expr = build_int_cst (TREE_TYPE (lse.expr), 1);
3096 /* (-1)**n is 1 - ((n & 1) << 1) */
3100 type = TREE_TYPE (lse.expr);
3101 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3102 rse.expr, build_int_cst (type, 1));
3103 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3104 tmp, build_int_cst (type, 1));
3105 tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
3106 build_int_cst (type, 1), tmp);
3110 else if (w > 0 && ((w & (w-1)) == 0) && ((w >> (bit_size-1)) == 0))
3112 /* Here v is +/- 2**e. The further simplification uses
3113 2**n = 1<<n, 4**n = 1<<(n+n), 8**n = 1 <<(3*n), 16**n =
3114 1<<(4*n), etc., but we have to make sure to return zero
3115 if the number of bits is too large. */
3125 type = TREE_TYPE (lse.expr);
3130 shift = fold_build2_loc (input_location, PLUS_EXPR,
3131 TREE_TYPE (rse.expr),
3132 rse.expr, rse.expr);
3135 /* use popcount for fast log2(w) */
3136 int e = wi::popcount (w-1);
3137 shift = fold_build2_loc (input_location, MULT_EXPR,
3138 TREE_TYPE (rse.expr),
3139 build_int_cst (TREE_TYPE (rse.expr), e),
3143 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3144 build_int_cst (type, 1), shift);
3145 ge = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3146 rse.expr, build_int_cst (type, 0));
3147 cond = fold_build3_loc (input_location, COND_EXPR, type, ge, lshift,
3148 build_int_cst (type, 0));
3149 num_bits = build_int_cst (TREE_TYPE (rse.expr), TYPE_PRECISION (type));
3150 cond2 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
3151 rse.expr, num_bits);
3152 tmp1 = fold_build3_loc (input_location, COND_EXPR, type, cond2,
3153 build_int_cst (type, 0), cond);
3160 /* for v < 0, calculate v**n = |v|**n * (-1)**n */
3162 tmp2 = fold_build2_loc (input_location, BIT_AND_EXPR, type,
3163 rse.expr, build_int_cst (type, 1));
3164 tmp2 = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3165 tmp2, build_int_cst (type, 1));
3166 tmp2 = fold_build2_loc (input_location, MINUS_EXPR, type,
3167 build_int_cst (type, 1), tmp2);
3168 se->expr = fold_build2_loc (input_location, MULT_EXPR, type,
3175 gfc_int4_type_node = gfc_get_int_type (4);
3177 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3178 library routine. But in the end, we have to convert the result back
3179 if this case applies -- with res_ikind_K, we keep track whether operand K
3180 falls into this case. */
3184 kind = expr->value.op.op1->ts.kind;
3185 switch (expr->value.op.op2->ts.type)
3188 ikind = expr->value.op.op2->ts.kind;
3193 rse.expr = convert (gfc_int4_type_node, rse.expr);
3194 res_ikind_2 = ikind;
3216 if (expr->value.op.op1->ts.type == BT_INTEGER)
3218 lse.expr = convert (gfc_int4_type_node, lse.expr);
3245 switch (expr->value.op.op1->ts.type)
3248 if (kind == 3) /* Case 16 was not handled properly above. */
3250 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3254 /* Use builtins for real ** int4. */
3260 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3264 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3268 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3272 /* Use the __builtin_powil() only if real(kind=16) is
3273 actually the C long double type. */
3274 if (!gfc_real16_is_float128)
3275 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3283 /* If we don't have a good builtin for this, go for the
3284 library function. */
3286 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3290 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3299 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3303 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3311 se->expr = build_call_expr_loc (input_location,
3312 fndecl, 2, lse.expr, rse.expr);
3314 /* Convert the result back if it is of wrong integer kind. */
3315 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3317 /* We want the maximum of both operand kinds as result. */
3318 if (res_ikind_1 < res_ikind_2)
3319 res_ikind_1 = res_ikind_2;
3320 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3325 /* Generate code to allocate a string temporary. */
3328 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3333 if (gfc_can_put_var_on_stack (len))
3335 /* Create a temporary variable to hold the result. */
3336 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3337 TREE_TYPE (len), len,
3338 build_int_cst (TREE_TYPE (len), 1));
3339 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3341 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3342 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3344 tmp = build_array_type (TREE_TYPE (type), tmp);
3346 var = gfc_create_var (tmp, "str");
3347 var = gfc_build_addr_expr (type, var);
3351 /* Allocate a temporary to hold the result. */
3352 var = gfc_create_var (type, "pstr");
3353 gcc_assert (POINTER_TYPE_P (type));
3354 tmp = TREE_TYPE (type);
3355 if (TREE_CODE (tmp) == ARRAY_TYPE)
3356 tmp = TREE_TYPE (tmp);
3357 tmp = TYPE_SIZE_UNIT (tmp);
3358 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3359 fold_convert (size_type_node, len),
3360 fold_convert (size_type_node, tmp));
3361 tmp = gfc_call_malloc (&se->pre, type, tmp);
3362 gfc_add_modify (&se->pre, var, tmp);
3364 /* Free the temporary afterwards. */
3365 tmp = gfc_call_free (var);
3366 gfc_add_expr_to_block (&se->post, tmp);
3373 /* Handle a string concatenation operation. A temporary will be allocated to
3377 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3380 tree len, type, var, tmp, fndecl;
3382 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3383 && expr->value.op.op2->ts.type == BT_CHARACTER);
3384 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3386 gfc_init_se (&lse, se);
3387 gfc_conv_expr (&lse, expr->value.op.op1);
3388 gfc_conv_string_parameter (&lse);
3389 gfc_init_se (&rse, se);
3390 gfc_conv_expr (&rse, expr->value.op.op2);
3391 gfc_conv_string_parameter (&rse);
3393 gfc_add_block_to_block (&se->pre, &lse.pre);
3394 gfc_add_block_to_block (&se->pre, &rse.pre);
3396 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3397 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3398 if (len == NULL_TREE)
3400 len = fold_build2_loc (input_location, PLUS_EXPR,
3401 gfc_charlen_type_node,
3402 fold_convert (gfc_charlen_type_node,
3404 fold_convert (gfc_charlen_type_node,
3405 rse.string_length));
3408 type = build_pointer_type (type);
3410 var = gfc_conv_string_tmp (se, type, len);
3412 /* Do the actual concatenation. */
3413 if (expr->ts.kind == 1)
3414 fndecl = gfor_fndecl_concat_string;
3415 else if (expr->ts.kind == 4)
3416 fndecl = gfor_fndecl_concat_string_char4;
3420 tmp = build_call_expr_loc (input_location,
3421 fndecl, 6, len, var, lse.string_length, lse.expr,
3422 rse.string_length, rse.expr);
3423 gfc_add_expr_to_block (&se->pre, tmp);
3425 /* Add the cleanup for the operands. */
3426 gfc_add_block_to_block (&se->pre, &rse.post);
3427 gfc_add_block_to_block (&se->pre, &lse.post);
3430 se->string_length = len;
3433 /* Translates an op expression. Common (binary) cases are handled by this
3434 function, others are passed on. Recursion is used in either case.
3435 We use the fact that (op1.ts == op2.ts) (except for the power
3437 Operators need no special handling for scalarized expressions as long as
3438 they call gfc_conv_simple_val to get their operands.
3439 Character strings get special handling. */
3442 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3444 enum tree_code code;
3453 switch (expr->value.op.op)
3455 case INTRINSIC_PARENTHESES:
3456 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3457 && flag_protect_parens)
3459 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3460 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3465 case INTRINSIC_UPLUS:
3466 gfc_conv_expr (se, expr->value.op.op1);
3469 case INTRINSIC_UMINUS:
3470 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3474 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3477 case INTRINSIC_PLUS:
3481 case INTRINSIC_MINUS:
3485 case INTRINSIC_TIMES:
3489 case INTRINSIC_DIVIDE:
3490 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3491 an integer, we must round towards zero, so we use a
3493 if (expr->ts.type == BT_INTEGER)
3494 code = TRUNC_DIV_EXPR;
3499 case INTRINSIC_POWER:
3500 gfc_conv_power_op (se, expr);
3503 case INTRINSIC_CONCAT:
3504 gfc_conv_concat_op (se, expr);
3508 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3513 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3517 /* EQV and NEQV only work on logicals, but since we represent them
3518 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3520 case INTRINSIC_EQ_OS:
3528 case INTRINSIC_NE_OS:
3529 case INTRINSIC_NEQV:
3536 case INTRINSIC_GT_OS:
3543 case INTRINSIC_GE_OS:
3550 case INTRINSIC_LT_OS:
3557 case INTRINSIC_LE_OS:
3563 case INTRINSIC_USER:
3564 case INTRINSIC_ASSIGN:
3565 /* These should be converted into function calls by the frontend. */
3569 fatal_error (input_location, "Unknown intrinsic op");
3573 /* The only exception to this is **, which is handled separately anyway. */
3574 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3576 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3580 gfc_init_se (&lse, se);
3581 gfc_conv_expr (&lse, expr->value.op.op1);
3582 gfc_add_block_to_block (&se->pre, &lse.pre);
3585 gfc_init_se (&rse, se);
3586 gfc_conv_expr (&rse, expr->value.op.op2);
3587 gfc_add_block_to_block (&se->pre, &rse.pre);
3591 gfc_conv_string_parameter (&lse);
3592 gfc_conv_string_parameter (&rse);
3594 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3595 rse.string_length, rse.expr,
3596 expr->value.op.op1->ts.kind,
3598 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3599 gfc_add_block_to_block (&lse.post, &rse.post);
3602 type = gfc_typenode_for_spec (&expr->ts);
3606 /* The result of logical ops is always logical_type_node. */
3607 tmp = fold_build2_loc (input_location, code, logical_type_node,
3608 lse.expr, rse.expr);
3609 se->expr = convert (type, tmp);
3612 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3614 /* Add the post blocks. */
3615 gfc_add_block_to_block (&se->post, &rse.post);
3616 gfc_add_block_to_block (&se->post, &lse.post);
3619 /* If a string's length is one, we convert it to a single character. */
3622 gfc_string_to_single_character (tree len, tree str, int kind)
3626 || !tree_fits_uhwi_p (len)
3627 || !POINTER_TYPE_P (TREE_TYPE (str)))
3630 if (TREE_INT_CST_LOW (len) == 1)
3632 str = fold_convert (gfc_get_pchar_type (kind), str);
3633 return build_fold_indirect_ref_loc (input_location, str);
3637 && TREE_CODE (str) == ADDR_EXPR
3638 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3639 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3640 && array_ref_low_bound (TREE_OPERAND (str, 0))
3641 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3642 && TREE_INT_CST_LOW (len) > 1
3643 && TREE_INT_CST_LOW (len)
3644 == (unsigned HOST_WIDE_INT)
3645 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3647 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3648 ret = build_fold_indirect_ref_loc (input_location, ret);
3649 if (TREE_CODE (ret) == INTEGER_CST)
3651 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3652 int i, length = TREE_STRING_LENGTH (string_cst);
3653 const char *ptr = TREE_STRING_POINTER (string_cst);
3655 for (i = 1; i < length; i++)
3668 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3671 if (sym->backend_decl)
3673 /* This becomes the nominal_type in
3674 function.c:assign_parm_find_data_types. */
3675 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3676 /* This becomes the passed_type in
3677 function.c:assign_parm_find_data_types. C promotes char to
3678 integer for argument passing. */
3679 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3681 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3686 /* If we have a constant character expression, make it into an
3688 if ((*expr)->expr_type == EXPR_CONSTANT)
3693 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3694 (int)(*expr)->value.character.string[0]);
3695 if ((*expr)->ts.kind != gfc_c_int_kind)
3697 /* The expr needs to be compatible with a C int. If the
3698 conversion fails, then the 2 causes an ICE. */
3699 ts.type = BT_INTEGER;
3700 ts.kind = gfc_c_int_kind;
3701 gfc_convert_type (*expr, &ts, 2);
3704 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3706 if ((*expr)->ref == NULL)
3708 se->expr = gfc_string_to_single_character
3709 (build_int_cst (integer_type_node, 1),
3710 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3712 ((*expr)->symtree->n.sym)),
3717 gfc_conv_variable (se, *expr);
3718 se->expr = gfc_string_to_single_character
3719 (build_int_cst (integer_type_node, 1),
3720 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3728 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3729 if STR is a string literal, otherwise return -1. */
3732 gfc_optimize_len_trim (tree len, tree str, int kind)
3735 && TREE_CODE (str) == ADDR_EXPR
3736 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3737 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3738 && array_ref_low_bound (TREE_OPERAND (str, 0))
3739 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3740 && tree_fits_uhwi_p (len)
3741 && tree_to_uhwi (len) >= 1
3742 && tree_to_uhwi (len)
3743 == (unsigned HOST_WIDE_INT)
3744 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3746 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3747 folded = build_fold_indirect_ref_loc (input_location, folded);
3748 if (TREE_CODE (folded) == INTEGER_CST)
3750 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3751 int length = TREE_STRING_LENGTH (string_cst);
3752 const char *ptr = TREE_STRING_POINTER (string_cst);
3754 for (; length > 0; length--)
3755 if (ptr[length - 1] != ' ')
3764 /* Helper to build a call to memcmp. */
3767 build_memcmp_call (tree s1, tree s2, tree n)
3771 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3772 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3774 s1 = fold_convert (pvoid_type_node, s1);
3776 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3777 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3779 s2 = fold_convert (pvoid_type_node, s2);
3781 n = fold_convert (size_type_node, n);
3783 tmp = build_call_expr_loc (input_location,
3784 builtin_decl_explicit (BUILT_IN_MEMCMP),
3787 return fold_convert (integer_type_node, tmp);
3790 /* Compare two strings. If they are all single characters, the result is the
3791 subtraction of them. Otherwise, we build a library call. */
3794 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3795 enum tree_code code)
3801 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3802 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3804 sc1 = gfc_string_to_single_character (len1, str1, kind);
3805 sc2 = gfc_string_to_single_character (len2, str2, kind);
3807 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3809 /* Deal with single character specially. */
3810 sc1 = fold_convert (integer_type_node, sc1);
3811 sc2 = fold_convert (integer_type_node, sc2);
3812 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3816 if ((code == EQ_EXPR || code == NE_EXPR)
3818 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3820 /* If one string is a string literal with LEN_TRIM longer
3821 than the length of the second string, the strings
3823 int len = gfc_optimize_len_trim (len1, str1, kind);
3824 if (len > 0 && compare_tree_int (len2, len) < 0)
3825 return integer_one_node;
3826 len = gfc_optimize_len_trim (len2, str2, kind);
3827 if (len > 0 && compare_tree_int (len1, len) < 0)
3828 return integer_one_node;
3831 /* We can compare via memcpy if the strings are known to be equal
3832 in length and they are
3834 - kind=4 and the comparison is for (in)equality. */
3836 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3837 && tree_int_cst_equal (len1, len2)
3838 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3843 chartype = gfc_get_char_type (kind);
3844 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3845 fold_convert (TREE_TYPE(len1),
3846 TYPE_SIZE_UNIT(chartype)),
3848 return build_memcmp_call (str1, str2, tmp);
3851 /* Build a call for the comparison. */
3853 fndecl = gfor_fndecl_compare_string;
3855 fndecl = gfor_fndecl_compare_string_char4;
3859 return build_call_expr_loc (input_location, fndecl, 4,
3860 len1, str1, len2, str2);
3864 /* Return the backend_decl for a procedure pointer component. */
3867 get_proc_ptr_comp (gfc_expr *e)
3873 gfc_init_se (&comp_se, NULL);
3874 e2 = gfc_copy_expr (e);
3875 /* We have to restore the expr type later so that gfc_free_expr frees
3876 the exact same thing that was allocated.
3877 TODO: This is ugly. */
3878 old_type = e2->expr_type;
3879 e2->expr_type = EXPR_VARIABLE;
3880 gfc_conv_expr (&comp_se, e2);
3881 e2->expr_type = old_type;
3883 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3887 /* Convert a typebound function reference from a class object. */
3889 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3894 if (!VAR_P (base_object))
3896 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3897 gfc_add_modify (&se->pre, var, base_object);
3899 se->expr = gfc_class_vptr_get (base_object);
3900 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3902 while (ref && ref->next)
3904 gcc_assert (ref && ref->type == REF_COMPONENT);
3905 if (ref->u.c.sym->attr.extension)
3906 conv_parent_component_references (se, ref);
3907 gfc_conv_component_ref (se, ref);
3908 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3913 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
3914 gfc_actual_arglist *actual_args)
3918 if (gfc_is_proc_ptr_comp (expr))
3919 tmp = get_proc_ptr_comp (expr);
3920 else if (sym->attr.dummy)
3922 tmp = gfc_get_symbol_decl (sym);
3923 if (sym->attr.proc_pointer)
3924 tmp = build_fold_indirect_ref_loc (input_location,
3926 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3927 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3931 if (!sym->backend_decl)
3932 sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
3934 TREE_USED (sym->backend_decl) = 1;
3936 tmp = sym->backend_decl;
3938 if (sym->attr.cray_pointee)
3940 /* TODO - make the cray pointee a pointer to a procedure,
3941 assign the pointer to it and use it for the call. This
3943 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3944 gfc_get_symbol_decl (sym->cp_pointer));
3945 tmp = gfc_evaluate_now (tmp, &se->pre);
3948 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3950 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3951 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3958 /* Initialize MAPPING. */
3961 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3963 mapping->syms = NULL;
3964 mapping->charlens = NULL;
3968 /* Free all memory held by MAPPING (but not MAPPING itself). */
3971 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3973 gfc_interface_sym_mapping *sym;
3974 gfc_interface_sym_mapping *nextsym;
3976 gfc_charlen *nextcl;
3978 for (sym = mapping->syms; sym; sym = nextsym)
3980 nextsym = sym->next;
3981 sym->new_sym->n.sym->formal = NULL;
3982 gfc_free_symbol (sym->new_sym->n.sym);
3983 gfc_free_expr (sym->expr);
3984 free (sym->new_sym);
3987 for (cl = mapping->charlens; cl; cl = nextcl)
3990 gfc_free_expr (cl->length);
3996 /* Return a copy of gfc_charlen CL. Add the returned structure to
3997 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3999 static gfc_charlen *
4000 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
4003 gfc_charlen *new_charlen;
4005 new_charlen = gfc_get_charlen ();
4006 new_charlen->next = mapping->charlens;
4007 new_charlen->length = gfc_copy_expr (cl->length);
4009 mapping->charlens = new_charlen;
4014 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
4015 array variable that can be used as the actual argument for dummy
4016 argument SYM. Add any initialization code to BLOCK. PACKED is as
4017 for gfc_get_nodesc_array_type and DATA points to the first element
4018 in the passed array. */
4021 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
4022 gfc_packed packed, tree data)
4027 type = gfc_typenode_for_spec (&sym->ts);
4028 type = gfc_get_nodesc_array_type (type, sym->as, packed,
4029 !sym->attr.target && !sym->attr.pointer
4030 && !sym->attr.proc_pointer);
4032 var = gfc_create_var (type, "ifm");
4033 gfc_add_modify (block, var, fold_convert (type, data));
4039 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
4040 and offset of descriptorless array type TYPE given that it has the same
4041 size as DESC. Add any set-up code to BLOCK. */
4044 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
4051 offset = gfc_index_zero_node;
4052 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
4054 dim = gfc_rank_cst[n];
4055 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
4056 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
4058 GFC_TYPE_ARRAY_LBOUND (type, n)
4059 = gfc_conv_descriptor_lbound_get (desc, dim);
4060 GFC_TYPE_ARRAY_UBOUND (type, n)
4061 = gfc_conv_descriptor_ubound_get (desc, dim);
4063 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
4065 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4066 gfc_array_index_type,
4067 gfc_conv_descriptor_ubound_get (desc, dim),
4068 gfc_conv_descriptor_lbound_get (desc, dim));
4069 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4070 gfc_array_index_type,
4071 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
4072 tmp = gfc_evaluate_now (tmp, block);
4073 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
4075 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4076 GFC_TYPE_ARRAY_LBOUND (type, n),
4077 GFC_TYPE_ARRAY_STRIDE (type, n));
4078 offset = fold_build2_loc (input_location, MINUS_EXPR,
4079 gfc_array_index_type, offset, tmp);
4081 offset = gfc_evaluate_now (offset, block);
4082 GFC_TYPE_ARRAY_OFFSET (type) = offset;
4086 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
4087 in SE. The caller may still use se->expr and se->string_length after
4088 calling this function. */
4091 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
4092 gfc_symbol * sym, gfc_se * se,
4095 gfc_interface_sym_mapping *sm;
4099 gfc_symbol *new_sym;
4101 gfc_symtree *new_symtree;
4103 /* Create a new symbol to represent the actual argument. */
4104 new_sym = gfc_new_symbol (sym->name, NULL);
4105 new_sym->ts = sym->ts;
4106 new_sym->as = gfc_copy_array_spec (sym->as);
4107 new_sym->attr.referenced = 1;
4108 new_sym->attr.dimension = sym->attr.dimension;
4109 new_sym->attr.contiguous = sym->attr.contiguous;
4110 new_sym->attr.codimension = sym->attr.codimension;
4111 new_sym->attr.pointer = sym->attr.pointer;
4112 new_sym->attr.allocatable = sym->attr.allocatable;
4113 new_sym->attr.flavor = sym->attr.flavor;
4114 new_sym->attr.function = sym->attr.function;
4116 /* Ensure that the interface is available and that
4117 descriptors are passed for array actual arguments. */
4118 if (sym->attr.flavor == FL_PROCEDURE)
4120 new_sym->formal = expr->symtree->n.sym->formal;
4121 new_sym->attr.always_explicit
4122 = expr->symtree->n.sym->attr.always_explicit;
4125 /* Create a fake symtree for it. */
4127 new_symtree = gfc_new_symtree (&root, sym->name);
4128 new_symtree->n.sym = new_sym;
4129 gcc_assert (new_symtree == root);
4131 /* Create a dummy->actual mapping. */
4132 sm = XCNEW (gfc_interface_sym_mapping);
4133 sm->next = mapping->syms;
4135 sm->new_sym = new_symtree;
4136 sm->expr = gfc_copy_expr (expr);
4139 /* Stabilize the argument's value. */
4140 if (!sym->attr.function && se)
4141 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4143 if (sym->ts.type == BT_CHARACTER)
4145 /* Create a copy of the dummy argument's length. */
4146 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4147 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4149 /* If the length is specified as "*", record the length that
4150 the caller is passing. We should use the callee's length
4151 in all other cases. */
4152 if (!new_sym->ts.u.cl->length && se)
4154 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4155 new_sym->ts.u.cl->backend_decl = se->string_length;
4162 /* Use the passed value as-is if the argument is a function. */
4163 if (sym->attr.flavor == FL_PROCEDURE)
4166 /* If the argument is a pass-by-value scalar, use the value as is. */
4167 else if (!sym->attr.dimension && sym->attr.value)
4170 /* If the argument is either a string or a pointer to a string,
4171 convert it to a boundless character type. */
4172 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4174 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4175 tmp = build_pointer_type (tmp);
4176 if (sym->attr.pointer)
4177 value = build_fold_indirect_ref_loc (input_location,
4181 value = fold_convert (tmp, value);
4184 /* If the argument is a scalar, a pointer to an array or an allocatable,
4186 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4187 value = build_fold_indirect_ref_loc (input_location,
4190 /* For character(*), use the actual argument's descriptor. */
4191 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4192 value = build_fold_indirect_ref_loc (input_location,
4195 /* If the argument is an array descriptor, use it to determine
4196 information about the actual argument's shape. */
4197 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4198 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4200 /* Get the actual argument's descriptor. */
4201 desc = build_fold_indirect_ref_loc (input_location,
4204 /* Create the replacement variable. */
4205 tmp = gfc_conv_descriptor_data_get (desc);
4206 value = gfc_get_interface_mapping_array (&se->pre, sym,
4209 /* Use DESC to work out the upper bounds, strides and offset. */
4210 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4213 /* Otherwise we have a packed array. */
4214 value = gfc_get_interface_mapping_array (&se->pre, sym,
4215 PACKED_FULL, se->expr);
4217 new_sym->backend_decl = value;
4221 /* Called once all dummy argument mappings have been added to MAPPING,
4222 but before the mapping is used to evaluate expressions. Pre-evaluate
4223 the length of each argument, adding any initialization code to PRE and
4224 any finalization code to POST. */
4227 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4228 stmtblock_t * pre, stmtblock_t * post)
4230 gfc_interface_sym_mapping *sym;
4234 for (sym = mapping->syms; sym; sym = sym->next)
4235 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4236 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4238 expr = sym->new_sym->n.sym->ts.u.cl->length;
4239 gfc_apply_interface_mapping_to_expr (mapping, expr);
4240 gfc_init_se (&se, NULL);
4241 gfc_conv_expr (&se, expr);
4242 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4243 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4244 gfc_add_block_to_block (pre, &se.pre);
4245 gfc_add_block_to_block (post, &se.post);
4247 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4252 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4256 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4257 gfc_constructor_base base)
4260 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4262 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4265 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4266 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4267 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4273 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4277 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4282 for (; ref; ref = ref->next)
4286 for (n = 0; n < ref->u.ar.dimen; n++)
4288 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4289 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4290 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4299 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4300 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4306 /* Convert intrinsic function calls into result expressions. */
4309 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4317 arg1 = expr->value.function.actual->expr;
4318 if (expr->value.function.actual->next)
4319 arg2 = expr->value.function.actual->next->expr;
4323 sym = arg1->symtree->n.sym;
4325 if (sym->attr.dummy)
4330 switch (expr->value.function.isym->id)
4333 /* TODO figure out why this condition is necessary. */
4334 if (sym->attr.function
4335 && (arg1->ts.u.cl->length == NULL
4336 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4337 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4340 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4343 case GFC_ISYM_LEN_TRIM:
4344 new_expr = gfc_copy_expr (arg1);
4345 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4350 gfc_replace_expr (arg1, new_expr);
4354 if (!sym->as || sym->as->rank == 0)
4357 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4359 dup = mpz_get_si (arg2->value.integer);
4364 dup = sym->as->rank;
4368 for (; d < dup; d++)
4372 if (!sym->as->upper[d] || !sym->as->lower[d])
4374 gfc_free_expr (new_expr);
4378 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4379 gfc_get_int_expr (gfc_default_integer_kind,
4381 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4383 new_expr = gfc_multiply (new_expr, tmp);
4389 case GFC_ISYM_LBOUND:
4390 case GFC_ISYM_UBOUND:
4391 /* TODO These implementations of lbound and ubound do not limit if
4392 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4394 if (!sym->as || sym->as->rank == 0)
4397 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4398 d = mpz_get_si (arg2->value.integer) - 1;
4402 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4404 if (sym->as->lower[d])
4405 new_expr = gfc_copy_expr (sym->as->lower[d]);
4409 if (sym->as->upper[d])
4410 new_expr = gfc_copy_expr (sym->as->upper[d]);
4418 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4422 gfc_replace_expr (expr, new_expr);
4428 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4429 gfc_interface_mapping * mapping)
4431 gfc_formal_arglist *f;
4432 gfc_actual_arglist *actual;
4434 actual = expr->value.function.actual;
4435 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4437 for (; f && actual; f = f->next, actual = actual->next)
4442 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4445 if (map_expr->symtree->n.sym->attr.dimension)
4450 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4452 for (d = 0; d < as->rank; d++)
4454 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4455 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4458 expr->value.function.esym->as = as;
4461 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4463 expr->value.function.esym->ts.u.cl->length
4464 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4466 gfc_apply_interface_mapping_to_expr (mapping,
4467 expr->value.function.esym->ts.u.cl->length);
4472 /* EXPR is a copy of an expression that appeared in the interface
4473 associated with MAPPING. Walk it recursively looking for references to
4474 dummy arguments that MAPPING maps to actual arguments. Replace each such
4475 reference with a reference to the associated actual argument. */
4478 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4481 gfc_interface_sym_mapping *sym;
4482 gfc_actual_arglist *actual;
4487 /* Copying an expression does not copy its length, so do that here. */
4488 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4490 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4491 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4494 /* Apply the mapping to any references. */
4495 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4497 /* ...and to the expression's symbol, if it has one. */
4498 /* TODO Find out why the condition on expr->symtree had to be moved into
4499 the loop rather than being outside it, as originally. */
4500 for (sym = mapping->syms; sym; sym = sym->next)
4501 if (expr->symtree && sym->old == expr->symtree->n.sym)
4503 if (sym->new_sym->n.sym->backend_decl)
4504 expr->symtree = sym->new_sym;
4506 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4509 /* ...and to subexpressions in expr->value. */
4510 switch (expr->expr_type)
4515 case EXPR_SUBSTRING:
4519 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4520 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4524 for (actual = expr->value.function.actual; actual; actual = actual->next)
4525 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4527 if (expr->value.function.esym == NULL
4528 && expr->value.function.isym != NULL
4529 && expr->value.function.actual
4530 && expr->value.function.actual->expr
4531 && expr->value.function.actual->expr->symtree
4532 && gfc_map_intrinsic_function (expr, mapping))
4535 for (sym = mapping->syms; sym; sym = sym->next)
4536 if (sym->old == expr->value.function.esym)
4538 expr->value.function.esym = sym->new_sym->n.sym;
4539 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4540 expr->value.function.esym->result = sym->new_sym->n.sym;
4545 case EXPR_STRUCTURE:
4546 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4560 /* Evaluate interface expression EXPR using MAPPING. Store the result
4564 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4565 gfc_se * se, gfc_expr * expr)
4567 expr = gfc_copy_expr (expr);
4568 gfc_apply_interface_mapping_to_expr (mapping, expr);
4569 gfc_conv_expr (se, expr);
4570 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4571 gfc_free_expr (expr);
4575 /* Returns a reference to a temporary array into which a component of
4576 an actual argument derived type array is copied and then returned
4577 after the function call. */
4579 gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
4580 sym_intent intent, bool formal_ptr,
4581 const gfc_symbol *fsym, const char *proc_name,
4582 gfc_symbol *sym, bool check_contiguous)
4590 gfc_array_info *info;
4603 pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
4605 if (pass_optional || check_contiguous)
4607 gfc_init_se (&work_se, NULL);
4613 if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
4615 /* We will create a temporary array, so let us warn. */
4618 if (fsym && proc_name)
4619 msg = xasprintf ("An array temporary was created for argument "
4620 "'%s' of procedure '%s'", fsym->name, proc_name);
4622 msg = xasprintf ("An array temporary was created");
4624 tmp = build_int_cst (logical_type_node, 1);
4625 gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
4630 gfc_init_se (&lse, NULL);
4631 gfc_init_se (&rse, NULL);
4633 /* Walk the argument expression. */
4634 rss = gfc_walk_expr (expr);
4636 gcc_assert (rss != gfc_ss_terminator);
4638 /* Initialize the scalarizer. */
4639 gfc_init_loopinfo (&loop);
4640 gfc_add_ss_to_loop (&loop, rss);
4642 /* Calculate the bounds of the scalarization. */
4643 gfc_conv_ss_startstride (&loop);
4645 /* Build an ss for the temporary. */
4646 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4647 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4649 base_type = gfc_typenode_for_spec (&expr->ts);
4650 if (GFC_ARRAY_TYPE_P (base_type)
4651 || GFC_DESCRIPTOR_TYPE_P (base_type))
4652 base_type = gfc_get_element_type (base_type);
4654 if (expr->ts.type == BT_CLASS)
4655 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4657 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4658 ? expr->ts.u.cl->backend_decl
4662 parmse->string_length = loop.temp_ss->info->string_length;
4664 /* Associate the SS with the loop. */
4665 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4667 /* Setup the scalarizing loops. */
4668 gfc_conv_loop_setup (&loop, &expr->where);
4670 /* Pass the temporary descriptor back to the caller. */
4671 info = &loop.temp_ss->info->data.array;
4672 parmse->expr = info->descriptor;
4674 /* Setup the gfc_se structures. */
4675 gfc_copy_loopinfo_to_se (&lse, &loop);
4676 gfc_copy_loopinfo_to_se (&rse, &loop);
4679 lse.ss = loop.temp_ss;
4680 gfc_mark_ss_chain_used (rss, 1);
4681 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4683 /* Start the scalarized loop body. */
4684 gfc_start_scalarized_body (&loop, &body);
4686 /* Translate the expression. */
4687 gfc_conv_expr (&rse, expr);
4689 /* Reset the offset for the function call since the loop
4690 is zero based on the data pointer. Note that the temp
4691 comes first in the loop chain since it is added second. */
4692 if (gfc_is_class_array_function (expr))
4694 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4695 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4696 gfc_index_zero_node);
4699 gfc_conv_tmp_array_ref (&lse);
4701 if (intent != INTENT_OUT)
4703 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4704 gfc_add_expr_to_block (&body, tmp);
4705 gcc_assert (rse.ss == gfc_ss_terminator);
4706 gfc_trans_scalarizing_loops (&loop, &body);
4710 /* Make sure that the temporary declaration survives by merging
4711 all the loop declarations into the current context. */
4712 for (n = 0; n < loop.dimen; n++)
4714 gfc_merge_block_scope (&body);
4715 body = loop.code[loop.order[n]];
4717 gfc_merge_block_scope (&body);
4720 /* Add the post block after the second loop, so that any
4721 freeing of allocated memory is done at the right time. */
4722 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4724 /**********Copy the temporary back again.*********/
4726 gfc_init_se (&lse, NULL);
4727 gfc_init_se (&rse, NULL);
4729 /* Walk the argument expression. */
4730 lss = gfc_walk_expr (expr);
4731 rse.ss = loop.temp_ss;
4734 /* Initialize the scalarizer. */
4735 gfc_init_loopinfo (&loop2);
4736 gfc_add_ss_to_loop (&loop2, lss);
4738 dimen = rse.ss->dimen;
4740 /* Skip the write-out loop for this case. */
4741 if (gfc_is_class_array_function (expr))
4742 goto class_array_fcn;
4744 /* Calculate the bounds of the scalarization. */
4745 gfc_conv_ss_startstride (&loop2);
4747 /* Setup the scalarizing loops. */
4748 gfc_conv_loop_setup (&loop2, &expr->where);
4750 gfc_copy_loopinfo_to_se (&lse, &loop2);
4751 gfc_copy_loopinfo_to_se (&rse, &loop2);
4753 gfc_mark_ss_chain_used (lss, 1);
4754 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4756 /* Declare the variable to hold the temporary offset and start the
4757 scalarized loop body. */
4758 offset = gfc_create_var (gfc_array_index_type, NULL);
4759 gfc_start_scalarized_body (&loop2, &body);
4761 /* Build the offsets for the temporary from the loop variables. The
4762 temporary array has lbounds of zero and strides of one in all
4763 dimensions, so this is very simple. The offset is only computed
4764 outside the innermost loop, so the overall transfer could be
4765 optimized further. */
4766 info = &rse.ss->info->data.array;
4768 tmp_index = gfc_index_zero_node;
4769 for (n = dimen - 1; n > 0; n--)
4772 tmp = rse.loop->loopvar[n];
4773 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4774 tmp, rse.loop->from[n]);
4775 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4778 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4779 gfc_array_index_type,
4780 rse.loop->to[n-1], rse.loop->from[n-1]);
4781 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4782 gfc_array_index_type,
4783 tmp_str, gfc_index_one_node);
4785 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4786 gfc_array_index_type, tmp, tmp_str);
4789 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4790 gfc_array_index_type,
4791 tmp_index, rse.loop->from[0]);
4792 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4794 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4795 gfc_array_index_type,
4796 rse.loop->loopvar[0], offset);
4798 /* Now use the offset for the reference. */
4799 tmp = build_fold_indirect_ref_loc (input_location,
4801 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4803 if (expr->ts.type == BT_CHARACTER)
4804 rse.string_length = expr->ts.u.cl->backend_decl;
4806 gfc_conv_expr (&lse, expr);
4808 gcc_assert (lse.ss == gfc_ss_terminator);
4810 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4811 gfc_add_expr_to_block (&body, tmp);
4813 /* Generate the copying loops. */
4814 gfc_trans_scalarizing_loops (&loop2, &body);
4816 /* Wrap the whole thing up by adding the second loop to the post-block
4817 and following it by the post-block of the first loop. In this way,
4818 if the temporary needs freeing, it is done after use! */
4819 if (intent != INTENT_IN)
4821 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4822 gfc_add_block_to_block (&parmse->post, &loop2.post);
4827 gfc_add_block_to_block (&parmse->post, &loop.post);
4829 gfc_cleanup_loop (&loop);
4830 gfc_cleanup_loop (&loop2);
4832 /* Pass the string length to the argument expression. */
4833 if (expr->ts.type == BT_CHARACTER)
4834 parmse->string_length = expr->ts.u.cl->backend_decl;
4836 /* Determine the offset for pointer formal arguments and set the
4840 size = gfc_index_one_node;
4841 offset = gfc_index_zero_node;
4842 for (n = 0; n < dimen; n++)
4844 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4846 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4847 gfc_array_index_type, tmp,
4848 gfc_index_one_node);
4849 gfc_conv_descriptor_ubound_set (&parmse->pre,
4853 gfc_conv_descriptor_lbound_set (&parmse->pre,
4856 gfc_index_one_node);
4857 size = gfc_evaluate_now (size, &parmse->pre);
4858 offset = fold_build2_loc (input_location, MINUS_EXPR,
4859 gfc_array_index_type,
4861 offset = gfc_evaluate_now (offset, &parmse->pre);
4862 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4863 gfc_array_index_type,
4864 rse.loop->to[n], rse.loop->from[n]);
4865 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4866 gfc_array_index_type,
4867 tmp, gfc_index_one_node);
4868 size = fold_build2_loc (input_location, MULT_EXPR,
4869 gfc_array_index_type, size, tmp);
4872 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4876 /* We want either the address for the data or the address of the descriptor,
4877 depending on the mode of passing array arguments. */
4879 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4881 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4883 /* Basically make this into
4894 pointer = parmse->expr;
4901 if (present && !contiguous)
4906 if (pass_optional || check_contiguous)
4909 stmtblock_t else_block;
4910 tree pre_stmts, post_stmts;
4913 tree present_var = NULL_TREE;
4914 tree cont_var = NULL_TREE;
4917 type = TREE_TYPE (parmse->expr);
4918 pointer = gfc_create_var (type, "arg_ptr");
4920 if (check_contiguous)
4922 gfc_se cont_se, array_se;
4923 stmtblock_t if_block, else_block;
4924 tree if_stmt, else_stmt;
4926 cont_var = gfc_create_var (boolean_type_node, "contiguous");
4928 /* cont_var = is_contiguous (expr); . */
4929 gfc_init_se (&cont_se, parmse);
4930 gfc_conv_is_contiguous_expr (&cont_se, expr);
4931 gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
4932 gfc_add_modify (&se->pre, cont_var, cont_se.expr);
4933 gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
4935 /* arrayse->expr = descriptor of a. */
4936 gfc_init_se (&array_se, se);
4937 gfc_conv_expr_descriptor (&array_se, expr);
4938 gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
4939 gfc_add_block_to_block (&se->pre, &(&array_se)->post);
4941 /* if_stmt = { pointer = &a[0]; } . */
4942 gfc_init_block (&if_block);
4943 tmp = gfc_conv_array_data (array_se.expr);
4944 tmp = fold_convert (type, tmp);
4945 gfc_add_modify (&if_block, pointer, tmp);
4946 if_stmt = gfc_finish_block (&if_block);
4948 /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
4949 gfc_init_block (&else_block);
4950 gfc_add_block_to_block (&else_block, &parmse->pre);
4951 gfc_add_modify (&else_block, pointer, parmse->expr);
4952 else_stmt = gfc_finish_block (&else_block);
4954 /* And put the above into an if statement. */
4955 pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4956 cont_var, if_stmt, else_stmt);
4960 /* pointer = pramse->expr; . */
4961 gfc_add_modify (&parmse->pre, pointer, parmse->expr);
4962 pre_stmts = gfc_finish_block (&parmse->pre);
4967 present_var = gfc_create_var (boolean_type_node, "present");
4969 /* present_var = present(sym); . */
4970 tmp = gfc_conv_expr_present (sym);
4971 tmp = fold_convert (boolean_type_node, tmp);
4972 gfc_add_modify (&se->pre, present_var, tmp);
4974 /* else_stmt = { pointer = NULL; } . */
4975 gfc_init_block (&else_block);
4976 gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
4977 else_stmt = gfc_finish_block (&else_block);
4979 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, present_var,
4980 pre_stmts, else_stmt);
4981 gfc_add_expr_to_block (&se->pre, tmp);
4986 gfc_add_expr_to_block (&se->pre, pre_stmts);
4988 post_stmts = gfc_finish_block (&parmse->post);
4990 /* Put together the post stuff, plus the optional
4992 if (check_contiguous)
4995 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4997 build_zero_cst (boolean_type_node));
4999 post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
5000 boolean_type_node, present_var, tmp);
5006 gcc_assert (pass_optional);
5007 post_cond = present_var;
5010 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
5011 post_stmts, build_empty_stmt (input_location));
5012 gfc_add_expr_to_block (&se->post, tmp);
5020 /* Generate the code for argument list functions. */
5023 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
5025 /* Pass by value for g77 %VAL(arg), pass the address
5026 indirectly for %LOC, else by reference. Thus %REF
5027 is a "do-nothing" and %LOC is the same as an F95
5029 if (strcmp (name, "%VAL") == 0)
5030 gfc_conv_expr (se, expr);
5031 else if (strcmp (name, "%LOC") == 0)
5033 gfc_conv_expr_reference (se, expr);
5034 se->expr = gfc_build_addr_expr (NULL, se->expr);
5036 else if (strcmp (name, "%REF") == 0)
5037 gfc_conv_expr_reference (se, expr);
5039 gfc_error ("Unknown argument list function at %L", &expr->where);
5043 /* This function tells whether the middle-end representation of the expression
5044 E given as input may point to data otherwise accessible through a variable
5046 It is assumed that the only expressions that may alias are variables,
5047 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
5049 This function is used to decide whether freeing an expression's allocatable
5050 components is safe or should be avoided.
5052 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
5053 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
5054 is necessary because for array constructors, aliasing depends on how
5056 - If E is an array constructor used as argument to an elemental procedure,
5057 the array, which is generated through shallow copy by the scalarizer,
5058 is used directly and can alias the expressions it was copied from.
5059 - If E is an array constructor used as argument to a non-elemental
5060 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
5061 the array as in the previous case, but then that array is used
5062 to initialize a new descriptor through deep copy. There is no alias
5063 possible in that case.
5064 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
5068 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
5072 if (e->expr_type == EXPR_VARIABLE)
5074 else if (e->expr_type == EXPR_FUNCTION)
5076 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
5078 if (proc_ifc->result != NULL
5079 && ((proc_ifc->result->ts.type == BT_CLASS
5080 && proc_ifc->result->ts.u.derived->attr.is_class
5081 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
5082 || proc_ifc->result->attr.pointer))
5087 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
5090 for (c = gfc_constructor_first (e->value.constructor);
5091 c; c = gfc_constructor_next (c))
5093 && expr_may_alias_variables (c->expr, array_may_alias))
5100 /* A helper function to set the dtype for unallocated or unassociated
5104 set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
5112 /* TODO Figure out how to handle optional dummies. */
5113 if (e && e->expr_type == EXPR_VARIABLE
5114 && e->symtree->n.sym->attr.optional)
5117 desc = parmse->expr;
5118 if (desc == NULL_TREE)
5121 if (POINTER_TYPE_P (TREE_TYPE (desc)))
5122 desc = build_fold_indirect_ref_loc (input_location, desc);
5124 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
5127 gfc_init_block (&block);
5128 tmp = gfc_conv_descriptor_data_get (desc);
5129 cond = fold_build2_loc (input_location, EQ_EXPR,
5130 logical_type_node, tmp,
5131 build_int_cst (TREE_TYPE (tmp), 0));
5132 tmp = gfc_conv_descriptor_dtype (desc);
5133 type = gfc_get_element_type (TREE_TYPE (desc));
5134 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5135 TREE_TYPE (tmp), tmp,
5136 gfc_get_dtype_rank_type (e->rank, type));
5137 gfc_add_expr_to_block (&block, tmp);
5138 cond = build3_v (COND_EXPR, cond,
5139 gfc_finish_block (&block),
5140 build_empty_stmt (input_location));
5141 gfc_add_expr_to_block (&parmse->pre, cond);
5146 /* Provide an interface between gfortran array descriptors and the F2018:18.4
5147 ISO_Fortran_binding array descriptors. */
5150 gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
5158 symbol_attribute attr = gfc_expr_attr (e);
5161 /* If this is a full array or a scalar, the allocatable and pointer
5162 attributes can be passed. Otherwise it is 'CFI_attribute_other'*/
5164 if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
5166 if (fsym->attr.pointer)
5168 else if (fsym->attr.allocatable)
5174 parmse->force_no_tmp = 1;
5175 if (fsym->attr.contiguous
5176 && !gfc_is_simply_contiguous (e, false, true))
5177 gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
5178 fsym->attr.pointer);
5180 gfc_conv_expr_descriptor (parmse, e);
5182 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5183 parmse->expr = build_fold_indirect_ref_loc (input_location,
5186 /* Unallocated allocatable arrays and unassociated pointer arrays
5187 need their dtype setting if they are argument associated with
5188 assumed rank dummies. */
5189 if (fsym && fsym->as
5190 && (gfc_expr_attr (e).pointer
5191 || gfc_expr_attr (e).allocatable))
5192 set_dtype_for_unallocated (parmse, e);
5194 /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
5195 the expression type is different from the descriptor type, then
5196 the offset must be found (eg. to a component ref or substring)
5197 and the dtype updated. Assumed type entities are only allowed
5198 to be dummies in Fortran. They therefore lack the decl specific
5199 appendiges and so must be treated differently from other fortran
5200 entities passed to CFI descriptors in the interface decl. */
5201 type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
5204 if (type && DECL_ARTIFICIAL (parmse->expr)
5205 && type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
5207 /* Obtain the offset to the data. */
5208 gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr,
5209 gfc_index_zero_node, true, e);
5211 /* Update the dtype. */
5212 gfc_add_modify (&parmse->pre,
5213 gfc_conv_descriptor_dtype (parmse->expr),
5214 gfc_get_dtype_rank_type (e->rank, type));
5216 else if (type == NULL_TREE
5217 || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)))
5219 /* Make sure that the span is set for expressions where it
5220 might not have been done already. */
5221 tmp = gfc_conv_descriptor_elem_len (parmse->expr);
5222 tmp = fold_convert (gfc_array_index_type, tmp);
5223 gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
5228 gfc_conv_expr (parmse, e);
5230 if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
5231 parmse->expr = build_fold_indirect_ref_loc (input_location,
5234 parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
5235 parmse->expr, attr);
5238 /* Set the CFI attribute field. */
5239 tmp = gfc_conv_descriptor_attribute (parmse->expr);
5240 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5241 void_type_node, tmp,
5242 build_int_cst (TREE_TYPE (tmp), attribute));
5243 gfc_add_expr_to_block (&parmse->pre, tmp);
5245 /* Now pass the gfc_descriptor by reference. */
5246 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5248 /* Variables to point to the gfc and CFI descriptors. */
5249 gfc_desc_ptr = parmse->expr;
5250 cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
5251 gfc_add_modify (&parmse->pre, cfi_desc_ptr,
5252 build_int_cst (pvoid_type_node, 0));
5254 /* Allocate the CFI descriptor and fill the fields. */
5255 tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
5256 tmp = build_call_expr_loc (input_location,
5257 gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
5258 gfc_add_expr_to_block (&parmse->pre, tmp);
5260 /* The CFI descriptor is passed to the bind_C procedure. */
5261 parmse->expr = cfi_desc_ptr;
5263 /* Free the CFI descriptor. */
5264 gfc_init_block (&block);
5265 cond = fold_build2_loc (input_location, NE_EXPR,
5266 logical_type_node, cfi_desc_ptr,
5267 build_int_cst (TREE_TYPE (cfi_desc_ptr), 0));
5268 tmp = gfc_call_free (cfi_desc_ptr);
5269 gfc_add_expr_to_block (&block, tmp);
5270 tmp = build3_v (COND_EXPR, cond,
5271 gfc_finish_block (&block),
5272 build_empty_stmt (input_location));
5273 gfc_prepend_expr_to_block (&parmse->post, tmp);
5275 /* Transfer values back to gfc descriptor. */
5276 tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
5277 tmp = build_call_expr_loc (input_location,
5278 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
5279 gfc_prepend_expr_to_block (&parmse->post, tmp);
5283 /* Generate code for a procedure call. Note can return se->post != NULL.
5284 If se->direct_byref is set then se->expr contains the return parameter.
5285 Return nonzero, if the call has alternate specifiers.
5286 'expr' is only needed for procedure pointer components. */
5289 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
5290 gfc_actual_arglist * args, gfc_expr * expr,
5291 vec<tree, va_gc> *append_args)
5293 gfc_interface_mapping mapping;
5294 vec<tree, va_gc> *arglist;
5295 vec<tree, va_gc> *retargs;
5299 gfc_array_info *info;
5306 vec<tree, va_gc> *stringargs;
5307 vec<tree, va_gc> *optionalargs;
5309 gfc_formal_arglist *formal;
5310 gfc_actual_arglist *arg;
5311 int has_alternate_specifier = 0;
5312 bool need_interface_mapping;
5320 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
5321 gfc_component *comp = NULL;
5328 optionalargs = NULL;
5333 comp = gfc_get_proc_ptr_comp (expr);
5335 bool elemental_proc = (comp
5336 && comp->ts.interface
5337 && comp->ts.interface->attr.elemental)
5338 || (comp && comp->attr.elemental)
5339 || sym->attr.elemental;
5343 if (!elemental_proc)
5345 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
5346 if (se->ss->info->useflags)
5348 gcc_assert ((!comp && gfc_return_by_reference (sym)
5349 && sym->result->attr.dimension)
5350 || (comp && comp->attr.dimension)
5351 || gfc_is_class_array_function (expr));
5352 gcc_assert (se->loop != NULL);
5353 /* Access the previously obtained result. */
5354 gfc_conv_tmp_array_ref (se);
5358 info = &se->ss->info->data.array;
5363 gfc_init_block (&post);
5364 gfc_init_interface_mapping (&mapping);
5367 formal = gfc_sym_get_dummy_args (sym);
5368 need_interface_mapping = sym->attr.dimension ||
5369 (sym->ts.type == BT_CHARACTER
5370 && sym->ts.u.cl->length
5371 && sym->ts.u.cl->length->expr_type
5376 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
5377 need_interface_mapping = comp->attr.dimension ||
5378 (comp->ts.type == BT_CHARACTER
5379 && comp->ts.u.cl->length
5380 && comp->ts.u.cl->length->expr_type
5384 base_object = NULL_TREE;
5385 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
5386 is the third and fourth argument to such a function call a value
5387 denoting the number of elements to copy (i.e., most of the time the
5388 length of a deferred length string). */
5389 ulim_copy = (formal == NULL)
5390 && UNLIMITED_POLY (sym)
5391 && comp && (strcmp ("_copy", comp->name) == 0);
5393 /* Evaluate the arguments. */
5394 for (arg = args, argc = 0; arg != NULL;
5395 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
5397 bool finalized = false;
5398 bool non_unity_length_string = false;
5401 fsym = formal ? formal->sym : NULL;
5402 parm_kind = MISSING;
5404 if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
5405 && (!fsym->ts.u.cl->length
5406 || fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
5407 || mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
5408 non_unity_length_string = true;
5410 /* If the procedure requires an explicit interface, the actual
5411 argument is passed according to the corresponding formal
5412 argument. If the corresponding formal argument is a POINTER,
5413 ALLOCATABLE or assumed shape, we do not use g77's calling
5414 convention, and pass the address of the array descriptor
5415 instead. Otherwise we use g77's calling convention, in other words
5416 pass the array data pointer without descriptor. */
5417 bool nodesc_arg = fsym != NULL
5418 && !(fsym->attr.pointer || fsym->attr.allocatable)
5420 && fsym->as->type != AS_ASSUMED_SHAPE
5421 && fsym->as->type != AS_ASSUMED_RANK;
5423 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
5425 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
5427 /* Class array expressions are sometimes coming completely unadorned
5428 with either arrayspec or _data component. Correct that here.
5429 OOP-TODO: Move this to the frontend. */
5430 if (e && e->expr_type == EXPR_VARIABLE
5432 && e->ts.type == BT_CLASS
5433 && (CLASS_DATA (e)->attr.codimension
5434 || CLASS_DATA (e)->attr.dimension))
5436 gfc_typespec temp_ts = e->ts;
5437 gfc_add_class_array_ref (e);
5443 if (se->ignore_optional)
5445 /* Some intrinsics have already been resolved to the correct
5449 else if (arg->label)
5451 has_alternate_specifier = 1;
5456 gfc_init_se (&parmse, NULL);
5458 /* For scalar arguments with VALUE attribute which are passed by
5459 value, pass "0" and a hidden argument gives the optional
5461 if (fsym && fsym->attr.optional && fsym->attr.value
5462 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
5463 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
5465 parmse.expr = fold_convert (gfc_sym_type (fsym),
5467 vec_safe_push (optionalargs, boolean_false_node);
5471 /* Pass a NULL pointer for an absent arg. */
5472 parmse.expr = null_pointer_node;
5473 if (arg->missing_arg_type == BT_CHARACTER)
5474 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5479 else if (arg->expr->expr_type == EXPR_NULL
5480 && fsym && !fsym->attr.pointer
5481 && (fsym->ts.type != BT_CLASS
5482 || !CLASS_DATA (fsym)->attr.class_pointer))
5484 /* Pass a NULL pointer to denote an absent arg. */
5485 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5486 && (fsym->ts.type != BT_CLASS
5487 || !CLASS_DATA (fsym)->attr.allocatable));
5488 gfc_init_se (&parmse, NULL);
5489 parmse.expr = null_pointer_node;
5490 if (arg->missing_arg_type == BT_CHARACTER)
5491 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5493 else if (fsym && fsym->ts.type == BT_CLASS
5494 && e->ts.type == BT_DERIVED)
5496 /* The derived type needs to be converted to a temporary
5498 gfc_init_se (&parmse, se);
5499 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5501 && e->expr_type == EXPR_VARIABLE
5502 && e->symtree->n.sym->attr.optional,
5503 CLASS_DATA (fsym)->attr.class_pointer
5504 || CLASS_DATA (fsym)->attr.allocatable);
5506 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
5508 /* The intrinsic type needs to be converted to a temporary
5509 CLASS object for the unlimited polymorphic formal. */
5510 gfc_init_se (&parmse, se);
5511 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5513 else if (se->ss && se->ss->info->useflags)
5519 /* An elemental function inside a scalarized loop. */
5520 gfc_init_se (&parmse, se);
5521 parm_kind = ELEMENTAL;
5523 /* When no fsym is present, ulim_copy is set and this is a third or
5524 fourth argument, use call-by-value instead of by reference to
5525 hand the length properties to the copy routine (i.e., most of the
5526 time this will be a call to a __copy_character_* routine where the
5527 third and fourth arguments are the lengths of a deferred length
5529 if ((fsym && fsym->attr.value)
5530 || (ulim_copy && (argc == 2 || argc == 3)))
5531 gfc_conv_expr (&parmse, e);
5533 gfc_conv_expr_reference (&parmse, e);
5535 if (e->ts.type == BT_CHARACTER && !e->rank
5536 && e->expr_type == EXPR_FUNCTION)
5537 parmse.expr = build_fold_indirect_ref_loc (input_location,
5540 if (fsym && fsym->ts.type == BT_DERIVED
5541 && gfc_is_class_container_ref (e))
5543 parmse.expr = gfc_class_data_get (parmse.expr);
5545 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5546 && e->symtree->n.sym->attr.optional)
5548 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5549 parmse.expr = build3_loc (input_location, COND_EXPR,
5550 TREE_TYPE (parmse.expr),
5552 fold_convert (TREE_TYPE (parmse.expr),
5553 null_pointer_node));
5557 /* If we are passing an absent array as optional dummy to an
5558 elemental procedure, make sure that we pass NULL when the data
5559 pointer is NULL. We need this extra conditional because of
5560 scalarization which passes arrays elements to the procedure,
5561 ignoring the fact that the array can be absent/unallocated/... */
5562 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5564 tree descriptor_data;
5566 descriptor_data = ss->info->data.array.data;
5567 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5569 fold_convert (TREE_TYPE (descriptor_data),
5570 null_pointer_node));
5572 = fold_build3_loc (input_location, COND_EXPR,
5573 TREE_TYPE (parmse.expr),
5574 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5575 fold_convert (TREE_TYPE (parmse.expr),
5580 /* The scalarizer does not repackage the reference to a class
5581 array - instead it returns a pointer to the data element. */
5582 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5583 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5584 fsym->attr.intent != INTENT_IN
5585 && (CLASS_DATA (fsym)->attr.class_pointer
5586 || CLASS_DATA (fsym)->attr.allocatable),
5588 && e->expr_type == EXPR_VARIABLE
5589 && e->symtree->n.sym->attr.optional,
5590 CLASS_DATA (fsym)->attr.class_pointer
5591 || CLASS_DATA (fsym)->attr.allocatable);
5598 gfc_init_se (&parmse, NULL);
5600 /* Check whether the expression is a scalar or not; we cannot use
5601 e->rank as it can be nonzero for functions arguments. */
5602 argss = gfc_walk_expr (e);
5603 scalar = argss == gfc_ss_terminator;
5605 gfc_free_ss_chain (argss);
5607 /* Special handling for passing scalar polymorphic coarrays;
5608 otherwise one passes "class->_data.data" instead of "&class". */
5609 if (e->rank == 0 && e->ts.type == BT_CLASS
5610 && fsym && fsym->ts.type == BT_CLASS
5611 && CLASS_DATA (fsym)->attr.codimension
5612 && !CLASS_DATA (fsym)->attr.dimension)
5614 gfc_add_class_array_ref (e);
5615 parmse.want_coarray = 1;
5619 /* A scalar or transformational function. */
5622 if (e->expr_type == EXPR_VARIABLE
5623 && e->symtree->n.sym->attr.cray_pointee
5624 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5626 /* The Cray pointer needs to be converted to a pointer to
5627 a type given by the expression. */
5628 gfc_conv_expr (&parmse, e);
5629 type = build_pointer_type (TREE_TYPE (parmse.expr));
5630 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5631 parmse.expr = convert (type, tmp);
5634 else if (sym->attr.is_bind_c && e
5635 && (is_CFI_desc (fsym, NULL)
5636 || non_unity_length_string))
5637 /* Implement F2018, C.12.6.1: paragraph (2). */
5638 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
5640 else if (fsym && fsym->attr.value)
5642 if (fsym->ts.type == BT_CHARACTER
5643 && fsym->ts.is_c_interop
5644 && fsym->ns->proc_name != NULL
5645 && fsym->ns->proc_name->attr.is_bind_c)
5648 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5649 if (parmse.expr == NULL)
5650 gfc_conv_expr (&parmse, e);
5654 gfc_conv_expr (&parmse, e);
5655 if (fsym->attr.optional
5656 && fsym->ts.type != BT_CLASS
5657 && fsym->ts.type != BT_DERIVED)
5659 if (e->expr_type != EXPR_VARIABLE
5660 || !e->symtree->n.sym->attr.optional
5662 vec_safe_push (optionalargs, boolean_true_node);
5665 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5666 if (!e->symtree->n.sym->attr.value)
5668 = fold_build3_loc (input_location, COND_EXPR,
5669 TREE_TYPE (parmse.expr),
5671 fold_convert (TREE_TYPE (parmse.expr),
5672 integer_zero_node));
5674 vec_safe_push (optionalargs, tmp);
5680 else if (arg->name && arg->name[0] == '%')
5681 /* Argument list functions %VAL, %LOC and %REF are signalled
5682 through arg->name. */
5683 conv_arglist_function (&parmse, arg->expr, arg->name);
5684 else if ((e->expr_type == EXPR_FUNCTION)
5685 && ((e->value.function.esym
5686 && e->value.function.esym->result->attr.pointer)
5687 || (!e->value.function.esym
5688 && e->symtree->n.sym->attr.pointer))
5689 && fsym && fsym->attr.target)
5691 gfc_conv_expr (&parmse, e);
5692 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5695 else if (e->expr_type == EXPR_FUNCTION
5696 && e->symtree->n.sym->result
5697 && e->symtree->n.sym->result != e->symtree->n.sym
5698 && e->symtree->n.sym->result->attr.proc_pointer)
5700 /* Functions returning procedure pointers. */
5701 gfc_conv_expr (&parmse, e);
5702 if (fsym && fsym->attr.proc_pointer)
5703 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5708 if (e->ts.type == BT_CLASS && fsym
5709 && fsym->ts.type == BT_CLASS
5710 && (!CLASS_DATA (fsym)->as
5711 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5712 && CLASS_DATA (e)->attr.codimension)
5714 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5715 gcc_assert (!CLASS_DATA (fsym)->as);
5716 gfc_add_class_array_ref (e);
5717 parmse.want_coarray = 1;
5718 gfc_conv_expr_reference (&parmse, e);
5719 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5721 && e->expr_type == EXPR_VARIABLE);
5723 else if (e->ts.type == BT_CLASS && fsym
5724 && fsym->ts.type == BT_CLASS
5725 && !CLASS_DATA (fsym)->as
5726 && !CLASS_DATA (e)->as
5727 && strcmp (fsym->ts.u.derived->name,
5728 e->ts.u.derived->name))
5730 type = gfc_typenode_for_spec (&fsym->ts);
5731 var = gfc_create_var (type, fsym->name);
5732 gfc_conv_expr (&parmse, e);
5733 if (fsym->attr.optional
5734 && e->expr_type == EXPR_VARIABLE
5735 && e->symtree->n.sym->attr.optional)
5739 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5740 cond = fold_build2_loc (input_location, NE_EXPR,
5741 logical_type_node, tmp,
5742 fold_convert (TREE_TYPE (tmp),
5743 null_pointer_node));
5744 gfc_start_block (&block);
5745 gfc_add_modify (&block, var,
5746 fold_build1_loc (input_location,
5748 type, parmse.expr));
5749 gfc_add_expr_to_block (&parmse.pre,
5750 fold_build3_loc (input_location,
5751 COND_EXPR, void_type_node,
5752 cond, gfc_finish_block (&block),
5753 build_empty_stmt (input_location)));
5754 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5755 parmse.expr = build3_loc (input_location, COND_EXPR,
5756 TREE_TYPE (parmse.expr),
5758 fold_convert (TREE_TYPE (parmse.expr),
5759 null_pointer_node));
5763 /* Since the internal representation of unlimited
5764 polymorphic expressions includes an extra field
5765 that other class objects do not, a cast to the
5766 formal type does not work. */
5767 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5771 /* Set the _data field. */
5772 tmp = gfc_class_data_get (var);
5773 efield = fold_convert (TREE_TYPE (tmp),
5774 gfc_class_data_get (parmse.expr));
5775 gfc_add_modify (&parmse.pre, tmp, efield);
5777 /* Set the _vptr field. */
5778 tmp = gfc_class_vptr_get (var);
5779 efield = fold_convert (TREE_TYPE (tmp),
5780 gfc_class_vptr_get (parmse.expr));
5781 gfc_add_modify (&parmse.pre, tmp, efield);
5783 /* Set the _len field. */
5784 tmp = gfc_class_len_get (var);
5785 gfc_add_modify (&parmse.pre, tmp,
5786 build_int_cst (TREE_TYPE (tmp), 0));
5790 tmp = fold_build1_loc (input_location,
5793 gfc_add_modify (&parmse.pre, var, tmp);
5796 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5802 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5803 && !fsym->attr.allocatable && !fsym->attr.pointer
5804 && !e->symtree->n.sym->attr.dimension
5805 && !e->symtree->n.sym->attr.pointer
5807 && !e->symtree->n.sym->attr.dummy
5808 /* FIXME - PR 87395 and PR 41453 */
5809 && e->symtree->n.sym->attr.save == SAVE_NONE
5810 && !e->symtree->n.sym->attr.associate_var
5811 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5812 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5814 gfc_conv_expr_reference (&parmse, e, add_clobber);
5816 /* Catch base objects that are not variables. */
5817 if (e->ts.type == BT_CLASS
5818 && e->expr_type != EXPR_VARIABLE
5819 && expr && e == expr->base_expr)
5820 base_object = build_fold_indirect_ref_loc (input_location,
5823 /* A class array element needs converting back to be a
5824 class object, if the formal argument is a class object. */
5825 if (fsym && fsym->ts.type == BT_CLASS
5826 && e->ts.type == BT_CLASS
5827 && ((CLASS_DATA (fsym)->as
5828 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5829 || CLASS_DATA (e)->attr.dimension))
5830 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5831 fsym->attr.intent != INTENT_IN
5832 && (CLASS_DATA (fsym)->attr.class_pointer
5833 || CLASS_DATA (fsym)->attr.allocatable),
5835 && e->expr_type == EXPR_VARIABLE
5836 && e->symtree->n.sym->attr.optional,
5837 CLASS_DATA (fsym)->attr.class_pointer
5838 || CLASS_DATA (fsym)->attr.allocatable);
5840 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5841 allocated on entry, it must be deallocated. */
5842 if (fsym && fsym->attr.intent == INTENT_OUT
5843 && (fsym->attr.allocatable
5844 || (fsym->ts.type == BT_CLASS
5845 && CLASS_DATA (fsym)->attr.allocatable)))
5850 gfc_init_block (&block);
5852 if (e->ts.type == BT_CLASS)
5853 ptr = gfc_class_data_get (ptr);
5855 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5858 gfc_add_expr_to_block (&block, tmp);
5859 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5860 void_type_node, ptr,
5862 gfc_add_expr_to_block (&block, tmp);
5864 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5866 gfc_add_modify (&block, ptr,
5867 fold_convert (TREE_TYPE (ptr),
5868 null_pointer_node));
5869 gfc_add_expr_to_block (&block, tmp);
5871 else if (fsym->ts.type == BT_CLASS)
5874 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5875 tmp = gfc_get_symbol_decl (vtab);
5876 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5877 ptr = gfc_class_vptr_get (parmse.expr);
5878 gfc_add_modify (&block, ptr,
5879 fold_convert (TREE_TYPE (ptr), tmp));
5880 gfc_add_expr_to_block (&block, tmp);
5883 if (fsym->attr.optional
5884 && e->expr_type == EXPR_VARIABLE
5885 && e->symtree->n.sym->attr.optional)
5887 tmp = fold_build3_loc (input_location, COND_EXPR,
5889 gfc_conv_expr_present (e->symtree->n.sym),
5890 gfc_finish_block (&block),
5891 build_empty_stmt (input_location));
5894 tmp = gfc_finish_block (&block);
5896 gfc_add_expr_to_block (&se->pre, tmp);
5899 if (fsym && (fsym->ts.type == BT_DERIVED
5900 || fsym->ts.type == BT_ASSUMED)
5901 && e->ts.type == BT_CLASS
5902 && !CLASS_DATA (e)->attr.dimension
5903 && !CLASS_DATA (e)->attr.codimension)
5905 parmse.expr = gfc_class_data_get (parmse.expr);
5906 /* The result is a class temporary, whose _data component
5907 must be freed to avoid a memory leak. */
5908 if (e->expr_type == EXPR_FUNCTION
5909 && CLASS_DATA (e)->attr.allocatable)
5915 /* Borrow the function symbol to make a call to
5916 gfc_add_finalizer_call and then restore it. */
5917 tmp = e->symtree->n.sym->backend_decl;
5918 e->symtree->n.sym->backend_decl
5919 = TREE_OPERAND (parmse.expr, 0);
5920 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5921 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5922 finalized = gfc_add_finalizer_call (&parmse.post,
5924 gfc_free_expr (var);
5925 e->symtree->n.sym->backend_decl = tmp;
5926 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5928 /* Then free the class _data. */
5929 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5930 tmp = fold_build2_loc (input_location, NE_EXPR,
5933 tmp = build3_v (COND_EXPR, tmp,
5934 gfc_call_free (parmse.expr),
5935 build_empty_stmt (input_location));
5936 gfc_add_expr_to_block (&parmse.post, tmp);
5937 gfc_add_modify (&parmse.post, parmse.expr, zero);
5941 /* Wrap scalar variable in a descriptor. We need to convert
5942 the address of a pointer back to the pointer itself before,
5943 we can assign it to the data field. */
5945 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5946 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5949 if (TREE_CODE (tmp) == ADDR_EXPR)
5950 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5951 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5953 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5956 else if (fsym && e->expr_type != EXPR_NULL
5957 && ((fsym->attr.pointer
5958 && fsym->attr.flavor != FL_PROCEDURE)
5959 || (fsym->attr.proc_pointer
5960 && !(e->expr_type == EXPR_VARIABLE
5961 && e->symtree->n.sym->attr.dummy))
5962 || (fsym->attr.proc_pointer
5963 && e->expr_type == EXPR_VARIABLE
5964 && gfc_is_proc_ptr_comp (e))
5965 || (fsym->attr.allocatable
5966 && fsym->attr.flavor != FL_PROCEDURE)))
5968 /* Scalar pointer dummy args require an extra level of
5969 indirection. The null pointer already contains
5970 this level of indirection. */
5971 parm_kind = SCALAR_POINTER;
5972 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5976 else if (e->ts.type == BT_CLASS
5977 && fsym && fsym->ts.type == BT_CLASS
5978 && (CLASS_DATA (fsym)->attr.dimension
5979 || CLASS_DATA (fsym)->attr.codimension))
5981 /* Pass a class array. */
5982 parmse.use_offset = 1;
5983 gfc_conv_expr_descriptor (&parmse, e);
5985 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5986 allocated on entry, it must be deallocated. */
5987 if (fsym->attr.intent == INTENT_OUT
5988 && CLASS_DATA (fsym)->attr.allocatable)
5993 gfc_init_block (&block);
5995 ptr = gfc_class_data_get (ptr);
5997 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5998 NULL_TREE, NULL_TREE,
6000 GFC_CAF_COARRAY_NOCOARRAY);
6001 gfc_add_expr_to_block (&block, tmp);
6002 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
6003 void_type_node, ptr,
6005 gfc_add_expr_to_block (&block, tmp);
6006 gfc_reset_vptr (&block, e);
6008 if (fsym->attr.optional
6009 && e->expr_type == EXPR_VARIABLE
6011 || (e->ref->type == REF_ARRAY
6012 && e->ref->u.ar.type != AR_FULL))
6013 && e->symtree->n.sym->attr.optional)
6015 tmp = fold_build3_loc (input_location, COND_EXPR,
6017 gfc_conv_expr_present (e->symtree->n.sym),
6018 gfc_finish_block (&block),
6019 build_empty_stmt (input_location));
6022 tmp = gfc_finish_block (&block);
6024 gfc_add_expr_to_block (&se->pre, tmp);
6027 /* The conversion does not repackage the reference to a class
6028 array - _data descriptor. */
6029 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
6030 fsym->attr.intent != INTENT_IN
6031 && (CLASS_DATA (fsym)->attr.class_pointer
6032 || CLASS_DATA (fsym)->attr.allocatable),
6034 && e->expr_type == EXPR_VARIABLE
6035 && e->symtree->n.sym->attr.optional,
6036 CLASS_DATA (fsym)->attr.class_pointer
6037 || CLASS_DATA (fsym)->attr.allocatable);
6041 /* If the argument is a function call that may not create
6042 a temporary for the result, we have to check that we
6043 can do it, i.e. that there is no alias between this
6044 argument and another one. */
6045 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
6051 intent = fsym->attr.intent;
6053 intent = INTENT_UNKNOWN;
6055 if (gfc_check_fncall_dependency (e, intent, sym, args,
6057 parmse.force_tmp = 1;
6059 iarg = e->value.function.actual->expr;
6061 /* Temporary needed if aliasing due to host association. */
6062 if (sym->attr.contained
6064 && !sym->attr.implicit_pure
6065 && !sym->attr.use_assoc
6066 && iarg->expr_type == EXPR_VARIABLE
6067 && sym->ns == iarg->symtree->n.sym->ns)
6068 parmse.force_tmp = 1;
6070 /* Ditto within module. */
6071 if (sym->attr.use_assoc
6073 && !sym->attr.implicit_pure
6074 && iarg->expr_type == EXPR_VARIABLE
6075 && sym->module == iarg->symtree->n.sym->module)
6076 parmse.force_tmp = 1;
6079 if (sym->attr.is_bind_c && e
6080 && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
6081 /* Implement F2018, C.12.6.1: paragraph (2). */
6082 gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
6084 else if (e->expr_type == EXPR_VARIABLE
6085 && is_subref_array (e)
6086 && !(fsym && fsym->attr.pointer))
6087 /* The actual argument is a component reference to an
6088 array of derived types. In this case, the argument
6089 is converted to a temporary, which is passed and then
6090 written back after the procedure call. */
6091 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6092 fsym ? fsym->attr.intent : INTENT_INOUT,
6093 fsym && fsym->attr.pointer);
6095 else if (gfc_is_class_array_ref (e, NULL)
6096 && fsym && fsym->ts.type == BT_DERIVED)
6097 /* The actual argument is a component reference to an
6098 array of derived types. In this case, the argument
6099 is converted to a temporary, which is passed and then
6100 written back after the procedure call.
6101 OOP-TODO: Insert code so that if the dynamic type is
6102 the same as the declared type, copy-in/copy-out does
6104 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6105 fsym ? fsym->attr.intent : INTENT_INOUT,
6106 fsym && fsym->attr.pointer);
6108 else if (gfc_is_class_array_function (e)
6109 && fsym && fsym->ts.type == BT_DERIVED)
6110 /* See previous comment. For function actual argument,
6111 the write out is not needed so the intent is set as
6114 e->must_finalize = 1;
6115 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6117 fsym && fsym->attr.pointer);
6119 else if (fsym && fsym->attr.contiguous
6120 && !gfc_is_simply_contiguous (e, false, true))
6122 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
6123 fsym ? fsym->attr.intent : INTENT_INOUT,
6124 fsym && fsym->attr.pointer);
6127 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
6130 /* Unallocated allocatable arrays and unassociated pointer arrays
6131 need their dtype setting if they are argument associated with
6132 assumed rank dummies. */
6133 if (!sym->attr.is_bind_c && e && fsym && fsym->as
6134 && fsym->as->type == AS_ASSUMED_RANK)
6136 if (gfc_expr_attr (e).pointer
6137 || gfc_expr_attr (e).allocatable)
6138 set_dtype_for_unallocated (&parmse, e);
6139 else if (e->expr_type == EXPR_VARIABLE
6140 && e->symtree->n.sym->attr.dummy
6141 && e->symtree->n.sym->as
6142 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
6145 tmp = build_fold_indirect_ref_loc (input_location,
6147 minus_one = build_int_cst (gfc_array_index_type, -1);
6148 gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
6149 gfc_rank_cst[e->rank - 1],
6154 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
6155 allocated on entry, it must be deallocated. */
6156 if (fsym && fsym->attr.allocatable
6157 && fsym->attr.intent == INTENT_OUT)
6159 if (fsym->ts.type == BT_DERIVED
6160 && fsym->ts.u.derived->attr.alloc_comp)
6162 // deallocate the components first
6163 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
6164 parmse.expr, e->rank);
6165 if (tmp != NULL_TREE)
6166 gfc_add_expr_to_block (&se->pre, tmp);
6169 tmp = build_fold_indirect_ref_loc (input_location,
6171 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
6172 tmp = gfc_conv_descriptor_data_get (tmp);
6173 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6174 NULL_TREE, NULL_TREE, true,
6176 GFC_CAF_COARRAY_NOCOARRAY);
6177 if (fsym->attr.optional
6178 && e->expr_type == EXPR_VARIABLE
6179 && e->symtree->n.sym->attr.optional)
6180 tmp = fold_build3_loc (input_location, COND_EXPR,
6182 gfc_conv_expr_present (e->symtree->n.sym),
6183 tmp, build_empty_stmt (input_location));
6184 gfc_add_expr_to_block (&se->pre, tmp);
6189 /* The case with fsym->attr.optional is that of a user subroutine
6190 with an interface indicating an optional argument. When we call
6191 an intrinsic subroutine, however, fsym is NULL, but we might still
6192 have an optional argument, so we proceed to the substitution
6194 if (e && (fsym == NULL || fsym->attr.optional))
6196 /* If an optional argument is itself an optional dummy argument,
6197 check its presence and substitute a null if absent. This is
6198 only needed when passing an array to an elemental procedure
6199 as then array elements are accessed - or no NULL pointer is
6200 allowed and a "1" or "0" should be passed if not present.
6201 When passing a non-array-descriptor full array to a
6202 non-array-descriptor dummy, no check is needed. For
6203 array-descriptor actual to array-descriptor dummy, see
6204 PR 41911 for why a check has to be inserted.
6205 fsym == NULL is checked as intrinsics required the descriptor
6206 but do not always set fsym.
6207 Also, it is necessary to pass a NULL pointer to library routines
6208 which usually ignore optional arguments, so they can handle
6209 these themselves. */
6210 if (e->expr_type == EXPR_VARIABLE
6211 && e->symtree->n.sym->attr.optional
6212 && (((e->rank != 0 && elemental_proc)
6213 || e->representation.length || e->ts.type == BT_CHARACTER
6217 && (fsym->as->type == AS_ASSUMED_SHAPE
6218 || fsym->as->type == AS_ASSUMED_RANK
6219 || fsym->as->type == AS_DEFERRED)))))
6220 || se->ignore_optional))
6221 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
6222 e->representation.length);
6227 /* Obtain the character length of an assumed character length
6228 length procedure from the typespec. */
6229 if (fsym->ts.type == BT_CHARACTER
6230 && parmse.string_length == NULL_TREE
6231 && e->ts.type == BT_PROCEDURE
6232 && e->symtree->n.sym->ts.type == BT_CHARACTER
6233 && e->symtree->n.sym->ts.u.cl->length != NULL
6234 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
6236 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
6237 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
6241 if (fsym && need_interface_mapping && e)
6242 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
6244 gfc_add_block_to_block (&se->pre, &parmse.pre);
6245 gfc_add_block_to_block (&post, &parmse.post);
6247 /* Allocated allocatable components of derived types must be
6248 deallocated for non-variable scalars, array arguments to elemental
6249 procedures, and array arguments with descriptor to non-elemental
6250 procedures. As bounds information for descriptorless arrays is no
6251 longer available here, they are dealt with in trans-array.c
6252 (gfc_conv_array_parameter). */
6253 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
6254 && e->ts.u.derived->attr.alloc_comp
6255 && (e->rank == 0 || elemental_proc || !nodesc_arg)
6256 && !expr_may_alias_variables (e, elemental_proc))
6259 /* It is known the e returns a structure type with at least one
6260 allocatable component. When e is a function, ensure that the
6261 function is called once only by using a temporary variable. */
6262 if (!DECL_P (parmse.expr))
6263 parmse.expr = gfc_evaluate_now_loc (input_location,
6264 parmse.expr, &se->pre);
6266 if (fsym && fsym->attr.value)
6269 tmp = build_fold_indirect_ref_loc (input_location,
6272 parm_rank = e->rank;
6280 case (SCALAR_POINTER):
6281 tmp = build_fold_indirect_ref_loc (input_location,
6286 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
6288 /* The derived type is passed to gfc_deallocate_alloc_comp.
6289 Therefore, class actuals can be handled correctly but derived
6290 types passed to class formals need the _data component. */
6291 tmp = gfc_class_data_get (tmp);
6292 if (!CLASS_DATA (fsym)->attr.dimension)
6293 tmp = build_fold_indirect_ref_loc (input_location, tmp);
6296 if (e->expr_type == EXPR_OP
6297 && e->value.op.op == INTRINSIC_PARENTHESES
6298 && e->value.op.op1->expr_type == EXPR_VARIABLE)
6301 local_tmp = gfc_evaluate_now (tmp, &se->pre);
6302 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
6304 gfc_add_expr_to_block (&se->post, local_tmp);
6307 if (!finalized && !e->must_finalize)
6309 if ((e->ts.type == BT_CLASS
6310 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
6311 || e->ts.type == BT_DERIVED)
6312 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
6314 else if (e->ts.type == BT_CLASS)
6315 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
6317 gfc_prepend_expr_to_block (&post, tmp);
6321 /* Add argument checking of passing an unallocated/NULL actual to
6322 a nonallocatable/nonpointer dummy. */
6324 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
6326 symbol_attribute attr;
6330 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
6331 attr = gfc_expr_attr (e);
6333 goto end_pointer_check;
6335 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
6336 allocatable to an optional dummy, cf. 12.5.2.12. */
6337 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
6338 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6339 goto end_pointer_check;
6343 /* If the actual argument is an optional pointer/allocatable and
6344 the formal argument takes an nonpointer optional value,
6345 it is invalid to pass a non-present argument on, even
6346 though there is no technical reason for this in gfortran.
6347 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
6348 tree present, null_ptr, type;
6350 if (attr.allocatable
6351 && (fsym == NULL || !fsym->attr.allocatable))
6352 msg = xasprintf ("Allocatable actual argument '%s' is not "
6353 "allocated or not present",
6354 e->symtree->n.sym->name);
6355 else if (attr.pointer
6356 && (fsym == NULL || !fsym->attr.pointer))
6357 msg = xasprintf ("Pointer actual argument '%s' is not "
6358 "associated or not present",
6359 e->symtree->n.sym->name);
6360 else if (attr.proc_pointer
6361 && (fsym == NULL || !fsym->attr.proc_pointer))
6362 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6363 "associated or not present",
6364 e->symtree->n.sym->name);
6366 goto end_pointer_check;
6368 present = gfc_conv_expr_present (e->symtree->n.sym);
6369 type = TREE_TYPE (present);
6370 present = fold_build2_loc (input_location, EQ_EXPR,
6371 logical_type_node, present,
6373 null_pointer_node));
6374 type = TREE_TYPE (parmse.expr);
6375 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
6376 logical_type_node, parmse.expr,
6378 null_pointer_node));
6379 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
6380 logical_type_node, present, null_ptr);
6384 if (attr.allocatable
6385 && (fsym == NULL || !fsym->attr.allocatable))
6386 msg = xasprintf ("Allocatable actual argument '%s' is not "
6387 "allocated", e->symtree->n.sym->name);
6388 else if (attr.pointer
6389 && (fsym == NULL || !fsym->attr.pointer))
6390 msg = xasprintf ("Pointer actual argument '%s' is not "
6391 "associated", e->symtree->n.sym->name);
6392 else if (attr.proc_pointer
6393 && (fsym == NULL || !fsym->attr.proc_pointer))
6394 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
6395 "associated", e->symtree->n.sym->name);
6397 goto end_pointer_check;
6401 /* If the argument is passed by value, we need to strip the
6403 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
6404 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6406 cond = fold_build2_loc (input_location, EQ_EXPR,
6407 logical_type_node, tmp,
6408 fold_convert (TREE_TYPE (tmp),
6409 null_pointer_node));
6412 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
6418 /* Deferred length dummies pass the character length by reference
6419 so that the value can be returned. */
6420 if (parmse.string_length && fsym && fsym->ts.deferred)
6422 if (INDIRECT_REF_P (parmse.string_length))
6423 /* In chains of functions/procedure calls the string_length already
6424 is a pointer to the variable holding the length. Therefore
6425 remove the deref on call. */
6426 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
6429 tmp = parmse.string_length;
6430 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
6431 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
6432 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
6436 /* Character strings are passed as two parameters, a length and a
6437 pointer - except for Bind(c) which only passes the pointer.
6438 An unlimited polymorphic formal argument likewise does not
6440 if (parmse.string_length != NULL_TREE
6441 && !sym->attr.is_bind_c
6442 && !(fsym && UNLIMITED_POLY (fsym)))
6443 vec_safe_push (stringargs, parmse.string_length);
6445 /* When calling __copy for character expressions to unlimited
6446 polymorphic entities, the dst argument needs a string length. */
6447 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
6448 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
6449 && arg->next && arg->next->expr
6450 && (arg->next->expr->ts.type == BT_DERIVED
6451 || arg->next->expr->ts.type == BT_CLASS)
6452 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
6453 vec_safe_push (stringargs, parmse.string_length);
6455 /* For descriptorless coarrays and assumed-shape coarray dummies, we
6456 pass the token and the offset as additional arguments. */
6457 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
6458 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6459 && !fsym->attr.allocatable)
6460 || (fsym->ts.type == BT_CLASS
6461 && CLASS_DATA (fsym)->attr.codimension
6462 && !CLASS_DATA (fsym)->attr.allocatable)))
6464 /* Token and offset. */
6465 vec_safe_push (stringargs, null_pointer_node);
6466 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
6467 gcc_assert (fsym->attr.optional);
6469 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
6470 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
6471 && !fsym->attr.allocatable)
6472 || (fsym->ts.type == BT_CLASS
6473 && CLASS_DATA (fsym)->attr.codimension
6474 && !CLASS_DATA (fsym)->attr.allocatable)))
6476 tree caf_decl, caf_type;
6479 caf_decl = gfc_get_tree_for_caf_expr (e);
6480 caf_type = TREE_TYPE (caf_decl);
6482 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6483 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
6484 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
6485 tmp = gfc_conv_descriptor_token (caf_decl);
6486 else if (DECL_LANG_SPECIFIC (caf_decl)
6487 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
6488 tmp = GFC_DECL_TOKEN (caf_decl);
6491 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
6492 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
6493 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
6496 vec_safe_push (stringargs, tmp);
6498 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
6499 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
6500 offset = build_int_cst (gfc_array_index_type, 0);
6501 else if (DECL_LANG_SPECIFIC (caf_decl)
6502 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
6503 offset = GFC_DECL_CAF_OFFSET (caf_decl);
6504 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
6505 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
6507 offset = build_int_cst (gfc_array_index_type, 0);
6509 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
6510 tmp = gfc_conv_descriptor_data_get (caf_decl);
6513 gcc_assert (POINTER_TYPE_P (caf_type));
6517 tmp2 = fsym->ts.type == BT_CLASS
6518 ? gfc_class_data_get (parmse.expr) : parmse.expr;
6519 if ((fsym->ts.type != BT_CLASS
6520 && (fsym->as->type == AS_ASSUMED_SHAPE
6521 || fsym->as->type == AS_ASSUMED_RANK))
6522 || (fsym->ts.type == BT_CLASS
6523 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6524 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6526 if (fsym->ts.type == BT_CLASS)
6527 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6530 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6531 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6533 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6534 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6536 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6537 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6540 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6543 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6544 gfc_array_index_type,
6545 fold_convert (gfc_array_index_type, tmp2),
6546 fold_convert (gfc_array_index_type, tmp));
6547 offset = fold_build2_loc (input_location, PLUS_EXPR,
6548 gfc_array_index_type, offset, tmp);
6550 vec_safe_push (stringargs, offset);
6553 vec_safe_push (arglist, parmse.expr);
6555 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6559 else if (sym->ts.type == BT_CLASS)
6560 ts = CLASS_DATA (sym)->ts;
6564 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6565 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6566 else if (ts.type == BT_CHARACTER)
6568 if (ts.u.cl->length == NULL)
6570 /* Assumed character length results are not allowed by C418 of the 2003
6571 standard and are trapped in resolve.c; except in the case of SPREAD
6572 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6573 we take the character length of the first argument for the result.
6574 For dummies, we have to look through the formal argument list for
6575 this function and use the character length found there.*/
6577 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6578 else if (!sym->attr.dummy)
6579 cl.backend_decl = (*stringargs)[0];
6582 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6583 for (; formal; formal = formal->next)
6584 if (strcmp (formal->sym->name, sym->name) == 0)
6585 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6587 len = cl.backend_decl;
6593 /* Calculate the length of the returned string. */
6594 gfc_init_se (&parmse, NULL);
6595 if (need_interface_mapping)
6596 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6598 gfc_conv_expr (&parmse, ts.u.cl->length);
6599 gfc_add_block_to_block (&se->pre, &parmse.pre);
6600 gfc_add_block_to_block (&se->post, &parmse.post);
6602 /* TODO: It would be better to have the charlens as
6603 gfc_charlen_type_node already when the interface is
6604 created instead of converting it here (see PR 84615). */
6605 tmp = fold_build2_loc (input_location, MAX_EXPR,
6606 gfc_charlen_type_node,
6607 fold_convert (gfc_charlen_type_node, tmp),
6608 build_zero_cst (gfc_charlen_type_node));
6609 cl.backend_decl = tmp;
6612 /* Set up a charlen structure for it. */
6617 len = cl.backend_decl;
6620 byref = (comp && (comp->attr.dimension
6621 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6622 || (!comp && gfc_return_by_reference (sym));
6625 if (se->direct_byref)
6627 /* Sometimes, too much indirection can be applied; e.g. for
6628 function_result = array_valued_recursive_function. */
6629 if (TREE_TYPE (TREE_TYPE (se->expr))
6630 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6631 && GFC_DESCRIPTOR_TYPE_P
6632 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6633 se->expr = build_fold_indirect_ref_loc (input_location,
6636 /* If the lhs of an assignment x = f(..) is allocatable and
6637 f2003 is allowed, we must do the automatic reallocation.
6638 TODO - deal with intrinsics, without using a temporary. */
6639 if (flag_realloc_lhs
6640 && se->ss && se->ss->loop_chain
6641 && se->ss->loop_chain->is_alloc_lhs
6642 && !expr->value.function.isym
6643 && sym->result->as != NULL)
6645 /* Evaluate the bounds of the result, if known. */
6646 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6649 /* Perform the automatic reallocation. */
6650 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6652 gfc_add_expr_to_block (&se->pre, tmp);
6654 /* Pass the temporary as the first argument. */
6655 result = info->descriptor;
6658 result = build_fold_indirect_ref_loc (input_location,
6660 vec_safe_push (retargs, se->expr);
6662 else if (comp && comp->attr.dimension)
6664 gcc_assert (se->loop && info);
6666 /* Set the type of the array. */
6667 tmp = gfc_typenode_for_spec (&comp->ts);
6668 gcc_assert (se->ss->dimen == se->loop->dimen);
6670 /* Evaluate the bounds of the result, if known. */
6671 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6673 /* If the lhs of an assignment x = f(..) is allocatable and
6674 f2003 is allowed, we must not generate the function call
6675 here but should just send back the results of the mapping.
6676 This is signalled by the function ss being flagged. */
6677 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6679 gfc_free_interface_mapping (&mapping);
6680 return has_alternate_specifier;
6683 /* Create a temporary to store the result. In case the function
6684 returns a pointer, the temporary will be a shallow copy and
6685 mustn't be deallocated. */
6686 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6687 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6688 tmp, NULL_TREE, false,
6689 !comp->attr.pointer, callee_alloc,
6690 &se->ss->info->expr->where);
6692 /* Pass the temporary as the first argument. */
6693 result = info->descriptor;
6694 tmp = gfc_build_addr_expr (NULL_TREE, result);
6695 vec_safe_push (retargs, tmp);
6697 else if (!comp && sym->result->attr.dimension)
6699 gcc_assert (se->loop && info);
6701 /* Set the type of the array. */
6702 tmp = gfc_typenode_for_spec (&ts);
6703 gcc_assert (se->ss->dimen == se->loop->dimen);
6705 /* Evaluate the bounds of the result, if known. */
6706 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6708 /* If the lhs of an assignment x = f(..) is allocatable and
6709 f2003 is allowed, we must not generate the function call
6710 here but should just send back the results of the mapping.
6711 This is signalled by the function ss being flagged. */
6712 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6714 gfc_free_interface_mapping (&mapping);
6715 return has_alternate_specifier;
6718 /* Create a temporary to store the result. In case the function
6719 returns a pointer, the temporary will be a shallow copy and
6720 mustn't be deallocated. */
6721 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6722 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6723 tmp, NULL_TREE, false,
6724 !sym->attr.pointer, callee_alloc,
6725 &se->ss->info->expr->where);
6727 /* Pass the temporary as the first argument. */
6728 result = info->descriptor;
6729 tmp = gfc_build_addr_expr (NULL_TREE, result);
6730 vec_safe_push (retargs, tmp);
6732 else if (ts.type == BT_CHARACTER)
6734 /* Pass the string length. */
6735 type = gfc_get_character_type (ts.kind, ts.u.cl);
6736 type = build_pointer_type (type);
6738 /* Emit a DECL_EXPR for the VLA type. */
6739 tmp = TREE_TYPE (type);
6741 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6743 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6744 DECL_ARTIFICIAL (tmp) = 1;
6745 DECL_IGNORED_P (tmp) = 1;
6746 tmp = fold_build1_loc (input_location, DECL_EXPR,
6747 TREE_TYPE (tmp), tmp);
6748 gfc_add_expr_to_block (&se->pre, tmp);
6751 /* Return an address to a char[0:len-1]* temporary for
6752 character pointers. */
6753 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6754 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6756 var = gfc_create_var (type, "pstr");
6758 if ((!comp && sym->attr.allocatable)
6759 || (comp && comp->attr.allocatable))
6761 gfc_add_modify (&se->pre, var,
6762 fold_convert (TREE_TYPE (var),
6763 null_pointer_node));
6764 tmp = gfc_call_free (var);
6765 gfc_add_expr_to_block (&se->post, tmp);
6768 /* Provide an address expression for the function arguments. */
6769 var = gfc_build_addr_expr (NULL_TREE, var);
6772 var = gfc_conv_string_tmp (se, type, len);
6774 vec_safe_push (retargs, var);
6778 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6780 type = gfc_get_complex_type (ts.kind);
6781 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6782 vec_safe_push (retargs, var);
6785 /* Add the string length to the argument list. */
6786 if (ts.type == BT_CHARACTER && ts.deferred)
6790 tmp = gfc_evaluate_now (len, &se->pre);
6791 TREE_STATIC (tmp) = 1;
6792 gfc_add_modify (&se->pre, tmp,
6793 build_int_cst (TREE_TYPE (tmp), 0));
6794 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6795 vec_safe_push (retargs, tmp);
6797 else if (ts.type == BT_CHARACTER)
6798 vec_safe_push (retargs, len);
6800 gfc_free_interface_mapping (&mapping);
6802 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6803 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6804 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6805 vec_safe_reserve (retargs, arglen);
6807 /* Add the return arguments. */
6808 vec_safe_splice (retargs, arglist);
6810 /* Add the hidden present status for optional+value to the arguments. */
6811 vec_safe_splice (retargs, optionalargs);
6813 /* Add the hidden string length parameters to the arguments. */
6814 vec_safe_splice (retargs, stringargs);
6816 /* We may want to append extra arguments here. This is used e.g. for
6817 calls to libgfortran_matmul_??, which need extra information. */
6818 vec_safe_splice (retargs, append_args);
6822 /* Generate the actual call. */
6823 if (base_object == NULL_TREE)
6824 conv_function_val (se, sym, expr, args);
6826 conv_base_obj_fcn_val (se, base_object, expr);
6828 /* If there are alternate return labels, function type should be
6829 integer. Can't modify the type in place though, since it can be shared
6830 with other functions. For dummy arguments, the typing is done to
6831 this result, even if it has to be repeated for each call. */
6832 if (has_alternate_specifier
6833 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6835 if (!sym->attr.dummy)
6837 TREE_TYPE (sym->backend_decl)
6838 = build_function_type (integer_type_node,
6839 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6840 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6843 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6846 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6847 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6849 /* Allocatable scalar function results must be freed and nullified
6850 after use. This necessitates the creation of a temporary to
6851 hold the result to prevent duplicate calls. */
6852 if (!byref && sym->ts.type != BT_CHARACTER
6853 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6854 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6856 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6857 gfc_add_modify (&se->pre, tmp, se->expr);
6859 tmp = gfc_call_free (tmp);
6860 gfc_add_expr_to_block (&post, tmp);
6861 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6864 /* If we have a pointer function, but we don't want a pointer, e.g.
6867 where f is pointer valued, we have to dereference the result. */
6868 if (!se->want_pointer && !byref
6869 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6870 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6871 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6873 /* f2c calling conventions require a scalar default real function to
6874 return a double precision result. Convert this back to default
6875 real. We only care about the cases that can happen in Fortran 77.
6877 if (flag_f2c && sym->ts.type == BT_REAL
6878 && sym->ts.kind == gfc_default_real_kind
6879 && !sym->attr.always_explicit)
6880 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6882 /* A pure function may still have side-effects - it may modify its
6884 TREE_SIDE_EFFECTS (se->expr) = 1;
6886 if (!sym->attr.pure)
6887 TREE_SIDE_EFFECTS (se->expr) = 1;
6892 /* Add the function call to the pre chain. There is no expression. */
6893 gfc_add_expr_to_block (&se->pre, se->expr);
6894 se->expr = NULL_TREE;
6896 if (!se->direct_byref)
6898 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6900 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6902 /* Check the data pointer hasn't been modified. This would
6903 happen in a function returning a pointer. */
6904 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6905 tmp = fold_build2_loc (input_location, NE_EXPR,
6908 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6911 se->expr = info->descriptor;
6912 /* Bundle in the string length. */
6913 se->string_length = len;
6915 else if (ts.type == BT_CHARACTER)
6917 /* Dereference for character pointer results. */
6918 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6919 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6920 se->expr = build_fold_indirect_ref_loc (input_location, var);
6924 se->string_length = len;
6928 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6929 se->expr = build_fold_indirect_ref_loc (input_location, var);
6934 /* Associate the rhs class object's meta-data with the result, when the
6935 result is a temporary. */
6936 if (args && args->expr && args->expr->ts.type == BT_CLASS
6937 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6938 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6941 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6943 gfc_init_se (&parmse, NULL);
6944 parmse.data_not_needed = 1;
6945 gfc_conv_expr (&parmse, class_expr);
6946 if (!DECL_LANG_SPECIFIC (result))
6947 gfc_allocate_lang_decl (result);
6948 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6949 gfc_free_expr (class_expr);
6950 gcc_assert (parmse.pre.head == NULL_TREE
6951 && parmse.post.head == NULL_TREE);
6954 /* Follow the function call with the argument post block. */
6957 gfc_add_block_to_block (&se->pre, &post);
6959 /* Transformational functions of derived types with allocatable
6960 components must have the result allocatable components copied when the
6961 argument is actually given. */
6962 arg = expr->value.function.actual;
6963 if (result && arg && expr->rank
6964 && expr->value.function.isym
6965 && expr->value.function.isym->transformational
6967 && arg->expr->ts.type == BT_DERIVED
6968 && arg->expr->ts.u.derived->attr.alloc_comp)
6971 /* Copy the allocatable components. We have to use a
6972 temporary here to prevent source allocatable components
6973 from being corrupted. */
6974 tmp2 = gfc_evaluate_now (result, &se->pre);
6975 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6976 result, tmp2, expr->rank, 0);
6977 gfc_add_expr_to_block (&se->pre, tmp);
6978 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6980 gfc_add_expr_to_block (&se->pre, tmp);
6982 /* Finally free the temporary's data field. */
6983 tmp = gfc_conv_descriptor_data_get (tmp2);
6984 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6985 NULL_TREE, NULL_TREE, true,
6986 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6987 gfc_add_expr_to_block (&se->pre, tmp);
6992 /* For a function with a class array result, save the result as
6993 a temporary, set the info fields needed by the scalarizer and
6994 call the finalization function of the temporary. Note that the
6995 nullification of allocatable components needed by the result
6996 is done in gfc_trans_assignment_1. */
6997 if (expr && ((gfc_is_class_array_function (expr)
6998 && se->ss && se->ss->loop)
6999 || gfc_is_alloc_class_scalar_function (expr))
7000 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
7001 && expr->must_finalize)
7006 if (se->ss && se->ss->loop)
7008 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
7009 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
7010 tmp = gfc_class_data_get (se->expr);
7011 info->descriptor = tmp;
7012 info->data = gfc_conv_descriptor_data_get (tmp);
7013 info->offset = gfc_conv_descriptor_offset_get (tmp);
7014 for (n = 0; n < se->ss->loop->dimen; n++)
7016 tree dim = gfc_rank_cst[n];
7017 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
7018 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
7023 /* TODO Eliminate the doubling of temporaries. This
7024 one is necessary to ensure no memory leakage. */
7025 se->expr = gfc_evaluate_now (se->expr, &se->pre);
7026 tmp = gfc_class_data_get (se->expr);
7027 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
7028 CLASS_DATA (expr->value.function.esym->result)->attr);
7031 if ((gfc_is_class_array_function (expr)
7032 || gfc_is_alloc_class_scalar_function (expr))
7033 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
7034 goto no_finalization;
7036 final_fndecl = gfc_class_vtab_final_get (se->expr);
7037 is_final = fold_build2_loc (input_location, NE_EXPR,
7040 fold_convert (TREE_TYPE (final_fndecl),
7041 null_pointer_node));
7042 final_fndecl = build_fold_indirect_ref_loc (input_location,
7044 tmp = build_call_expr_loc (input_location,
7046 gfc_build_addr_expr (NULL, tmp),
7047 gfc_class_vtab_size_get (se->expr),
7048 boolean_false_node);
7049 tmp = fold_build3_loc (input_location, COND_EXPR,
7050 void_type_node, is_final, tmp,
7051 build_empty_stmt (input_location));
7053 if (se->ss && se->ss->loop)
7055 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
7056 tmp = fold_build2_loc (input_location, NE_EXPR,
7059 fold_convert (TREE_TYPE (info->data),
7060 null_pointer_node));
7061 tmp = fold_build3_loc (input_location, COND_EXPR,
7062 void_type_node, tmp,
7063 gfc_call_free (info->data),
7064 build_empty_stmt (input_location));
7065 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
7070 gfc_prepend_expr_to_block (&se->post, tmp);
7071 classdata = gfc_class_data_get (se->expr);
7072 tmp = fold_build2_loc (input_location, NE_EXPR,
7075 fold_convert (TREE_TYPE (classdata),
7076 null_pointer_node));
7077 tmp = fold_build3_loc (input_location, COND_EXPR,
7078 void_type_node, tmp,
7079 gfc_call_free (classdata),
7080 build_empty_stmt (input_location));
7081 gfc_add_expr_to_block (&se->post, tmp);
7086 gfc_add_block_to_block (&se->post, &post);
7089 return has_alternate_specifier;
7093 /* Fill a character string with spaces. */
7096 fill_with_spaces (tree start, tree type, tree size)
7098 stmtblock_t block, loop;
7099 tree i, el, exit_label, cond, tmp;
7101 /* For a simple char type, we can call memset(). */
7102 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
7103 return build_call_expr_loc (input_location,
7104 builtin_decl_explicit (BUILT_IN_MEMSET),
7106 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
7107 lang_hooks.to_target_charset (' ')),
7108 fold_convert (size_type_node, size));
7110 /* Otherwise, we use a loop:
7111 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
7115 /* Initialize variables. */
7116 gfc_init_block (&block);
7117 i = gfc_create_var (sizetype, "i");
7118 gfc_add_modify (&block, i, fold_convert (sizetype, size));
7119 el = gfc_create_var (build_pointer_type (type), "el");
7120 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
7121 exit_label = gfc_build_label_decl (NULL_TREE);
7122 TREE_USED (exit_label) = 1;
7126 gfc_init_block (&loop);
7128 /* Exit condition. */
7129 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
7130 build_zero_cst (sizetype));
7131 tmp = build1_v (GOTO_EXPR, exit_label);
7132 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7133 build_empty_stmt (input_location));
7134 gfc_add_expr_to_block (&loop, tmp);
7137 gfc_add_modify (&loop,
7138 fold_build1_loc (input_location, INDIRECT_REF, type, el),
7139 build_int_cst (type, lang_hooks.to_target_charset (' ')));
7141 /* Increment loop variables. */
7142 gfc_add_modify (&loop, i,
7143 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
7144 TYPE_SIZE_UNIT (type)));
7145 gfc_add_modify (&loop, el,
7146 fold_build_pointer_plus_loc (input_location,
7147 el, TYPE_SIZE_UNIT (type)));
7149 /* Making the loop... actually loop! */
7150 tmp = gfc_finish_block (&loop);
7151 tmp = build1_v (LOOP_EXPR, tmp);
7152 gfc_add_expr_to_block (&block, tmp);
7154 /* The exit label. */
7155 tmp = build1_v (LABEL_EXPR, exit_label);
7156 gfc_add_expr_to_block (&block, tmp);
7159 return gfc_finish_block (&block);
7163 /* Generate code to copy a string. */
7166 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
7167 int dkind, tree slength, tree src, int skind)
7169 tree tmp, dlen, slen;
7178 stmtblock_t tempblock;
7180 gcc_assert (dkind == skind);
7182 if (slength != NULL_TREE)
7184 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
7185 ssc = gfc_string_to_single_character (slen, src, skind);
7189 slen = build_one_cst (gfc_charlen_type_node);
7193 if (dlength != NULL_TREE)
7195 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
7196 dsc = gfc_string_to_single_character (dlen, dest, dkind);
7200 dlen = build_one_cst (gfc_charlen_type_node);
7204 /* Assign directly if the types are compatible. */
7205 if (dsc != NULL_TREE && ssc != NULL_TREE
7206 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
7208 gfc_add_modify (block, dsc, ssc);
7212 /* The string copy algorithm below generates code like
7216 if (srclen < destlen)
7218 memmove (dest, src, srclen);
7220 memset (&dest[srclen], ' ', destlen - srclen);
7224 // Truncate if too long.
7225 memmove (dest, src, destlen);
7230 /* Do nothing if the destination length is zero. */
7231 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
7232 build_zero_cst (TREE_TYPE (dlen)));
7234 /* For non-default character kinds, we have to multiply the string
7235 length by the base type size. */
7236 chartype = gfc_get_char_type (dkind);
7237 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
7239 fold_convert (TREE_TYPE (slen),
7240 TYPE_SIZE_UNIT (chartype)));
7241 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
7243 fold_convert (TREE_TYPE (dlen),
7244 TYPE_SIZE_UNIT (chartype)));
7246 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
7247 dest = fold_convert (pvoid_type_node, dest);
7249 dest = gfc_build_addr_expr (pvoid_type_node, dest);
7251 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
7252 src = fold_convert (pvoid_type_node, src);
7254 src = gfc_build_addr_expr (pvoid_type_node, src);
7256 /* Truncate string if source is too long. */
7257 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
7260 /* Copy and pad with spaces. */
7261 tmp3 = build_call_expr_loc (input_location,
7262 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7264 fold_convert (size_type_node, slen));
7266 /* Wstringop-overflow appears at -O3 even though this warning is not
7267 explicitly available in fortran nor can it be switched off. If the
7268 source length is a constant, its negative appears as a very large
7269 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
7270 the result of the MINUS_EXPR suppresses this spurious warning. */
7271 tmp = fold_build2_loc (input_location, MINUS_EXPR,
7272 TREE_TYPE(dlen), dlen, slen);
7273 if (slength && TREE_CONSTANT (slength))
7274 tmp = gfc_evaluate_now (tmp, block);
7276 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
7277 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
7279 gfc_init_block (&tempblock);
7280 gfc_add_expr_to_block (&tempblock, tmp3);
7281 gfc_add_expr_to_block (&tempblock, tmp4);
7282 tmp3 = gfc_finish_block (&tempblock);
7284 /* The truncated memmove if the slen >= dlen. */
7285 tmp2 = build_call_expr_loc (input_location,
7286 builtin_decl_explicit (BUILT_IN_MEMMOVE),
7288 fold_convert (size_type_node, dlen));
7290 /* The whole copy_string function is there. */
7291 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
7293 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7294 build_empty_stmt (input_location));
7295 gfc_add_expr_to_block (block, tmp);
7299 /* Translate a statement function.
7300 The value of a statement function reference is obtained by evaluating the
7301 expression using the values of the actual arguments for the values of the
7302 corresponding dummy arguments. */
7305 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
7309 gfc_formal_arglist *fargs;
7310 gfc_actual_arglist *args;
7313 gfc_saved_var *saved_vars;
7319 sym = expr->symtree->n.sym;
7320 args = expr->value.function.actual;
7321 gfc_init_se (&lse, NULL);
7322 gfc_init_se (&rse, NULL);
7325 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
7327 saved_vars = XCNEWVEC (gfc_saved_var, n);
7328 temp_vars = XCNEWVEC (tree, n);
7330 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7331 fargs = fargs->next, n++)
7333 /* Each dummy shall be specified, explicitly or implicitly, to be
7335 gcc_assert (fargs->sym->attr.dimension == 0);
7338 if (fsym->ts.type == BT_CHARACTER)
7340 /* Copy string arguments. */
7343 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
7344 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
7346 /* Create a temporary to hold the value. */
7347 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
7348 fsym->ts.u.cl->backend_decl
7349 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
7351 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
7352 temp_vars[n] = gfc_create_var (type, fsym->name);
7354 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
7356 gfc_conv_expr (&rse, args->expr);
7357 gfc_conv_string_parameter (&rse);
7358 gfc_add_block_to_block (&se->pre, &lse.pre);
7359 gfc_add_block_to_block (&se->pre, &rse.pre);
7361 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
7362 rse.string_length, rse.expr, fsym->ts.kind);
7363 gfc_add_block_to_block (&se->pre, &lse.post);
7364 gfc_add_block_to_block (&se->pre, &rse.post);
7368 /* For everything else, just evaluate the expression. */
7370 /* Create a temporary to hold the value. */
7371 type = gfc_typenode_for_spec (&fsym->ts);
7372 temp_vars[n] = gfc_create_var (type, fsym->name);
7374 gfc_conv_expr (&lse, args->expr);
7376 gfc_add_block_to_block (&se->pre, &lse.pre);
7377 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
7378 gfc_add_block_to_block (&se->pre, &lse.post);
7384 /* Use the temporary variables in place of the real ones. */
7385 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7386 fargs = fargs->next, n++)
7387 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
7389 gfc_conv_expr (se, sym->value);
7391 if (sym->ts.type == BT_CHARACTER)
7393 gfc_conv_const_charlen (sym->ts.u.cl);
7395 /* Force the expression to the correct length. */
7396 if (!INTEGER_CST_P (se->string_length)
7397 || tree_int_cst_lt (se->string_length,
7398 sym->ts.u.cl->backend_decl))
7400 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
7401 tmp = gfc_create_var (type, sym->name);
7402 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
7403 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
7404 sym->ts.kind, se->string_length, se->expr,
7408 se->string_length = sym->ts.u.cl->backend_decl;
7411 /* Restore the original variables. */
7412 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
7413 fargs = fargs->next, n++)
7414 gfc_restore_sym (fargs->sym, &saved_vars[n]);
7420 /* Translate a function expression. */
7423 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
7427 if (expr->value.function.isym)
7429 gfc_conv_intrinsic_function (se, expr);
7433 /* expr.value.function.esym is the resolved (specific) function symbol for
7434 most functions. However this isn't set for dummy procedures. */
7435 sym = expr->value.function.esym;
7437 sym = expr->symtree->n.sym;
7439 /* The IEEE_ARITHMETIC functions are caught here. */
7440 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
7441 if (gfc_conv_ieee_arithmetic_function (se, expr))
7444 /* We distinguish statement functions from general functions to improve
7445 runtime performance. */
7446 if (sym->attr.proc == PROC_ST_FUNCTION)
7448 gfc_conv_statement_function (se, expr);
7452 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
7457 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
7460 is_zero_initializer_p (gfc_expr * expr)
7462 if (expr->expr_type != EXPR_CONSTANT)
7465 /* We ignore constants with prescribed memory representations for now. */
7466 if (expr->representation.string)
7469 switch (expr->ts.type)
7472 return mpz_cmp_si (expr->value.integer, 0) == 0;
7475 return mpfr_zero_p (expr->value.real)
7476 && MPFR_SIGN (expr->value.real) >= 0;
7479 return expr->value.logical == 0;
7482 return mpfr_zero_p (mpc_realref (expr->value.complex))
7483 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
7484 && mpfr_zero_p (mpc_imagref (expr->value.complex))
7485 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
7495 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
7500 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
7501 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
7503 gfc_conv_tmp_array_ref (se);
7507 /* Build a static initializer. EXPR is the expression for the initial value.
7508 The other parameters describe the variable of the component being
7509 initialized. EXPR may be null. */
7512 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
7513 bool array, bool pointer, bool procptr)
7517 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
7518 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
7519 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
7520 return build_constructor (type, NULL);
7522 if (!(expr || pointer || procptr))
7525 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7526 (these are the only two iso_c_binding derived types that can be
7527 used as initialization expressions). If so, we need to modify
7528 the 'expr' to be that for a (void *). */
7529 if (expr != NULL && expr->ts.type == BT_DERIVED
7530 && expr->ts.is_iso_c && expr->ts.u.derived)
7532 if (TREE_CODE (type) == ARRAY_TYPE)
7533 return build_constructor (type, NULL);
7534 else if (POINTER_TYPE_P (type))
7535 return build_int_cst (type, 0);
7540 if (array && !procptr)
7543 /* Arrays need special handling. */
7545 ctor = gfc_build_null_descriptor (type);
7546 /* Special case assigning an array to zero. */
7547 else if (is_zero_initializer_p (expr))
7548 ctor = build_constructor (type, NULL);
7550 ctor = gfc_conv_array_initializer (type, expr);
7551 TREE_STATIC (ctor) = 1;
7554 else if (pointer || procptr)
7556 if (ts->type == BT_CLASS && !procptr)
7558 gfc_init_se (&se, NULL);
7559 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7560 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7561 TREE_STATIC (se.expr) = 1;
7564 else if (!expr || expr->expr_type == EXPR_NULL)
7565 return fold_convert (type, null_pointer_node);
7568 gfc_init_se (&se, NULL);
7569 se.want_pointer = 1;
7570 gfc_conv_expr (&se, expr);
7571 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7581 gfc_init_se (&se, NULL);
7582 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7583 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7585 gfc_conv_structure (&se, expr, 1);
7586 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7587 TREE_STATIC (se.expr) = 1;
7592 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7593 TREE_STATIC (ctor) = 1;
7598 gfc_init_se (&se, NULL);
7599 gfc_conv_constant (&se, expr);
7600 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7607 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7613 gfc_array_info *lss_array;
7620 gfc_start_block (&block);
7622 /* Initialize the scalarizer. */
7623 gfc_init_loopinfo (&loop);
7625 gfc_init_se (&lse, NULL);
7626 gfc_init_se (&rse, NULL);
7629 rss = gfc_walk_expr (expr);
7630 if (rss == gfc_ss_terminator)
7631 /* The rhs is scalar. Add a ss for the expression. */
7632 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7634 /* Create a SS for the destination. */
7635 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7637 lss_array = &lss->info->data.array;
7638 lss_array->shape = gfc_get_shape (cm->as->rank);
7639 lss_array->descriptor = dest;
7640 lss_array->data = gfc_conv_array_data (dest);
7641 lss_array->offset = gfc_conv_array_offset (dest);
7642 for (n = 0; n < cm->as->rank; n++)
7644 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7645 lss_array->stride[n] = gfc_index_one_node;
7647 mpz_init (lss_array->shape[n]);
7648 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7649 cm->as->lower[n]->value.integer);
7650 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7653 /* Associate the SS with the loop. */
7654 gfc_add_ss_to_loop (&loop, lss);
7655 gfc_add_ss_to_loop (&loop, rss);
7657 /* Calculate the bounds of the scalarization. */
7658 gfc_conv_ss_startstride (&loop);
7660 /* Setup the scalarizing loops. */
7661 gfc_conv_loop_setup (&loop, &expr->where);
7663 /* Setup the gfc_se structures. */
7664 gfc_copy_loopinfo_to_se (&lse, &loop);
7665 gfc_copy_loopinfo_to_se (&rse, &loop);
7668 gfc_mark_ss_chain_used (rss, 1);
7670 gfc_mark_ss_chain_used (lss, 1);
7672 /* Start the scalarized loop body. */
7673 gfc_start_scalarized_body (&loop, &body);
7675 gfc_conv_tmp_array_ref (&lse);
7676 if (cm->ts.type == BT_CHARACTER)
7677 lse.string_length = cm->ts.u.cl->backend_decl;
7679 gfc_conv_expr (&rse, expr);
7681 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7682 gfc_add_expr_to_block (&body, tmp);
7684 gcc_assert (rse.ss == gfc_ss_terminator);
7686 /* Generate the copying loops. */
7687 gfc_trans_scalarizing_loops (&loop, &body);
7689 /* Wrap the whole thing up. */
7690 gfc_add_block_to_block (&block, &loop.pre);
7691 gfc_add_block_to_block (&block, &loop.post);
7693 gcc_assert (lss_array->shape != NULL);
7694 gfc_free_shape (&lss_array->shape, cm->as->rank);
7695 gfc_cleanup_loop (&loop);
7697 return gfc_finish_block (&block);
7702 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7712 gfc_expr *arg = NULL;
7714 gfc_start_block (&block);
7715 gfc_init_se (&se, NULL);
7717 /* Get the descriptor for the expressions. */
7718 se.want_pointer = 0;
7719 gfc_conv_expr_descriptor (&se, expr);
7720 gfc_add_block_to_block (&block, &se.pre);
7721 gfc_add_modify (&block, dest, se.expr);
7723 /* Deal with arrays of derived types with allocatable components. */
7724 if (gfc_bt_struct (cm->ts.type)
7725 && cm->ts.u.derived->attr.alloc_comp)
7726 // TODO: Fix caf_mode
7727 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7730 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7731 && CLASS_DATA(cm)->attr.allocatable)
7733 if (cm->ts.u.derived->attr.alloc_comp)
7734 // TODO: Fix caf_mode
7735 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7740 tmp = TREE_TYPE (dest);
7741 tmp = gfc_duplicate_allocatable (dest, se.expr,
7742 tmp, expr->rank, NULL_TREE);
7746 tmp = gfc_duplicate_allocatable (dest, se.expr,
7747 TREE_TYPE(cm->backend_decl),
7748 cm->as->rank, NULL_TREE);
7750 gfc_add_expr_to_block (&block, tmp);
7751 gfc_add_block_to_block (&block, &se.post);
7753 if (expr->expr_type != EXPR_VARIABLE)
7754 gfc_conv_descriptor_data_set (&block, se.expr,
7757 /* We need to know if the argument of a conversion function is a
7758 variable, so that the correct lower bound can be used. */
7759 if (expr->expr_type == EXPR_FUNCTION
7760 && expr->value.function.isym
7761 && expr->value.function.isym->conversion
7762 && expr->value.function.actual->expr
7763 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7764 arg = expr->value.function.actual->expr;
7766 /* Obtain the array spec of full array references. */
7768 as = gfc_get_full_arrayspec_from_expr (arg);
7770 as = gfc_get_full_arrayspec_from_expr (expr);
7772 /* Shift the lbound and ubound of temporaries to being unity,
7773 rather than zero, based. Always calculate the offset. */
7774 offset = gfc_conv_descriptor_offset_get (dest);
7775 gfc_add_modify (&block, offset, gfc_index_zero_node);
7776 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7778 for (n = 0; n < expr->rank; n++)
7783 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7784 TODO It looks as if gfc_conv_expr_descriptor should return
7785 the correct bounds and that the following should not be
7786 necessary. This would simplify gfc_conv_intrinsic_bound
7788 if (as && as->lower[n])
7791 gfc_init_se (&lbse, NULL);
7792 gfc_conv_expr (&lbse, as->lower[n]);
7793 gfc_add_block_to_block (&block, &lbse.pre);
7794 lbound = gfc_evaluate_now (lbse.expr, &block);
7798 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7799 lbound = gfc_conv_descriptor_lbound_get (tmp,
7803 lbound = gfc_conv_descriptor_lbound_get (dest,
7806 lbound = gfc_index_one_node;
7808 lbound = fold_convert (gfc_array_index_type, lbound);
7810 /* Shift the bounds and set the offset accordingly. */
7811 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7812 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7813 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7814 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7816 gfc_conv_descriptor_ubound_set (&block, dest,
7817 gfc_rank_cst[n], tmp);
7818 gfc_conv_descriptor_lbound_set (&block, dest,
7819 gfc_rank_cst[n], lbound);
7821 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7822 gfc_conv_descriptor_lbound_get (dest,
7824 gfc_conv_descriptor_stride_get (dest,
7826 gfc_add_modify (&block, tmp2, tmp);
7827 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7829 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7834 /* If a conversion expression has a null data pointer
7835 argument, nullify the allocatable component. */
7839 if (arg->symtree->n.sym->attr.allocatable
7840 || arg->symtree->n.sym->attr.pointer)
7842 non_null_expr = gfc_finish_block (&block);
7843 gfc_start_block (&block);
7844 gfc_conv_descriptor_data_set (&block, dest,
7846 null_expr = gfc_finish_block (&block);
7847 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7848 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7849 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7850 return build3_v (COND_EXPR, tmp,
7851 null_expr, non_null_expr);
7855 return gfc_finish_block (&block);
7859 /* Allocate or reallocate scalar component, as necessary. */
7862 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7872 tree lhs_cl_size = NULL_TREE;
7877 if (!expr2 || expr2->rank)
7880 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7882 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7884 char name[GFC_MAX_SYMBOL_LEN+9];
7885 gfc_component *strlen;
7886 /* Use the rhs string length and the lhs element size. */
7887 gcc_assert (expr2->ts.type == BT_CHARACTER);
7888 if (!expr2->ts.u.cl->backend_decl)
7890 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7891 gcc_assert (expr2->ts.u.cl->backend_decl);
7894 size = expr2->ts.u.cl->backend_decl;
7896 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7898 sprintf (name, "_%s_length", cm->name);
7899 strlen = gfc_find_component (sym, name, true, true, NULL);
7900 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7901 gfc_charlen_type_node,
7902 TREE_OPERAND (comp, 0),
7903 strlen->backend_decl, NULL_TREE);
7905 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7906 tmp = TYPE_SIZE_UNIT (tmp);
7907 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7908 TREE_TYPE (tmp), tmp,
7909 fold_convert (TREE_TYPE (tmp), size));
7911 else if (cm->ts.type == BT_CLASS)
7913 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7914 if (expr2->ts.type == BT_DERIVED)
7916 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7917 size = TYPE_SIZE_UNIT (tmp);
7923 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7924 gfc_add_vptr_component (e2vtab);
7925 gfc_add_size_component (e2vtab);
7926 gfc_init_se (&se, NULL);
7927 gfc_conv_expr (&se, e2vtab);
7928 gfc_add_block_to_block (block, &se.pre);
7929 size = fold_convert (size_type_node, se.expr);
7930 gfc_free_expr (e2vtab);
7932 size_in_bytes = size;
7936 /* Otherwise use the length in bytes of the rhs. */
7937 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7938 size_in_bytes = size;
7941 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7942 size_in_bytes, size_one_node);
7944 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7946 tmp = build_call_expr_loc (input_location,
7947 builtin_decl_explicit (BUILT_IN_CALLOC),
7948 2, build_one_cst (size_type_node),
7950 tmp = fold_convert (TREE_TYPE (comp), tmp);
7951 gfc_add_modify (block, comp, tmp);
7955 tmp = build_call_expr_loc (input_location,
7956 builtin_decl_explicit (BUILT_IN_MALLOC),
7958 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7959 ptr = gfc_class_data_get (comp);
7962 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7963 gfc_add_modify (block, ptr, tmp);
7966 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7967 /* Update the lhs character length. */
7968 gfc_add_modify (block, lhs_cl_size,
7969 fold_convert (TREE_TYPE (lhs_cl_size), size));
7973 /* Assign a single component of a derived type constructor. */
7976 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7977 gfc_symbol *sym, bool init)
7985 gfc_start_block (&block);
7987 if (cm->attr.pointer || cm->attr.proc_pointer)
7989 /* Only care about pointers here, not about allocatables. */
7990 gfc_init_se (&se, NULL);
7991 /* Pointer component. */
7992 if ((cm->attr.dimension || cm->attr.codimension)
7993 && !cm->attr.proc_pointer)
7995 /* Array pointer. */
7996 if (expr->expr_type == EXPR_NULL)
7997 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8000 se.direct_byref = 1;
8002 gfc_conv_expr_descriptor (&se, expr);
8003 gfc_add_block_to_block (&block, &se.pre);
8004 gfc_add_block_to_block (&block, &se.post);
8009 /* Scalar pointers. */
8010 se.want_pointer = 1;
8011 gfc_conv_expr (&se, expr);
8012 gfc_add_block_to_block (&block, &se.pre);
8014 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8015 && expr->symtree->n.sym->attr.dummy)
8016 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8018 gfc_add_modify (&block, dest,
8019 fold_convert (TREE_TYPE (dest), se.expr));
8020 gfc_add_block_to_block (&block, &se.post);
8023 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
8025 /* NULL initialization for CLASS components. */
8026 tmp = gfc_trans_structure_assign (dest,
8027 gfc_class_initializer (&cm->ts, expr),
8029 gfc_add_expr_to_block (&block, tmp);
8031 else if ((cm->attr.dimension || cm->attr.codimension)
8032 && !cm->attr.proc_pointer)
8034 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8035 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
8036 else if (cm->attr.allocatable || cm->attr.pdt_array)
8038 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
8039 gfc_add_expr_to_block (&block, tmp);
8043 tmp = gfc_trans_subarray_assign (dest, cm, expr);
8044 gfc_add_expr_to_block (&block, tmp);
8047 else if (cm->ts.type == BT_CLASS
8048 && CLASS_DATA (cm)->attr.dimension
8049 && CLASS_DATA (cm)->attr.allocatable
8050 && expr->ts.type == BT_DERIVED)
8052 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8053 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8054 tmp = gfc_class_vptr_get (dest);
8055 gfc_add_modify (&block, tmp,
8056 fold_convert (TREE_TYPE (tmp), vtab));
8057 tmp = gfc_class_data_get (dest);
8058 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
8059 gfc_add_expr_to_block (&block, tmp);
8061 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
8063 /* NULL initialization for allocatable components. */
8064 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
8065 null_pointer_node));
8067 else if (init && (cm->attr.allocatable
8068 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
8069 && expr->ts.type != BT_CLASS)))
8071 /* Take care about non-array allocatable components here. The alloc_*
8072 routine below is motivated by the alloc_scalar_allocatable_for_
8073 assignment() routine, but with the realloc portions removed and
8075 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
8080 /* The remainder of these instructions follow the if (cm->attr.pointer)
8081 if (!cm->attr.dimension) part above. */
8082 gfc_init_se (&se, NULL);
8083 gfc_conv_expr (&se, expr);
8084 gfc_add_block_to_block (&block, &se.pre);
8086 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
8087 && expr->symtree->n.sym->attr.dummy)
8088 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
8090 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
8092 tmp = gfc_class_data_get (dest);
8093 tmp = build_fold_indirect_ref_loc (input_location, tmp);
8094 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
8095 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
8096 gfc_add_modify (&block, gfc_class_vptr_get (dest),
8097 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
8100 tmp = build_fold_indirect_ref_loc (input_location, dest);
8102 /* For deferred strings insert a memcpy. */
8103 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
8106 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
8107 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
8109 : expr->ts.u.cl->backend_decl);
8110 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
8111 gfc_add_expr_to_block (&block, tmp);
8114 gfc_add_modify (&block, tmp,
8115 fold_convert (TREE_TYPE (tmp), se.expr));
8116 gfc_add_block_to_block (&block, &se.post);
8118 else if (expr->ts.type == BT_UNION)
8121 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
8122 /* We mark that the entire union should be initialized with a contrived
8123 EXPR_NULL expression at the beginning. */
8124 if (c != NULL && c->n.component == NULL
8125 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
8127 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8128 dest, build_constructor (TREE_TYPE (dest), NULL));
8129 gfc_add_expr_to_block (&block, tmp);
8130 c = gfc_constructor_next (c);
8132 /* The following constructor expression, if any, represents a specific
8133 map intializer, as given by the user. */
8134 if (c != NULL && c->expr != NULL)
8136 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8137 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8138 gfc_add_expr_to_block (&block, tmp);
8141 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
8143 if (expr->expr_type != EXPR_STRUCTURE)
8145 tree dealloc = NULL_TREE;
8146 gfc_init_se (&se, NULL);
8147 gfc_conv_expr (&se, expr);
8148 gfc_add_block_to_block (&block, &se.pre);
8149 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
8150 expression in a temporary variable and deallocate the allocatable
8151 components. Then we can the copy the expression to the result. */
8152 if (cm->ts.u.derived->attr.alloc_comp
8153 && expr->expr_type != EXPR_VARIABLE)
8155 se.expr = gfc_evaluate_now (se.expr, &block);
8156 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
8159 gfc_add_modify (&block, dest,
8160 fold_convert (TREE_TYPE (dest), se.expr));
8161 if (cm->ts.u.derived->attr.alloc_comp
8162 && expr->expr_type != EXPR_NULL)
8164 // TODO: Fix caf_mode
8165 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
8166 dest, expr->rank, 0);
8167 gfc_add_expr_to_block (&block, tmp);
8168 if (dealloc != NULL_TREE)
8169 gfc_add_expr_to_block (&block, dealloc);
8171 gfc_add_block_to_block (&block, &se.post);
8175 /* Nested constructors. */
8176 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
8177 gfc_add_expr_to_block (&block, tmp);
8180 else if (gfc_deferred_strlen (cm, &tmp))
8184 gcc_assert (strlen);
8185 strlen = fold_build3_loc (input_location, COMPONENT_REF,
8187 TREE_OPERAND (dest, 0),
8190 if (expr->expr_type == EXPR_NULL)
8192 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
8193 gfc_add_modify (&block, dest, tmp);
8194 tmp = build_int_cst (TREE_TYPE (strlen), 0);
8195 gfc_add_modify (&block, strlen, tmp);
8200 gfc_init_se (&se, NULL);
8201 gfc_conv_expr (&se, expr);
8202 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
8203 tmp = build_call_expr_loc (input_location,
8204 builtin_decl_explicit (BUILT_IN_MALLOC),
8206 gfc_add_modify (&block, dest,
8207 fold_convert (TREE_TYPE (dest), tmp));
8208 gfc_add_modify (&block, strlen,
8209 fold_convert (TREE_TYPE (strlen), se.string_length));
8210 tmp = gfc_build_memcpy_call (dest, se.expr, size);
8211 gfc_add_expr_to_block (&block, tmp);
8214 else if (!cm->attr.artificial)
8216 /* Scalar component (excluding deferred parameters). */
8217 gfc_init_se (&se, NULL);
8218 gfc_init_se (&lse, NULL);
8220 gfc_conv_expr (&se, expr);
8221 if (cm->ts.type == BT_CHARACTER)
8222 lse.string_length = cm->ts.u.cl->backend_decl;
8224 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
8225 gfc_add_expr_to_block (&block, tmp);
8227 return gfc_finish_block (&block);
8230 /* Assign a derived type constructor to a variable. */
8233 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
8242 gfc_start_block (&block);
8243 cm = expr->ts.u.derived->components;
8245 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
8246 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
8247 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
8251 gfc_init_se (&se, NULL);
8252 gfc_init_se (&lse, NULL);
8253 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
8255 gfc_add_modify (&block, lse.expr,
8256 fold_convert (TREE_TYPE (lse.expr), se.expr));
8258 return gfc_finish_block (&block);
8262 gfc_init_se (&se, NULL);
8264 for (c = gfc_constructor_first (expr->value.constructor);
8265 c; c = gfc_constructor_next (c), cm = cm->next)
8267 /* Skip absent members in default initializers. */
8268 if (!c->expr && !cm->attr.allocatable)
8271 /* Register the component with the caf-lib before it is initialized.
8272 Register only allocatable components, that are not coarray'ed
8273 components (%comp[*]). Only register when the constructor is not the
8275 if (coarray && !cm->attr.codimension
8276 && (cm->attr.allocatable || cm->attr.pointer)
8277 && (!c->expr || c->expr->expr_type == EXPR_NULL))
8279 tree token, desc, size;
8280 bool is_array = cm->ts.type == BT_CLASS
8281 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
8283 field = cm->backend_decl;
8284 field = fold_build3_loc (input_location, COMPONENT_REF,
8285 TREE_TYPE (field), dest, field, NULL_TREE);
8286 if (cm->ts.type == BT_CLASS)
8287 field = gfc_class_data_get (field);
8289 token = is_array ? gfc_conv_descriptor_token (field)
8290 : fold_build3_loc (input_location, COMPONENT_REF,
8291 TREE_TYPE (cm->caf_token), dest,
8292 cm->caf_token, NULL_TREE);
8296 /* The _caf_register routine looks at the rank of the array
8297 descriptor to decide whether the data registered is an array
8299 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
8301 /* When the rank is not known just set a positive rank, which
8302 suffices to recognize the data as array. */
8305 size = build_zero_cst (size_type_node);
8307 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
8308 build_int_cst (signed_char_type_node, rank));
8312 desc = gfc_conv_scalar_to_descriptor (&se, field,
8313 cm->ts.type == BT_CLASS
8314 ? CLASS_DATA (cm)->attr
8316 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
8318 gfc_add_block_to_block (&block, &se.pre);
8319 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
8320 7, size, build_int_cst (
8322 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
8323 gfc_build_addr_expr (pvoid_type_node,
8325 gfc_build_addr_expr (NULL_TREE, desc),
8326 null_pointer_node, null_pointer_node,
8328 gfc_add_expr_to_block (&block, tmp);
8330 field = cm->backend_decl;
8331 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
8332 dest, field, NULL_TREE);
8335 gfc_expr *e = gfc_get_null_expr (NULL);
8336 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
8341 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
8342 expr->ts.u.derived, init);
8343 gfc_add_expr_to_block (&block, tmp);
8345 return gfc_finish_block (&block);
8349 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
8350 gfc_component *un, gfc_expr *init)
8352 gfc_constructor *ctor;
8354 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
8357 ctor = gfc_constructor_first (init->value.constructor);
8359 if (ctor == NULL || ctor->expr == NULL)
8362 gcc_assert (init->expr_type == EXPR_STRUCTURE);
8364 /* If we have an 'initialize all' constructor, do it first. */
8365 if (ctor->expr->expr_type == EXPR_NULL)
8367 tree union_type = TREE_TYPE (un->backend_decl);
8368 tree val = build_constructor (union_type, NULL);
8369 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8370 ctor = gfc_constructor_next (ctor);
8373 /* Add the map initializer on top. */
8374 if (ctor != NULL && ctor->expr != NULL)
8376 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
8377 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
8378 TREE_TYPE (un->backend_decl),
8379 un->attr.dimension, un->attr.pointer,
8380 un->attr.proc_pointer);
8381 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
8385 /* Build an expression for a constructor. If init is nonzero then
8386 this is part of a static variable initializer. */
8389 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
8396 vec<constructor_elt, va_gc> *v = NULL;
8398 gcc_assert (se->ss == NULL);
8399 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
8400 type = gfc_typenode_for_spec (&expr->ts);
8404 /* Create a temporary variable and fill it in. */
8405 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
8406 /* The symtree in expr is NULL, if the code to generate is for
8407 initializing the static members only. */
8408 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
8410 gfc_add_expr_to_block (&se->pre, tmp);
8414 cm = expr->ts.u.derived->components;
8416 for (c = gfc_constructor_first (expr->value.constructor);
8417 c; c = gfc_constructor_next (c), cm = cm->next)
8419 /* Skip absent members in default initializers and allocatable
8420 components. Although the latter have a default initializer
8421 of EXPR_NULL,... by default, the static nullify is not needed
8422 since this is done every time we come into scope. */
8423 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
8426 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
8427 && strcmp (cm->name, "_extends") == 0
8428 && cm->initializer->symtree)
8432 vtabs = cm->initializer->symtree->n.sym;
8433 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
8434 vtab = unshare_expr_without_location (vtab);
8435 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
8437 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
8439 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
8440 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8441 fold_convert (TREE_TYPE (cm->backend_decl),
8444 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
8445 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
8446 fold_convert (TREE_TYPE (cm->backend_decl),
8447 integer_zero_node));
8448 else if (cm->ts.type == BT_UNION)
8449 gfc_conv_union_initializer (v, cm, c->expr);
8452 val = gfc_conv_initializer (c->expr, &cm->ts,
8453 TREE_TYPE (cm->backend_decl),
8454 cm->attr.dimension, cm->attr.pointer,
8455 cm->attr.proc_pointer);
8456 val = unshare_expr_without_location (val);
8458 /* Append it to the constructor list. */
8459 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
8463 se->expr = build_constructor (type, v);
8465 TREE_CONSTANT (se->expr) = 1;
8469 /* Translate a substring expression. */
8472 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
8478 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
8480 se->expr = gfc_build_wide_string_const (expr->ts.kind,
8481 expr->value.character.length,
8482 expr->value.character.string);
8484 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
8485 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
8488 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
8492 /* Entry point for expression translation. Evaluates a scalar quantity.
8493 EXPR is the expression to be translated, and SE is the state structure if
8494 called from within the scalarized. */
8497 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
8502 if (ss && ss->info->expr == expr
8503 && (ss->info->type == GFC_SS_SCALAR
8504 || ss->info->type == GFC_SS_REFERENCE))
8506 gfc_ss_info *ss_info;
8509 /* Substitute a scalar expression evaluated outside the scalarization
8511 se->expr = ss_info->data.scalar.value;
8512 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
8513 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
8515 se->string_length = ss_info->string_length;
8516 gfc_advance_se_ss_chain (se);
8520 /* We need to convert the expressions for the iso_c_binding derived types.
8521 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8522 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8523 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8524 updated to be an integer with a kind equal to the size of a (void *). */
8525 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8526 && expr->ts.u.derived->attr.is_bind_c)
8528 if (expr->expr_type == EXPR_VARIABLE
8529 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8530 || expr->symtree->n.sym->intmod_sym_id
8531 == ISOCBINDING_NULL_FUNPTR))
8533 /* Set expr_type to EXPR_NULL, which will result in
8534 null_pointer_node being used below. */
8535 expr->expr_type = EXPR_NULL;
8539 /* Update the type/kind of the expression to be what the new
8540 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8541 expr->ts.type = BT_INTEGER;
8542 expr->ts.f90_type = BT_VOID;
8543 expr->ts.kind = gfc_index_integer_kind;
8547 gfc_fix_class_refs (expr);
8549 switch (expr->expr_type)
8552 gfc_conv_expr_op (se, expr);
8556 gfc_conv_function_expr (se, expr);
8560 gfc_conv_constant (se, expr);
8564 gfc_conv_variable (se, expr);
8568 se->expr = null_pointer_node;
8571 case EXPR_SUBSTRING:
8572 gfc_conv_substring_expr (se, expr);
8575 case EXPR_STRUCTURE:
8576 gfc_conv_structure (se, expr, 0);
8580 gfc_conv_array_constructor_expr (se, expr);
8589 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8590 of an assignment. */
8592 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8594 gfc_conv_expr (se, expr);
8595 /* All numeric lvalues should have empty post chains. If not we need to
8596 figure out a way of rewriting an lvalue so that it has no post chain. */
8597 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8600 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8601 numeric expressions. Used for scalar values where inserting cleanup code
8604 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8608 gcc_assert (expr->ts.type != BT_CHARACTER);
8609 gfc_conv_expr (se, expr);
8612 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8613 gfc_add_modify (&se->pre, val, se->expr);
8615 gfc_add_block_to_block (&se->pre, &se->post);
8619 /* Helper to translate an expression and convert it to a particular type. */
8621 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8623 gfc_conv_expr_val (se, expr);
8624 se->expr = convert (type, se->expr);
8628 /* Converts an expression so that it can be passed by reference. Scalar
8632 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8638 if (ss && ss->info->expr == expr
8639 && ss->info->type == GFC_SS_REFERENCE)
8641 /* Returns a reference to the scalar evaluated outside the loop
8643 gfc_conv_expr (se, expr);
8645 if (expr->ts.type == BT_CHARACTER
8646 && expr->expr_type != EXPR_FUNCTION)
8647 gfc_conv_string_parameter (se);
8649 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8654 if (expr->ts.type == BT_CHARACTER)
8656 gfc_conv_expr (se, expr);
8657 gfc_conv_string_parameter (se);
8661 if (expr->expr_type == EXPR_VARIABLE)
8663 se->want_pointer = 1;
8664 gfc_conv_expr (se, expr);
8667 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8668 gfc_add_modify (&se->pre, var, se->expr);
8669 gfc_add_block_to_block (&se->pre, &se->post);
8672 else if (add_clobber && expr->ref == NULL)
8676 /* FIXME: This fails if var is passed by reference, see PR
8678 var = expr->symtree->n.sym->backend_decl;
8679 clobber = build_clobber (TREE_TYPE (var));
8680 gfc_add_modify (&se->pre, var, clobber);
8685 if (expr->expr_type == EXPR_FUNCTION
8686 && ((expr->value.function.esym
8687 && expr->value.function.esym->result->attr.pointer
8688 && !expr->value.function.esym->result->attr.dimension)
8689 || (!expr->value.function.esym && !expr->ref
8690 && expr->symtree->n.sym->attr.pointer
8691 && !expr->symtree->n.sym->attr.dimension)))
8693 se->want_pointer = 1;
8694 gfc_conv_expr (se, expr);
8695 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8696 gfc_add_modify (&se->pre, var, se->expr);
8701 gfc_conv_expr (se, expr);
8703 /* Create a temporary var to hold the value. */
8704 if (TREE_CONSTANT (se->expr))
8706 tree tmp = se->expr;
8707 STRIP_TYPE_NOPS (tmp);
8708 var = build_decl (input_location,
8709 CONST_DECL, NULL, TREE_TYPE (tmp));
8710 DECL_INITIAL (var) = tmp;
8711 TREE_STATIC (var) = 1;
8716 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8717 gfc_add_modify (&se->pre, var, se->expr);
8720 if (!expr->must_finalize)
8721 gfc_add_block_to_block (&se->pre, &se->post);
8723 /* Take the address of that value. */
8724 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8728 /* Get the _len component for an unlimited polymorphic expression. */
8731 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8734 gfc_ref *ref = expr->ref;
8736 gfc_init_se (&se, NULL);
8737 while (ref && ref->next)
8739 gfc_add_len_component (expr);
8740 gfc_conv_expr (&se, expr);
8741 gfc_add_block_to_block (block, &se.pre);
8742 gcc_assert (se.post.head == NULL_TREE);
8745 gfc_free_ref_list (ref->next);
8750 gfc_free_ref_list (expr->ref);
8757 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8758 statement-list outside of the scalarizer-loop. When code is generated, that
8759 depends on the scalarized expression, it is added to RSE.PRE.
8760 Returns le's _vptr tree and when set the len expressions in to_lenp and
8761 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8765 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8766 gfc_expr * re, gfc_se *rse,
8767 tree * to_lenp, tree * from_lenp)
8770 gfc_expr * vptr_expr;
8771 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8772 bool set_vptr = false, temp_rhs = false;
8773 stmtblock_t *pre = block;
8775 /* Create a temporary for complicated expressions. */
8776 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8777 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8779 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8781 gfc_add_modify (&rse->pre, tmp, rse->expr);
8786 /* Get the _vptr for the left-hand side expression. */
8787 gfc_init_se (&se, NULL);
8788 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8789 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8791 /* Care about _len for unlimited polymorphic entities. */
8792 if (UNLIMITED_POLY (vptr_expr)
8793 || (vptr_expr->ts.type == BT_DERIVED
8794 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8795 to_len = trans_get_upoly_len (block, vptr_expr);
8796 gfc_add_vptr_component (vptr_expr);
8800 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8801 se.want_pointer = 1;
8802 gfc_conv_expr (&se, vptr_expr);
8803 gfc_free_expr (vptr_expr);
8804 gfc_add_block_to_block (block, &se.pre);
8805 gcc_assert (se.post.head == NULL_TREE);
8807 STRIP_NOPS (lhs_vptr);
8809 /* Set the _vptr only when the left-hand side of the assignment is a
8813 /* Get the vptr from the rhs expression only, when it is variable.
8814 Functions are expected to be assigned to a temporary beforehand. */
8815 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8816 ? gfc_find_and_cut_at_last_class_ref (re)
8818 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8820 if (to_len != NULL_TREE)
8822 /* Get the _len information from the rhs. */
8823 if (UNLIMITED_POLY (vptr_expr)
8824 || (vptr_expr->ts.type == BT_DERIVED
8825 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8826 from_len = trans_get_upoly_len (block, vptr_expr);
8828 gfc_add_vptr_component (vptr_expr);
8832 if (re->expr_type == EXPR_VARIABLE
8833 && DECL_P (re->symtree->n.sym->backend_decl)
8834 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8835 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8836 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8837 re->symtree->n.sym->backend_decl))))
8840 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8841 re->symtree->n.sym->backend_decl));
8843 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8844 re->symtree->n.sym->backend_decl));
8846 else if (temp_rhs && re->ts.type == BT_CLASS)
8849 se.expr = gfc_class_vptr_get (rse->expr);
8850 if (UNLIMITED_POLY (re))
8851 from_len = gfc_class_len_get (rse->expr);
8853 else if (re->expr_type != EXPR_NULL)
8854 /* Only when rhs is non-NULL use its declared type for vptr
8856 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8858 /* When the rhs is NULL use the vtab of lhs' declared type. */
8859 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8864 gfc_init_se (&se, NULL);
8865 se.want_pointer = 1;
8866 gfc_conv_expr (&se, vptr_expr);
8867 gfc_free_expr (vptr_expr);
8868 gfc_add_block_to_block (block, &se.pre);
8869 gcc_assert (se.post.head == NULL_TREE);
8871 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8874 if (to_len != NULL_TREE)
8876 /* The _len component needs to be set. Figure how to get the
8877 value of the right-hand side. */
8878 if (from_len == NULL_TREE)
8880 if (rse->string_length != NULL_TREE)
8881 from_len = rse->string_length;
8882 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8884 from_len = gfc_get_expr_charlen (re);
8885 gfc_init_se (&se, NULL);
8886 gfc_conv_expr (&se, re->ts.u.cl->length);
8887 gfc_add_block_to_block (block, &se.pre);
8888 gcc_assert (se.post.head == NULL_TREE);
8889 from_len = gfc_evaluate_now (se.expr, block);
8892 from_len = build_zero_cst (gfc_charlen_type_node);
8894 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8899 /* Return the _len trees only, when requested. */
8903 *from_lenp = from_len;
8908 /* Assign tokens for pointer components. */
8911 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8914 symbol_attribute lhs_attr, rhs_attr;
8915 tree tmp, lhs_tok, rhs_tok;
8916 /* Flag to indicated component refs on the rhs. */
8919 lhs_attr = gfc_caf_attr (expr1);
8920 if (expr2->expr_type != EXPR_NULL)
8922 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8923 if (lhs_attr.codimension && rhs_attr.codimension)
8925 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8926 lhs_tok = build_fold_indirect_ref (lhs_tok);
8929 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8933 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8934 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8937 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8939 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8940 gfc_prepend_expr_to_block (&lse->post, tmp);
8943 else if (lhs_attr.codimension)
8945 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8946 lhs_tok = build_fold_indirect_ref (lhs_tok);
8947 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8948 lhs_tok, null_pointer_node);
8949 gfc_prepend_expr_to_block (&lse->post, tmp);
8953 /* Indentify class valued proc_pointer assignments. */
8956 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8961 while (ref && ref->next)
8964 return ref && ref->type == REF_COMPONENT
8965 && ref->u.c.component->attr.proc_pointer
8966 && expr2->expr_type == EXPR_VARIABLE
8967 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8971 /* Do everything that is needed for a CLASS function expr2. */
8974 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8975 gfc_expr *expr1, gfc_expr *expr2)
8977 tree expr1_vptr = NULL_TREE;
8980 gfc_conv_function_expr (rse, expr2);
8981 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8983 if (expr1->ts.type != BT_CLASS)
8984 rse->expr = gfc_class_data_get (rse->expr);
8987 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8990 gfc_add_block_to_block (block, &rse->pre);
8991 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8992 gfc_add_modify (&lse->pre, tmp, rse->expr);
8994 gfc_add_modify (&lse->pre, expr1_vptr,
8995 fold_convert (TREE_TYPE (expr1_vptr),
8996 gfc_class_vptr_get (tmp)));
8997 rse->expr = gfc_class_data_get (tmp);
9005 gfc_trans_pointer_assign (gfc_code * code)
9007 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
9011 /* Generate code for a pointer assignment. */
9014 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
9021 tree expr1_vptr = NULL_TREE;
9022 bool scalar, non_proc_pointer_assign;
9025 gfc_start_block (&block);
9027 gfc_init_se (&lse, NULL);
9029 /* Usually testing whether this is not a proc pointer assignment. */
9030 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
9032 /* Check whether the expression is a scalar or not; we cannot use
9033 expr1->rank as it can be nonzero for proc pointers. */
9034 ss = gfc_walk_expr (expr1);
9035 scalar = ss == gfc_ss_terminator;
9037 gfc_free_ss_chain (ss);
9039 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
9040 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
9042 gfc_add_data_component (expr2);
9043 /* The following is required as gfc_add_data_component doesn't
9044 update ts.type if there is a tailing REF_ARRAY. */
9045 expr2->ts.type = BT_DERIVED;
9050 /* Scalar pointers. */
9051 lse.want_pointer = 1;
9052 gfc_conv_expr (&lse, expr1);
9053 gfc_init_se (&rse, NULL);
9054 rse.want_pointer = 1;
9055 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9056 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
9058 gfc_conv_expr (&rse, expr2);
9060 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
9062 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
9064 lse.expr = gfc_class_data_get (lse.expr);
9067 if (expr1->symtree->n.sym->attr.proc_pointer
9068 && expr1->symtree->n.sym->attr.dummy)
9069 lse.expr = build_fold_indirect_ref_loc (input_location,
9072 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
9073 && expr2->symtree->n.sym->attr.dummy)
9074 rse.expr = build_fold_indirect_ref_loc (input_location,
9077 gfc_add_block_to_block (&block, &lse.pre);
9078 gfc_add_block_to_block (&block, &rse.pre);
9080 /* Check character lengths if character expression. The test is only
9081 really added if -fbounds-check is enabled. Exclude deferred
9082 character length lefthand sides. */
9083 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
9084 && !expr1->ts.deferred
9085 && !expr1->symtree->n.sym->attr.proc_pointer
9086 && !gfc_is_proc_ptr_comp (expr1))
9088 gcc_assert (expr2->ts.type == BT_CHARACTER);
9089 gcc_assert (lse.string_length && rse.string_length);
9090 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9091 lse.string_length, rse.string_length,
9095 /* The assignment to an deferred character length sets the string
9096 length to that of the rhs. */
9097 if (expr1->ts.deferred)
9099 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
9100 gfc_add_modify (&block, lse.string_length,
9101 fold_convert (TREE_TYPE (lse.string_length),
9102 rse.string_length));
9103 else if (lse.string_length != NULL)
9104 gfc_add_modify (&block, lse.string_length,
9105 build_zero_cst (TREE_TYPE (lse.string_length)));
9108 gfc_add_modify (&block, lse.expr,
9109 fold_convert (TREE_TYPE (lse.expr), rse.expr));
9111 /* Also set the tokens for pointer components in derived typed
9113 if (flag_coarray == GFC_FCOARRAY_LIB)
9114 trans_caf_token_assign (&lse, &rse, expr1, expr2);
9116 gfc_add_block_to_block (&block, &rse.post);
9117 gfc_add_block_to_block (&block, &lse.post);
9124 tree strlen_rhs = NULL_TREE;
9126 /* Array pointer. Find the last reference on the LHS and if it is an
9127 array section ref, we're dealing with bounds remapping. In this case,
9128 set it to AR_FULL so that gfc_conv_expr_descriptor does
9129 not see it and process the bounds remapping afterwards explicitly. */
9130 for (remap = expr1->ref; remap; remap = remap->next)
9131 if (!remap->next && remap->type == REF_ARRAY
9132 && remap->u.ar.type == AR_SECTION)
9134 rank_remap = (remap && remap->u.ar.end[0]);
9136 gfc_init_se (&lse, NULL);
9138 lse.descriptor_only = 1;
9139 gfc_conv_expr_descriptor (&lse, expr1);
9140 strlen_lhs = lse.string_length;
9143 if (expr2->expr_type == EXPR_NULL)
9145 /* Just set the data pointer to null. */
9146 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
9148 else if (rank_remap)
9150 /* If we are rank-remapping, just get the RHS's descriptor and
9151 process this later on. */
9152 gfc_init_se (&rse, NULL);
9153 rse.direct_byref = 1;
9154 rse.byref_noassign = 1;
9156 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9157 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
9159 else if (expr2->expr_type == EXPR_FUNCTION)
9161 tree bound[GFC_MAX_DIMENSIONS];
9164 for (i = 0; i < expr2->rank; i++)
9165 bound[i] = NULL_TREE;
9166 tmp = gfc_typenode_for_spec (&expr2->ts);
9167 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
9169 GFC_ARRAY_POINTER_CONT, false);
9170 tmp = gfc_create_var (tmp, "ptrtemp");
9171 rse.descriptor_only = 0;
9173 rse.direct_byref = 1;
9174 gfc_conv_expr_descriptor (&rse, expr2);
9175 strlen_rhs = rse.string_length;
9180 gfc_conv_expr_descriptor (&rse, expr2);
9181 strlen_rhs = rse.string_length;
9182 if (expr1->ts.type == BT_CLASS)
9183 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9188 else if (expr2->expr_type == EXPR_VARIABLE)
9190 /* Assign directly to the LHS's descriptor. */
9191 lse.descriptor_only = 0;
9192 lse.direct_byref = 1;
9193 gfc_conv_expr_descriptor (&lse, expr2);
9194 strlen_rhs = lse.string_length;
9196 if (expr1->ts.type == BT_CLASS)
9198 rse.expr = NULL_TREE;
9199 rse.string_length = NULL_TREE;
9200 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
9206 /* If the target is not a whole array, use the target array
9207 reference for remap. */
9208 for (remap = expr2->ref; remap; remap = remap->next)
9209 if (remap->type == REF_ARRAY
9210 && remap->u.ar.type == AR_FULL
9215 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
9217 gfc_init_se (&rse, NULL);
9218 rse.want_pointer = 1;
9219 gfc_conv_function_expr (&rse, expr2);
9220 if (expr1->ts.type != BT_CLASS)
9222 rse.expr = gfc_class_data_get (rse.expr);
9223 gfc_add_modify (&lse.pre, desc, rse.expr);
9224 /* Set the lhs span. */
9225 tmp = TREE_TYPE (rse.expr);
9226 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9227 tmp = fold_convert (gfc_array_index_type, tmp);
9228 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
9232 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
9235 gfc_add_block_to_block (&block, &rse.pre);
9236 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
9237 gfc_add_modify (&lse.pre, tmp, rse.expr);
9239 gfc_add_modify (&lse.pre, expr1_vptr,
9240 fold_convert (TREE_TYPE (expr1_vptr),
9241 gfc_class_vptr_get (tmp)));
9242 rse.expr = gfc_class_data_get (tmp);
9243 gfc_add_modify (&lse.pre, desc, rse.expr);
9248 /* Assign to a temporary descriptor and then copy that
9249 temporary to the pointer. */
9250 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
9251 lse.descriptor_only = 0;
9253 lse.direct_byref = 1;
9254 gfc_conv_expr_descriptor (&lse, expr2);
9255 strlen_rhs = lse.string_length;
9256 gfc_add_modify (&lse.pre, desc, tmp);
9259 gfc_add_block_to_block (&block, &lse.pre);
9261 gfc_add_block_to_block (&block, &rse.pre);
9263 /* If we do bounds remapping, update LHS descriptor accordingly. */
9267 gcc_assert (remap->u.ar.dimen == expr1->rank);
9271 /* Do rank remapping. We already have the RHS's descriptor
9272 converted in rse and now have to build the correct LHS
9273 descriptor for it. */
9275 tree dtype, data, span;
9277 tree lbound, ubound;
9280 dtype = gfc_conv_descriptor_dtype (desc);
9281 tmp = gfc_get_dtype (TREE_TYPE (desc));
9282 gfc_add_modify (&block, dtype, tmp);
9284 /* Copy data pointer. */
9285 data = gfc_conv_descriptor_data_get (rse.expr);
9286 gfc_conv_descriptor_data_set (&block, desc, data);
9288 /* Copy the span. */
9289 if (TREE_CODE (rse.expr) == VAR_DECL
9290 && GFC_DECL_PTR_ARRAY_P (rse.expr))
9291 span = gfc_conv_descriptor_span_get (rse.expr);
9294 tmp = TREE_TYPE (rse.expr);
9295 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
9296 span = fold_convert (gfc_array_index_type, tmp);
9298 gfc_conv_descriptor_span_set (&block, desc, span);
9300 /* Copy offset but adjust it such that it would correspond
9301 to a lbound of zero. */
9302 offs = gfc_conv_descriptor_offset_get (rse.expr);
9303 for (dim = 0; dim < expr2->rank; ++dim)
9305 stride = gfc_conv_descriptor_stride_get (rse.expr,
9307 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
9309 tmp = fold_build2_loc (input_location, MULT_EXPR,
9310 gfc_array_index_type, stride, lbound);
9311 offs = fold_build2_loc (input_location, PLUS_EXPR,
9312 gfc_array_index_type, offs, tmp);
9314 gfc_conv_descriptor_offset_set (&block, desc, offs);
9316 /* Set the bounds as declared for the LHS and calculate strides as
9317 well as another offset update accordingly. */
9318 stride = gfc_conv_descriptor_stride_get (rse.expr,
9320 for (dim = 0; dim < expr1->rank; ++dim)
9325 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
9327 /* Convert declared bounds. */
9328 gfc_init_se (&lower_se, NULL);
9329 gfc_init_se (&upper_se, NULL);
9330 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
9331 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
9333 gfc_add_block_to_block (&block, &lower_se.pre);
9334 gfc_add_block_to_block (&block, &upper_se.pre);
9336 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
9337 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
9339 lbound = gfc_evaluate_now (lbound, &block);
9340 ubound = gfc_evaluate_now (ubound, &block);
9342 gfc_add_block_to_block (&block, &lower_se.post);
9343 gfc_add_block_to_block (&block, &upper_se.post);
9345 /* Set bounds in descriptor. */
9346 gfc_conv_descriptor_lbound_set (&block, desc,
9347 gfc_rank_cst[dim], lbound);
9348 gfc_conv_descriptor_ubound_set (&block, desc,
9349 gfc_rank_cst[dim], ubound);
9352 stride = gfc_evaluate_now (stride, &block);
9353 gfc_conv_descriptor_stride_set (&block, desc,
9354 gfc_rank_cst[dim], stride);
9356 /* Update offset. */
9357 offs = gfc_conv_descriptor_offset_get (desc);
9358 tmp = fold_build2_loc (input_location, MULT_EXPR,
9359 gfc_array_index_type, lbound, stride);
9360 offs = fold_build2_loc (input_location, MINUS_EXPR,
9361 gfc_array_index_type, offs, tmp);
9362 offs = gfc_evaluate_now (offs, &block);
9363 gfc_conv_descriptor_offset_set (&block, desc, offs);
9365 /* Update stride. */
9366 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
9367 stride = fold_build2_loc (input_location, MULT_EXPR,
9368 gfc_array_index_type, stride, tmp);
9373 /* Bounds remapping. Just shift the lower bounds. */
9375 gcc_assert (expr1->rank == expr2->rank);
9377 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
9381 gcc_assert (!remap->u.ar.end[dim]);
9382 gfc_init_se (&lbound_se, NULL);
9383 if (remap->u.ar.start[dim])
9385 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
9386 gfc_add_block_to_block (&block, &lbound_se.pre);
9389 /* This remap arises from a target that is not a whole
9390 array. The start expressions will be NULL but we need
9391 the lbounds to be one. */
9392 lbound_se.expr = gfc_index_one_node;
9393 gfc_conv_shift_descriptor_lbound (&block, desc,
9394 dim, lbound_se.expr);
9395 gfc_add_block_to_block (&block, &lbound_se.post);
9400 /* If rank remapping was done, check with -fcheck=bounds that
9401 the target is at least as large as the pointer. */
9402 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
9408 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
9409 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
9411 lsize = gfc_evaluate_now (lsize, &block);
9412 rsize = gfc_evaluate_now (rsize, &block);
9413 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
9416 msg = _("Target of rank remapping is too small (%ld < %ld)");
9417 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
9421 if (expr1->ts.type == BT_CHARACTER
9422 && expr1->symtree->n.sym->ts.deferred
9423 && expr1->symtree->n.sym->ts.u.cl->backend_decl
9424 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
9426 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
9427 if (expr2->expr_type != EXPR_NULL)
9428 gfc_add_modify (&block, tmp,
9429 fold_convert (TREE_TYPE (tmp), strlen_rhs));
9431 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
9434 /* Check string lengths if applicable. The check is only really added
9435 to the output code if -fbounds-check is enabled. */
9436 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
9438 gcc_assert (expr2->ts.type == BT_CHARACTER);
9439 gcc_assert (strlen_lhs && strlen_rhs);
9440 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
9441 strlen_lhs, strlen_rhs, &block);
9444 gfc_add_block_to_block (&block, &lse.post);
9446 gfc_add_block_to_block (&block, &rse.post);
9449 return gfc_finish_block (&block);
9453 /* Makes sure se is suitable for passing as a function string parameter. */
9454 /* TODO: Need to check all callers of this function. It may be abused. */
9457 gfc_conv_string_parameter (gfc_se * se)
9461 if (TREE_CODE (se->expr) == STRING_CST)
9463 type = TREE_TYPE (TREE_TYPE (se->expr));
9464 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9468 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
9470 if (TREE_CODE (se->expr) != INDIRECT_REF)
9472 type = TREE_TYPE (se->expr);
9473 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
9477 type = gfc_get_character_type_len (gfc_default_character_kind,
9479 type = build_pointer_type (type);
9480 se->expr = gfc_build_addr_expr (type, se->expr);
9484 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
9488 /* Generate code for assignment of scalar variables. Includes character
9489 strings and derived types with allocatable components.
9490 If you know that the LHS has no allocations, set dealloc to false.
9492 DEEP_COPY has no effect if the typespec TS is not a derived type with
9493 allocatable components. Otherwise, if it is set, an explicit copy of each
9494 allocatable component is made. This is necessary as a simple copy of the
9495 whole object would copy array descriptors as is, so that the lhs's
9496 allocatable components would point to the rhs's after the assignment.
9497 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
9498 necessary if the rhs is a non-pointer function, as the allocatable components
9499 are not accessible by other means than the function's result after the
9500 function has returned. It is even more subtle when temporaries are involved,
9501 as the two following examples show:
9502 1. When we evaluate an array constructor, a temporary is created. Thus
9503 there is theoretically no alias possible. However, no deep copy is
9504 made for this temporary, so that if the constructor is made of one or
9505 more variable with allocatable components, those components still point
9506 to the variable's: DEEP_COPY should be set for the assignment from the
9507 temporary to the lhs in that case.
9508 2. When assigning a scalar to an array, we evaluate the scalar value out
9509 of the loop, store it into a temporary variable, and assign from that.
9510 In that case, deep copying when assigning to the temporary would be a
9511 waste of resources; however deep copies should happen when assigning from
9512 the temporary to each array element: again DEEP_COPY should be set for
9513 the assignment from the temporary to the lhs. */
9516 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9517 bool deep_copy, bool dealloc, bool in_coarray)
9523 gfc_init_block (&block);
9525 if (ts.type == BT_CHARACTER)
9530 if (lse->string_length != NULL_TREE)
9532 gfc_conv_string_parameter (lse);
9533 gfc_add_block_to_block (&block, &lse->pre);
9534 llen = lse->string_length;
9537 if (rse->string_length != NULL_TREE)
9539 gfc_conv_string_parameter (rse);
9540 gfc_add_block_to_block (&block, &rse->pre);
9541 rlen = rse->string_length;
9544 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9545 rse->expr, ts.kind);
9547 else if (gfc_bt_struct (ts.type)
9548 && (ts.u.derived->attr.alloc_comp
9549 || (deep_copy && ts.u.derived->attr.pdt_type)))
9551 tree tmp_var = NULL_TREE;
9554 /* Are the rhs and the lhs the same? */
9557 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9558 gfc_build_addr_expr (NULL_TREE, lse->expr),
9559 gfc_build_addr_expr (NULL_TREE, rse->expr));
9560 cond = gfc_evaluate_now (cond, &lse->pre);
9563 /* Deallocate the lhs allocated components as long as it is not
9564 the same as the rhs. This must be done following the assignment
9565 to prevent deallocating data that could be used in the rhs
9569 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9570 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9572 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9574 gfc_add_expr_to_block (&lse->post, tmp);
9577 gfc_add_block_to_block (&block, &rse->pre);
9578 gfc_add_block_to_block (&block, &lse->pre);
9580 gfc_add_modify (&block, lse->expr,
9581 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9583 /* Restore pointer address of coarray components. */
9584 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9586 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9587 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9589 gfc_add_expr_to_block (&block, tmp);
9592 /* Do a deep copy if the rhs is a variable, if it is not the
9596 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9597 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9598 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9600 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9602 gfc_add_expr_to_block (&block, tmp);
9605 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9607 gfc_add_block_to_block (&block, &lse->pre);
9608 gfc_add_block_to_block (&block, &rse->pre);
9609 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9610 TREE_TYPE (lse->expr), rse->expr);
9611 gfc_add_modify (&block, lse->expr, tmp);
9615 gfc_add_block_to_block (&block, &lse->pre);
9616 gfc_add_block_to_block (&block, &rse->pre);
9618 gfc_add_modify (&block, lse->expr,
9619 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9622 gfc_add_block_to_block (&block, &lse->post);
9623 gfc_add_block_to_block (&block, &rse->post);
9625 return gfc_finish_block (&block);
9629 /* There are quite a lot of restrictions on the optimisation in using an
9630 array function assign without a temporary. */
9633 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9636 bool seen_array_ref;
9638 gfc_symbol *sym = expr1->symtree->n.sym;
9640 /* Play it safe with class functions assigned to a derived type. */
9641 if (gfc_is_class_array_function (expr2)
9642 && expr1->ts.type == BT_DERIVED)
9645 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9646 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9649 /* Elemental functions are scalarized so that they don't need a
9650 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9651 they would need special treatment in gfc_trans_arrayfunc_assign. */
9652 if (expr2->value.function.esym != NULL
9653 && expr2->value.function.esym->attr.elemental)
9656 /* Need a temporary if rhs is not FULL or a contiguous section. */
9657 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9660 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9661 if (gfc_ref_needs_temporary_p (expr1->ref))
9664 /* Functions returning pointers or allocatables need temporaries. */
9665 c = expr2->value.function.esym
9666 ? (expr2->value.function.esym->attr.pointer
9667 || expr2->value.function.esym->attr.allocatable)
9668 : (expr2->symtree->n.sym->attr.pointer
9669 || expr2->symtree->n.sym->attr.allocatable);
9673 /* Character array functions need temporaries unless the
9674 character lengths are the same. */
9675 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9677 if (expr1->ts.u.cl->length == NULL
9678 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9681 if (expr2->ts.u.cl->length == NULL
9682 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9685 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9686 expr2->ts.u.cl->length->value.integer) != 0)
9690 /* Check that no LHS component references appear during an array
9691 reference. This is needed because we do not have the means to
9692 span any arbitrary stride with an array descriptor. This check
9693 is not needed for the rhs because the function result has to be
9695 seen_array_ref = false;
9696 for (ref = expr1->ref; ref; ref = ref->next)
9698 if (ref->type == REF_ARRAY)
9699 seen_array_ref= true;
9700 else if (ref->type == REF_COMPONENT && seen_array_ref)
9704 /* Check for a dependency. */
9705 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9706 expr2->value.function.esym,
9707 expr2->value.function.actual,
9711 /* If we have reached here with an intrinsic function, we do not
9712 need a temporary except in the particular case that reallocation
9713 on assignment is active and the lhs is allocatable and a target. */
9714 if (expr2->value.function.isym)
9715 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9717 /* If the LHS is a dummy, we need a temporary if it is not
9719 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9722 /* If the lhs has been host_associated, is in common, a pointer or is
9723 a target and the function is not using a RESULT variable, aliasing
9724 can occur and a temporary is needed. */
9725 if ((sym->attr.host_assoc
9726 || sym->attr.in_common
9727 || sym->attr.pointer
9728 || sym->attr.cray_pointee
9729 || sym->attr.target)
9730 && expr2->symtree != NULL
9731 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9734 /* A PURE function can unconditionally be called without a temporary. */
9735 if (expr2->value.function.esym != NULL
9736 && expr2->value.function.esym->attr.pure)
9739 /* Implicit_pure functions are those which could legally be declared
9741 if (expr2->value.function.esym != NULL
9742 && expr2->value.function.esym->attr.implicit_pure)
9745 if (!sym->attr.use_assoc
9746 && !sym->attr.in_common
9747 && !sym->attr.pointer
9748 && !sym->attr.target
9749 && !sym->attr.cray_pointee
9750 && expr2->value.function.esym)
9752 /* A temporary is not needed if the function is not contained and
9753 the variable is local or host associated and not a pointer or
9755 if (!expr2->value.function.esym->attr.contained)
9758 /* A temporary is not needed if the lhs has never been host
9759 associated and the procedure is contained. */
9760 else if (!sym->attr.host_assoc)
9763 /* A temporary is not needed if the variable is local and not
9764 a pointer, a target or a result. */
9766 && expr2->value.function.esym->ns == sym->ns->parent)
9770 /* Default to temporary use. */
9775 /* Provide the loop info so that the lhs descriptor can be built for
9776 reallocatable assignments from extrinsic function calls. */
9779 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9782 /* Signal that the function call should not be made by
9783 gfc_conv_loop_setup. */
9784 se->ss->is_alloc_lhs = 1;
9785 gfc_init_loopinfo (loop);
9786 gfc_add_ss_to_loop (loop, *ss);
9787 gfc_add_ss_to_loop (loop, se->ss);
9788 gfc_conv_ss_startstride (loop);
9789 gfc_conv_loop_setup (loop, where);
9790 gfc_copy_loopinfo_to_se (se, loop);
9791 gfc_add_block_to_block (&se->pre, &loop->pre);
9792 gfc_add_block_to_block (&se->pre, &loop->post);
9793 se->ss->is_alloc_lhs = 0;
9797 /* For assignment to a reallocatable lhs from intrinsic functions,
9798 replace the se.expr (ie. the result) with a temporary descriptor.
9799 Null the data field so that the library allocates space for the
9800 result. Free the data of the original descriptor after the function,
9801 in case it appears in an argument expression and transfer the
9802 result to the original descriptor. */
9805 fcncall_realloc_result (gfc_se *se, int rank)
9814 /* Use the allocation done by the library. Substitute the lhs
9815 descriptor with a copy, whose data field is nulled.*/
9816 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9817 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9818 desc = build_fold_indirect_ref_loc (input_location, desc);
9820 /* Unallocated, the descriptor does not have a dtype. */
9821 tmp = gfc_conv_descriptor_dtype (desc);
9822 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9824 res_desc = gfc_evaluate_now (desc, &se->pre);
9825 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9826 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9828 /* Free the lhs after the function call and copy the result data to
9829 the lhs descriptor. */
9830 tmp = gfc_conv_descriptor_data_get (desc);
9831 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9832 logical_type_node, tmp,
9833 build_int_cst (TREE_TYPE (tmp), 0));
9834 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9835 tmp = gfc_call_free (tmp);
9836 gfc_add_expr_to_block (&se->post, tmp);
9838 tmp = gfc_conv_descriptor_data_get (res_desc);
9839 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9841 /* Check that the shapes are the same between lhs and expression. */
9842 for (n = 0 ; n < rank; n++)
9845 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9846 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9847 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9848 gfc_array_index_type, tmp, tmp1);
9849 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9850 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9851 gfc_array_index_type, tmp, tmp1);
9852 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9853 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9854 gfc_array_index_type, tmp, tmp1);
9855 tmp = fold_build2_loc (input_location, NE_EXPR,
9856 logical_type_node, tmp,
9857 gfc_index_zero_node);
9858 tmp = gfc_evaluate_now (tmp, &se->post);
9859 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9860 logical_type_node, tmp,
9864 /* 'zero_cond' being true is equal to lhs not being allocated or the
9865 shapes being different. */
9866 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9868 /* Now reset the bounds returned from the function call to bounds based
9869 on the lhs lbounds, except where the lhs is not allocated or the shapes
9870 of 'variable and 'expr' are different. Set the offset accordingly. */
9871 offset = gfc_index_zero_node;
9872 for (n = 0 ; n < rank; n++)
9876 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9877 lbound = fold_build3_loc (input_location, COND_EXPR,
9878 gfc_array_index_type, zero_cond,
9879 gfc_index_one_node, lbound);
9880 lbound = gfc_evaluate_now (lbound, &se->post);
9882 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9883 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9884 gfc_array_index_type, tmp, lbound);
9885 gfc_conv_descriptor_lbound_set (&se->post, desc,
9886 gfc_rank_cst[n], lbound);
9887 gfc_conv_descriptor_ubound_set (&se->post, desc,
9888 gfc_rank_cst[n], tmp);
9890 /* Set stride and accumulate the offset. */
9891 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9892 gfc_conv_descriptor_stride_set (&se->post, desc,
9893 gfc_rank_cst[n], tmp);
9894 tmp = fold_build2_loc (input_location, MULT_EXPR,
9895 gfc_array_index_type, lbound, tmp);
9896 offset = fold_build2_loc (input_location, MINUS_EXPR,
9897 gfc_array_index_type, offset, tmp);
9898 offset = gfc_evaluate_now (offset, &se->post);
9901 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9906 /* Try to translate array(:) = func (...), where func is a transformational
9907 array function, without using a temporary. Returns NULL if this isn't the
9911 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9915 gfc_component *comp = NULL;
9918 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9921 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9923 comp = gfc_get_proc_ptr_comp (expr2);
9925 if (!(expr2->value.function.isym
9926 || (comp && comp->attr.dimension)
9927 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9928 && expr2->value.function.esym->result->attr.dimension)))
9931 gfc_init_se (&se, NULL);
9932 gfc_start_block (&se.pre);
9933 se.want_pointer = 1;
9935 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9937 if (expr1->ts.type == BT_DERIVED
9938 && expr1->ts.u.derived->attr.alloc_comp)
9941 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9943 gfc_add_expr_to_block (&se.pre, tmp);
9946 se.direct_byref = 1;
9947 se.ss = gfc_walk_expr (expr2);
9948 gcc_assert (se.ss != gfc_ss_terminator);
9950 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9951 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9952 Clearly, this cannot be done for an allocatable function result, since
9953 the shape of the result is unknown and, in any case, the function must
9954 correctly take care of the reallocation internally. For intrinsic
9955 calls, the array data is freed and the library takes care of allocation.
9956 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9958 if (flag_realloc_lhs
9959 && gfc_is_reallocatable_lhs (expr1)
9960 && !gfc_expr_attr (expr1).codimension
9961 && !gfc_is_coindexed (expr1)
9962 && !(expr2->value.function.esym
9963 && expr2->value.function.esym->result->attr.allocatable))
9965 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9967 if (!expr2->value.function.isym)
9969 ss = gfc_walk_expr (expr1);
9970 gcc_assert (ss != gfc_ss_terminator);
9972 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9973 ss->is_alloc_lhs = 1;
9976 fcncall_realloc_result (&se, expr1->rank);
9979 gfc_conv_function_expr (&se, expr2);
9980 gfc_add_block_to_block (&se.pre, &se.post);
9983 gfc_cleanup_loop (&loop);
9985 gfc_free_ss_chain (se.ss);
9987 return gfc_finish_block (&se.pre);
9991 /* Try to efficiently translate array(:) = 0. Return NULL if this
9995 gfc_trans_zero_assign (gfc_expr * expr)
9997 tree dest, len, type;
10001 sym = expr->symtree->n.sym;
10002 dest = gfc_get_symbol_decl (sym);
10004 type = TREE_TYPE (dest);
10005 if (POINTER_TYPE_P (type))
10006 type = TREE_TYPE (type);
10007 if (!GFC_ARRAY_TYPE_P (type))
10010 /* Determine the length of the array. */
10011 len = GFC_TYPE_ARRAY_SIZE (type);
10012 if (!len || TREE_CODE (len) != INTEGER_CST)
10015 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
10016 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10017 fold_convert (gfc_array_index_type, tmp));
10019 /* If we are zeroing a local array avoid taking its address by emitting
10021 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
10022 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
10023 dest, build_constructor (TREE_TYPE (dest),
10026 /* Convert arguments to the correct types. */
10027 dest = fold_convert (pvoid_type_node, dest);
10028 len = fold_convert (size_type_node, len);
10030 /* Construct call to __builtin_memset. */
10031 tmp = build_call_expr_loc (input_location,
10032 builtin_decl_explicit (BUILT_IN_MEMSET),
10033 3, dest, integer_zero_node, len);
10034 return fold_convert (void_type_node, tmp);
10038 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
10039 that constructs the call to __builtin_memcpy. */
10042 gfc_build_memcpy_call (tree dst, tree src, tree len)
10046 /* Convert arguments to the correct types. */
10047 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
10048 dst = gfc_build_addr_expr (pvoid_type_node, dst);
10050 dst = fold_convert (pvoid_type_node, dst);
10052 if (!POINTER_TYPE_P (TREE_TYPE (src)))
10053 src = gfc_build_addr_expr (pvoid_type_node, src);
10055 src = fold_convert (pvoid_type_node, src);
10057 len = fold_convert (size_type_node, len);
10059 /* Construct call to __builtin_memcpy. */
10060 tmp = build_call_expr_loc (input_location,
10061 builtin_decl_explicit (BUILT_IN_MEMCPY),
10063 return fold_convert (void_type_node, tmp);
10067 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
10068 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
10069 source/rhs, both are gfc_full_array_ref_p which have been checked for
10073 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
10075 tree dst, dlen, dtype;
10076 tree src, slen, stype;
10079 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10080 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
10082 dtype = TREE_TYPE (dst);
10083 if (POINTER_TYPE_P (dtype))
10084 dtype = TREE_TYPE (dtype);
10085 stype = TREE_TYPE (src);
10086 if (POINTER_TYPE_P (stype))
10087 stype = TREE_TYPE (stype);
10089 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
10092 /* Determine the lengths of the arrays. */
10093 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
10094 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
10096 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10097 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10098 dlen, fold_convert (gfc_array_index_type, tmp));
10100 slen = GFC_TYPE_ARRAY_SIZE (stype);
10101 if (!slen || TREE_CODE (slen) != INTEGER_CST)
10103 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
10104 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
10105 slen, fold_convert (gfc_array_index_type, tmp));
10107 /* Sanity check that they are the same. This should always be
10108 the case, as we should already have checked for conformance. */
10109 if (!tree_int_cst_equal (slen, dlen))
10112 return gfc_build_memcpy_call (dst, src, dlen);
10116 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
10117 this can't be done. EXPR1 is the destination/lhs for which
10118 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
10121 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
10123 unsigned HOST_WIDE_INT nelem;
10129 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
10133 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
10134 dtype = TREE_TYPE (dst);
10135 if (POINTER_TYPE_P (dtype))
10136 dtype = TREE_TYPE (dtype);
10137 if (!GFC_ARRAY_TYPE_P (dtype))
10140 /* Determine the lengths of the array. */
10141 len = GFC_TYPE_ARRAY_SIZE (dtype);
10142 if (!len || TREE_CODE (len) != INTEGER_CST)
10145 /* Confirm that the constructor is the same size. */
10146 if (compare_tree_int (len, nelem) != 0)
10149 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
10150 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
10151 fold_convert (gfc_array_index_type, tmp));
10153 stype = gfc_typenode_for_spec (&expr2->ts);
10154 src = gfc_build_constant_array_constructor (expr2, stype);
10156 stype = TREE_TYPE (src);
10157 if (POINTER_TYPE_P (stype))
10158 stype = TREE_TYPE (stype);
10160 return gfc_build_memcpy_call (dst, src, len);
10164 /* Tells whether the expression is to be treated as a variable reference. */
10167 gfc_expr_is_variable (gfc_expr *expr)
10170 gfc_component *comp;
10171 gfc_symbol *func_ifc;
10173 if (expr->expr_type == EXPR_VARIABLE)
10176 arg = gfc_get_noncopying_intrinsic_argument (expr);
10179 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
10180 return gfc_expr_is_variable (arg);
10183 /* A data-pointer-returning function should be considered as a variable
10185 if (expr->expr_type == EXPR_FUNCTION
10186 && expr->ref == NULL)
10188 if (expr->value.function.isym != NULL)
10191 if (expr->value.function.esym != NULL)
10193 func_ifc = expr->value.function.esym;
10198 gcc_assert (expr->symtree);
10199 func_ifc = expr->symtree->n.sym;
10203 gcc_unreachable ();
10206 comp = gfc_get_proc_ptr_comp (expr);
10207 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
10210 func_ifc = comp->ts.interface;
10214 if (expr->expr_type == EXPR_COMPCALL)
10216 gcc_assert (!expr->value.compcall.tbp->is_generic);
10217 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
10224 gcc_assert (func_ifc->attr.function
10225 && func_ifc->result != NULL);
10226 return func_ifc->result->attr.pointer;
10230 /* Is the lhs OK for automatic reallocation? */
10233 is_scalar_reallocatable_lhs (gfc_expr *expr)
10237 /* An allocatable variable with no reference. */
10238 if (expr->symtree->n.sym->attr.allocatable
10242 /* All that can be left are allocatable components. However, we do
10243 not check for allocatable components here because the expression
10244 could be an allocatable component of a pointer component. */
10245 if (expr->symtree->n.sym->ts.type != BT_DERIVED
10246 && expr->symtree->n.sym->ts.type != BT_CLASS)
10249 /* Find an allocatable component ref last. */
10250 for (ref = expr->ref; ref; ref = ref->next)
10251 if (ref->type == REF_COMPONENT
10253 && ref->u.c.component->attr.allocatable)
10260 /* Allocate or reallocate scalar lhs, as necessary. */
10263 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
10264 tree string_length,
10272 tree size_in_bytes;
10278 if (!expr1 || expr1->rank)
10281 if (!expr2 || expr2->rank)
10284 for (ref = expr1->ref; ref; ref = ref->next)
10285 if (ref->type == REF_SUBSTRING)
10288 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
10290 /* Since this is a scalar lhs, we can afford to do this. That is,
10291 there is no risk of side effects being repeated. */
10292 gfc_init_se (&lse, NULL);
10293 lse.want_pointer = 1;
10294 gfc_conv_expr (&lse, expr1);
10296 jump_label1 = gfc_build_label_decl (NULL_TREE);
10297 jump_label2 = gfc_build_label_decl (NULL_TREE);
10299 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
10300 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
10301 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
10303 tmp = build3_v (COND_EXPR, cond,
10304 build1_v (GOTO_EXPR, jump_label1),
10305 build_empty_stmt (input_location));
10306 gfc_add_expr_to_block (block, tmp);
10308 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10310 /* Use the rhs string length and the lhs element size. */
10311 size = string_length;
10312 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
10313 tmp = TYPE_SIZE_UNIT (tmp);
10314 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
10315 TREE_TYPE (tmp), tmp,
10316 fold_convert (TREE_TYPE (tmp), size));
10320 /* Otherwise use the length in bytes of the rhs. */
10321 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
10322 size_in_bytes = size;
10325 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
10326 size_in_bytes, size_one_node);
10328 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
10330 tree caf_decl, token;
10332 symbol_attribute attr;
10334 gfc_clear_attr (&attr);
10335 gfc_init_se (&caf_se, NULL);
10337 caf_decl = gfc_get_tree_for_caf_expr (expr1);
10338 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
10340 gfc_add_block_to_block (block, &caf_se.pre);
10341 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
10342 gfc_build_addr_expr (NULL_TREE, token),
10343 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
10346 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
10348 tmp = build_call_expr_loc (input_location,
10349 builtin_decl_explicit (BUILT_IN_CALLOC),
10350 2, build_one_cst (size_type_node),
10352 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10353 gfc_add_modify (block, lse.expr, tmp);
10357 tmp = build_call_expr_loc (input_location,
10358 builtin_decl_explicit (BUILT_IN_MALLOC),
10360 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10361 gfc_add_modify (block, lse.expr, tmp);
10364 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10366 /* Deferred characters need checking for lhs and rhs string
10367 length. Other deferred parameter variables will have to
10369 tmp = build1_v (GOTO_EXPR, jump_label2);
10370 gfc_add_expr_to_block (block, tmp);
10372 tmp = build1_v (LABEL_EXPR, jump_label1);
10373 gfc_add_expr_to_block (block, tmp);
10375 /* For a deferred length character, reallocate if lengths of lhs and
10376 rhs are different. */
10377 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
10379 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10381 fold_convert (TREE_TYPE (lse.string_length),
10383 /* Jump past the realloc if the lengths are the same. */
10384 tmp = build3_v (COND_EXPR, cond,
10385 build1_v (GOTO_EXPR, jump_label2),
10386 build_empty_stmt (input_location));
10387 gfc_add_expr_to_block (block, tmp);
10388 tmp = build_call_expr_loc (input_location,
10389 builtin_decl_explicit (BUILT_IN_REALLOC),
10390 2, fold_convert (pvoid_type_node, lse.expr),
10392 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
10393 gfc_add_modify (block, lse.expr, tmp);
10394 tmp = build1_v (LABEL_EXPR, jump_label2);
10395 gfc_add_expr_to_block (block, tmp);
10397 /* Update the lhs character length. */
10398 size = string_length;
10399 gfc_add_modify (block, lse.string_length,
10400 fold_convert (TREE_TYPE (lse.string_length), size));
10404 /* Check for assignments of the type
10408 to make sure we do not check for reallocation unneccessarily. */
10412 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
10414 gfc_actual_arglist *a;
10417 switch (expr2->expr_type)
10419 case EXPR_VARIABLE:
10420 return gfc_dep_compare_expr (expr1, expr2) == 0;
10422 case EXPR_FUNCTION:
10423 if (expr2->value.function.esym
10424 && expr2->value.function.esym->attr.elemental)
10426 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10429 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10434 else if (expr2->value.function.isym
10435 && expr2->value.function.isym->elemental)
10437 for (a = expr2->value.function.actual; a != NULL; a = a->next)
10440 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
10449 switch (expr2->value.op.op)
10451 case INTRINSIC_NOT:
10452 case INTRINSIC_UPLUS:
10453 case INTRINSIC_UMINUS:
10454 case INTRINSIC_PARENTHESES:
10455 return is_runtime_conformable (expr1, expr2->value.op.op1);
10457 case INTRINSIC_PLUS:
10458 case INTRINSIC_MINUS:
10459 case INTRINSIC_TIMES:
10460 case INTRINSIC_DIVIDE:
10461 case INTRINSIC_POWER:
10462 case INTRINSIC_AND:
10464 case INTRINSIC_EQV:
10465 case INTRINSIC_NEQV:
10472 case INTRINSIC_EQ_OS:
10473 case INTRINSIC_NE_OS:
10474 case INTRINSIC_GT_OS:
10475 case INTRINSIC_GE_OS:
10476 case INTRINSIC_LT_OS:
10477 case INTRINSIC_LE_OS:
10479 e1 = expr2->value.op.op1;
10480 e2 = expr2->value.op.op2;
10482 if (e1->rank == 0 && e2->rank > 0)
10483 return is_runtime_conformable (expr1, e2);
10484 else if (e1->rank > 0 && e2->rank == 0)
10485 return is_runtime_conformable (expr1, e1);
10486 else if (e1->rank > 0 && e2->rank > 0)
10487 return is_runtime_conformable (expr1, e1)
10488 && is_runtime_conformable (expr1, e2);
10506 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
10507 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
10508 bool class_realloc)
10510 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
10511 vec<tree, va_gc> *args = NULL;
10513 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
10516 /* Generate allocation of the lhs. */
10522 tmp = gfc_vptr_size_get (vptr);
10523 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10524 ? gfc_class_data_get (lse->expr) : lse->expr;
10525 gfc_init_block (&alloc);
10526 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
10527 tmp = fold_build2_loc (input_location, EQ_EXPR,
10528 logical_type_node, class_han,
10529 build_int_cst (prvoid_type_node, 0));
10530 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10532 PRED_FORTRAN_FAIL_ALLOC),
10533 gfc_finish_block (&alloc),
10534 build_empty_stmt (input_location));
10535 gfc_add_expr_to_block (&lse->pre, tmp);
10538 fcn = gfc_vptr_copy_get (vptr);
10540 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
10541 ? gfc_class_data_get (rse->expr) : rse->expr;
10544 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10545 || INDIRECT_REF_P (tmp)
10546 || (rhs->ts.type == BT_DERIVED
10547 && rhs->ts.u.derived->attr.unlimited_polymorphic
10548 && !rhs->ts.u.derived->attr.pointer
10549 && !rhs->ts.u.derived->attr.allocatable)
10550 || (UNLIMITED_POLY (rhs)
10551 && !CLASS_DATA (rhs)->attr.pointer
10552 && !CLASS_DATA (rhs)->attr.allocatable))
10553 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10555 vec_safe_push (args, tmp);
10556 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10557 ? gfc_class_data_get (lse->expr) : lse->expr;
10558 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10559 || INDIRECT_REF_P (tmp)
10560 || (lhs->ts.type == BT_DERIVED
10561 && lhs->ts.u.derived->attr.unlimited_polymorphic
10562 && !lhs->ts.u.derived->attr.pointer
10563 && !lhs->ts.u.derived->attr.allocatable)
10564 || (UNLIMITED_POLY (lhs)
10565 && !CLASS_DATA (lhs)->attr.pointer
10566 && !CLASS_DATA (lhs)->attr.allocatable))
10567 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10569 vec_safe_push (args, tmp);
10571 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10573 if (to_len != NULL_TREE && !integer_zerop (from_len))
10576 vec_safe_push (args, from_len);
10577 vec_safe_push (args, to_len);
10578 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10580 tmp = fold_build2_loc (input_location, GT_EXPR,
10581 logical_type_node, from_len,
10582 build_zero_cst (TREE_TYPE (from_len)));
10583 return fold_build3_loc (input_location, COND_EXPR,
10584 void_type_node, tmp,
10592 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10593 ? gfc_class_data_get (lse->expr) : lse->expr;
10594 stmtblock_t tblock;
10595 gfc_init_block (&tblock);
10596 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10597 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10598 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10599 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10600 /* When coming from a ptr_copy lhs and rhs are swapped. */
10601 gfc_add_modify_loc (input_location, &tblock, rhst,
10602 fold_convert (TREE_TYPE (rhst), tmp));
10603 return gfc_finish_block (&tblock);
10607 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10608 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10609 init_flag indicates initialization expressions and dealloc that no
10610 deallocate prior assignment is needed (if in doubt, set true).
10611 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10612 routine instead of a pointer assignment. Alias resolution is only done,
10613 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10614 where it is known, that newly allocated memory on the lhs can never be
10615 an alias of the rhs. */
10618 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10619 bool dealloc, bool use_vptr_copy, bool may_alias)
10624 gfc_ss *lss_section;
10631 bool scalar_to_array;
10632 tree string_length;
10634 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10635 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10636 bool is_poly_assign;
10638 /* Assignment of the form lhs = rhs. */
10639 gfc_start_block (&block);
10641 gfc_init_se (&lse, NULL);
10642 gfc_init_se (&rse, NULL);
10644 /* Walk the lhs. */
10645 lss = gfc_walk_expr (expr1);
10646 if (gfc_is_reallocatable_lhs (expr1))
10648 lss->no_bounds_check = 1;
10649 if (!(expr2->expr_type == EXPR_FUNCTION
10650 && expr2->value.function.isym != NULL
10651 && !(expr2->value.function.isym->elemental
10652 || expr2->value.function.isym->conversion)))
10653 lss->is_alloc_lhs = 1;
10656 lss->no_bounds_check = expr1->no_bounds_check;
10660 if ((expr1->ts.type == BT_DERIVED)
10661 && (gfc_is_class_array_function (expr2)
10662 || gfc_is_alloc_class_scalar_function (expr2)))
10663 expr2->must_finalize = 1;
10665 /* Checking whether a class assignment is desired is quite complicated and
10666 needed at two locations, so do it once only before the information is
10668 lhs_attr = gfc_expr_attr (expr1);
10669 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10670 || (lhs_attr.allocatable && !lhs_attr.dimension))
10671 && (expr1->ts.type == BT_CLASS
10672 || gfc_is_class_array_ref (expr1, NULL)
10673 || gfc_is_class_scalar_expr (expr1)
10674 || gfc_is_class_array_ref (expr2, NULL)
10675 || gfc_is_class_scalar_expr (expr2));
10678 /* Only analyze the expressions for coarray properties, when in coarray-lib
10680 if (flag_coarray == GFC_FCOARRAY_LIB)
10682 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10683 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10686 if (lss != gfc_ss_terminator)
10688 /* The assignment needs scalarization. */
10691 /* Find a non-scalar SS from the lhs. */
10692 while (lss_section != gfc_ss_terminator
10693 && lss_section->info->type != GFC_SS_SECTION)
10694 lss_section = lss_section->next;
10696 gcc_assert (lss_section != gfc_ss_terminator);
10698 /* Initialize the scalarizer. */
10699 gfc_init_loopinfo (&loop);
10701 /* Walk the rhs. */
10702 rss = gfc_walk_expr (expr2);
10703 if (rss == gfc_ss_terminator)
10704 /* The rhs is scalar. Add a ss for the expression. */
10705 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10706 /* When doing a class assign, then the handle to the rhs needs to be a
10707 pointer to allow for polymorphism. */
10708 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10709 rss->info->type = GFC_SS_REFERENCE;
10711 rss->no_bounds_check = expr2->no_bounds_check;
10712 /* Associate the SS with the loop. */
10713 gfc_add_ss_to_loop (&loop, lss);
10714 gfc_add_ss_to_loop (&loop, rss);
10716 /* Calculate the bounds of the scalarization. */
10717 gfc_conv_ss_startstride (&loop);
10718 /* Enable loop reversal. */
10719 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10720 loop.reverse[n] = GFC_ENABLE_REVERSE;
10721 /* Resolve any data dependencies in the statement. */
10723 gfc_conv_resolve_dependencies (&loop, lss, rss);
10724 /* Setup the scalarizing loops. */
10725 gfc_conv_loop_setup (&loop, &expr2->where);
10727 /* Setup the gfc_se structures. */
10728 gfc_copy_loopinfo_to_se (&lse, &loop);
10729 gfc_copy_loopinfo_to_se (&rse, &loop);
10732 gfc_mark_ss_chain_used (rss, 1);
10733 if (loop.temp_ss == NULL)
10736 gfc_mark_ss_chain_used (lss, 1);
10740 lse.ss = loop.temp_ss;
10741 gfc_mark_ss_chain_used (lss, 3);
10742 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10745 /* Allow the scalarizer to workshare array assignments. */
10746 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10747 == OMPWS_WORKSHARE_FLAG
10748 && loop.temp_ss == NULL)
10750 maybe_workshare = true;
10751 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10754 /* Start the scalarized loop body. */
10755 gfc_start_scalarized_body (&loop, &body);
10758 gfc_init_block (&body);
10760 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10762 /* Translate the expression. */
10763 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10764 && lhs_caf_attr.codimension;
10765 gfc_conv_expr (&rse, expr2);
10767 /* Deal with the case of a scalar class function assigned to a derived type. */
10768 if (gfc_is_alloc_class_scalar_function (expr2)
10769 && expr1->ts.type == BT_DERIVED)
10771 rse.expr = gfc_class_data_get (rse.expr);
10772 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10775 /* Stabilize a string length for temporaries. */
10776 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10777 && !(VAR_P (rse.string_length)
10778 || TREE_CODE (rse.string_length) == PARM_DECL
10779 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10780 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10781 else if (expr2->ts.type == BT_CHARACTER)
10783 if (expr1->ts.deferred
10784 && gfc_expr_attr (expr1).allocatable
10785 && gfc_check_dependency (expr1, expr2, true))
10786 rse.string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10787 string_length = rse.string_length;
10790 string_length = NULL_TREE;
10794 gfc_conv_tmp_array_ref (&lse);
10795 if (expr2->ts.type == BT_CHARACTER)
10796 lse.string_length = string_length;
10800 gfc_conv_expr (&lse, expr1);
10801 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10803 && gfc_expr_attr (expr1).allocatable
10810 tmp = INDIRECT_REF_P (lse.expr)
10811 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10813 /* We should only get array references here. */
10814 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10815 || TREE_CODE (tmp) == ARRAY_REF);
10817 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10818 or the array itself(ARRAY_REF). */
10819 tmp = TREE_OPERAND (tmp, 0);
10821 /* Provide the address of the array. */
10822 if (TREE_CODE (lse.expr) == ARRAY_REF)
10823 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10825 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10826 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10827 msg = _("Assignment of scalar to unallocated array");
10828 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10829 &expr1->where, msg);
10832 /* Deallocate the lhs parameterized components if required. */
10833 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10834 && !expr1->symtree->n.sym->attr.associate_var)
10836 if (expr1->ts.type == BT_DERIVED
10837 && expr1->ts.u.derived
10838 && expr1->ts.u.derived->attr.pdt_type)
10840 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10842 gfc_add_expr_to_block (&lse.pre, tmp);
10844 else if (expr1->ts.type == BT_CLASS
10845 && CLASS_DATA (expr1)->ts.u.derived
10846 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10848 tmp = gfc_class_data_get (lse.expr);
10849 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10851 gfc_add_expr_to_block (&lse.pre, tmp);
10856 /* Assignments of scalar derived types with allocatable components
10857 to arrays must be done with a deep copy and the rhs temporary
10858 must have its components deallocated afterwards. */
10859 scalar_to_array = (expr2->ts.type == BT_DERIVED
10860 && expr2->ts.u.derived->attr.alloc_comp
10861 && !gfc_expr_is_variable (expr2)
10862 && expr1->rank && !expr2->rank);
10863 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10865 && expr1->ts.u.derived->attr.alloc_comp
10866 && gfc_is_alloc_class_scalar_function (expr2));
10867 if (scalar_to_array && dealloc)
10869 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10870 gfc_prepend_expr_to_block (&loop.post, tmp);
10873 /* When assigning a character function result to a deferred-length variable,
10874 the function call must happen before the (re)allocation of the lhs -
10875 otherwise the character length of the result is not known.
10876 NOTE 1: This relies on having the exact dependence of the length type
10877 parameter available to the caller; gfortran saves it in the .mod files.
10878 NOTE 2: Vector array references generate an index temporary that must
10879 not go outside the loop. Otherwise, variables should not generate
10881 NOTE 3: The concatenation operation generates a temporary pointer,
10882 whose allocation must go to the innermost loop.
10883 NOTE 4: Elemental functions may generate a temporary, too. */
10884 if (flag_realloc_lhs
10885 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10886 && !(lss != gfc_ss_terminator
10887 && rss != gfc_ss_terminator
10888 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10889 || (expr2->expr_type == EXPR_FUNCTION
10890 && expr2->value.function.esym != NULL
10891 && expr2->value.function.esym->attr.elemental)
10892 || (expr2->expr_type == EXPR_FUNCTION
10893 && expr2->value.function.isym != NULL
10894 && expr2->value.function.isym->elemental)
10895 || (expr2->expr_type == EXPR_OP
10896 && expr2->value.op.op == INTRINSIC_CONCAT))))
10897 gfc_add_block_to_block (&block, &rse.pre);
10899 /* Nullify the allocatable components corresponding to those of the lhs
10900 derived type, so that the finalization of the function result does not
10901 affect the lhs of the assignment. Prepend is used to ensure that the
10902 nullification occurs before the call to the finalizer. In the case of
10903 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10904 as part of the deep copy. */
10905 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10906 && (gfc_is_class_array_function (expr2)
10907 || gfc_is_alloc_class_scalar_function (expr2)))
10910 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10911 gfc_prepend_expr_to_block (&rse.post, tmp);
10912 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10913 gfc_add_block_to_block (&loop.post, &rse.post);
10918 if (is_poly_assign)
10919 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10920 use_vptr_copy || (lhs_attr.allocatable
10921 && !lhs_attr.dimension),
10922 flag_realloc_lhs && !lhs_attr.pointer);
10923 else if (flag_coarray == GFC_FCOARRAY_LIB
10924 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10925 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10926 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10928 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10929 allocatable component, because those need to be accessed via the
10930 caf-runtime. No need to check for coindexes here, because resolve
10931 has rewritten those already. */
10933 gfc_actual_arglist a1, a2;
10934 /* Clear the structures to prevent accessing garbage. */
10935 memset (&code, '\0', sizeof (gfc_code));
10936 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10937 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10942 code.ext.actual = &a1;
10943 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10944 tmp = gfc_conv_intrinsic_subroutine (&code);
10946 else if (!is_poly_assign && expr2->must_finalize
10947 && expr1->ts.type == BT_CLASS
10948 && expr2->ts.type == BT_CLASS)
10950 /* This case comes about when the scalarizer provides array element
10951 references. Use the vptr copy function, since this does a deep
10952 copy of allocatable components, without which the finalizer call */
10953 tmp = gfc_get_vptr_from_expr (rse.expr);
10954 if (tmp != NULL_TREE)
10956 tree fcn = gfc_vptr_copy_get (tmp);
10957 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10958 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10959 tmp = build_call_expr_loc (input_location,
10961 gfc_build_addr_expr (NULL, rse.expr),
10962 gfc_build_addr_expr (NULL, lse.expr));
10966 /* If nothing else works, do it the old fashioned way! */
10967 if (tmp == NULL_TREE)
10968 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10969 gfc_expr_is_variable (expr2)
10971 || expr2->expr_type == EXPR_ARRAY,
10972 !(l_is_temp || init_flag) && dealloc,
10973 expr1->symtree->n.sym->attr.codimension);
10975 /* Add the pre blocks to the body. */
10976 gfc_add_block_to_block (&body, &rse.pre);
10977 gfc_add_block_to_block (&body, &lse.pre);
10978 gfc_add_expr_to_block (&body, tmp);
10979 /* Add the post blocks to the body. */
10980 gfc_add_block_to_block (&body, &rse.post);
10981 gfc_add_block_to_block (&body, &lse.post);
10983 if (lss == gfc_ss_terminator)
10985 /* F2003: Add the code for reallocation on assignment. */
10986 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10987 && !is_poly_assign)
10988 alloc_scalar_allocatable_for_assignment (&block, string_length,
10991 /* Use the scalar assignment as is. */
10992 gfc_add_block_to_block (&block, &body);
10996 gcc_assert (lse.ss == gfc_ss_terminator
10997 && rse.ss == gfc_ss_terminator);
11001 gfc_trans_scalarized_loop_boundary (&loop, &body);
11003 /* We need to copy the temporary to the actual lhs. */
11004 gfc_init_se (&lse, NULL);
11005 gfc_init_se (&rse, NULL);
11006 gfc_copy_loopinfo_to_se (&lse, &loop);
11007 gfc_copy_loopinfo_to_se (&rse, &loop);
11009 rse.ss = loop.temp_ss;
11012 gfc_conv_tmp_array_ref (&rse);
11013 gfc_conv_expr (&lse, expr1);
11015 gcc_assert (lse.ss == gfc_ss_terminator
11016 && rse.ss == gfc_ss_terminator);
11018 if (expr2->ts.type == BT_CHARACTER)
11019 rse.string_length = string_length;
11021 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
11023 gfc_add_expr_to_block (&body, tmp);
11026 /* F2003: Allocate or reallocate lhs of allocatable array. */
11027 if (flag_realloc_lhs
11028 && gfc_is_reallocatable_lhs (expr1)
11030 && !is_runtime_conformable (expr1, expr2))
11032 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
11033 ompws_flags &= ~OMPWS_SCALARIZER_WS;
11034 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
11035 if (tmp != NULL_TREE)
11036 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
11039 if (maybe_workshare)
11040 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
11042 /* Generate the copying loops. */
11043 gfc_trans_scalarizing_loops (&loop, &body);
11045 /* Wrap the whole thing up. */
11046 gfc_add_block_to_block (&block, &loop.pre);
11047 gfc_add_block_to_block (&block, &loop.post);
11049 gfc_cleanup_loop (&loop);
11052 return gfc_finish_block (&block);
11056 /* Check whether EXPR is a copyable array. */
11059 copyable_array_p (gfc_expr * expr)
11061 if (expr->expr_type != EXPR_VARIABLE)
11064 /* First check it's an array. */
11065 if (expr->rank < 1 || !expr->ref || expr->ref->next)
11068 if (!gfc_full_array_ref_p (expr->ref, NULL))
11071 /* Next check that it's of a simple enough type. */
11072 switch (expr->ts.type)
11084 return !expr->ts.u.derived->attr.alloc_comp;
11093 /* Translate an assignment. */
11096 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
11097 bool dealloc, bool use_vptr_copy, bool may_alias)
11101 /* Special case a single function returning an array. */
11102 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
11104 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
11109 /* Special case assigning an array to zero. */
11110 if (copyable_array_p (expr1)
11111 && is_zero_initializer_p (expr2))
11113 tmp = gfc_trans_zero_assign (expr1);
11118 /* Special case copying one array to another. */
11119 if (copyable_array_p (expr1)
11120 && copyable_array_p (expr2)
11121 && gfc_compare_types (&expr1->ts, &expr2->ts)
11122 && !gfc_check_dependency (expr1, expr2, 0))
11124 tmp = gfc_trans_array_copy (expr1, expr2);
11129 /* Special case initializing an array from a constant array constructor. */
11130 if (copyable_array_p (expr1)
11131 && expr2->expr_type == EXPR_ARRAY
11132 && gfc_compare_types (&expr1->ts, &expr2->ts))
11134 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
11139 if (UNLIMITED_POLY (expr1) && expr1->rank
11140 && expr2->ts.type != BT_CLASS)
11141 use_vptr_copy = true;
11143 /* Fallback to the scalarizer to generate explicit loops. */
11144 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
11145 use_vptr_copy, may_alias);
11149 gfc_trans_init_assign (gfc_code * code)
11151 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
11155 gfc_trans_assign (gfc_code * code)
11157 return gfc_trans_assignment (code->expr1, code->expr2, false, true);