1 /* Expression translation
2 Copyright (C) 2002-2018 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)
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)
397 base_expr = gfc_expr_to_initialize (e);
399 /* Restore the original tail expression. */
402 gfc_free_ref_list (class_ref->next);
403 class_ref->next = tail;
405 else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
407 gfc_free_ref_list (e->ref);
414 /* Reset the vptr to the declared type, e.g. after deallocation. */
417 gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
424 /* Evaluate the expression and obtain the vptr from it. */
425 gfc_init_se (&se, NULL);
427 gfc_conv_expr_descriptor (&se, e);
429 gfc_conv_expr (&se, e);
430 gfc_add_block_to_block (block, &se.pre);
431 vptr = gfc_get_vptr_from_expr (se.expr);
433 /* If a vptr is not found, we can do nothing more. */
434 if (vptr == NULL_TREE)
437 if (UNLIMITED_POLY (e))
438 gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
441 /* Return the vptr to the address of the declared type. */
442 vtab = gfc_find_derived_vtab (e->ts.u.derived);
443 vtable = vtab->backend_decl;
444 if (vtable == NULL_TREE)
445 vtable = gfc_get_symbol_decl (vtab);
446 vtable = gfc_build_addr_expr (NULL, vtable);
447 vtable = fold_convert (TREE_TYPE (vptr), vtable);
448 gfc_add_modify (block, vptr, vtable);
453 /* Reset the len for unlimited polymorphic objects. */
456 gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
460 e = gfc_find_and_cut_at_last_class_ref (expr);
463 gfc_add_len_component (e);
464 gfc_init_se (&se_len, NULL);
465 gfc_conv_expr (&se_len, e);
466 gfc_add_modify (block, se_len.expr,
467 fold_convert (TREE_TYPE (se_len.expr), integer_zero_node));
472 /* Obtain the vptr of the last class reference in an expression.
473 Return NULL_TREE if no class reference is found. */
476 gfc_get_vptr_from_expr (tree expr)
481 for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
483 type = TREE_TYPE (tmp);
486 if (GFC_CLASS_TYPE_P (type))
487 return gfc_class_vptr_get (tmp);
488 if (type != TYPE_CANONICAL (type))
489 type = TYPE_CANONICAL (type);
493 if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL)
497 if (POINTER_TYPE_P (TREE_TYPE (tmp)))
498 tmp = build_fold_indirect_ref_loc (input_location, tmp);
500 if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
501 return gfc_class_vptr_get (tmp);
508 class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
511 tree tmp, tmp2, type;
513 gfc_conv_descriptor_data_set (block, lhs_desc,
514 gfc_conv_descriptor_data_get (rhs_desc));
515 gfc_conv_descriptor_offset_set (block, lhs_desc,
516 gfc_conv_descriptor_offset_get (rhs_desc));
518 gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc),
519 gfc_conv_descriptor_dtype (rhs_desc));
521 /* Assign the dimension as range-ref. */
522 tmp = gfc_get_descriptor_dimension (lhs_desc);
523 tmp2 = gfc_get_descriptor_dimension (rhs_desc);
525 type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
526 tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
527 gfc_index_zero_node, NULL_TREE, NULL_TREE);
528 tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
529 gfc_index_zero_node, NULL_TREE, NULL_TREE);
530 gfc_add_modify (block, tmp, tmp2);
534 /* Takes a derived type expression and returns the address of a temporary
535 class object of the 'declared' type. If vptr is not NULL, this is
536 used for the temporary class object.
537 optional_alloc_ptr is false when the dummy is neither allocatable
538 nor a pointer; that's only relevant for the optional handling. */
540 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
541 gfc_typespec class_ts, tree vptr, bool optional,
542 bool optional_alloc_ptr)
545 tree cond_optional = NULL_TREE;
552 /* The derived type needs to be converted to a temporary
554 tmp = gfc_typenode_for_spec (&class_ts);
555 var = gfc_create_var (tmp, "class");
558 ctree = gfc_class_vptr_get (var);
560 if (vptr != NULL_TREE)
562 /* Use the dynamic vptr. */
567 /* In this case the vtab corresponds to the derived type and the
568 vptr must point to it. */
569 vtab = gfc_find_derived_vtab (e->ts.u.derived);
571 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
573 gfc_add_modify (&parmse->pre, ctree,
574 fold_convert (TREE_TYPE (ctree), tmp));
576 /* Now set the data field. */
577 ctree = gfc_class_data_get (var);
580 cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
582 if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
584 /* If there is a ready made pointer to a derived type, use it
585 rather than evaluating the expression again. */
586 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
587 gfc_add_modify (&parmse->pre, ctree, tmp);
589 else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
591 /* For an array reference in an elemental procedure call we need
592 to retain the ss to provide the scalarized array reference. */
593 gfc_conv_expr_reference (parmse, e);
594 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
596 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
598 fold_convert (TREE_TYPE (tmp), null_pointer_node));
599 gfc_add_modify (&parmse->pre, ctree, tmp);
603 ss = gfc_walk_expr (e);
604 if (ss == gfc_ss_terminator)
607 gfc_conv_expr_reference (parmse, e);
609 /* Scalar to an assumed-rank array. */
610 if (class_ts.u.derived->components->as)
613 type = get_scalar_to_descriptor_type (parmse->expr,
615 gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
616 gfc_get_dtype (type));
618 parmse->expr = build3_loc (input_location, COND_EXPR,
619 TREE_TYPE (parmse->expr),
620 cond_optional, parmse->expr,
621 fold_convert (TREE_TYPE (parmse->expr),
623 gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
627 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
629 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
631 fold_convert (TREE_TYPE (tmp),
633 gfc_add_modify (&parmse->pre, ctree, tmp);
639 gfc_init_block (&block);
643 parmse->use_offset = 1;
644 gfc_conv_expr_descriptor (parmse, e);
646 /* Detect any array references with vector subscripts. */
647 for (ref = e->ref; ref; ref = ref->next)
648 if (ref->type == REF_ARRAY
649 && ref->u.ar.type != AR_ELEMENT
650 && ref->u.ar.type != AR_FULL)
652 for (dim = 0; dim < ref->u.ar.dimen; dim++)
653 if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
655 if (dim < ref->u.ar.dimen)
659 /* Array references with vector subscripts and non-variable expressions
660 need be converted to a one-based descriptor. */
661 if (ref || e->expr_type != EXPR_VARIABLE)
663 for (dim = 0; dim < e->rank; ++dim)
664 gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim,
668 if (e->rank != class_ts.u.derived->components->as->rank)
670 gcc_assert (class_ts.u.derived->components->as->type
672 class_array_data_assign (&block, ctree, parmse->expr, false);
676 if (gfc_expr_attr (e).codimension)
677 parmse->expr = fold_build1_loc (input_location,
681 gfc_add_modify (&block, ctree, parmse->expr);
686 tmp = gfc_finish_block (&block);
688 gfc_init_block (&block);
689 gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
691 tmp = build3_v (COND_EXPR, cond_optional, tmp,
692 gfc_finish_block (&block));
693 gfc_add_expr_to_block (&parmse->pre, tmp);
696 gfc_add_block_to_block (&parmse->pre, &block);
700 if (class_ts.u.derived->components->ts.type == BT_DERIVED
701 && class_ts.u.derived->components->ts.u.derived
702 ->attr.unlimited_polymorphic)
704 /* Take care about initializing the _len component correctly. */
705 ctree = gfc_class_len_get (var);
706 if (UNLIMITED_POLY (e))
711 len = gfc_copy_expr (e);
712 gfc_add_len_component (len);
713 gfc_init_se (&se, NULL);
714 gfc_conv_expr (&se, len);
716 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr),
717 cond_optional, se.expr,
718 fold_convert (TREE_TYPE (se.expr),
724 tmp = integer_zero_node;
725 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree),
728 /* Pass the address of the class object. */
729 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
731 if (optional && optional_alloc_ptr)
732 parmse->expr = build3_loc (input_location, COND_EXPR,
733 TREE_TYPE (parmse->expr),
734 cond_optional, parmse->expr,
735 fold_convert (TREE_TYPE (parmse->expr),
740 /* Create a new class container, which is required as scalar coarrays
741 have an array descriptor while normal scalars haven't. Optionally,
742 NULL pointer checks are added if the argument is OPTIONAL. */
745 class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
746 gfc_typespec class_ts, bool optional)
748 tree var, ctree, tmp;
753 gfc_init_block (&block);
756 for (ref = e->ref; ref; ref = ref->next)
758 if (ref->type == REF_COMPONENT
759 && ref->u.c.component->ts.type == BT_CLASS)
763 if (class_ref == NULL
764 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
765 tmp = e->symtree->n.sym->backend_decl;
768 /* Remove everything after the last class reference, convert the
769 expression and then recover its tailend once more. */
771 ref = class_ref->next;
772 class_ref->next = NULL;
773 gfc_init_se (&tmpse, NULL);
774 gfc_conv_expr (&tmpse, e);
775 class_ref->next = ref;
779 var = gfc_typenode_for_spec (&class_ts);
780 var = gfc_create_var (var, "class");
782 ctree = gfc_class_vptr_get (var);
783 gfc_add_modify (&block, ctree,
784 fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
786 ctree = gfc_class_data_get (var);
787 tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
788 gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
790 /* Pass the address of the class object. */
791 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
795 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
798 tmp = gfc_finish_block (&block);
800 gfc_init_block (&block);
801 tmp2 = gfc_class_data_get (var);
802 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
804 tmp2 = gfc_finish_block (&block);
806 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
808 gfc_add_expr_to_block (&parmse->pre, tmp);
811 gfc_add_block_to_block (&parmse->pre, &block);
815 /* Takes an intrinsic type expression and returns the address of a temporary
816 class object of the 'declared' type. */
818 gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
819 gfc_typespec class_ts)
827 /* The intrinsic type needs to be converted to a temporary
829 tmp = gfc_typenode_for_spec (&class_ts);
830 var = gfc_create_var (tmp, "class");
833 ctree = gfc_class_vptr_get (var);
835 vtab = gfc_find_vtab (&e->ts);
837 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
838 gfc_add_modify (&parmse->pre, ctree,
839 fold_convert (TREE_TYPE (ctree), tmp));
841 /* Now set the data field. */
842 ctree = gfc_class_data_get (var);
843 if (parmse->ss && parmse->ss->info->useflags)
845 /* For an array reference in an elemental procedure call we need
846 to retain the ss to provide the scalarized array reference. */
847 gfc_conv_expr_reference (parmse, e);
848 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
849 gfc_add_modify (&parmse->pre, ctree, tmp);
853 ss = gfc_walk_expr (e);
854 if (ss == gfc_ss_terminator)
857 gfc_conv_expr_reference (parmse, e);
858 if (class_ts.u.derived->components->as
859 && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK)
861 tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr,
863 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
864 TREE_TYPE (ctree), tmp);
867 tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
868 gfc_add_modify (&parmse->pre, ctree, tmp);
873 parmse->use_offset = 1;
874 gfc_conv_expr_descriptor (parmse, e);
875 if (class_ts.u.derived->components->as->rank != e->rank)
877 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
878 TREE_TYPE (ctree), parmse->expr);
879 gfc_add_modify (&parmse->pre, ctree, tmp);
882 gfc_add_modify (&parmse->pre, ctree, parmse->expr);
886 gcc_assert (class_ts.type == BT_CLASS);
887 if (class_ts.u.derived->components->ts.type == BT_DERIVED
888 && class_ts.u.derived->components->ts.u.derived
889 ->attr.unlimited_polymorphic)
891 ctree = gfc_class_len_get (var);
892 /* When the actual arg is a char array, then set the _len component of the
893 unlimited polymorphic entity to the length of the string. */
894 if (e->ts.type == BT_CHARACTER)
896 /* Start with parmse->string_length because this seems to be set to a
897 correct value more often. */
898 if (parmse->string_length)
899 tmp = parmse->string_length;
900 /* When the string_length is not yet set, then try the backend_decl of
902 else if (e->ts.u.cl->backend_decl)
903 tmp = e->ts.u.cl->backend_decl;
904 /* If both of the above approaches fail, then try to generate an
905 expression from the input, which is only feasible currently, when the
906 expression can be evaluated to a constant one. */
909 /* Try to simplify the expression. */
910 gfc_simplify_expr (e, 0);
911 if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved)
913 /* Amazingly all data is present to compute the length of a
914 constant string, but the expression is not yet there. */
915 e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER,
916 gfc_charlen_int_kind,
918 mpz_set_ui (e->ts.u.cl->length->value.integer,
919 e->value.character.length);
920 gfc_conv_const_charlen (e->ts.u.cl);
921 e->ts.u.cl->resolved = 1;
922 tmp = e->ts.u.cl->backend_decl;
926 gfc_error ("Can't compute the length of the char array at %L.",
932 tmp = integer_zero_node;
934 gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
936 else if (class_ts.type == BT_CLASS
937 && class_ts.u.derived->components
938 && class_ts.u.derived->components->ts.u
939 .derived->attr.unlimited_polymorphic)
941 ctree = gfc_class_len_get (var);
942 gfc_add_modify (&parmse->pre, ctree,
943 fold_convert (TREE_TYPE (ctree),
946 /* Pass the address of the class object. */
947 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
951 /* Takes a scalarized class array expression and returns the
952 address of a temporary scalar class object of the 'declared'
954 OOP-TODO: This could be improved by adding code that branched on
955 the dynamic type being the same as the declared type. In this case
956 the original class expression can be passed directly.
957 optional_alloc_ptr is false when the dummy is neither allocatable
958 nor a pointer; that's relevant for the optional handling.
959 Set copyback to true if class container's _data and _vtab pointers
960 might get modified. */
963 gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
964 bool elemental, bool copyback, bool optional,
965 bool optional_alloc_ptr)
971 tree cond = NULL_TREE;
972 tree slen = NULL_TREE;
976 bool full_array = false;
978 gfc_init_block (&block);
981 for (ref = e->ref; ref; ref = ref->next)
983 if (ref->type == REF_COMPONENT
984 && ref->u.c.component->ts.type == BT_CLASS)
987 if (ref->next == NULL)
991 if ((ref == NULL || class_ref == ref)
992 && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
993 && (!class_ts.u.derived->components->as
994 || class_ts.u.derived->components->as->rank != -1))
997 /* Test for FULL_ARRAY. */
998 if (e->rank == 0 && gfc_expr_attr (e).codimension
999 && gfc_expr_attr (e).dimension)
1002 gfc_is_class_array_ref (e, &full_array);
1004 /* The derived type needs to be converted to a temporary
1006 tmp = gfc_typenode_for_spec (&class_ts);
1007 var = gfc_create_var (tmp, "class");
1010 ctree = gfc_class_data_get (var);
1011 if (class_ts.u.derived->components->as
1012 && e->rank != class_ts.u.derived->components->as->rank)
1016 tree type = get_scalar_to_descriptor_type (parmse->expr,
1018 gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
1019 gfc_get_dtype (type));
1021 tmp = gfc_class_data_get (parmse->expr);
1022 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1023 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1025 gfc_conv_descriptor_data_set (&block, ctree, tmp);
1028 class_array_data_assign (&block, ctree, parmse->expr, false);
1032 if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
1033 parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
1034 TREE_TYPE (ctree), parmse->expr);
1035 gfc_add_modify (&block, ctree, parmse->expr);
1038 /* Return the data component, except in the case of scalarized array
1039 references, where nullification of the cannot occur and so there
1041 if (!elemental && full_array && copyback)
1043 if (class_ts.u.derived->components->as
1044 && e->rank != class_ts.u.derived->components->as->rank)
1047 gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr),
1048 gfc_conv_descriptor_data_get (ctree));
1050 class_array_data_assign (&parmse->post, parmse->expr, ctree, true);
1053 gfc_add_modify (&parmse->post, parmse->expr, ctree);
1057 ctree = gfc_class_vptr_get (var);
1059 /* The vptr is the second field of the actual argument.
1060 First we have to find the corresponding class reference. */
1063 if (gfc_is_class_array_function (e)
1064 && parmse->class_vptr != NULL_TREE)
1065 tmp = parmse->class_vptr;
1066 else if (class_ref == NULL
1067 && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
1069 tmp = e->symtree->n.sym->backend_decl;
1071 if (TREE_CODE (tmp) == FUNCTION_DECL)
1072 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
1074 if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
1075 tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
1077 slen = build_zero_cst (size_type_node);
1081 /* Remove everything after the last class reference, convert the
1082 expression and then recover its tailend once more. */
1084 ref = class_ref->next;
1085 class_ref->next = NULL;
1086 gfc_init_se (&tmpse, NULL);
1087 gfc_conv_expr (&tmpse, e);
1088 class_ref->next = ref;
1090 slen = tmpse.string_length;
1093 gcc_assert (tmp != NULL_TREE);
1095 /* Dereference if needs be. */
1096 if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
1097 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1099 if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
1100 vptr = gfc_class_vptr_get (tmp);
1104 gfc_add_modify (&block, ctree,
1105 fold_convert (TREE_TYPE (ctree), vptr));
1107 /* Return the vptr component, except in the case of scalarized array
1108 references, where the dynamic type cannot change. */
1109 if (!elemental && full_array && copyback)
1110 gfc_add_modify (&parmse->post, vptr,
1111 fold_convert (TREE_TYPE (vptr), ctree));
1113 /* For unlimited polymorphic objects also set the _len component. */
1114 if (class_ts.type == BT_CLASS
1115 && class_ts.u.derived->components
1116 && class_ts.u.derived->components->ts.u
1117 .derived->attr.unlimited_polymorphic)
1119 ctree = gfc_class_len_get (var);
1120 if (UNLIMITED_POLY (e))
1121 tmp = gfc_class_len_get (tmp);
1122 else if (e->ts.type == BT_CHARACTER)
1124 gcc_assert (slen != NULL_TREE);
1128 tmp = build_zero_cst (size_type_node);
1129 gfc_add_modify (&parmse->pre, ctree,
1130 fold_convert (TREE_TYPE (ctree), tmp));
1132 /* Return the len component, except in the case of scalarized array
1133 references, where the dynamic type cannot change. */
1134 if (!elemental && full_array && copyback)
1135 gfc_add_modify (&parmse->post, tmp,
1136 fold_convert (TREE_TYPE (tmp), ctree));
1143 cond = gfc_conv_expr_present (e->symtree->n.sym);
1144 /* parmse->pre may contain some preparatory instructions for the
1145 temporary array descriptor. Those may only be executed when the
1146 optional argument is set, therefore add parmse->pre's instructions
1147 to block, which is later guarded by an if (optional_arg_given). */
1148 gfc_add_block_to_block (&parmse->pre, &block);
1149 block.head = parmse->pre.head;
1150 parmse->pre.head = NULL_TREE;
1151 tmp = gfc_finish_block (&block);
1153 if (optional_alloc_ptr)
1154 tmp2 = build_empty_stmt (input_location);
1157 gfc_init_block (&block);
1159 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1160 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1161 null_pointer_node));
1162 tmp2 = gfc_finish_block (&block);
1165 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1167 gfc_add_expr_to_block (&parmse->pre, tmp);
1170 gfc_add_block_to_block (&parmse->pre, &block);
1172 /* Pass the address of the class object. */
1173 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1175 if (optional && optional_alloc_ptr)
1176 parmse->expr = build3_loc (input_location, COND_EXPR,
1177 TREE_TYPE (parmse->expr),
1179 fold_convert (TREE_TYPE (parmse->expr),
1180 null_pointer_node));
1184 /* Given a class array declaration and an index, returns the address
1185 of the referenced element. */
1188 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1191 tree data, size, tmp, ctmp, offset, ptr;
1193 data = data_comp != NULL_TREE ? data_comp :
1194 gfc_class_data_get (class_decl);
1195 size = gfc_class_vtab_size_get (class_decl);
1199 tmp = fold_convert (gfc_array_index_type,
1200 gfc_class_len_get (class_decl));
1201 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1202 gfc_array_index_type, size, tmp);
1203 tmp = fold_build2_loc (input_location, GT_EXPR,
1204 logical_type_node, tmp,
1205 build_zero_cst (TREE_TYPE (tmp)));
1206 size = fold_build3_loc (input_location, COND_EXPR,
1207 gfc_array_index_type, tmp, ctmp, size);
1210 offset = fold_build2_loc (input_location, MULT_EXPR,
1211 gfc_array_index_type,
1214 data = gfc_conv_descriptor_data_get (data);
1215 ptr = fold_convert (pvoid_type_node, data);
1216 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1217 return fold_convert (TREE_TYPE (data), ptr);
1221 /* Copies one class expression to another, assuming that if either
1222 'to' or 'from' are arrays they are packed. Should 'from' be
1223 NULL_TREE, the initialization expression for 'to' is used, assuming
1224 that the _vptr is set. */
1227 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1237 vec<tree, va_gc> *args;
1242 bool is_from_desc = false, is_to_class = false;
1245 /* To prevent warnings on uninitialized variables. */
1246 from_len = to_len = NULL_TREE;
1248 if (from != NULL_TREE)
1249 fcn = gfc_class_vtab_copy_get (from);
1251 fcn = gfc_class_vtab_copy_get (to);
1253 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1255 if (from != NULL_TREE)
1257 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1261 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1265 /* Check that from is a class. When the class is part of a coarray,
1266 then from is a common pointer and is to be used as is. */
1267 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1268 ? build_fold_indirect_ref (from) : from;
1270 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1271 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1272 ? gfc_class_data_get (from) : from;
1273 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1277 from_data = gfc_class_vtab_def_init_get (to);
1281 if (from != NULL_TREE && unlimited)
1282 from_len = gfc_class_len_or_zero_get (from);
1284 from_len = build_zero_cst (size_type_node);
1287 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1290 to_data = gfc_class_data_get (to);
1292 to_len = gfc_class_len_get (to);
1295 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1298 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1300 stmtblock_t loopbody;
1304 tree orig_nelems = nelems; /* Needed for bounds check. */
1306 gfc_init_block (&body);
1307 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1308 gfc_array_index_type, nelems,
1309 gfc_index_one_node);
1310 nelems = gfc_evaluate_now (tmp, &body);
1311 index = gfc_create_var (gfc_array_index_type, "S");
1315 from_ref = gfc_get_class_array_ref (index, from, from_data,
1317 vec_safe_push (args, from_ref);
1320 vec_safe_push (args, from_data);
1323 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1326 tmp = gfc_conv_array_data (to);
1327 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1328 to_ref = gfc_build_addr_expr (NULL_TREE,
1329 gfc_build_array_ref (tmp, index, to));
1331 vec_safe_push (args, to_ref);
1333 /* Add bounds check. */
1334 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1337 const char *name = "<<unknown>>";
1341 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1343 from_len = gfc_conv_descriptor_size (from_data, 1);
1344 tmp = fold_build2_loc (input_location, NE_EXPR,
1345 logical_type_node, from_len, orig_nelems);
1346 msg = xasprintf ("Array bound mismatch for dimension %d "
1347 "of array '%s' (%%ld/%%ld)",
1350 gfc_trans_runtime_check (true, false, tmp, &body,
1351 &gfc_current_locus, msg,
1352 fold_convert (long_integer_type_node, orig_nelems),
1353 fold_convert (long_integer_type_node, from_len));
1358 tmp = build_call_vec (fcn_type, fcn, args);
1360 /* Build the body of the loop. */
1361 gfc_init_block (&loopbody);
1362 gfc_add_expr_to_block (&loopbody, tmp);
1364 /* Build the loop and return. */
1365 gfc_init_loopinfo (&loop);
1367 loop.from[0] = gfc_index_zero_node;
1368 loop.loopvar[0] = index;
1369 loop.to[0] = nelems;
1370 gfc_trans_scalarizing_loops (&loop, &loopbody);
1371 gfc_init_block (&ifbody);
1372 gfc_add_block_to_block (&ifbody, &loop.pre);
1373 stdcopy = gfc_finish_block (&ifbody);
1374 /* In initialization mode from_len is a constant zero. */
1375 if (unlimited && !integer_zerop (from_len))
1377 vec_safe_push (args, from_len);
1378 vec_safe_push (args, to_len);
1379 tmp = build_call_vec (fcn_type, fcn, args);
1380 /* Build the body of the loop. */
1381 gfc_init_block (&loopbody);
1382 gfc_add_expr_to_block (&loopbody, tmp);
1384 /* Build the loop and return. */
1385 gfc_init_loopinfo (&loop);
1387 loop.from[0] = gfc_index_zero_node;
1388 loop.loopvar[0] = index;
1389 loop.to[0] = nelems;
1390 gfc_trans_scalarizing_loops (&loop, &loopbody);
1391 gfc_init_block (&ifbody);
1392 gfc_add_block_to_block (&ifbody, &loop.pre);
1393 extcopy = gfc_finish_block (&ifbody);
1395 tmp = fold_build2_loc (input_location, GT_EXPR,
1396 logical_type_node, from_len,
1397 build_zero_cst (TREE_TYPE (from_len)));
1398 tmp = fold_build3_loc (input_location, COND_EXPR,
1399 void_type_node, tmp, extcopy, stdcopy);
1400 gfc_add_expr_to_block (&body, tmp);
1401 tmp = gfc_finish_block (&body);
1405 gfc_add_expr_to_block (&body, stdcopy);
1406 tmp = gfc_finish_block (&body);
1408 gfc_cleanup_loop (&loop);
1412 gcc_assert (!is_from_desc);
1413 vec_safe_push (args, from_data);
1414 vec_safe_push (args, to_data);
1415 stdcopy = build_call_vec (fcn_type, fcn, args);
1417 /* In initialization mode from_len is a constant zero. */
1418 if (unlimited && !integer_zerop (from_len))
1420 vec_safe_push (args, from_len);
1421 vec_safe_push (args, to_len);
1422 extcopy = build_call_vec (fcn_type, fcn, args);
1423 tmp = fold_build2_loc (input_location, GT_EXPR,
1424 logical_type_node, from_len,
1425 build_zero_cst (TREE_TYPE (from_len)));
1426 tmp = fold_build3_loc (input_location, COND_EXPR,
1427 void_type_node, tmp, extcopy, stdcopy);
1433 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1434 if (from == NULL_TREE)
1437 cond = fold_build2_loc (input_location, NE_EXPR,
1439 from_data, null_pointer_node);
1440 tmp = fold_build3_loc (input_location, COND_EXPR,
1441 void_type_node, cond,
1442 tmp, build_empty_stmt (input_location));
1450 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1452 gfc_actual_arglist *actual;
1457 actual = gfc_get_actual_arglist ();
1458 actual->expr = gfc_copy_expr (rhs);
1459 actual->next = gfc_get_actual_arglist ();
1460 actual->next->expr = gfc_copy_expr (lhs);
1461 ppc = gfc_copy_expr (obj);
1462 gfc_add_vptr_component (ppc);
1463 gfc_add_component_ref (ppc, "_copy");
1464 ppc_code = gfc_get_code (EXEC_CALL);
1465 ppc_code->resolved_sym = ppc->symtree->n.sym;
1466 /* Although '_copy' is set to be elemental in class.c, it is
1467 not staying that way. Find out why, sometime.... */
1468 ppc_code->resolved_sym->attr.elemental = 1;
1469 ppc_code->ext.actual = actual;
1470 ppc_code->expr1 = ppc;
1471 /* Since '_copy' is elemental, the scalarizer will take care
1472 of arrays in gfc_trans_call. */
1473 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1474 gfc_free_statements (ppc_code);
1476 if (UNLIMITED_POLY(obj))
1478 /* Check if rhs is non-NULL. */
1480 gfc_init_se (&src, NULL);
1481 gfc_conv_expr (&src, rhs);
1482 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1483 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1484 src.expr, fold_convert (TREE_TYPE (src.expr),
1485 null_pointer_node));
1486 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1487 build_empty_stmt (input_location));
1493 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1494 A MEMCPY is needed to copy the full data from the default initializer
1495 of the dynamic type. */
1498 gfc_trans_class_init_assign (gfc_code *code)
1502 gfc_se dst,src,memsz;
1503 gfc_expr *lhs, *rhs, *sz;
1505 gfc_start_block (&block);
1507 lhs = gfc_copy_expr (code->expr1);
1509 rhs = gfc_copy_expr (code->expr1);
1510 gfc_add_vptr_component (rhs);
1512 /* Make sure that the component backend_decls have been built, which
1513 will not have happened if the derived types concerned have not
1515 gfc_get_derived_type (rhs->ts.u.derived);
1516 gfc_add_def_init_component (rhs);
1517 /* The _def_init is always scalar. */
1520 if (code->expr1->ts.type == BT_CLASS
1521 && CLASS_DATA (code->expr1)->attr.dimension)
1523 gfc_array_spec *tmparr = gfc_get_array_spec ();
1524 *tmparr = *CLASS_DATA (code->expr1)->as;
1525 /* Adding the array ref to the class expression results in correct
1526 indexing to the dynamic type. */
1527 gfc_add_full_array_ref (lhs, tmparr);
1528 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1532 /* Scalar initialization needs the _data component. */
1533 gfc_add_data_component (lhs);
1534 sz = gfc_copy_expr (code->expr1);
1535 gfc_add_vptr_component (sz);
1536 gfc_add_size_component (sz);
1538 gfc_init_se (&dst, NULL);
1539 gfc_init_se (&src, NULL);
1540 gfc_init_se (&memsz, NULL);
1541 gfc_conv_expr (&dst, lhs);
1542 gfc_conv_expr (&src, rhs);
1543 gfc_conv_expr (&memsz, sz);
1544 gfc_add_block_to_block (&block, &src.pre);
1545 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1547 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1549 if (UNLIMITED_POLY(code->expr1))
1551 /* Check if _def_init is non-NULL. */
1552 tree cond = fold_build2_loc (input_location, NE_EXPR,
1553 logical_type_node, src.expr,
1554 fold_convert (TREE_TYPE (src.expr),
1555 null_pointer_node));
1556 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1557 tmp, build_empty_stmt (input_location));
1561 if (code->expr1->symtree->n.sym->attr.optional
1562 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1564 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1565 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1567 build_empty_stmt (input_location));
1570 gfc_add_expr_to_block (&block, tmp);
1572 return gfc_finish_block (&block);
1576 /* End of prototype trans-class.c */
1580 realloc_lhs_warning (bt type, bool array, locus *where)
1582 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1583 gfc_warning (OPT_Wrealloc_lhs,
1584 "Code for reallocating the allocatable array at %L will "
1586 else if (warn_realloc_lhs_all)
1587 gfc_warning (OPT_Wrealloc_lhs_all,
1588 "Code for reallocating the allocatable variable at %L "
1589 "will be added", where);
1593 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1596 /* Copy the scalarization loop variables. */
1599 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1602 dest->loop = src->loop;
1606 /* Initialize a simple expression holder.
1608 Care must be taken when multiple se are created with the same parent.
1609 The child se must be kept in sync. The easiest way is to delay creation
1610 of a child se until after after the previous se has been translated. */
1613 gfc_init_se (gfc_se * se, gfc_se * parent)
1615 memset (se, 0, sizeof (gfc_se));
1616 gfc_init_block (&se->pre);
1617 gfc_init_block (&se->post);
1619 se->parent = parent;
1622 gfc_copy_se_loopvars (se, parent);
1626 /* Advances to the next SS in the chain. Use this rather than setting
1627 se->ss = se->ss->next because all the parents needs to be kept in sync.
1631 gfc_advance_se_ss_chain (gfc_se * se)
1636 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1639 /* Walk down the parent chain. */
1642 /* Simple consistency check. */
1643 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1644 || p->parent->ss->nested_ss == p->ss);
1646 /* If we were in a nested loop, the next scalarized expression can be
1647 on the parent ss' next pointer. Thus we should not take the next
1648 pointer blindly, but rather go up one nest level as long as next
1649 is the end of chain. */
1651 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1661 /* Ensures the result of the expression as either a temporary variable
1662 or a constant so that it can be used repeatedly. */
1665 gfc_make_safe_expr (gfc_se * se)
1669 if (CONSTANT_CLASS_P (se->expr))
1672 /* We need a temporary for this result. */
1673 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1674 gfc_add_modify (&se->pre, var, se->expr);
1679 /* Return an expression which determines if a dummy parameter is present.
1680 Also used for arguments to procedures with multiple entry points. */
1683 gfc_conv_expr_present (gfc_symbol * sym)
1687 gcc_assert (sym->attr.dummy);
1688 decl = gfc_get_symbol_decl (sym);
1690 /* Intrinsic scalars with VALUE attribute which are passed by value
1691 use a hidden argument to denote the present status. */
1692 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1693 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1694 && !sym->attr.dimension)
1696 char name[GFC_MAX_SYMBOL_LEN + 2];
1699 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1701 strcpy (&name[1], sym->name);
1702 tree_name = get_identifier (name);
1704 /* Walk function argument list to find hidden arg. */
1705 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1706 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1707 if (DECL_NAME (cond) == tree_name)
1714 if (TREE_CODE (decl) != PARM_DECL)
1716 /* Array parameters use a temporary descriptor, we want the real
1718 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1719 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1720 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1723 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1724 fold_convert (TREE_TYPE (decl), null_pointer_node));
1726 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1727 as actual argument to denote absent dummies. For array descriptors,
1728 we thus also need to check the array descriptor. For BT_CLASS, it
1729 can also occur for scalars and F2003 due to type->class wrapping and
1730 class->class wrapping. Note further that BT_CLASS always uses an
1731 array descriptor for arrays, also for explicit-shape/assumed-size. */
1733 if (!sym->attr.allocatable
1734 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1735 || (sym->ts.type == BT_CLASS
1736 && !CLASS_DATA (sym)->attr.allocatable
1737 && !CLASS_DATA (sym)->attr.class_pointer))
1738 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1739 || sym->ts.type == BT_CLASS))
1743 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1744 || sym->as->type == AS_ASSUMED_RANK
1745 || sym->attr.codimension))
1746 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1748 tmp = build_fold_indirect_ref_loc (input_location, decl);
1749 if (sym->ts.type == BT_CLASS)
1750 tmp = gfc_class_data_get (tmp);
1751 tmp = gfc_conv_array_data (tmp);
1753 else if (sym->ts.type == BT_CLASS)
1754 tmp = gfc_class_data_get (decl);
1758 if (tmp != NULL_TREE)
1760 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1761 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1762 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1763 logical_type_node, cond, tmp);
1771 /* Converts a missing, dummy argument into a null or zero. */
1774 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1779 present = gfc_conv_expr_present (arg->symtree->n.sym);
1783 /* Create a temporary and convert it to the correct type. */
1784 tmp = gfc_get_int_type (kind);
1785 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1788 /* Test for a NULL value. */
1789 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1790 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1791 tmp = gfc_evaluate_now (tmp, &se->pre);
1792 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1796 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1798 build_zero_cst (TREE_TYPE (se->expr)));
1799 tmp = gfc_evaluate_now (tmp, &se->pre);
1803 if (ts.type == BT_CHARACTER)
1805 tmp = build_int_cst (gfc_charlen_type_node, 0);
1806 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1807 present, se->string_length, tmp);
1808 tmp = gfc_evaluate_now (tmp, &se->pre);
1809 se->string_length = tmp;
1815 /* Get the character length of an expression, looking through gfc_refs
1819 gfc_get_expr_charlen (gfc_expr *e)
1824 gcc_assert (e->expr_type == EXPR_VARIABLE
1825 && e->ts.type == BT_CHARACTER);
1827 length = NULL; /* To silence compiler warning. */
1829 if (is_subref_array (e) && e->ts.u.cl->length)
1832 gfc_init_se (&tmpse, NULL);
1833 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1834 e->ts.u.cl->backend_decl = tmpse.expr;
1838 /* First candidate: if the variable is of type CHARACTER, the
1839 expression's length could be the length of the character
1841 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1842 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1844 /* Look through the reference chain for component references. */
1845 for (r = e->ref; r; r = r->next)
1850 if (r->u.c.component->ts.type == BT_CHARACTER)
1851 length = r->u.c.component->ts.u.cl->backend_decl;
1859 /* We should never got substring references here. These will be
1860 broken down by the scalarizer. */
1866 gcc_assert (length != NULL);
1871 /* Return for an expression the backend decl of the coarray. */
1874 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1880 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1882 /* Not-implemented diagnostic. */
1883 if (expr->symtree->n.sym->ts.type == BT_CLASS
1884 && UNLIMITED_POLY (expr->symtree->n.sym)
1885 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1886 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1887 "%L is not supported", &expr->where);
1889 for (ref = expr->ref; ref; ref = ref->next)
1890 if (ref->type == REF_COMPONENT)
1892 if (ref->u.c.component->ts.type == BT_CLASS
1893 && UNLIMITED_POLY (ref->u.c.component)
1894 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1895 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1896 "component at %L is not supported", &expr->where);
1899 /* Make sure the backend_decl is present before accessing it. */
1900 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1901 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1902 : expr->symtree->n.sym->backend_decl;
1904 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1906 if (expr->ref && expr->ref->type == REF_ARRAY)
1908 caf_decl = gfc_class_data_get (caf_decl);
1909 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1912 for (ref = expr->ref; ref; ref = ref->next)
1914 if (ref->type == REF_COMPONENT
1915 && strcmp (ref->u.c.component->name, "_data") != 0)
1917 caf_decl = gfc_class_data_get (caf_decl);
1918 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1922 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1926 if (expr->symtree->n.sym->attr.codimension)
1929 /* The following code assumes that the coarray is a component reachable via
1930 only scalar components/variables; the Fortran standard guarantees this. */
1932 for (ref = expr->ref; ref; ref = ref->next)
1933 if (ref->type == REF_COMPONENT)
1935 gfc_component *comp = ref->u.c.component;
1937 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1938 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1939 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1940 TREE_TYPE (comp->backend_decl), caf_decl,
1941 comp->backend_decl, NULL_TREE);
1942 if (comp->ts.type == BT_CLASS)
1944 caf_decl = gfc_class_data_get (caf_decl);
1945 if (CLASS_DATA (comp)->attr.codimension)
1951 if (comp->attr.codimension)
1957 gcc_assert (found && caf_decl);
1962 /* Obtain the Coarray token - and optionally also the offset. */
1965 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1966 tree se_expr, gfc_expr *expr)
1970 /* Coarray token. */
1971 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1973 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1974 == GFC_ARRAY_ALLOCATABLE
1975 || expr->symtree->n.sym->attr.select_type_temporary);
1976 *token = gfc_conv_descriptor_token (caf_decl);
1978 else if (DECL_LANG_SPECIFIC (caf_decl)
1979 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1980 *token = GFC_DECL_TOKEN (caf_decl);
1983 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
1984 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
1985 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
1991 /* Offset between the coarray base address and the address wanted. */
1992 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
1993 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
1994 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
1995 *offset = build_int_cst (gfc_array_index_type, 0);
1996 else if (DECL_LANG_SPECIFIC (caf_decl)
1997 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
1998 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
1999 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2000 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2002 *offset = build_int_cst (gfc_array_index_type, 0);
2004 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2005 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2007 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2008 tmp = gfc_conv_descriptor_data_get (tmp);
2010 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2011 tmp = gfc_conv_descriptor_data_get (se_expr);
2014 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2018 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2019 *offset, fold_convert (gfc_array_index_type, tmp));
2021 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2022 && expr->symtree->n.sym->attr.codimension
2023 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2025 gfc_expr *base_expr = gfc_copy_expr (expr);
2026 gfc_ref *ref = base_expr->ref;
2029 // Iterate through the refs until the last one.
2033 if (ref->type == REF_ARRAY
2034 && ref->u.ar.type != AR_FULL)
2036 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2038 for (i = 0; i < ranksum; ++i)
2040 ref->u.ar.start[i] = NULL;
2041 ref->u.ar.end[i] = NULL;
2043 ref->u.ar.type = AR_FULL;
2045 gfc_init_se (&base_se, NULL);
2046 if (gfc_caf_attr (base_expr).dimension)
2048 gfc_conv_expr_descriptor (&base_se, base_expr);
2049 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2053 gfc_conv_expr (&base_se, base_expr);
2057 gfc_free_expr (base_expr);
2058 gfc_add_block_to_block (&se->pre, &base_se.pre);
2059 gfc_add_block_to_block (&se->post, &base_se.post);
2061 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2062 tmp = gfc_conv_descriptor_data_get (caf_decl);
2065 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2069 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2070 fold_convert (gfc_array_index_type, *offset),
2071 fold_convert (gfc_array_index_type, tmp));
2075 /* Convert the coindex of a coarray into an image index; the result is
2076 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2077 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2080 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2083 tree lbound, ubound, extent, tmp, img_idx;
2087 for (ref = e->ref; ref; ref = ref->next)
2088 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2090 gcc_assert (ref != NULL);
2092 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2094 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2098 img_idx = build_zero_cst (gfc_array_index_type);
2099 extent = build_one_cst (gfc_array_index_type);
2100 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2101 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2103 gfc_init_se (&se, NULL);
2104 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2105 gfc_add_block_to_block (block, &se.pre);
2106 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2107 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2108 TREE_TYPE (lbound), se.expr, lbound);
2109 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2111 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2112 TREE_TYPE (tmp), img_idx, tmp);
2113 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2115 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2116 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2117 extent = fold_build2_loc (input_location, MULT_EXPR,
2118 TREE_TYPE (tmp), extent, tmp);
2122 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2124 gfc_init_se (&se, NULL);
2125 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2126 gfc_add_block_to_block (block, &se.pre);
2127 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2128 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2129 TREE_TYPE (lbound), se.expr, lbound);
2130 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2132 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2134 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2136 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2137 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2138 TREE_TYPE (ubound), ubound, lbound);
2139 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2140 tmp, build_one_cst (TREE_TYPE (tmp)));
2141 extent = fold_build2_loc (input_location, MULT_EXPR,
2142 TREE_TYPE (tmp), extent, tmp);
2145 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2146 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2147 return fold_convert (integer_type_node, img_idx);
2151 /* For each character array constructor subexpression without a ts.u.cl->length,
2152 replace it by its first element (if there aren't any elements, the length
2153 should already be set to zero). */
2156 flatten_array_ctors_without_strlen (gfc_expr* e)
2158 gfc_actual_arglist* arg;
2164 switch (e->expr_type)
2168 flatten_array_ctors_without_strlen (e->value.op.op1);
2169 flatten_array_ctors_without_strlen (e->value.op.op2);
2173 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2177 for (arg = e->value.function.actual; arg; arg = arg->next)
2178 flatten_array_ctors_without_strlen (arg->expr);
2183 /* We've found what we're looking for. */
2184 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2189 gcc_assert (e->value.constructor);
2191 c = gfc_constructor_first (e->value.constructor);
2195 flatten_array_ctors_without_strlen (new_expr);
2196 gfc_replace_expr (e, new_expr);
2200 /* Otherwise, fall through to handle constructor elements. */
2202 case EXPR_STRUCTURE:
2203 for (c = gfc_constructor_first (e->value.constructor);
2204 c; c = gfc_constructor_next (c))
2205 flatten_array_ctors_without_strlen (c->expr);
2215 /* Generate code to initialize a string length variable. Returns the
2216 value. For array constructors, cl->length might be NULL and in this case,
2217 the first element of the constructor is needed. expr is the original
2218 expression so we can access it but can be NULL if this is not needed. */
2221 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2225 gfc_init_se (&se, NULL);
2227 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2230 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2231 "flatten" array constructors by taking their first element; all elements
2232 should be the same length or a cl->length should be present. */
2235 gfc_expr* expr_flat;
2238 expr_flat = gfc_copy_expr (expr);
2239 flatten_array_ctors_without_strlen (expr_flat);
2240 gfc_resolve_expr (expr_flat);
2242 gfc_conv_expr (&se, expr_flat);
2243 gfc_add_block_to_block (pblock, &se.pre);
2244 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2246 gfc_free_expr (expr_flat);
2250 /* Convert cl->length. */
2252 gcc_assert (cl->length);
2254 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2255 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2256 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2257 gfc_add_block_to_block (pblock, &se.pre);
2259 if (cl->backend_decl)
2260 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2262 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2267 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2268 const char *name, locus *where)
2278 type = gfc_get_character_type (kind, ref->u.ss.length);
2279 type = build_pointer_type (type);
2281 gfc_init_se (&start, se);
2282 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2283 gfc_add_block_to_block (&se->pre, &start.pre);
2285 if (integer_onep (start.expr))
2286 gfc_conv_string_parameter (se);
2291 /* Avoid multiple evaluation of substring start. */
2292 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2293 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2295 /* Change the start of the string. */
2296 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2299 tmp = build_fold_indirect_ref_loc (input_location,
2301 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2302 se->expr = gfc_build_addr_expr (type, tmp);
2305 /* Length = end + 1 - start. */
2306 gfc_init_se (&end, se);
2307 if (ref->u.ss.end == NULL)
2308 end.expr = se->string_length;
2311 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2312 gfc_add_block_to_block (&se->pre, &end.pre);
2316 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2317 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2319 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2321 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2322 logical_type_node, start.expr,
2325 /* Check lower bound. */
2326 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2328 build_one_cst (TREE_TYPE (start.expr)));
2329 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2330 logical_type_node, nonempty, fault);
2332 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2333 "is less than one", name);
2335 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2336 "is less than one");
2337 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2338 fold_convert (long_integer_type_node,
2342 /* Check upper bound. */
2343 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2344 end.expr, se->string_length);
2345 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2346 logical_type_node, nonempty, fault);
2348 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2349 "exceeds string length (%%ld)", name);
2351 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2352 "exceeds string length (%%ld)");
2353 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2354 fold_convert (long_integer_type_node, end.expr),
2355 fold_convert (long_integer_type_node,
2356 se->string_length));
2360 /* Try to calculate the length from the start and end expressions. */
2362 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2364 HOST_WIDE_INT i_len;
2366 i_len = gfc_mpz_get_hwi (length) + 1;
2370 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2371 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2375 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2376 fold_convert (gfc_charlen_type_node, end.expr),
2377 fold_convert (gfc_charlen_type_node, start.expr));
2378 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2379 build_int_cst (gfc_charlen_type_node, 1), tmp);
2380 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2381 tmp, build_int_cst (gfc_charlen_type_node, 0));
2384 se->string_length = tmp;
2388 /* Convert a derived type component reference. */
2391 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2399 c = ref->u.c.component;
2401 if (c->backend_decl == NULL_TREE
2402 && ref->u.c.sym != NULL)
2403 gfc_get_derived_type (ref->u.c.sym);
2405 field = c->backend_decl;
2406 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2408 context = DECL_FIELD_CONTEXT (field);
2410 /* Components can correspond to fields of different containing
2411 types, as components are created without context, whereas
2412 a concrete use of a component has the type of decl as context.
2413 So, if the type doesn't match, we search the corresponding
2414 FIELD_DECL in the parent type. To not waste too much time
2415 we cache this result in norestrict_decl.
2416 On the other hand, if the context is a UNION or a MAP (a
2417 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2419 if (context != TREE_TYPE (decl)
2420 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2421 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2423 tree f2 = c->norestrict_decl;
2424 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2425 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2426 if (TREE_CODE (f2) == FIELD_DECL
2427 && DECL_NAME (f2) == DECL_NAME (field))
2430 c->norestrict_decl = f2;
2434 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2435 && strcmp ("_data", c->name) == 0)
2437 /* Found a ref to the _data component. Store the associated ref to
2438 the vptr in se->class_vptr. */
2439 se->class_vptr = gfc_class_vptr_get (decl);
2442 se->class_vptr = NULL_TREE;
2444 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2445 decl, field, NULL_TREE);
2449 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2450 strlen () conditional below. */
2451 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2452 && !(c->attr.allocatable && c->ts.deferred)
2453 && !c->attr.pdt_string)
2455 tmp = c->ts.u.cl->backend_decl;
2456 /* Components must always be constant length. */
2457 gcc_assert (tmp && INTEGER_CST_P (tmp));
2458 se->string_length = tmp;
2461 if (gfc_deferred_strlen (c, &field))
2463 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2465 decl, field, NULL_TREE);
2466 se->string_length = tmp;
2469 if (((c->attr.pointer || c->attr.allocatable)
2470 && (!c->attr.dimension && !c->attr.codimension)
2471 && c->ts.type != BT_CHARACTER)
2472 || c->attr.proc_pointer)
2473 se->expr = build_fold_indirect_ref_loc (input_location,
2478 /* This function deals with component references to components of the
2479 parent type for derived type extensions. */
2481 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2489 c = ref->u.c.component;
2491 /* Return if the component is in the parent type. */
2492 for (cmp = dt->components; cmp; cmp = cmp->next)
2493 if (strcmp (c->name, cmp->name) == 0)
2496 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2497 parent.type = REF_COMPONENT;
2499 parent.u.c.sym = dt;
2500 parent.u.c.component = dt->components;
2502 if (dt->backend_decl == NULL)
2503 gfc_get_derived_type (dt);
2505 /* Build the reference and call self. */
2506 gfc_conv_component_ref (se, &parent);
2507 parent.u.c.sym = dt->components->ts.u.derived;
2508 parent.u.c.component = c;
2509 conv_parent_component_references (se, &parent);
2512 /* Return the contents of a variable. Also handles reference/pointer
2513 variables (all Fortran pointer references are implicit). */
2516 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2521 tree parent_decl = NULL_TREE;
2524 bool alternate_entry;
2527 bool first_time = true;
2529 sym = expr->symtree->n.sym;
2530 is_classarray = IS_CLASS_ARRAY (sym);
2534 gfc_ss_info *ss_info = ss->info;
2536 /* Check that something hasn't gone horribly wrong. */
2537 gcc_assert (ss != gfc_ss_terminator);
2538 gcc_assert (ss_info->expr == expr);
2540 /* A scalarized term. We already know the descriptor. */
2541 se->expr = ss_info->data.array.descriptor;
2542 se->string_length = ss_info->string_length;
2543 ref = ss_info->data.array.ref;
2545 gcc_assert (ref->type == REF_ARRAY
2546 && ref->u.ar.type != AR_ELEMENT);
2548 gfc_conv_tmp_array_ref (se);
2552 tree se_expr = NULL_TREE;
2554 se->expr = gfc_get_symbol_decl (sym);
2556 /* Deal with references to a parent results or entries by storing
2557 the current_function_decl and moving to the parent_decl. */
2558 return_value = sym->attr.function && sym->result == sym;
2559 alternate_entry = sym->attr.function && sym->attr.entry
2560 && sym->result == sym;
2561 entry_master = sym->attr.result
2562 && sym->ns->proc_name->attr.entry_master
2563 && !gfc_return_by_reference (sym->ns->proc_name);
2564 if (current_function_decl)
2565 parent_decl = DECL_CONTEXT (current_function_decl);
2567 if ((se->expr == parent_decl && return_value)
2568 || (sym->ns && sym->ns->proc_name
2570 && sym->ns->proc_name->backend_decl == parent_decl
2571 && (alternate_entry || entry_master)))
2576 /* Special case for assigning the return value of a function.
2577 Self recursive functions must have an explicit return value. */
2578 if (return_value && (se->expr == current_function_decl || parent_flag))
2579 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2581 /* Similarly for alternate entry points. */
2582 else if (alternate_entry
2583 && (sym->ns->proc_name->backend_decl == current_function_decl
2586 gfc_entry_list *el = NULL;
2588 for (el = sym->ns->entries; el; el = el->next)
2591 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2596 else if (entry_master
2597 && (sym->ns->proc_name->backend_decl == current_function_decl
2599 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2604 /* Procedure actual arguments. Look out for temporary variables
2605 with the same attributes as function values. */
2606 else if (!sym->attr.temporary
2607 && sym->attr.flavor == FL_PROCEDURE
2608 && se->expr != current_function_decl)
2610 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2612 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2613 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2619 /* Dereference the expression, where needed. Since characters
2620 are entirely different from other types, they are treated
2622 if (sym->ts.type == BT_CHARACTER)
2624 /* Dereference character pointer dummy arguments
2626 if ((sym->attr.pointer || sym->attr.allocatable)
2628 || sym->attr.function
2629 || sym->attr.result))
2630 se->expr = build_fold_indirect_ref_loc (input_location,
2634 else if (!sym->attr.value)
2636 /* Dereference temporaries for class array dummy arguments. */
2637 if (sym->attr.dummy && is_classarray
2638 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2640 if (!se->descriptor_only)
2641 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2643 se->expr = build_fold_indirect_ref_loc (input_location,
2647 /* Dereference non-character scalar dummy arguments. */
2648 if (sym->attr.dummy && !sym->attr.dimension
2649 && !(sym->attr.codimension && sym->attr.allocatable)
2650 && (sym->ts.type != BT_CLASS
2651 || (!CLASS_DATA (sym)->attr.dimension
2652 && !(CLASS_DATA (sym)->attr.codimension
2653 && CLASS_DATA (sym)->attr.allocatable))))
2654 se->expr = build_fold_indirect_ref_loc (input_location,
2657 /* Dereference scalar hidden result. */
2658 if (flag_f2c && sym->ts.type == BT_COMPLEX
2659 && (sym->attr.function || sym->attr.result)
2660 && !sym->attr.dimension && !sym->attr.pointer
2661 && !sym->attr.always_explicit)
2662 se->expr = build_fold_indirect_ref_loc (input_location,
2665 /* Dereference non-character, non-class pointer variables.
2666 These must be dummies, results, or scalars. */
2668 && (sym->attr.pointer || sym->attr.allocatable
2669 || gfc_is_associate_pointer (sym)
2670 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2672 || sym->attr.function
2674 || (!sym->attr.dimension
2675 && (!sym->attr.codimension || !sym->attr.allocatable))))
2676 se->expr = build_fold_indirect_ref_loc (input_location,
2678 /* Now treat the class array pointer variables accordingly. */
2679 else if (sym->ts.type == BT_CLASS
2681 && (CLASS_DATA (sym)->attr.dimension
2682 || CLASS_DATA (sym)->attr.codimension)
2683 && ((CLASS_DATA (sym)->as
2684 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2685 || CLASS_DATA (sym)->attr.allocatable
2686 || CLASS_DATA (sym)->attr.class_pointer))
2687 se->expr = build_fold_indirect_ref_loc (input_location,
2689 /* And the case where a non-dummy, non-result, non-function,
2690 non-allotable and non-pointer classarray is present. This case was
2691 previously covered by the first if, but with introducing the
2692 condition !is_classarray there, that case has to be covered
2694 else if (sym->ts.type == BT_CLASS
2696 && !sym->attr.function
2697 && !sym->attr.result
2698 && (CLASS_DATA (sym)->attr.dimension
2699 || CLASS_DATA (sym)->attr.codimension)
2701 || !CLASS_DATA (sym)->attr.allocatable)
2702 && !CLASS_DATA (sym)->attr.class_pointer)
2703 se->expr = build_fold_indirect_ref_loc (input_location,
2710 /* For character variables, also get the length. */
2711 if (sym->ts.type == BT_CHARACTER)
2713 /* If the character length of an entry isn't set, get the length from
2714 the master function instead. */
2715 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2716 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2718 se->string_length = sym->ts.u.cl->backend_decl;
2719 gcc_assert (se->string_length);
2727 /* Return the descriptor if that's what we want and this is an array
2728 section reference. */
2729 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2731 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2732 /* Return the descriptor for array pointers and allocations. */
2733 if (se->want_pointer
2734 && ref->next == NULL && (se->descriptor_only))
2737 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2738 /* Return a pointer to an element. */
2742 if (first_time && is_classarray && sym->attr.dummy
2743 && se->descriptor_only
2744 && !CLASS_DATA (sym)->attr.allocatable
2745 && !CLASS_DATA (sym)->attr.class_pointer
2746 && CLASS_DATA (sym)->as
2747 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2748 && strcmp ("_data", ref->u.c.component->name) == 0)
2749 /* Skip the first ref of a _data component, because for class
2750 arrays that one is already done by introducing a temporary
2751 array descriptor. */
2754 if (ref->u.c.sym->attr.extension)
2755 conv_parent_component_references (se, ref);
2757 gfc_conv_component_ref (se, ref);
2758 if (!ref->next && ref->u.c.sym->attr.codimension
2759 && se->want_pointer && se->descriptor_only)
2765 gfc_conv_substring (se, ref, expr->ts.kind,
2766 expr->symtree->name, &expr->where);
2776 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2778 if (se->want_pointer)
2780 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2781 gfc_conv_string_parameter (se);
2783 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2788 /* Unary ops are easy... Or they would be if ! was a valid op. */
2791 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2796 gcc_assert (expr->ts.type != BT_CHARACTER);
2797 /* Initialize the operand. */
2798 gfc_init_se (&operand, se);
2799 gfc_conv_expr_val (&operand, expr->value.op.op1);
2800 gfc_add_block_to_block (&se->pre, &operand.pre);
2802 type = gfc_typenode_for_spec (&expr->ts);
2804 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2805 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2806 All other unary operators have an equivalent GIMPLE unary operator. */
2807 if (code == TRUTH_NOT_EXPR)
2808 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2809 build_int_cst (type, 0));
2811 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2815 /* Expand power operator to optimal multiplications when a value is raised
2816 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2817 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2818 Programming", 3rd Edition, 1998. */
2820 /* This code is mostly duplicated from expand_powi in the backend.
2821 We establish the "optimal power tree" lookup table with the defined size.
2822 The items in the table are the exponents used to calculate the index
2823 exponents. Any integer n less than the value can get an "addition chain",
2824 with the first node being one. */
2825 #define POWI_TABLE_SIZE 256
2827 /* The table is from builtins.c. */
2828 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2830 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2831 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2832 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2833 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2834 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2835 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2836 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2837 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2838 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2839 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2840 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2841 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2842 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2843 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2844 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2845 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2846 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2847 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2848 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2849 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2850 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2851 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2852 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2853 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2854 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2855 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2856 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2857 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2858 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2859 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2860 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2861 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2864 /* If n is larger than lookup table's max index, we use the "window
2866 #define POWI_WINDOW_SIZE 3
2868 /* Recursive function to expand the power operator. The temporary
2869 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2871 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2878 if (n < POWI_TABLE_SIZE)
2883 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2884 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2888 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2889 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2890 op1 = gfc_conv_powi (se, digit, tmpvar);
2894 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2898 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2899 tmp = gfc_evaluate_now (tmp, &se->pre);
2901 if (n < POWI_TABLE_SIZE)
2908 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2909 return 1. Else return 0 and a call to runtime library functions
2910 will have to be built. */
2912 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2917 tree vartmp[POWI_TABLE_SIZE];
2919 unsigned HOST_WIDE_INT n;
2921 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2923 /* If exponent is too large, we won't expand it anyway, so don't bother
2924 with large integer values. */
2925 if (!wi::fits_shwi_p (wrhs))
2928 m = wrhs.to_shwi ();
2929 /* Use the wide_int's routine to reliably get the absolute value on all
2930 platforms. Then convert it to a HOST_WIDE_INT like above. */
2931 n = wi::abs (wrhs).to_shwi ();
2933 type = TREE_TYPE (lhs);
2934 sgn = tree_int_cst_sgn (rhs);
2936 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2937 || optimize_size) && (m > 2 || m < -1))
2943 se->expr = gfc_build_const (type, integer_one_node);
2947 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2948 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2950 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2951 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2952 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2953 lhs, build_int_cst (TREE_TYPE (lhs), 1));
2956 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2959 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2960 logical_type_node, tmp, cond);
2961 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2962 tmp, build_int_cst (type, 1),
2963 build_int_cst (type, 0));
2967 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2968 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
2969 build_int_cst (type, -1),
2970 build_int_cst (type, 0));
2971 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2972 cond, build_int_cst (type, 1), tmp);
2976 memset (vartmp, 0, sizeof (vartmp));
2980 tmp = gfc_build_const (type, integer_one_node);
2981 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
2985 se->expr = gfc_conv_powi (se, n, vartmp);
2991 /* Power op (**). Constant integer exponent has special handling. */
2994 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
2996 tree gfc_int4_type_node;
2999 int res_ikind_1, res_ikind_2;
3004 gfc_init_se (&lse, se);
3005 gfc_conv_expr_val (&lse, expr->value.op.op1);
3006 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3007 gfc_add_block_to_block (&se->pre, &lse.pre);
3009 gfc_init_se (&rse, se);
3010 gfc_conv_expr_val (&rse, expr->value.op.op2);
3011 gfc_add_block_to_block (&se->pre, &rse.pre);
3013 if (expr->value.op.op2->ts.type == BT_INTEGER
3014 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3015 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3018 gfc_int4_type_node = gfc_get_int_type (4);
3020 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3021 library routine. But in the end, we have to convert the result back
3022 if this case applies -- with res_ikind_K, we keep track whether operand K
3023 falls into this case. */
3027 kind = expr->value.op.op1->ts.kind;
3028 switch (expr->value.op.op2->ts.type)
3031 ikind = expr->value.op.op2->ts.kind;
3036 rse.expr = convert (gfc_int4_type_node, rse.expr);
3037 res_ikind_2 = ikind;
3059 if (expr->value.op.op1->ts.type == BT_INTEGER)
3061 lse.expr = convert (gfc_int4_type_node, lse.expr);
3088 switch (expr->value.op.op1->ts.type)
3091 if (kind == 3) /* Case 16 was not handled properly above. */
3093 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3097 /* Use builtins for real ** int4. */
3103 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3107 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3111 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3115 /* Use the __builtin_powil() only if real(kind=16) is
3116 actually the C long double type. */
3117 if (!gfc_real16_is_float128)
3118 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3126 /* If we don't have a good builtin for this, go for the
3127 library function. */
3129 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3133 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3142 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3146 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3154 se->expr = build_call_expr_loc (input_location,
3155 fndecl, 2, lse.expr, rse.expr);
3157 /* Convert the result back if it is of wrong integer kind. */
3158 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3160 /* We want the maximum of both operand kinds as result. */
3161 if (res_ikind_1 < res_ikind_2)
3162 res_ikind_1 = res_ikind_2;
3163 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3168 /* Generate code to allocate a string temporary. */
3171 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3176 if (gfc_can_put_var_on_stack (len))
3178 /* Create a temporary variable to hold the result. */
3179 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3180 TREE_TYPE (len), len,
3181 build_int_cst (TREE_TYPE (len), 1));
3182 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3184 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3185 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3187 tmp = build_array_type (TREE_TYPE (type), tmp);
3189 var = gfc_create_var (tmp, "str");
3190 var = gfc_build_addr_expr (type, var);
3194 /* Allocate a temporary to hold the result. */
3195 var = gfc_create_var (type, "pstr");
3196 gcc_assert (POINTER_TYPE_P (type));
3197 tmp = TREE_TYPE (type);
3198 if (TREE_CODE (tmp) == ARRAY_TYPE)
3199 tmp = TREE_TYPE (tmp);
3200 tmp = TYPE_SIZE_UNIT (tmp);
3201 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3202 fold_convert (size_type_node, len),
3203 fold_convert (size_type_node, tmp));
3204 tmp = gfc_call_malloc (&se->pre, type, tmp);
3205 gfc_add_modify (&se->pre, var, tmp);
3207 /* Free the temporary afterwards. */
3208 tmp = gfc_call_free (var);
3209 gfc_add_expr_to_block (&se->post, tmp);
3216 /* Handle a string concatenation operation. A temporary will be allocated to
3220 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3223 tree len, type, var, tmp, fndecl;
3225 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3226 && expr->value.op.op2->ts.type == BT_CHARACTER);
3227 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3229 gfc_init_se (&lse, se);
3230 gfc_conv_expr (&lse, expr->value.op.op1);
3231 gfc_conv_string_parameter (&lse);
3232 gfc_init_se (&rse, se);
3233 gfc_conv_expr (&rse, expr->value.op.op2);
3234 gfc_conv_string_parameter (&rse);
3236 gfc_add_block_to_block (&se->pre, &lse.pre);
3237 gfc_add_block_to_block (&se->pre, &rse.pre);
3239 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3240 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3241 if (len == NULL_TREE)
3243 len = fold_build2_loc (input_location, PLUS_EXPR,
3244 gfc_charlen_type_node,
3245 fold_convert (gfc_charlen_type_node,
3247 fold_convert (gfc_charlen_type_node,
3248 rse.string_length));
3251 type = build_pointer_type (type);
3253 var = gfc_conv_string_tmp (se, type, len);
3255 /* Do the actual concatenation. */
3256 if (expr->ts.kind == 1)
3257 fndecl = gfor_fndecl_concat_string;
3258 else if (expr->ts.kind == 4)
3259 fndecl = gfor_fndecl_concat_string_char4;
3263 tmp = build_call_expr_loc (input_location,
3264 fndecl, 6, len, var, lse.string_length, lse.expr,
3265 rse.string_length, rse.expr);
3266 gfc_add_expr_to_block (&se->pre, tmp);
3268 /* Add the cleanup for the operands. */
3269 gfc_add_block_to_block (&se->pre, &rse.post);
3270 gfc_add_block_to_block (&se->pre, &lse.post);
3273 se->string_length = len;
3276 /* Translates an op expression. Common (binary) cases are handled by this
3277 function, others are passed on. Recursion is used in either case.
3278 We use the fact that (op1.ts == op2.ts) (except for the power
3280 Operators need no special handling for scalarized expressions as long as
3281 they call gfc_conv_simple_val to get their operands.
3282 Character strings get special handling. */
3285 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3287 enum tree_code code;
3296 switch (expr->value.op.op)
3298 case INTRINSIC_PARENTHESES:
3299 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3300 && flag_protect_parens)
3302 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3303 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3308 case INTRINSIC_UPLUS:
3309 gfc_conv_expr (se, expr->value.op.op1);
3312 case INTRINSIC_UMINUS:
3313 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3317 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3320 case INTRINSIC_PLUS:
3324 case INTRINSIC_MINUS:
3328 case INTRINSIC_TIMES:
3332 case INTRINSIC_DIVIDE:
3333 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3334 an integer, we must round towards zero, so we use a
3336 if (expr->ts.type == BT_INTEGER)
3337 code = TRUNC_DIV_EXPR;
3342 case INTRINSIC_POWER:
3343 gfc_conv_power_op (se, expr);
3346 case INTRINSIC_CONCAT:
3347 gfc_conv_concat_op (se, expr);
3351 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3356 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3360 /* EQV and NEQV only work on logicals, but since we represent them
3361 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3363 case INTRINSIC_EQ_OS:
3371 case INTRINSIC_NE_OS:
3372 case INTRINSIC_NEQV:
3379 case INTRINSIC_GT_OS:
3386 case INTRINSIC_GE_OS:
3393 case INTRINSIC_LT_OS:
3400 case INTRINSIC_LE_OS:
3406 case INTRINSIC_USER:
3407 case INTRINSIC_ASSIGN:
3408 /* These should be converted into function calls by the frontend. */
3412 fatal_error (input_location, "Unknown intrinsic op");
3416 /* The only exception to this is **, which is handled separately anyway. */
3417 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3419 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3423 gfc_init_se (&lse, se);
3424 gfc_conv_expr (&lse, expr->value.op.op1);
3425 gfc_add_block_to_block (&se->pre, &lse.pre);
3428 gfc_init_se (&rse, se);
3429 gfc_conv_expr (&rse, expr->value.op.op2);
3430 gfc_add_block_to_block (&se->pre, &rse.pre);
3434 gfc_conv_string_parameter (&lse);
3435 gfc_conv_string_parameter (&rse);
3437 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3438 rse.string_length, rse.expr,
3439 expr->value.op.op1->ts.kind,
3441 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3442 gfc_add_block_to_block (&lse.post, &rse.post);
3445 type = gfc_typenode_for_spec (&expr->ts);
3449 /* The result of logical ops is always logical_type_node. */
3450 tmp = fold_build2_loc (input_location, code, logical_type_node,
3451 lse.expr, rse.expr);
3452 se->expr = convert (type, tmp);
3455 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3457 /* Add the post blocks. */
3458 gfc_add_block_to_block (&se->post, &rse.post);
3459 gfc_add_block_to_block (&se->post, &lse.post);
3462 /* If a string's length is one, we convert it to a single character. */
3465 gfc_string_to_single_character (tree len, tree str, int kind)
3469 || !tree_fits_uhwi_p (len)
3470 || !POINTER_TYPE_P (TREE_TYPE (str)))
3473 if (TREE_INT_CST_LOW (len) == 1)
3475 str = fold_convert (gfc_get_pchar_type (kind), str);
3476 return build_fold_indirect_ref_loc (input_location, str);
3480 && TREE_CODE (str) == ADDR_EXPR
3481 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3482 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3483 && array_ref_low_bound (TREE_OPERAND (str, 0))
3484 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3485 && TREE_INT_CST_LOW (len) > 1
3486 && TREE_INT_CST_LOW (len)
3487 == (unsigned HOST_WIDE_INT)
3488 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3490 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3491 ret = build_fold_indirect_ref_loc (input_location, ret);
3492 if (TREE_CODE (ret) == INTEGER_CST)
3494 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3495 int i, length = TREE_STRING_LENGTH (string_cst);
3496 const char *ptr = TREE_STRING_POINTER (string_cst);
3498 for (i = 1; i < length; i++)
3511 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3514 if (sym->backend_decl)
3516 /* This becomes the nominal_type in
3517 function.c:assign_parm_find_data_types. */
3518 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3519 /* This becomes the passed_type in
3520 function.c:assign_parm_find_data_types. C promotes char to
3521 integer for argument passing. */
3522 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3524 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3529 /* If we have a constant character expression, make it into an
3531 if ((*expr)->expr_type == EXPR_CONSTANT)
3536 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3537 (int)(*expr)->value.character.string[0]);
3538 if ((*expr)->ts.kind != gfc_c_int_kind)
3540 /* The expr needs to be compatible with a C int. If the
3541 conversion fails, then the 2 causes an ICE. */
3542 ts.type = BT_INTEGER;
3543 ts.kind = gfc_c_int_kind;
3544 gfc_convert_type (*expr, &ts, 2);
3547 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3549 if ((*expr)->ref == NULL)
3551 se->expr = gfc_string_to_single_character
3552 (build_int_cst (integer_type_node, 1),
3553 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3555 ((*expr)->symtree->n.sym)),
3560 gfc_conv_variable (se, *expr);
3561 se->expr = gfc_string_to_single_character
3562 (build_int_cst (integer_type_node, 1),
3563 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3571 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3572 if STR is a string literal, otherwise return -1. */
3575 gfc_optimize_len_trim (tree len, tree str, int kind)
3578 && TREE_CODE (str) == ADDR_EXPR
3579 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3580 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3581 && array_ref_low_bound (TREE_OPERAND (str, 0))
3582 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3583 && tree_fits_uhwi_p (len)
3584 && tree_to_uhwi (len) >= 1
3585 && tree_to_uhwi (len)
3586 == (unsigned HOST_WIDE_INT)
3587 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3589 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3590 folded = build_fold_indirect_ref_loc (input_location, folded);
3591 if (TREE_CODE (folded) == INTEGER_CST)
3593 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3594 int length = TREE_STRING_LENGTH (string_cst);
3595 const char *ptr = TREE_STRING_POINTER (string_cst);
3597 for (; length > 0; length--)
3598 if (ptr[length - 1] != ' ')
3607 /* Helper to build a call to memcmp. */
3610 build_memcmp_call (tree s1, tree s2, tree n)
3614 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3615 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3617 s1 = fold_convert (pvoid_type_node, s1);
3619 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3620 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3622 s2 = fold_convert (pvoid_type_node, s2);
3624 n = fold_convert (size_type_node, n);
3626 tmp = build_call_expr_loc (input_location,
3627 builtin_decl_explicit (BUILT_IN_MEMCMP),
3630 return fold_convert (integer_type_node, tmp);
3633 /* Compare two strings. If they are all single characters, the result is the
3634 subtraction of them. Otherwise, we build a library call. */
3637 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3638 enum tree_code code)
3644 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3645 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3647 sc1 = gfc_string_to_single_character (len1, str1, kind);
3648 sc2 = gfc_string_to_single_character (len2, str2, kind);
3650 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3652 /* Deal with single character specially. */
3653 sc1 = fold_convert (integer_type_node, sc1);
3654 sc2 = fold_convert (integer_type_node, sc2);
3655 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3659 if ((code == EQ_EXPR || code == NE_EXPR)
3661 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3663 /* If one string is a string literal with LEN_TRIM longer
3664 than the length of the second string, the strings
3666 int len = gfc_optimize_len_trim (len1, str1, kind);
3667 if (len > 0 && compare_tree_int (len2, len) < 0)
3668 return integer_one_node;
3669 len = gfc_optimize_len_trim (len2, str2, kind);
3670 if (len > 0 && compare_tree_int (len1, len) < 0)
3671 return integer_one_node;
3674 /* We can compare via memcpy if the strings are known to be equal
3675 in length and they are
3677 - kind=4 and the comparison is for (in)equality. */
3679 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3680 && tree_int_cst_equal (len1, len2)
3681 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3686 chartype = gfc_get_char_type (kind);
3687 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3688 fold_convert (TREE_TYPE(len1),
3689 TYPE_SIZE_UNIT(chartype)),
3691 return build_memcmp_call (str1, str2, tmp);
3694 /* Build a call for the comparison. */
3696 fndecl = gfor_fndecl_compare_string;
3698 fndecl = gfor_fndecl_compare_string_char4;
3702 return build_call_expr_loc (input_location, fndecl, 4,
3703 len1, str1, len2, str2);
3707 /* Return the backend_decl for a procedure pointer component. */
3710 get_proc_ptr_comp (gfc_expr *e)
3716 gfc_init_se (&comp_se, NULL);
3717 e2 = gfc_copy_expr (e);
3718 /* We have to restore the expr type later so that gfc_free_expr frees
3719 the exact same thing that was allocated.
3720 TODO: This is ugly. */
3721 old_type = e2->expr_type;
3722 e2->expr_type = EXPR_VARIABLE;
3723 gfc_conv_expr (&comp_se, e2);
3724 e2->expr_type = old_type;
3726 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3730 /* Convert a typebound function reference from a class object. */
3732 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3737 if (!VAR_P (base_object))
3739 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3740 gfc_add_modify (&se->pre, var, base_object);
3742 se->expr = gfc_class_vptr_get (base_object);
3743 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3745 while (ref && ref->next)
3747 gcc_assert (ref && ref->type == REF_COMPONENT);
3748 if (ref->u.c.sym->attr.extension)
3749 conv_parent_component_references (se, ref);
3750 gfc_conv_component_ref (se, ref);
3751 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3756 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
3760 if (gfc_is_proc_ptr_comp (expr))
3761 tmp = get_proc_ptr_comp (expr);
3762 else if (sym->attr.dummy)
3764 tmp = gfc_get_symbol_decl (sym);
3765 if (sym->attr.proc_pointer)
3766 tmp = build_fold_indirect_ref_loc (input_location,
3768 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3769 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3773 if (!sym->backend_decl)
3774 sym->backend_decl = gfc_get_extern_function_decl (sym);
3776 TREE_USED (sym->backend_decl) = 1;
3778 tmp = sym->backend_decl;
3780 if (sym->attr.cray_pointee)
3782 /* TODO - make the cray pointee a pointer to a procedure,
3783 assign the pointer to it and use it for the call. This
3785 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3786 gfc_get_symbol_decl (sym->cp_pointer));
3787 tmp = gfc_evaluate_now (tmp, &se->pre);
3790 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3792 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3793 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3800 /* Initialize MAPPING. */
3803 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3805 mapping->syms = NULL;
3806 mapping->charlens = NULL;
3810 /* Free all memory held by MAPPING (but not MAPPING itself). */
3813 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3815 gfc_interface_sym_mapping *sym;
3816 gfc_interface_sym_mapping *nextsym;
3818 gfc_charlen *nextcl;
3820 for (sym = mapping->syms; sym; sym = nextsym)
3822 nextsym = sym->next;
3823 sym->new_sym->n.sym->formal = NULL;
3824 gfc_free_symbol (sym->new_sym->n.sym);
3825 gfc_free_expr (sym->expr);
3826 free (sym->new_sym);
3829 for (cl = mapping->charlens; cl; cl = nextcl)
3832 gfc_free_expr (cl->length);
3838 /* Return a copy of gfc_charlen CL. Add the returned structure to
3839 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3841 static gfc_charlen *
3842 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3845 gfc_charlen *new_charlen;
3847 new_charlen = gfc_get_charlen ();
3848 new_charlen->next = mapping->charlens;
3849 new_charlen->length = gfc_copy_expr (cl->length);
3851 mapping->charlens = new_charlen;
3856 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3857 array variable that can be used as the actual argument for dummy
3858 argument SYM. Add any initialization code to BLOCK. PACKED is as
3859 for gfc_get_nodesc_array_type and DATA points to the first element
3860 in the passed array. */
3863 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
3864 gfc_packed packed, tree data)
3869 type = gfc_typenode_for_spec (&sym->ts);
3870 type = gfc_get_nodesc_array_type (type, sym->as, packed,
3871 !sym->attr.target && !sym->attr.pointer
3872 && !sym->attr.proc_pointer);
3874 var = gfc_create_var (type, "ifm");
3875 gfc_add_modify (block, var, fold_convert (type, data));
3881 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3882 and offset of descriptorless array type TYPE given that it has the same
3883 size as DESC. Add any set-up code to BLOCK. */
3886 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
3893 offset = gfc_index_zero_node;
3894 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
3896 dim = gfc_rank_cst[n];
3897 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
3898 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
3900 GFC_TYPE_ARRAY_LBOUND (type, n)
3901 = gfc_conv_descriptor_lbound_get (desc, dim);
3902 GFC_TYPE_ARRAY_UBOUND (type, n)
3903 = gfc_conv_descriptor_ubound_get (desc, dim);
3905 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
3907 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3908 gfc_array_index_type,
3909 gfc_conv_descriptor_ubound_get (desc, dim),
3910 gfc_conv_descriptor_lbound_get (desc, dim));
3911 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3912 gfc_array_index_type,
3913 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
3914 tmp = gfc_evaluate_now (tmp, block);
3915 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
3917 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3918 GFC_TYPE_ARRAY_LBOUND (type, n),
3919 GFC_TYPE_ARRAY_STRIDE (type, n));
3920 offset = fold_build2_loc (input_location, MINUS_EXPR,
3921 gfc_array_index_type, offset, tmp);
3923 offset = gfc_evaluate_now (offset, block);
3924 GFC_TYPE_ARRAY_OFFSET (type) = offset;
3928 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3929 in SE. The caller may still use se->expr and se->string_length after
3930 calling this function. */
3933 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
3934 gfc_symbol * sym, gfc_se * se,
3937 gfc_interface_sym_mapping *sm;
3941 gfc_symbol *new_sym;
3943 gfc_symtree *new_symtree;
3945 /* Create a new symbol to represent the actual argument. */
3946 new_sym = gfc_new_symbol (sym->name, NULL);
3947 new_sym->ts = sym->ts;
3948 new_sym->as = gfc_copy_array_spec (sym->as);
3949 new_sym->attr.referenced = 1;
3950 new_sym->attr.dimension = sym->attr.dimension;
3951 new_sym->attr.contiguous = sym->attr.contiguous;
3952 new_sym->attr.codimension = sym->attr.codimension;
3953 new_sym->attr.pointer = sym->attr.pointer;
3954 new_sym->attr.allocatable = sym->attr.allocatable;
3955 new_sym->attr.flavor = sym->attr.flavor;
3956 new_sym->attr.function = sym->attr.function;
3958 /* Ensure that the interface is available and that
3959 descriptors are passed for array actual arguments. */
3960 if (sym->attr.flavor == FL_PROCEDURE)
3962 new_sym->formal = expr->symtree->n.sym->formal;
3963 new_sym->attr.always_explicit
3964 = expr->symtree->n.sym->attr.always_explicit;
3967 /* Create a fake symtree for it. */
3969 new_symtree = gfc_new_symtree (&root, sym->name);
3970 new_symtree->n.sym = new_sym;
3971 gcc_assert (new_symtree == root);
3973 /* Create a dummy->actual mapping. */
3974 sm = XCNEW (gfc_interface_sym_mapping);
3975 sm->next = mapping->syms;
3977 sm->new_sym = new_symtree;
3978 sm->expr = gfc_copy_expr (expr);
3981 /* Stabilize the argument's value. */
3982 if (!sym->attr.function && se)
3983 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3985 if (sym->ts.type == BT_CHARACTER)
3987 /* Create a copy of the dummy argument's length. */
3988 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
3989 sm->expr->ts.u.cl = new_sym->ts.u.cl;
3991 /* If the length is specified as "*", record the length that
3992 the caller is passing. We should use the callee's length
3993 in all other cases. */
3994 if (!new_sym->ts.u.cl->length && se)
3996 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
3997 new_sym->ts.u.cl->backend_decl = se->string_length;
4004 /* Use the passed value as-is if the argument is a function. */
4005 if (sym->attr.flavor == FL_PROCEDURE)
4008 /* If the argument is a pass-by-value scalar, use the value as is. */
4009 else if (!sym->attr.dimension && sym->attr.value)
4012 /* If the argument is either a string or a pointer to a string,
4013 convert it to a boundless character type. */
4014 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4016 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4017 tmp = build_pointer_type (tmp);
4018 if (sym->attr.pointer)
4019 value = build_fold_indirect_ref_loc (input_location,
4023 value = fold_convert (tmp, value);
4026 /* If the argument is a scalar, a pointer to an array or an allocatable,
4028 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4029 value = build_fold_indirect_ref_loc (input_location,
4032 /* For character(*), use the actual argument's descriptor. */
4033 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4034 value = build_fold_indirect_ref_loc (input_location,
4037 /* If the argument is an array descriptor, use it to determine
4038 information about the actual argument's shape. */
4039 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4040 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4042 /* Get the actual argument's descriptor. */
4043 desc = build_fold_indirect_ref_loc (input_location,
4046 /* Create the replacement variable. */
4047 tmp = gfc_conv_descriptor_data_get (desc);
4048 value = gfc_get_interface_mapping_array (&se->pre, sym,
4051 /* Use DESC to work out the upper bounds, strides and offset. */
4052 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4055 /* Otherwise we have a packed array. */
4056 value = gfc_get_interface_mapping_array (&se->pre, sym,
4057 PACKED_FULL, se->expr);
4059 new_sym->backend_decl = value;
4063 /* Called once all dummy argument mappings have been added to MAPPING,
4064 but before the mapping is used to evaluate expressions. Pre-evaluate
4065 the length of each argument, adding any initialization code to PRE and
4066 any finalization code to POST. */
4069 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4070 stmtblock_t * pre, stmtblock_t * post)
4072 gfc_interface_sym_mapping *sym;
4076 for (sym = mapping->syms; sym; sym = sym->next)
4077 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4078 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4080 expr = sym->new_sym->n.sym->ts.u.cl->length;
4081 gfc_apply_interface_mapping_to_expr (mapping, expr);
4082 gfc_init_se (&se, NULL);
4083 gfc_conv_expr (&se, expr);
4084 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4085 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4086 gfc_add_block_to_block (pre, &se.pre);
4087 gfc_add_block_to_block (post, &se.post);
4089 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4094 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4098 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4099 gfc_constructor_base base)
4102 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4104 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4107 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4108 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4109 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4115 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4119 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4124 for (; ref; ref = ref->next)
4128 for (n = 0; n < ref->u.ar.dimen; n++)
4130 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4131 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4132 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4140 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4141 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4147 /* Convert intrinsic function calls into result expressions. */
4150 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4158 arg1 = expr->value.function.actual->expr;
4159 if (expr->value.function.actual->next)
4160 arg2 = expr->value.function.actual->next->expr;
4164 sym = arg1->symtree->n.sym;
4166 if (sym->attr.dummy)
4171 switch (expr->value.function.isym->id)
4174 /* TODO figure out why this condition is necessary. */
4175 if (sym->attr.function
4176 && (arg1->ts.u.cl->length == NULL
4177 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4178 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4181 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4184 case GFC_ISYM_LEN_TRIM:
4185 new_expr = gfc_copy_expr (arg1);
4186 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4191 gfc_replace_expr (arg1, new_expr);
4195 if (!sym->as || sym->as->rank == 0)
4198 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4200 dup = mpz_get_si (arg2->value.integer);
4205 dup = sym->as->rank;
4209 for (; d < dup; d++)
4213 if (!sym->as->upper[d] || !sym->as->lower[d])
4215 gfc_free_expr (new_expr);
4219 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4220 gfc_get_int_expr (gfc_default_integer_kind,
4222 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4224 new_expr = gfc_multiply (new_expr, tmp);
4230 case GFC_ISYM_LBOUND:
4231 case GFC_ISYM_UBOUND:
4232 /* TODO These implementations of lbound and ubound do not limit if
4233 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4235 if (!sym->as || sym->as->rank == 0)
4238 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4239 d = mpz_get_si (arg2->value.integer) - 1;
4243 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4245 if (sym->as->lower[d])
4246 new_expr = gfc_copy_expr (sym->as->lower[d]);
4250 if (sym->as->upper[d])
4251 new_expr = gfc_copy_expr (sym->as->upper[d]);
4259 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4263 gfc_replace_expr (expr, new_expr);
4269 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4270 gfc_interface_mapping * mapping)
4272 gfc_formal_arglist *f;
4273 gfc_actual_arglist *actual;
4275 actual = expr->value.function.actual;
4276 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4278 for (; f && actual; f = f->next, actual = actual->next)
4283 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4286 if (map_expr->symtree->n.sym->attr.dimension)
4291 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4293 for (d = 0; d < as->rank; d++)
4295 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4296 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4299 expr->value.function.esym->as = as;
4302 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4304 expr->value.function.esym->ts.u.cl->length
4305 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4307 gfc_apply_interface_mapping_to_expr (mapping,
4308 expr->value.function.esym->ts.u.cl->length);
4313 /* EXPR is a copy of an expression that appeared in the interface
4314 associated with MAPPING. Walk it recursively looking for references to
4315 dummy arguments that MAPPING maps to actual arguments. Replace each such
4316 reference with a reference to the associated actual argument. */
4319 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4322 gfc_interface_sym_mapping *sym;
4323 gfc_actual_arglist *actual;
4328 /* Copying an expression does not copy its length, so do that here. */
4329 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4331 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4332 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4335 /* Apply the mapping to any references. */
4336 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4338 /* ...and to the expression's symbol, if it has one. */
4339 /* TODO Find out why the condition on expr->symtree had to be moved into
4340 the loop rather than being outside it, as originally. */
4341 for (sym = mapping->syms; sym; sym = sym->next)
4342 if (expr->symtree && sym->old == expr->symtree->n.sym)
4344 if (sym->new_sym->n.sym->backend_decl)
4345 expr->symtree = sym->new_sym;
4347 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4350 /* ...and to subexpressions in expr->value. */
4351 switch (expr->expr_type)
4356 case EXPR_SUBSTRING:
4360 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4361 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4365 for (actual = expr->value.function.actual; actual; actual = actual->next)
4366 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4368 if (expr->value.function.esym == NULL
4369 && expr->value.function.isym != NULL
4370 && expr->value.function.actual
4371 && expr->value.function.actual->expr
4372 && expr->value.function.actual->expr->symtree
4373 && gfc_map_intrinsic_function (expr, mapping))
4376 for (sym = mapping->syms; sym; sym = sym->next)
4377 if (sym->old == expr->value.function.esym)
4379 expr->value.function.esym = sym->new_sym->n.sym;
4380 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4381 expr->value.function.esym->result = sym->new_sym->n.sym;
4386 case EXPR_STRUCTURE:
4387 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4400 /* Evaluate interface expression EXPR using MAPPING. Store the result
4404 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4405 gfc_se * se, gfc_expr * expr)
4407 expr = gfc_copy_expr (expr);
4408 gfc_apply_interface_mapping_to_expr (mapping, expr);
4409 gfc_conv_expr (se, expr);
4410 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4411 gfc_free_expr (expr);
4415 /* Returns a reference to a temporary array into which a component of
4416 an actual argument derived type array is copied and then returned
4417 after the function call. */
4419 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4420 sym_intent intent, bool formal_ptr)
4428 gfc_array_info *info;
4438 gfc_init_se (&lse, NULL);
4439 gfc_init_se (&rse, NULL);
4441 /* Walk the argument expression. */
4442 rss = gfc_walk_expr (expr);
4444 gcc_assert (rss != gfc_ss_terminator);
4446 /* Initialize the scalarizer. */
4447 gfc_init_loopinfo (&loop);
4448 gfc_add_ss_to_loop (&loop, rss);
4450 /* Calculate the bounds of the scalarization. */
4451 gfc_conv_ss_startstride (&loop);
4453 /* Build an ss for the temporary. */
4454 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4455 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4457 base_type = gfc_typenode_for_spec (&expr->ts);
4458 if (GFC_ARRAY_TYPE_P (base_type)
4459 || GFC_DESCRIPTOR_TYPE_P (base_type))
4460 base_type = gfc_get_element_type (base_type);
4462 if (expr->ts.type == BT_CLASS)
4463 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4465 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4466 ? expr->ts.u.cl->backend_decl
4470 parmse->string_length = loop.temp_ss->info->string_length;
4472 /* Associate the SS with the loop. */
4473 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4475 /* Setup the scalarizing loops. */
4476 gfc_conv_loop_setup (&loop, &expr->where);
4478 /* Pass the temporary descriptor back to the caller. */
4479 info = &loop.temp_ss->info->data.array;
4480 parmse->expr = info->descriptor;
4482 /* Setup the gfc_se structures. */
4483 gfc_copy_loopinfo_to_se (&lse, &loop);
4484 gfc_copy_loopinfo_to_se (&rse, &loop);
4487 lse.ss = loop.temp_ss;
4488 gfc_mark_ss_chain_used (rss, 1);
4489 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4491 /* Start the scalarized loop body. */
4492 gfc_start_scalarized_body (&loop, &body);
4494 /* Translate the expression. */
4495 gfc_conv_expr (&rse, expr);
4497 /* Reset the offset for the function call since the loop
4498 is zero based on the data pointer. Note that the temp
4499 comes first in the loop chain since it is added second. */
4500 if (gfc_is_class_array_function (expr))
4502 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4503 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4504 gfc_index_zero_node);
4507 gfc_conv_tmp_array_ref (&lse);
4509 if (intent != INTENT_OUT)
4511 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4512 gfc_add_expr_to_block (&body, tmp);
4513 gcc_assert (rse.ss == gfc_ss_terminator);
4514 gfc_trans_scalarizing_loops (&loop, &body);
4518 /* Make sure that the temporary declaration survives by merging
4519 all the loop declarations into the current context. */
4520 for (n = 0; n < loop.dimen; n++)
4522 gfc_merge_block_scope (&body);
4523 body = loop.code[loop.order[n]];
4525 gfc_merge_block_scope (&body);
4528 /* Add the post block after the second loop, so that any
4529 freeing of allocated memory is done at the right time. */
4530 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4532 /**********Copy the temporary back again.*********/
4534 gfc_init_se (&lse, NULL);
4535 gfc_init_se (&rse, NULL);
4537 /* Walk the argument expression. */
4538 lss = gfc_walk_expr (expr);
4539 rse.ss = loop.temp_ss;
4542 /* Initialize the scalarizer. */
4543 gfc_init_loopinfo (&loop2);
4544 gfc_add_ss_to_loop (&loop2, lss);
4546 dimen = rse.ss->dimen;
4548 /* Skip the write-out loop for this case. */
4549 if (gfc_is_class_array_function (expr))
4550 goto class_array_fcn;
4552 /* Calculate the bounds of the scalarization. */
4553 gfc_conv_ss_startstride (&loop2);
4555 /* Setup the scalarizing loops. */
4556 gfc_conv_loop_setup (&loop2, &expr->where);
4558 gfc_copy_loopinfo_to_se (&lse, &loop2);
4559 gfc_copy_loopinfo_to_se (&rse, &loop2);
4561 gfc_mark_ss_chain_used (lss, 1);
4562 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4564 /* Declare the variable to hold the temporary offset and start the
4565 scalarized loop body. */
4566 offset = gfc_create_var (gfc_array_index_type, NULL);
4567 gfc_start_scalarized_body (&loop2, &body);
4569 /* Build the offsets for the temporary from the loop variables. The
4570 temporary array has lbounds of zero and strides of one in all
4571 dimensions, so this is very simple. The offset is only computed
4572 outside the innermost loop, so the overall transfer could be
4573 optimized further. */
4574 info = &rse.ss->info->data.array;
4576 tmp_index = gfc_index_zero_node;
4577 for (n = dimen - 1; n > 0; n--)
4580 tmp = rse.loop->loopvar[n];
4581 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4582 tmp, rse.loop->from[n]);
4583 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4586 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4587 gfc_array_index_type,
4588 rse.loop->to[n-1], rse.loop->from[n-1]);
4589 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4590 gfc_array_index_type,
4591 tmp_str, gfc_index_one_node);
4593 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4594 gfc_array_index_type, tmp, tmp_str);
4597 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4598 gfc_array_index_type,
4599 tmp_index, rse.loop->from[0]);
4600 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4602 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4603 gfc_array_index_type,
4604 rse.loop->loopvar[0], offset);
4606 /* Now use the offset for the reference. */
4607 tmp = build_fold_indirect_ref_loc (input_location,
4609 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4611 if (expr->ts.type == BT_CHARACTER)
4612 rse.string_length = expr->ts.u.cl->backend_decl;
4614 gfc_conv_expr (&lse, expr);
4616 gcc_assert (lse.ss == gfc_ss_terminator);
4618 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4619 gfc_add_expr_to_block (&body, tmp);
4621 /* Generate the copying loops. */
4622 gfc_trans_scalarizing_loops (&loop2, &body);
4624 /* Wrap the whole thing up by adding the second loop to the post-block
4625 and following it by the post-block of the first loop. In this way,
4626 if the temporary needs freeing, it is done after use! */
4627 if (intent != INTENT_IN)
4629 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4630 gfc_add_block_to_block (&parmse->post, &loop2.post);
4635 gfc_add_block_to_block (&parmse->post, &loop.post);
4637 gfc_cleanup_loop (&loop);
4638 gfc_cleanup_loop (&loop2);
4640 /* Pass the string length to the argument expression. */
4641 if (expr->ts.type == BT_CHARACTER)
4642 parmse->string_length = expr->ts.u.cl->backend_decl;
4644 /* Determine the offset for pointer formal arguments and set the
4648 size = gfc_index_one_node;
4649 offset = gfc_index_zero_node;
4650 for (n = 0; n < dimen; n++)
4652 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4654 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4655 gfc_array_index_type, tmp,
4656 gfc_index_one_node);
4657 gfc_conv_descriptor_ubound_set (&parmse->pre,
4661 gfc_conv_descriptor_lbound_set (&parmse->pre,
4664 gfc_index_one_node);
4665 size = gfc_evaluate_now (size, &parmse->pre);
4666 offset = fold_build2_loc (input_location, MINUS_EXPR,
4667 gfc_array_index_type,
4669 offset = gfc_evaluate_now (offset, &parmse->pre);
4670 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4671 gfc_array_index_type,
4672 rse.loop->to[n], rse.loop->from[n]);
4673 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4674 gfc_array_index_type,
4675 tmp, gfc_index_one_node);
4676 size = fold_build2_loc (input_location, MULT_EXPR,
4677 gfc_array_index_type, size, tmp);
4680 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4684 /* We want either the address for the data or the address of the descriptor,
4685 depending on the mode of passing array arguments. */
4687 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4689 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4695 /* Generate the code for argument list functions. */
4698 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4700 /* Pass by value for g77 %VAL(arg), pass the address
4701 indirectly for %LOC, else by reference. Thus %REF
4702 is a "do-nothing" and %LOC is the same as an F95
4704 if (strcmp (name, "%VAL") == 0)
4705 gfc_conv_expr (se, expr);
4706 else if (strcmp (name, "%LOC") == 0)
4708 gfc_conv_expr_reference (se, expr);
4709 se->expr = gfc_build_addr_expr (NULL, se->expr);
4711 else if (strcmp (name, "%REF") == 0)
4712 gfc_conv_expr_reference (se, expr);
4714 gfc_error ("Unknown argument list function at %L", &expr->where);
4718 /* This function tells whether the middle-end representation of the expression
4719 E given as input may point to data otherwise accessible through a variable
4721 It is assumed that the only expressions that may alias are variables,
4722 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4724 This function is used to decide whether freeing an expression's allocatable
4725 components is safe or should be avoided.
4727 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4728 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4729 is necessary because for array constructors, aliasing depends on how
4731 - If E is an array constructor used as argument to an elemental procedure,
4732 the array, which is generated through shallow copy by the scalarizer,
4733 is used directly and can alias the expressions it was copied from.
4734 - If E is an array constructor used as argument to a non-elemental
4735 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4736 the array as in the previous case, but then that array is used
4737 to initialize a new descriptor through deep copy. There is no alias
4738 possible in that case.
4739 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4743 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4747 if (e->expr_type == EXPR_VARIABLE)
4749 else if (e->expr_type == EXPR_FUNCTION)
4751 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4753 if (proc_ifc->result != NULL
4754 && ((proc_ifc->result->ts.type == BT_CLASS
4755 && proc_ifc->result->ts.u.derived->attr.is_class
4756 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4757 || proc_ifc->result->attr.pointer))
4762 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4765 for (c = gfc_constructor_first (e->value.constructor);
4766 c; c = gfc_constructor_next (c))
4768 && expr_may_alias_variables (c->expr, array_may_alias))
4775 /* Generate code for a procedure call. Note can return se->post != NULL.
4776 If se->direct_byref is set then se->expr contains the return parameter.
4777 Return nonzero, if the call has alternate specifiers.
4778 'expr' is only needed for procedure pointer components. */
4781 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
4782 gfc_actual_arglist * args, gfc_expr * expr,
4783 vec<tree, va_gc> *append_args)
4785 gfc_interface_mapping mapping;
4786 vec<tree, va_gc> *arglist;
4787 vec<tree, va_gc> *retargs;
4791 gfc_array_info *info;
4798 vec<tree, va_gc> *stringargs;
4799 vec<tree, va_gc> *optionalargs;
4801 gfc_formal_arglist *formal;
4802 gfc_actual_arglist *arg;
4803 int has_alternate_specifier = 0;
4804 bool need_interface_mapping;
4812 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
4813 gfc_component *comp = NULL;
4820 optionalargs = NULL;
4825 comp = gfc_get_proc_ptr_comp (expr);
4827 bool elemental_proc = (comp
4828 && comp->ts.interface
4829 && comp->ts.interface->attr.elemental)
4830 || (comp && comp->attr.elemental)
4831 || sym->attr.elemental;
4835 if (!elemental_proc)
4837 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
4838 if (se->ss->info->useflags)
4840 gcc_assert ((!comp && gfc_return_by_reference (sym)
4841 && sym->result->attr.dimension)
4842 || (comp && comp->attr.dimension)
4843 || gfc_is_class_array_function (expr));
4844 gcc_assert (se->loop != NULL);
4845 /* Access the previously obtained result. */
4846 gfc_conv_tmp_array_ref (se);
4850 info = &se->ss->info->data.array;
4855 gfc_init_block (&post);
4856 gfc_init_interface_mapping (&mapping);
4859 formal = gfc_sym_get_dummy_args (sym);
4860 need_interface_mapping = sym->attr.dimension ||
4861 (sym->ts.type == BT_CHARACTER
4862 && sym->ts.u.cl->length
4863 && sym->ts.u.cl->length->expr_type
4868 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
4869 need_interface_mapping = comp->attr.dimension ||
4870 (comp->ts.type == BT_CHARACTER
4871 && comp->ts.u.cl->length
4872 && comp->ts.u.cl->length->expr_type
4876 base_object = NULL_TREE;
4877 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4878 is the third and fourth argument to such a function call a value
4879 denoting the number of elements to copy (i.e., most of the time the
4880 length of a deferred length string). */
4881 ulim_copy = (formal == NULL)
4882 && UNLIMITED_POLY (sym)
4883 && comp && (strcmp ("_copy", comp->name) == 0);
4885 /* Evaluate the arguments. */
4886 for (arg = args, argc = 0; arg != NULL;
4887 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
4889 bool finalized = false;
4892 fsym = formal ? formal->sym : NULL;
4893 parm_kind = MISSING;
4895 /* If the procedure requires an explicit interface, the actual
4896 argument is passed according to the corresponding formal
4897 argument. If the corresponding formal argument is a POINTER,
4898 ALLOCATABLE or assumed shape, we do not use g77's calling
4899 convention, and pass the address of the array descriptor
4900 instead. Otherwise we use g77's calling convention, in other words
4901 pass the array data pointer without descriptor. */
4902 bool nodesc_arg = fsym != NULL
4903 && !(fsym->attr.pointer || fsym->attr.allocatable)
4905 && fsym->as->type != AS_ASSUMED_SHAPE
4906 && fsym->as->type != AS_ASSUMED_RANK;
4908 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
4910 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
4912 /* Class array expressions are sometimes coming completely unadorned
4913 with either arrayspec or _data component. Correct that here.
4914 OOP-TODO: Move this to the frontend. */
4915 if (e && e->expr_type == EXPR_VARIABLE
4917 && e->ts.type == BT_CLASS
4918 && (CLASS_DATA (e)->attr.codimension
4919 || CLASS_DATA (e)->attr.dimension))
4921 gfc_typespec temp_ts = e->ts;
4922 gfc_add_class_array_ref (e);
4928 if (se->ignore_optional)
4930 /* Some intrinsics have already been resolved to the correct
4934 else if (arg->label)
4936 has_alternate_specifier = 1;
4941 gfc_init_se (&parmse, NULL);
4943 /* For scalar arguments with VALUE attribute which are passed by
4944 value, pass "0" and a hidden argument gives the optional
4946 if (fsym && fsym->attr.optional && fsym->attr.value
4947 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
4948 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
4950 parmse.expr = fold_convert (gfc_sym_type (fsym),
4952 vec_safe_push (optionalargs, boolean_false_node);
4956 /* Pass a NULL pointer for an absent arg. */
4957 parmse.expr = null_pointer_node;
4958 if (arg->missing_arg_type == BT_CHARACTER)
4959 parmse.string_length = build_int_cst (gfc_charlen_type_node,
4964 else if (arg->expr->expr_type == EXPR_NULL
4965 && fsym && !fsym->attr.pointer
4966 && (fsym->ts.type != BT_CLASS
4967 || !CLASS_DATA (fsym)->attr.class_pointer))
4969 /* Pass a NULL pointer to denote an absent arg. */
4970 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
4971 && (fsym->ts.type != BT_CLASS
4972 || !CLASS_DATA (fsym)->attr.allocatable));
4973 gfc_init_se (&parmse, NULL);
4974 parmse.expr = null_pointer_node;
4975 if (arg->missing_arg_type == BT_CHARACTER)
4976 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
4978 else if (fsym && fsym->ts.type == BT_CLASS
4979 && e->ts.type == BT_DERIVED)
4981 /* The derived type needs to be converted to a temporary
4983 gfc_init_se (&parmse, se);
4984 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
4986 && e->expr_type == EXPR_VARIABLE
4987 && e->symtree->n.sym->attr.optional,
4988 CLASS_DATA (fsym)->attr.class_pointer
4989 || CLASS_DATA (fsym)->attr.allocatable);
4991 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
4993 /* The intrinsic type needs to be converted to a temporary
4994 CLASS object for the unlimited polymorphic formal. */
4995 gfc_init_se (&parmse, se);
4996 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
4998 else if (se->ss && se->ss->info->useflags)
5004 /* An elemental function inside a scalarized loop. */
5005 gfc_init_se (&parmse, se);
5006 parm_kind = ELEMENTAL;
5008 /* When no fsym is present, ulim_copy is set and this is a third or
5009 fourth argument, use call-by-value instead of by reference to
5010 hand the length properties to the copy routine (i.e., most of the
5011 time this will be a call to a __copy_character_* routine where the
5012 third and fourth arguments are the lengths of a deferred length
5014 if ((fsym && fsym->attr.value)
5015 || (ulim_copy && (argc == 2 || argc == 3)))
5016 gfc_conv_expr (&parmse, e);
5018 gfc_conv_expr_reference (&parmse, e);
5020 if (e->ts.type == BT_CHARACTER && !e->rank
5021 && e->expr_type == EXPR_FUNCTION)
5022 parmse.expr = build_fold_indirect_ref_loc (input_location,
5025 if (fsym && fsym->ts.type == BT_DERIVED
5026 && gfc_is_class_container_ref (e))
5028 parmse.expr = gfc_class_data_get (parmse.expr);
5030 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5031 && e->symtree->n.sym->attr.optional)
5033 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5034 parmse.expr = build3_loc (input_location, COND_EXPR,
5035 TREE_TYPE (parmse.expr),
5037 fold_convert (TREE_TYPE (parmse.expr),
5038 null_pointer_node));
5042 /* If we are passing an absent array as optional dummy to an
5043 elemental procedure, make sure that we pass NULL when the data
5044 pointer is NULL. We need this extra conditional because of
5045 scalarization which passes arrays elements to the procedure,
5046 ignoring the fact that the array can be absent/unallocated/... */
5047 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5049 tree descriptor_data;
5051 descriptor_data = ss->info->data.array.data;
5052 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5054 fold_convert (TREE_TYPE (descriptor_data),
5055 null_pointer_node));
5057 = fold_build3_loc (input_location, COND_EXPR,
5058 TREE_TYPE (parmse.expr),
5059 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5060 fold_convert (TREE_TYPE (parmse.expr),
5065 /* The scalarizer does not repackage the reference to a class
5066 array - instead it returns a pointer to the data element. */
5067 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5068 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5069 fsym->attr.intent != INTENT_IN
5070 && (CLASS_DATA (fsym)->attr.class_pointer
5071 || CLASS_DATA (fsym)->attr.allocatable),
5073 && e->expr_type == EXPR_VARIABLE
5074 && e->symtree->n.sym->attr.optional,
5075 CLASS_DATA (fsym)->attr.class_pointer
5076 || CLASS_DATA (fsym)->attr.allocatable);
5083 gfc_init_se (&parmse, NULL);
5085 /* Check whether the expression is a scalar or not; we cannot use
5086 e->rank as it can be nonzero for functions arguments. */
5087 argss = gfc_walk_expr (e);
5088 scalar = argss == gfc_ss_terminator;
5090 gfc_free_ss_chain (argss);
5092 /* Special handling for passing scalar polymorphic coarrays;
5093 otherwise one passes "class->_data.data" instead of "&class". */
5094 if (e->rank == 0 && e->ts.type == BT_CLASS
5095 && fsym && fsym->ts.type == BT_CLASS
5096 && CLASS_DATA (fsym)->attr.codimension
5097 && !CLASS_DATA (fsym)->attr.dimension)
5099 gfc_add_class_array_ref (e);
5100 parmse.want_coarray = 1;
5104 /* A scalar or transformational function. */
5107 if (e->expr_type == EXPR_VARIABLE
5108 && e->symtree->n.sym->attr.cray_pointee
5109 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5111 /* The Cray pointer needs to be converted to a pointer to
5112 a type given by the expression. */
5113 gfc_conv_expr (&parmse, e);
5114 type = build_pointer_type (TREE_TYPE (parmse.expr));
5115 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5116 parmse.expr = convert (type, tmp);
5118 else if (fsym && fsym->attr.value)
5120 if (fsym->ts.type == BT_CHARACTER
5121 && fsym->ts.is_c_interop
5122 && fsym->ns->proc_name != NULL
5123 && fsym->ns->proc_name->attr.is_bind_c)
5126 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5127 if (parmse.expr == NULL)
5128 gfc_conv_expr (&parmse, e);
5132 gfc_conv_expr (&parmse, e);
5133 if (fsym->attr.optional
5134 && fsym->ts.type != BT_CLASS
5135 && fsym->ts.type != BT_DERIVED)
5137 if (e->expr_type != EXPR_VARIABLE
5138 || !e->symtree->n.sym->attr.optional
5140 vec_safe_push (optionalargs, boolean_true_node);
5143 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5144 if (!e->symtree->n.sym->attr.value)
5146 = fold_build3_loc (input_location, COND_EXPR,
5147 TREE_TYPE (parmse.expr),
5149 fold_convert (TREE_TYPE (parmse.expr),
5150 integer_zero_node));
5152 vec_safe_push (optionalargs, tmp);
5157 else if (arg->name && arg->name[0] == '%')
5158 /* Argument list functions %VAL, %LOC and %REF are signalled
5159 through arg->name. */
5160 conv_arglist_function (&parmse, arg->expr, arg->name);
5161 else if ((e->expr_type == EXPR_FUNCTION)
5162 && ((e->value.function.esym
5163 && e->value.function.esym->result->attr.pointer)
5164 || (!e->value.function.esym
5165 && e->symtree->n.sym->attr.pointer))
5166 && fsym && fsym->attr.target)
5168 gfc_conv_expr (&parmse, e);
5169 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5171 else if (e->expr_type == EXPR_FUNCTION
5172 && e->symtree->n.sym->result
5173 && e->symtree->n.sym->result != e->symtree->n.sym
5174 && e->symtree->n.sym->result->attr.proc_pointer)
5176 /* Functions returning procedure pointers. */
5177 gfc_conv_expr (&parmse, e);
5178 if (fsym && fsym->attr.proc_pointer)
5179 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5183 if (e->ts.type == BT_CLASS && fsym
5184 && fsym->ts.type == BT_CLASS
5185 && (!CLASS_DATA (fsym)->as
5186 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5187 && CLASS_DATA (e)->attr.codimension)
5189 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5190 gcc_assert (!CLASS_DATA (fsym)->as);
5191 gfc_add_class_array_ref (e);
5192 parmse.want_coarray = 1;
5193 gfc_conv_expr_reference (&parmse, e);
5194 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5196 && e->expr_type == EXPR_VARIABLE);
5198 else if (e->ts.type == BT_CLASS && fsym
5199 && fsym->ts.type == BT_CLASS
5200 && !CLASS_DATA (fsym)->as
5201 && !CLASS_DATA (e)->as
5202 && strcmp (fsym->ts.u.derived->name,
5203 e->ts.u.derived->name))
5205 type = gfc_typenode_for_spec (&fsym->ts);
5206 var = gfc_create_var (type, fsym->name);
5207 gfc_conv_expr (&parmse, e);
5208 if (fsym->attr.optional
5209 && e->expr_type == EXPR_VARIABLE
5210 && e->symtree->n.sym->attr.optional)
5214 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5215 cond = fold_build2_loc (input_location, NE_EXPR,
5216 logical_type_node, tmp,
5217 fold_convert (TREE_TYPE (tmp),
5218 null_pointer_node));
5219 gfc_start_block (&block);
5220 gfc_add_modify (&block, var,
5221 fold_build1_loc (input_location,
5223 type, parmse.expr));
5224 gfc_add_expr_to_block (&parmse.pre,
5225 fold_build3_loc (input_location,
5226 COND_EXPR, void_type_node,
5227 cond, gfc_finish_block (&block),
5228 build_empty_stmt (input_location)));
5229 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5230 parmse.expr = build3_loc (input_location, COND_EXPR,
5231 TREE_TYPE (parmse.expr),
5233 fold_convert (TREE_TYPE (parmse.expr),
5234 null_pointer_node));
5238 /* Since the internal representation of unlimited
5239 polymorphic expressions includes an extra field
5240 that other class objects do not, a cast to the
5241 formal type does not work. */
5242 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5246 /* Set the _data field. */
5247 tmp = gfc_class_data_get (var);
5248 efield = fold_convert (TREE_TYPE (tmp),
5249 gfc_class_data_get (parmse.expr));
5250 gfc_add_modify (&parmse.pre, tmp, efield);
5252 /* Set the _vptr field. */
5253 tmp = gfc_class_vptr_get (var);
5254 efield = fold_convert (TREE_TYPE (tmp),
5255 gfc_class_vptr_get (parmse.expr));
5256 gfc_add_modify (&parmse.pre, tmp, efield);
5258 /* Set the _len field. */
5259 tmp = gfc_class_len_get (var);
5260 gfc_add_modify (&parmse.pre, tmp,
5261 build_int_cst (TREE_TYPE (tmp), 0));
5265 tmp = fold_build1_loc (input_location,
5268 gfc_add_modify (&parmse.pre, var, tmp);
5271 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5277 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5278 && !fsym->attr.allocatable && !fsym->attr.pointer
5279 && !e->symtree->n.sym->attr.dimension
5280 && !e->symtree->n.sym->attr.pointer
5282 && !e->symtree->n.sym->attr.dummy
5283 /* FIXME - PR 87395 and PR 41453 */
5284 && e->symtree->n.sym->attr.save == SAVE_NONE
5285 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5286 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5288 gfc_conv_expr_reference (&parmse, e, add_clobber);
5290 /* Catch base objects that are not variables. */
5291 if (e->ts.type == BT_CLASS
5292 && e->expr_type != EXPR_VARIABLE
5293 && expr && e == expr->base_expr)
5294 base_object = build_fold_indirect_ref_loc (input_location,
5297 /* A class array element needs converting back to be a
5298 class object, if the formal argument is a class object. */
5299 if (fsym && fsym->ts.type == BT_CLASS
5300 && e->ts.type == BT_CLASS
5301 && ((CLASS_DATA (fsym)->as
5302 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5303 || CLASS_DATA (e)->attr.dimension))
5304 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5305 fsym->attr.intent != INTENT_IN
5306 && (CLASS_DATA (fsym)->attr.class_pointer
5307 || CLASS_DATA (fsym)->attr.allocatable),
5309 && e->expr_type == EXPR_VARIABLE
5310 && e->symtree->n.sym->attr.optional,
5311 CLASS_DATA (fsym)->attr.class_pointer
5312 || CLASS_DATA (fsym)->attr.allocatable);
5314 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5315 allocated on entry, it must be deallocated. */
5316 if (fsym && fsym->attr.intent == INTENT_OUT
5317 && (fsym->attr.allocatable
5318 || (fsym->ts.type == BT_CLASS
5319 && CLASS_DATA (fsym)->attr.allocatable)))
5324 gfc_init_block (&block);
5326 if (e->ts.type == BT_CLASS)
5327 ptr = gfc_class_data_get (ptr);
5329 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5332 gfc_add_expr_to_block (&block, tmp);
5333 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5334 void_type_node, ptr,
5336 gfc_add_expr_to_block (&block, tmp);
5338 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5340 gfc_add_modify (&block, ptr,
5341 fold_convert (TREE_TYPE (ptr),
5342 null_pointer_node));
5343 gfc_add_expr_to_block (&block, tmp);
5345 else if (fsym->ts.type == BT_CLASS)
5348 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5349 tmp = gfc_get_symbol_decl (vtab);
5350 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5351 ptr = gfc_class_vptr_get (parmse.expr);
5352 gfc_add_modify (&block, ptr,
5353 fold_convert (TREE_TYPE (ptr), tmp));
5354 gfc_add_expr_to_block (&block, tmp);
5357 if (fsym->attr.optional
5358 && e->expr_type == EXPR_VARIABLE
5359 && e->symtree->n.sym->attr.optional)
5361 tmp = fold_build3_loc (input_location, COND_EXPR,
5363 gfc_conv_expr_present (e->symtree->n.sym),
5364 gfc_finish_block (&block),
5365 build_empty_stmt (input_location));
5368 tmp = gfc_finish_block (&block);
5370 gfc_add_expr_to_block (&se->pre, tmp);
5373 if (fsym && (fsym->ts.type == BT_DERIVED
5374 || fsym->ts.type == BT_ASSUMED)
5375 && e->ts.type == BT_CLASS
5376 && !CLASS_DATA (e)->attr.dimension
5377 && !CLASS_DATA (e)->attr.codimension)
5379 parmse.expr = gfc_class_data_get (parmse.expr);
5380 /* The result is a class temporary, whose _data component
5381 must be freed to avoid a memory leak. */
5382 if (e->expr_type == EXPR_FUNCTION
5383 && CLASS_DATA (e)->attr.allocatable)
5389 /* Borrow the function symbol to make a call to
5390 gfc_add_finalizer_call and then restore it. */
5391 tmp = e->symtree->n.sym->backend_decl;
5392 e->symtree->n.sym->backend_decl
5393 = TREE_OPERAND (parmse.expr, 0);
5394 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5395 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5396 finalized = gfc_add_finalizer_call (&parmse.post,
5398 gfc_free_expr (var);
5399 e->symtree->n.sym->backend_decl = tmp;
5400 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5402 /* Then free the class _data. */
5403 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5404 tmp = fold_build2_loc (input_location, NE_EXPR,
5407 tmp = build3_v (COND_EXPR, tmp,
5408 gfc_call_free (parmse.expr),
5409 build_empty_stmt (input_location));
5410 gfc_add_expr_to_block (&parmse.post, tmp);
5411 gfc_add_modify (&parmse.post, parmse.expr, zero);
5415 /* Wrap scalar variable in a descriptor. We need to convert
5416 the address of a pointer back to the pointer itself before,
5417 we can assign it to the data field. */
5419 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5420 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5423 if (TREE_CODE (tmp) == ADDR_EXPR)
5424 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5425 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5427 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5430 else if (fsym && e->expr_type != EXPR_NULL
5431 && ((fsym->attr.pointer
5432 && fsym->attr.flavor != FL_PROCEDURE)
5433 || (fsym->attr.proc_pointer
5434 && !(e->expr_type == EXPR_VARIABLE
5435 && e->symtree->n.sym->attr.dummy))
5436 || (fsym->attr.proc_pointer
5437 && e->expr_type == EXPR_VARIABLE
5438 && gfc_is_proc_ptr_comp (e))
5439 || (fsym->attr.allocatable
5440 && fsym->attr.flavor != FL_PROCEDURE)))
5442 /* Scalar pointer dummy args require an extra level of
5443 indirection. The null pointer already contains
5444 this level of indirection. */
5445 parm_kind = SCALAR_POINTER;
5446 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5450 else if (e->ts.type == BT_CLASS
5451 && fsym && fsym->ts.type == BT_CLASS
5452 && (CLASS_DATA (fsym)->attr.dimension
5453 || CLASS_DATA (fsym)->attr.codimension))
5455 /* Pass a class array. */
5456 parmse.use_offset = 1;
5457 gfc_conv_expr_descriptor (&parmse, e);
5459 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5460 allocated on entry, it must be deallocated. */
5461 if (fsym->attr.intent == INTENT_OUT
5462 && CLASS_DATA (fsym)->attr.allocatable)
5467 gfc_init_block (&block);
5469 ptr = gfc_class_data_get (ptr);
5471 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5472 NULL_TREE, NULL_TREE,
5474 GFC_CAF_COARRAY_NOCOARRAY);
5475 gfc_add_expr_to_block (&block, tmp);
5476 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5477 void_type_node, ptr,
5479 gfc_add_expr_to_block (&block, tmp);
5480 gfc_reset_vptr (&block, e);
5482 if (fsym->attr.optional
5483 && e->expr_type == EXPR_VARIABLE
5485 || (e->ref->type == REF_ARRAY
5486 && e->ref->u.ar.type != AR_FULL))
5487 && e->symtree->n.sym->attr.optional)
5489 tmp = fold_build3_loc (input_location, COND_EXPR,
5491 gfc_conv_expr_present (e->symtree->n.sym),
5492 gfc_finish_block (&block),
5493 build_empty_stmt (input_location));
5496 tmp = gfc_finish_block (&block);
5498 gfc_add_expr_to_block (&se->pre, tmp);
5501 /* The conversion does not repackage the reference to a class
5502 array - _data descriptor. */
5503 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5504 fsym->attr.intent != INTENT_IN
5505 && (CLASS_DATA (fsym)->attr.class_pointer
5506 || CLASS_DATA (fsym)->attr.allocatable),
5508 && e->expr_type == EXPR_VARIABLE
5509 && e->symtree->n.sym->attr.optional,
5510 CLASS_DATA (fsym)->attr.class_pointer
5511 || CLASS_DATA (fsym)->attr.allocatable);
5515 /* If the argument is a function call that may not create
5516 a temporary for the result, we have to check that we
5517 can do it, i.e. that there is no alias between this
5518 argument and another one. */
5519 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5525 intent = fsym->attr.intent;
5527 intent = INTENT_UNKNOWN;
5529 if (gfc_check_fncall_dependency (e, intent, sym, args,
5531 parmse.force_tmp = 1;
5533 iarg = e->value.function.actual->expr;
5535 /* Temporary needed if aliasing due to host association. */
5536 if (sym->attr.contained
5538 && !sym->attr.implicit_pure
5539 && !sym->attr.use_assoc
5540 && iarg->expr_type == EXPR_VARIABLE
5541 && sym->ns == iarg->symtree->n.sym->ns)
5542 parmse.force_tmp = 1;
5544 /* Ditto within module. */
5545 if (sym->attr.use_assoc
5547 && !sym->attr.implicit_pure
5548 && iarg->expr_type == EXPR_VARIABLE
5549 && sym->module == iarg->symtree->n.sym->module)
5550 parmse.force_tmp = 1;
5553 if (e->expr_type == EXPR_VARIABLE
5554 && is_subref_array (e)
5555 && !(fsym && fsym->attr.pointer))
5556 /* The actual argument is a component reference to an
5557 array of derived types. In this case, the argument
5558 is converted to a temporary, which is passed and then
5559 written back after the procedure call. */
5560 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5561 fsym ? fsym->attr.intent : INTENT_INOUT,
5562 fsym && fsym->attr.pointer);
5563 else if (gfc_is_class_array_ref (e, NULL)
5564 && fsym && fsym->ts.type == BT_DERIVED)
5565 /* The actual argument is a component reference to an
5566 array of derived types. In this case, the argument
5567 is converted to a temporary, which is passed and then
5568 written back after the procedure call.
5569 OOP-TODO: Insert code so that if the dynamic type is
5570 the same as the declared type, copy-in/copy-out does
5572 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5573 fsym ? fsym->attr.intent : INTENT_INOUT,
5574 fsym && fsym->attr.pointer);
5576 else if (gfc_is_class_array_function (e)
5577 && fsym && fsym->ts.type == BT_DERIVED)
5578 /* See previous comment. For function actual argument,
5579 the write out is not needed so the intent is set as
5582 e->must_finalize = 1;
5583 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5585 fsym && fsym->attr.pointer);
5588 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5591 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5592 allocated on entry, it must be deallocated. */
5593 if (fsym && fsym->attr.allocatable
5594 && fsym->attr.intent == INTENT_OUT)
5596 if (fsym->ts.type == BT_DERIVED
5597 && fsym->ts.u.derived->attr.alloc_comp)
5599 // deallocate the components first
5600 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5601 parmse.expr, e->rank);
5602 if (tmp != NULL_TREE)
5603 gfc_add_expr_to_block (&se->pre, tmp);
5606 tmp = build_fold_indirect_ref_loc (input_location,
5608 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5609 tmp = gfc_conv_descriptor_data_get (tmp);
5610 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5611 NULL_TREE, NULL_TREE, true,
5613 GFC_CAF_COARRAY_NOCOARRAY);
5614 if (fsym->attr.optional
5615 && e->expr_type == EXPR_VARIABLE
5616 && e->symtree->n.sym->attr.optional)
5617 tmp = fold_build3_loc (input_location, COND_EXPR,
5619 gfc_conv_expr_present (e->symtree->n.sym),
5620 tmp, build_empty_stmt (input_location));
5621 gfc_add_expr_to_block (&se->pre, tmp);
5626 /* The case with fsym->attr.optional is that of a user subroutine
5627 with an interface indicating an optional argument. When we call
5628 an intrinsic subroutine, however, fsym is NULL, but we might still
5629 have an optional argument, so we proceed to the substitution
5631 if (e && (fsym == NULL || fsym->attr.optional))
5633 /* If an optional argument is itself an optional dummy argument,
5634 check its presence and substitute a null if absent. This is
5635 only needed when passing an array to an elemental procedure
5636 as then array elements are accessed - or no NULL pointer is
5637 allowed and a "1" or "0" should be passed if not present.
5638 When passing a non-array-descriptor full array to a
5639 non-array-descriptor dummy, no check is needed. For
5640 array-descriptor actual to array-descriptor dummy, see
5641 PR 41911 for why a check has to be inserted.
5642 fsym == NULL is checked as intrinsics required the descriptor
5643 but do not always set fsym. */
5644 if (e->expr_type == EXPR_VARIABLE
5645 && e->symtree->n.sym->attr.optional
5646 && ((e->rank != 0 && elemental_proc)
5647 || e->representation.length || e->ts.type == BT_CHARACTER
5651 && (fsym->as->type == AS_ASSUMED_SHAPE
5652 || fsym->as->type == AS_ASSUMED_RANK
5653 || fsym->as->type == AS_DEFERRED))))))
5654 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
5655 e->representation.length);
5660 /* Obtain the character length of an assumed character length
5661 length procedure from the typespec. */
5662 if (fsym->ts.type == BT_CHARACTER
5663 && parmse.string_length == NULL_TREE
5664 && e->ts.type == BT_PROCEDURE
5665 && e->symtree->n.sym->ts.type == BT_CHARACTER
5666 && e->symtree->n.sym->ts.u.cl->length != NULL
5667 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5669 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
5670 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
5674 if (fsym && need_interface_mapping && e)
5675 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
5677 gfc_add_block_to_block (&se->pre, &parmse.pre);
5678 gfc_add_block_to_block (&post, &parmse.post);
5680 /* Allocated allocatable components of derived types must be
5681 deallocated for non-variable scalars, array arguments to elemental
5682 procedures, and array arguments with descriptor to non-elemental
5683 procedures. As bounds information for descriptorless arrays is no
5684 longer available here, they are dealt with in trans-array.c
5685 (gfc_conv_array_parameter). */
5686 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
5687 && e->ts.u.derived->attr.alloc_comp
5688 && (e->rank == 0 || elemental_proc || !nodesc_arg)
5689 && !expr_may_alias_variables (e, elemental_proc))
5692 /* It is known the e returns a structure type with at least one
5693 allocatable component. When e is a function, ensure that the
5694 function is called once only by using a temporary variable. */
5695 if (!DECL_P (parmse.expr))
5696 parmse.expr = gfc_evaluate_now_loc (input_location,
5697 parmse.expr, &se->pre);
5699 if (fsym && fsym->attr.value)
5702 tmp = build_fold_indirect_ref_loc (input_location,
5705 parm_rank = e->rank;
5713 case (SCALAR_POINTER):
5714 tmp = build_fold_indirect_ref_loc (input_location,
5719 if (e->expr_type == EXPR_OP
5720 && e->value.op.op == INTRINSIC_PARENTHESES
5721 && e->value.op.op1->expr_type == EXPR_VARIABLE)
5724 local_tmp = gfc_evaluate_now (tmp, &se->pre);
5725 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
5727 gfc_add_expr_to_block (&se->post, local_tmp);
5730 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
5732 /* The derived type is passed to gfc_deallocate_alloc_comp.
5733 Therefore, class actuals can handled correctly but derived
5734 types passed to class formals need the _data component. */
5735 tmp = gfc_class_data_get (tmp);
5736 if (!CLASS_DATA (fsym)->attr.dimension)
5737 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5740 if (!finalized && !e->must_finalize)
5742 if ((e->ts.type == BT_CLASS
5743 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
5744 || e->ts.type == BT_DERIVED)
5745 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
5747 else if (e->ts.type == BT_CLASS)
5748 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
5750 gfc_prepend_expr_to_block (&post, tmp);
5754 /* Add argument checking of passing an unallocated/NULL actual to
5755 a nonallocatable/nonpointer dummy. */
5757 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
5759 symbol_attribute attr;
5763 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
5764 attr = gfc_expr_attr (e);
5766 goto end_pointer_check;
5768 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5769 allocatable to an optional dummy, cf. 12.5.2.12. */
5770 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
5771 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5772 goto end_pointer_check;
5776 /* If the actual argument is an optional pointer/allocatable and
5777 the formal argument takes an nonpointer optional value,
5778 it is invalid to pass a non-present argument on, even
5779 though there is no technical reason for this in gfortran.
5780 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5781 tree present, null_ptr, type;
5783 if (attr.allocatable
5784 && (fsym == NULL || !fsym->attr.allocatable))
5785 msg = xasprintf ("Allocatable actual argument '%s' is not "
5786 "allocated or not present",
5787 e->symtree->n.sym->name);
5788 else if (attr.pointer
5789 && (fsym == NULL || !fsym->attr.pointer))
5790 msg = xasprintf ("Pointer actual argument '%s' is not "
5791 "associated or not present",
5792 e->symtree->n.sym->name);
5793 else if (attr.proc_pointer
5794 && (fsym == NULL || !fsym->attr.proc_pointer))
5795 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5796 "associated or not present",
5797 e->symtree->n.sym->name);
5799 goto end_pointer_check;
5801 present = gfc_conv_expr_present (e->symtree->n.sym);
5802 type = TREE_TYPE (present);
5803 present = fold_build2_loc (input_location, EQ_EXPR,
5804 logical_type_node, present,
5806 null_pointer_node));
5807 type = TREE_TYPE (parmse.expr);
5808 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
5809 logical_type_node, parmse.expr,
5811 null_pointer_node));
5812 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
5813 logical_type_node, present, null_ptr);
5817 if (attr.allocatable
5818 && (fsym == NULL || !fsym->attr.allocatable))
5819 msg = xasprintf ("Allocatable actual argument '%s' is not "
5820 "allocated", e->symtree->n.sym->name);
5821 else if (attr.pointer
5822 && (fsym == NULL || !fsym->attr.pointer))
5823 msg = xasprintf ("Pointer actual argument '%s' is not "
5824 "associated", e->symtree->n.sym->name);
5825 else if (attr.proc_pointer
5826 && (fsym == NULL || !fsym->attr.proc_pointer))
5827 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5828 "associated", e->symtree->n.sym->name);
5830 goto end_pointer_check;
5834 /* If the argument is passed by value, we need to strip the
5836 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
5837 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5839 cond = fold_build2_loc (input_location, EQ_EXPR,
5840 logical_type_node, tmp,
5841 fold_convert (TREE_TYPE (tmp),
5842 null_pointer_node));
5845 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
5851 /* Deferred length dummies pass the character length by reference
5852 so that the value can be returned. */
5853 if (parmse.string_length && fsym && fsym->ts.deferred)
5855 if (INDIRECT_REF_P (parmse.string_length))
5856 /* In chains of functions/procedure calls the string_length already
5857 is a pointer to the variable holding the length. Therefore
5858 remove the deref on call. */
5859 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
5862 tmp = parmse.string_length;
5863 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
5864 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
5865 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
5869 /* Character strings are passed as two parameters, a length and a
5870 pointer - except for Bind(c) which only passes the pointer.
5871 An unlimited polymorphic formal argument likewise does not
5873 if (parmse.string_length != NULL_TREE
5874 && !sym->attr.is_bind_c
5875 && !(fsym && UNLIMITED_POLY (fsym)))
5876 vec_safe_push (stringargs, parmse.string_length);
5878 /* When calling __copy for character expressions to unlimited
5879 polymorphic entities, the dst argument needs a string length. */
5880 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
5881 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
5882 && arg->next && arg->next->expr
5883 && (arg->next->expr->ts.type == BT_DERIVED
5884 || arg->next->expr->ts.type == BT_CLASS)
5885 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
5886 vec_safe_push (stringargs, parmse.string_length);
5888 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5889 pass the token and the offset as additional arguments. */
5890 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
5891 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5892 && !fsym->attr.allocatable)
5893 || (fsym->ts.type == BT_CLASS
5894 && CLASS_DATA (fsym)->attr.codimension
5895 && !CLASS_DATA (fsym)->attr.allocatable)))
5897 /* Token and offset. */
5898 vec_safe_push (stringargs, null_pointer_node);
5899 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
5900 gcc_assert (fsym->attr.optional);
5902 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
5903 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5904 && !fsym->attr.allocatable)
5905 || (fsym->ts.type == BT_CLASS
5906 && CLASS_DATA (fsym)->attr.codimension
5907 && !CLASS_DATA (fsym)->attr.allocatable)))
5909 tree caf_decl, caf_type;
5912 caf_decl = gfc_get_tree_for_caf_expr (e);
5913 caf_type = TREE_TYPE (caf_decl);
5915 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5916 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
5917 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
5918 tmp = gfc_conv_descriptor_token (caf_decl);
5919 else if (DECL_LANG_SPECIFIC (caf_decl)
5920 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
5921 tmp = GFC_DECL_TOKEN (caf_decl);
5924 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
5925 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
5926 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
5929 vec_safe_push (stringargs, tmp);
5931 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5932 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
5933 offset = build_int_cst (gfc_array_index_type, 0);
5934 else if (DECL_LANG_SPECIFIC (caf_decl)
5935 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
5936 offset = GFC_DECL_CAF_OFFSET (caf_decl);
5937 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
5938 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
5940 offset = build_int_cst (gfc_array_index_type, 0);
5942 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
5943 tmp = gfc_conv_descriptor_data_get (caf_decl);
5946 gcc_assert (POINTER_TYPE_P (caf_type));
5950 tmp2 = fsym->ts.type == BT_CLASS
5951 ? gfc_class_data_get (parmse.expr) : parmse.expr;
5952 if ((fsym->ts.type != BT_CLASS
5953 && (fsym->as->type == AS_ASSUMED_SHAPE
5954 || fsym->as->type == AS_ASSUMED_RANK))
5955 || (fsym->ts.type == BT_CLASS
5956 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
5957 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
5959 if (fsym->ts.type == BT_CLASS)
5960 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
5963 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5964 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
5966 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
5967 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5969 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
5970 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5973 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5976 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5977 gfc_array_index_type,
5978 fold_convert (gfc_array_index_type, tmp2),
5979 fold_convert (gfc_array_index_type, tmp));
5980 offset = fold_build2_loc (input_location, PLUS_EXPR,
5981 gfc_array_index_type, offset, tmp);
5983 vec_safe_push (stringargs, offset);
5986 vec_safe_push (arglist, parmse.expr);
5988 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
5992 else if (sym->ts.type == BT_CLASS)
5993 ts = CLASS_DATA (sym)->ts;
5997 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
5998 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
5999 else if (ts.type == BT_CHARACTER)
6001 if (ts.u.cl->length == NULL)
6003 /* Assumed character length results are not allowed by C418 of the 2003
6004 standard and are trapped in resolve.c; except in the case of SPREAD
6005 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6006 we take the character length of the first argument for the result.
6007 For dummies, we have to look through the formal argument list for
6008 this function and use the character length found there.*/
6010 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6011 else if (!sym->attr.dummy)
6012 cl.backend_decl = (*stringargs)[0];
6015 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6016 for (; formal; formal = formal->next)
6017 if (strcmp (formal->sym->name, sym->name) == 0)
6018 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6020 len = cl.backend_decl;
6026 /* Calculate the length of the returned string. */
6027 gfc_init_se (&parmse, NULL);
6028 if (need_interface_mapping)
6029 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6031 gfc_conv_expr (&parmse, ts.u.cl->length);
6032 gfc_add_block_to_block (&se->pre, &parmse.pre);
6033 gfc_add_block_to_block (&se->post, &parmse.post);
6035 /* TODO: It would be better to have the charlens as
6036 gfc_charlen_type_node already when the interface is
6037 created instead of converting it here (see PR 84615). */
6038 tmp = fold_build2_loc (input_location, MAX_EXPR,
6039 gfc_charlen_type_node,
6040 fold_convert (gfc_charlen_type_node, tmp),
6041 build_zero_cst (gfc_charlen_type_node));
6042 cl.backend_decl = tmp;
6045 /* Set up a charlen structure for it. */
6050 len = cl.backend_decl;
6053 byref = (comp && (comp->attr.dimension
6054 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6055 || (!comp && gfc_return_by_reference (sym));
6058 if (se->direct_byref)
6060 /* Sometimes, too much indirection can be applied; e.g. for
6061 function_result = array_valued_recursive_function. */
6062 if (TREE_TYPE (TREE_TYPE (se->expr))
6063 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6064 && GFC_DESCRIPTOR_TYPE_P
6065 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6066 se->expr = build_fold_indirect_ref_loc (input_location,
6069 /* If the lhs of an assignment x = f(..) is allocatable and
6070 f2003 is allowed, we must do the automatic reallocation.
6071 TODO - deal with intrinsics, without using a temporary. */
6072 if (flag_realloc_lhs
6073 && se->ss && se->ss->loop_chain
6074 && se->ss->loop_chain->is_alloc_lhs
6075 && !expr->value.function.isym
6076 && sym->result->as != NULL)
6078 /* Evaluate the bounds of the result, if known. */
6079 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6082 /* Perform the automatic reallocation. */
6083 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6085 gfc_add_expr_to_block (&se->pre, tmp);
6087 /* Pass the temporary as the first argument. */
6088 result = info->descriptor;
6091 result = build_fold_indirect_ref_loc (input_location,
6093 vec_safe_push (retargs, se->expr);
6095 else if (comp && comp->attr.dimension)
6097 gcc_assert (se->loop && info);
6099 /* Set the type of the array. */
6100 tmp = gfc_typenode_for_spec (&comp->ts);
6101 gcc_assert (se->ss->dimen == se->loop->dimen);
6103 /* Evaluate the bounds of the result, if known. */
6104 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6106 /* If the lhs of an assignment x = f(..) is allocatable and
6107 f2003 is allowed, we must not generate the function call
6108 here but should just send back the results of the mapping.
6109 This is signalled by the function ss being flagged. */
6110 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6112 gfc_free_interface_mapping (&mapping);
6113 return has_alternate_specifier;
6116 /* Create a temporary to store the result. In case the function
6117 returns a pointer, the temporary will be a shallow copy and
6118 mustn't be deallocated. */
6119 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6120 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6121 tmp, NULL_TREE, false,
6122 !comp->attr.pointer, callee_alloc,
6123 &se->ss->info->expr->where);
6125 /* Pass the temporary as the first argument. */
6126 result = info->descriptor;
6127 tmp = gfc_build_addr_expr (NULL_TREE, result);
6128 vec_safe_push (retargs, tmp);
6130 else if (!comp && sym->result->attr.dimension)
6132 gcc_assert (se->loop && info);
6134 /* Set the type of the array. */
6135 tmp = gfc_typenode_for_spec (&ts);
6136 gcc_assert (se->ss->dimen == se->loop->dimen);
6138 /* Evaluate the bounds of the result, if known. */
6139 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6141 /* If the lhs of an assignment x = f(..) is allocatable and
6142 f2003 is allowed, we must not generate the function call
6143 here but should just send back the results of the mapping.
6144 This is signalled by the function ss being flagged. */
6145 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6147 gfc_free_interface_mapping (&mapping);
6148 return has_alternate_specifier;
6151 /* Create a temporary to store the result. In case the function
6152 returns a pointer, the temporary will be a shallow copy and
6153 mustn't be deallocated. */
6154 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6155 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6156 tmp, NULL_TREE, false,
6157 !sym->attr.pointer, callee_alloc,
6158 &se->ss->info->expr->where);
6160 /* Pass the temporary as the first argument. */
6161 result = info->descriptor;
6162 tmp = gfc_build_addr_expr (NULL_TREE, result);
6163 vec_safe_push (retargs, tmp);
6165 else if (ts.type == BT_CHARACTER)
6167 /* Pass the string length. */
6168 type = gfc_get_character_type (ts.kind, ts.u.cl);
6169 type = build_pointer_type (type);
6171 /* Emit a DECL_EXPR for the VLA type. */
6172 tmp = TREE_TYPE (type);
6174 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6176 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6177 DECL_ARTIFICIAL (tmp) = 1;
6178 DECL_IGNORED_P (tmp) = 1;
6179 tmp = fold_build1_loc (input_location, DECL_EXPR,
6180 TREE_TYPE (tmp), tmp);
6181 gfc_add_expr_to_block (&se->pre, tmp);
6184 /* Return an address to a char[0:len-1]* temporary for
6185 character pointers. */
6186 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6187 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6189 var = gfc_create_var (type, "pstr");
6191 if ((!comp && sym->attr.allocatable)
6192 || (comp && comp->attr.allocatable))
6194 gfc_add_modify (&se->pre, var,
6195 fold_convert (TREE_TYPE (var),
6196 null_pointer_node));
6197 tmp = gfc_call_free (var);
6198 gfc_add_expr_to_block (&se->post, tmp);
6201 /* Provide an address expression for the function arguments. */
6202 var = gfc_build_addr_expr (NULL_TREE, var);
6205 var = gfc_conv_string_tmp (se, type, len);
6207 vec_safe_push (retargs, var);
6211 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6213 type = gfc_get_complex_type (ts.kind);
6214 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6215 vec_safe_push (retargs, var);
6218 /* Add the string length to the argument list. */
6219 if (ts.type == BT_CHARACTER && ts.deferred)
6223 tmp = gfc_evaluate_now (len, &se->pre);
6224 TREE_STATIC (tmp) = 1;
6225 gfc_add_modify (&se->pre, tmp,
6226 build_int_cst (TREE_TYPE (tmp), 0));
6227 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6228 vec_safe_push (retargs, tmp);
6230 else if (ts.type == BT_CHARACTER)
6231 vec_safe_push (retargs, len);
6233 gfc_free_interface_mapping (&mapping);
6235 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6236 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6237 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6238 vec_safe_reserve (retargs, arglen);
6240 /* Add the return arguments. */
6241 vec_safe_splice (retargs, arglist);
6243 /* Add the hidden present status for optional+value to the arguments. */
6244 vec_safe_splice (retargs, optionalargs);
6246 /* Add the hidden string length parameters to the arguments. */
6247 vec_safe_splice (retargs, stringargs);
6249 /* We may want to append extra arguments here. This is used e.g. for
6250 calls to libgfortran_matmul_??, which need extra information. */
6251 vec_safe_splice (retargs, append_args);
6255 /* Generate the actual call. */
6256 if (base_object == NULL_TREE)
6257 conv_function_val (se, sym, expr);
6259 conv_base_obj_fcn_val (se, base_object, expr);
6261 /* If there are alternate return labels, function type should be
6262 integer. Can't modify the type in place though, since it can be shared
6263 with other functions. For dummy arguments, the typing is done to
6264 this result, even if it has to be repeated for each call. */
6265 if (has_alternate_specifier
6266 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6268 if (!sym->attr.dummy)
6270 TREE_TYPE (sym->backend_decl)
6271 = build_function_type (integer_type_node,
6272 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6273 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6276 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6279 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6280 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6282 /* Allocatable scalar function results must be freed and nullified
6283 after use. This necessitates the creation of a temporary to
6284 hold the result to prevent duplicate calls. */
6285 if (!byref && sym->ts.type != BT_CHARACTER
6286 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6287 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6289 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6290 gfc_add_modify (&se->pre, tmp, se->expr);
6292 tmp = gfc_call_free (tmp);
6293 gfc_add_expr_to_block (&post, tmp);
6294 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6297 /* If we have a pointer function, but we don't want a pointer, e.g.
6300 where f is pointer valued, we have to dereference the result. */
6301 if (!se->want_pointer && !byref
6302 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6303 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6304 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6306 /* f2c calling conventions require a scalar default real function to
6307 return a double precision result. Convert this back to default
6308 real. We only care about the cases that can happen in Fortran 77.
6310 if (flag_f2c && sym->ts.type == BT_REAL
6311 && sym->ts.kind == gfc_default_real_kind
6312 && !sym->attr.always_explicit)
6313 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6315 /* A pure function may still have side-effects - it may modify its
6317 TREE_SIDE_EFFECTS (se->expr) = 1;
6319 if (!sym->attr.pure)
6320 TREE_SIDE_EFFECTS (se->expr) = 1;
6325 /* Add the function call to the pre chain. There is no expression. */
6326 gfc_add_expr_to_block (&se->pre, se->expr);
6327 se->expr = NULL_TREE;
6329 if (!se->direct_byref)
6331 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6333 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6335 /* Check the data pointer hasn't been modified. This would
6336 happen in a function returning a pointer. */
6337 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6338 tmp = fold_build2_loc (input_location, NE_EXPR,
6341 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6344 se->expr = info->descriptor;
6345 /* Bundle in the string length. */
6346 se->string_length = len;
6348 else if (ts.type == BT_CHARACTER)
6350 /* Dereference for character pointer results. */
6351 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6352 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6353 se->expr = build_fold_indirect_ref_loc (input_location, var);
6357 se->string_length = len;
6361 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6362 se->expr = build_fold_indirect_ref_loc (input_location, var);
6367 /* Associate the rhs class object's meta-data with the result, when the
6368 result is a temporary. */
6369 if (args && args->expr && args->expr->ts.type == BT_CLASS
6370 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6371 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6374 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6376 gfc_init_se (&parmse, NULL);
6377 parmse.data_not_needed = 1;
6378 gfc_conv_expr (&parmse, class_expr);
6379 if (!DECL_LANG_SPECIFIC (result))
6380 gfc_allocate_lang_decl (result);
6381 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6382 gfc_free_expr (class_expr);
6383 gcc_assert (parmse.pre.head == NULL_TREE
6384 && parmse.post.head == NULL_TREE);
6387 /* Follow the function call with the argument post block. */
6390 gfc_add_block_to_block (&se->pre, &post);
6392 /* Transformational functions of derived types with allocatable
6393 components must have the result allocatable components copied when the
6394 argument is actually given. */
6395 arg = expr->value.function.actual;
6396 if (result && arg && expr->rank
6397 && expr->value.function.isym
6398 && expr->value.function.isym->transformational
6400 && arg->expr->ts.type == BT_DERIVED
6401 && arg->expr->ts.u.derived->attr.alloc_comp)
6404 /* Copy the allocatable components. We have to use a
6405 temporary here to prevent source allocatable components
6406 from being corrupted. */
6407 tmp2 = gfc_evaluate_now (result, &se->pre);
6408 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6409 result, tmp2, expr->rank, 0);
6410 gfc_add_expr_to_block (&se->pre, tmp);
6411 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6413 gfc_add_expr_to_block (&se->pre, tmp);
6415 /* Finally free the temporary's data field. */
6416 tmp = gfc_conv_descriptor_data_get (tmp2);
6417 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6418 NULL_TREE, NULL_TREE, true,
6419 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6420 gfc_add_expr_to_block (&se->pre, tmp);
6425 /* For a function with a class array result, save the result as
6426 a temporary, set the info fields needed by the scalarizer and
6427 call the finalization function of the temporary. Note that the
6428 nullification of allocatable components needed by the result
6429 is done in gfc_trans_assignment_1. */
6430 if (expr && ((gfc_is_class_array_function (expr)
6431 && se->ss && se->ss->loop)
6432 || gfc_is_alloc_class_scalar_function (expr))
6433 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6434 && expr->must_finalize)
6439 if (se->ss && se->ss->loop)
6441 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6442 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6443 tmp = gfc_class_data_get (se->expr);
6444 info->descriptor = tmp;
6445 info->data = gfc_conv_descriptor_data_get (tmp);
6446 info->offset = gfc_conv_descriptor_offset_get (tmp);
6447 for (n = 0; n < se->ss->loop->dimen; n++)
6449 tree dim = gfc_rank_cst[n];
6450 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6451 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6456 /* TODO Eliminate the doubling of temporaries. This
6457 one is necessary to ensure no memory leakage. */
6458 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6459 tmp = gfc_class_data_get (se->expr);
6460 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6461 CLASS_DATA (expr->value.function.esym->result)->attr);
6464 if ((gfc_is_class_array_function (expr)
6465 || gfc_is_alloc_class_scalar_function (expr))
6466 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6467 goto no_finalization;
6469 final_fndecl = gfc_class_vtab_final_get (se->expr);
6470 is_final = fold_build2_loc (input_location, NE_EXPR,
6473 fold_convert (TREE_TYPE (final_fndecl),
6474 null_pointer_node));
6475 final_fndecl = build_fold_indirect_ref_loc (input_location,
6477 tmp = build_call_expr_loc (input_location,
6479 gfc_build_addr_expr (NULL, tmp),
6480 gfc_class_vtab_size_get (se->expr),
6481 boolean_false_node);
6482 tmp = fold_build3_loc (input_location, COND_EXPR,
6483 void_type_node, is_final, tmp,
6484 build_empty_stmt (input_location));
6486 if (se->ss && se->ss->loop)
6488 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
6489 tmp = fold_build2_loc (input_location, NE_EXPR,
6492 fold_convert (TREE_TYPE (info->data),
6493 null_pointer_node));
6494 tmp = fold_build3_loc (input_location, COND_EXPR,
6495 void_type_node, tmp,
6496 gfc_call_free (info->data),
6497 build_empty_stmt (input_location));
6498 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6503 gfc_prepend_expr_to_block (&se->post, tmp);
6504 classdata = gfc_class_data_get (se->expr);
6505 tmp = fold_build2_loc (input_location, NE_EXPR,
6508 fold_convert (TREE_TYPE (classdata),
6509 null_pointer_node));
6510 tmp = fold_build3_loc (input_location, COND_EXPR,
6511 void_type_node, tmp,
6512 gfc_call_free (classdata),
6513 build_empty_stmt (input_location));
6514 gfc_add_expr_to_block (&se->post, tmp);
6519 gfc_add_block_to_block (&se->post, &post);
6522 return has_alternate_specifier;
6526 /* Fill a character string with spaces. */
6529 fill_with_spaces (tree start, tree type, tree size)
6531 stmtblock_t block, loop;
6532 tree i, el, exit_label, cond, tmp;
6534 /* For a simple char type, we can call memset(). */
6535 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6536 return build_call_expr_loc (input_location,
6537 builtin_decl_explicit (BUILT_IN_MEMSET),
6539 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6540 lang_hooks.to_target_charset (' ')),
6541 fold_convert (size_type_node, size));
6543 /* Otherwise, we use a loop:
6544 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6548 /* Initialize variables. */
6549 gfc_init_block (&block);
6550 i = gfc_create_var (sizetype, "i");
6551 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6552 el = gfc_create_var (build_pointer_type (type), "el");
6553 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6554 exit_label = gfc_build_label_decl (NULL_TREE);
6555 TREE_USED (exit_label) = 1;
6559 gfc_init_block (&loop);
6561 /* Exit condition. */
6562 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6563 build_zero_cst (sizetype));
6564 tmp = build1_v (GOTO_EXPR, exit_label);
6565 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6566 build_empty_stmt (input_location));
6567 gfc_add_expr_to_block (&loop, tmp);
6570 gfc_add_modify (&loop,
6571 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6572 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6574 /* Increment loop variables. */
6575 gfc_add_modify (&loop, i,
6576 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6577 TYPE_SIZE_UNIT (type)));
6578 gfc_add_modify (&loop, el,
6579 fold_build_pointer_plus_loc (input_location,
6580 el, TYPE_SIZE_UNIT (type)));
6582 /* Making the loop... actually loop! */
6583 tmp = gfc_finish_block (&loop);
6584 tmp = build1_v (LOOP_EXPR, tmp);
6585 gfc_add_expr_to_block (&block, tmp);
6587 /* The exit label. */
6588 tmp = build1_v (LABEL_EXPR, exit_label);
6589 gfc_add_expr_to_block (&block, tmp);
6592 return gfc_finish_block (&block);
6596 /* Generate code to copy a string. */
6599 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6600 int dkind, tree slength, tree src, int skind)
6602 tree tmp, dlen, slen;
6611 stmtblock_t tempblock;
6613 gcc_assert (dkind == skind);
6615 if (slength != NULL_TREE)
6617 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
6618 ssc = gfc_string_to_single_character (slen, src, skind);
6622 slen = build_one_cst (gfc_charlen_type_node);
6626 if (dlength != NULL_TREE)
6628 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
6629 dsc = gfc_string_to_single_character (dlen, dest, dkind);
6633 dlen = build_one_cst (gfc_charlen_type_node);
6637 /* Assign directly if the types are compatible. */
6638 if (dsc != NULL_TREE && ssc != NULL_TREE
6639 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
6641 gfc_add_modify (block, dsc, ssc);
6645 /* The string copy algorithm below generates code like
6649 if (srclen < destlen)
6651 memmove (dest, src, srclen);
6653 memset (&dest[srclen], ' ', destlen - srclen);
6657 // Truncate if too long.
6658 memmove (dest, src, destlen);
6663 /* Do nothing if the destination length is zero. */
6664 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
6665 build_zero_cst (TREE_TYPE (dlen)));
6667 /* For non-default character kinds, we have to multiply the string
6668 length by the base type size. */
6669 chartype = gfc_get_char_type (dkind);
6670 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
6672 fold_convert (TREE_TYPE (slen),
6673 TYPE_SIZE_UNIT (chartype)));
6674 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
6676 fold_convert (TREE_TYPE (dlen),
6677 TYPE_SIZE_UNIT (chartype)));
6679 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
6680 dest = fold_convert (pvoid_type_node, dest);
6682 dest = gfc_build_addr_expr (pvoid_type_node, dest);
6684 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
6685 src = fold_convert (pvoid_type_node, src);
6687 src = gfc_build_addr_expr (pvoid_type_node, src);
6689 /* Truncate string if source is too long. */
6690 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
6693 /* Copy and pad with spaces. */
6694 tmp3 = build_call_expr_loc (input_location,
6695 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6697 fold_convert (size_type_node, slen));
6699 /* Wstringop-overflow appears at -O3 even though this warning is not
6700 explicitly available in fortran nor can it be switched off. If the
6701 source length is a constant, its negative appears as a very large
6702 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6703 the result of the MINUS_EXPR suppresses this spurious warning. */
6704 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6705 TREE_TYPE(dlen), dlen, slen);
6706 if (slength && TREE_CONSTANT (slength))
6707 tmp = gfc_evaluate_now (tmp, block);
6709 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
6710 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
6712 gfc_init_block (&tempblock);
6713 gfc_add_expr_to_block (&tempblock, tmp3);
6714 gfc_add_expr_to_block (&tempblock, tmp4);
6715 tmp3 = gfc_finish_block (&tempblock);
6717 /* The truncated memmove if the slen >= dlen. */
6718 tmp2 = build_call_expr_loc (input_location,
6719 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6721 fold_convert (size_type_node, dlen));
6723 /* The whole copy_string function is there. */
6724 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
6726 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6727 build_empty_stmt (input_location));
6728 gfc_add_expr_to_block (block, tmp);
6732 /* Translate a statement function.
6733 The value of a statement function reference is obtained by evaluating the
6734 expression using the values of the actual arguments for the values of the
6735 corresponding dummy arguments. */
6738 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
6742 gfc_formal_arglist *fargs;
6743 gfc_actual_arglist *args;
6746 gfc_saved_var *saved_vars;
6752 sym = expr->symtree->n.sym;
6753 args = expr->value.function.actual;
6754 gfc_init_se (&lse, NULL);
6755 gfc_init_se (&rse, NULL);
6758 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
6760 saved_vars = XCNEWVEC (gfc_saved_var, n);
6761 temp_vars = XCNEWVEC (tree, n);
6763 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6764 fargs = fargs->next, n++)
6766 /* Each dummy shall be specified, explicitly or implicitly, to be
6768 gcc_assert (fargs->sym->attr.dimension == 0);
6771 if (fsym->ts.type == BT_CHARACTER)
6773 /* Copy string arguments. */
6776 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
6777 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
6779 /* Create a temporary to hold the value. */
6780 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
6781 fsym->ts.u.cl->backend_decl
6782 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
6784 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
6785 temp_vars[n] = gfc_create_var (type, fsym->name);
6787 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
6789 gfc_conv_expr (&rse, args->expr);
6790 gfc_conv_string_parameter (&rse);
6791 gfc_add_block_to_block (&se->pre, &lse.pre);
6792 gfc_add_block_to_block (&se->pre, &rse.pre);
6794 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
6795 rse.string_length, rse.expr, fsym->ts.kind);
6796 gfc_add_block_to_block (&se->pre, &lse.post);
6797 gfc_add_block_to_block (&se->pre, &rse.post);
6801 /* For everything else, just evaluate the expression. */
6803 /* Create a temporary to hold the value. */
6804 type = gfc_typenode_for_spec (&fsym->ts);
6805 temp_vars[n] = gfc_create_var (type, fsym->name);
6807 gfc_conv_expr (&lse, args->expr);
6809 gfc_add_block_to_block (&se->pre, &lse.pre);
6810 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
6811 gfc_add_block_to_block (&se->pre, &lse.post);
6817 /* Use the temporary variables in place of the real ones. */
6818 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6819 fargs = fargs->next, n++)
6820 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
6822 gfc_conv_expr (se, sym->value);
6824 if (sym->ts.type == BT_CHARACTER)
6826 gfc_conv_const_charlen (sym->ts.u.cl);
6828 /* Force the expression to the correct length. */
6829 if (!INTEGER_CST_P (se->string_length)
6830 || tree_int_cst_lt (se->string_length,
6831 sym->ts.u.cl->backend_decl))
6833 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
6834 tmp = gfc_create_var (type, sym->name);
6835 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
6836 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
6837 sym->ts.kind, se->string_length, se->expr,
6841 se->string_length = sym->ts.u.cl->backend_decl;
6844 /* Restore the original variables. */
6845 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6846 fargs = fargs->next, n++)
6847 gfc_restore_sym (fargs->sym, &saved_vars[n]);
6853 /* Translate a function expression. */
6856 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
6860 if (expr->value.function.isym)
6862 gfc_conv_intrinsic_function (se, expr);
6866 /* expr.value.function.esym is the resolved (specific) function symbol for
6867 most functions. However this isn't set for dummy procedures. */
6868 sym = expr->value.function.esym;
6870 sym = expr->symtree->n.sym;
6872 /* The IEEE_ARITHMETIC functions are caught here. */
6873 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6874 if (gfc_conv_ieee_arithmetic_function (se, expr))
6877 /* We distinguish statement functions from general functions to improve
6878 runtime performance. */
6879 if (sym->attr.proc == PROC_ST_FUNCTION)
6881 gfc_conv_statement_function (se, expr);
6885 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6890 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6893 is_zero_initializer_p (gfc_expr * expr)
6895 if (expr->expr_type != EXPR_CONSTANT)
6898 /* We ignore constants with prescribed memory representations for now. */
6899 if (expr->representation.string)
6902 switch (expr->ts.type)
6905 return mpz_cmp_si (expr->value.integer, 0) == 0;
6908 return mpfr_zero_p (expr->value.real)
6909 && MPFR_SIGN (expr->value.real) >= 0;
6912 return expr->value.logical == 0;
6915 return mpfr_zero_p (mpc_realref (expr->value.complex))
6916 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
6917 && mpfr_zero_p (mpc_imagref (expr->value.complex))
6918 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
6928 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
6933 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
6934 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
6936 gfc_conv_tmp_array_ref (se);
6940 /* Build a static initializer. EXPR is the expression for the initial value.
6941 The other parameters describe the variable of the component being
6942 initialized. EXPR may be null. */
6945 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
6946 bool array, bool pointer, bool procptr)
6950 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
6951 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6952 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
6953 return build_constructor (type, NULL);
6955 if (!(expr || pointer || procptr))
6958 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6959 (these are the only two iso_c_binding derived types that can be
6960 used as initialization expressions). If so, we need to modify
6961 the 'expr' to be that for a (void *). */
6962 if (expr != NULL && expr->ts.type == BT_DERIVED
6963 && expr->ts.is_iso_c && expr->ts.u.derived)
6965 gfc_symbol *derived = expr->ts.u.derived;
6967 /* The derived symbol has already been converted to a (void *). Use
6969 if (derived->ts.kind == 0)
6970 derived->ts.kind = gfc_default_integer_kind;
6971 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
6972 expr->ts.f90_type = derived->ts.f90_type;
6974 gfc_init_se (&se, NULL);
6975 gfc_conv_constant (&se, expr);
6976 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6980 if (array && !procptr)
6983 /* Arrays need special handling. */
6985 ctor = gfc_build_null_descriptor (type);
6986 /* Special case assigning an array to zero. */
6987 else if (is_zero_initializer_p (expr))
6988 ctor = build_constructor (type, NULL);
6990 ctor = gfc_conv_array_initializer (type, expr);
6991 TREE_STATIC (ctor) = 1;
6994 else if (pointer || procptr)
6996 if (ts->type == BT_CLASS && !procptr)
6998 gfc_init_se (&se, NULL);
6999 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7000 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7001 TREE_STATIC (se.expr) = 1;
7004 else if (!expr || expr->expr_type == EXPR_NULL)
7005 return fold_convert (type, null_pointer_node);
7008 gfc_init_se (&se, NULL);
7009 se.want_pointer = 1;
7010 gfc_conv_expr (&se, expr);
7011 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7021 gfc_init_se (&se, NULL);
7022 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7023 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7025 gfc_conv_structure (&se, expr, 1);
7026 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7027 TREE_STATIC (se.expr) = 1;
7032 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7033 TREE_STATIC (ctor) = 1;
7038 gfc_init_se (&se, NULL);
7039 gfc_conv_constant (&se, expr);
7040 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7047 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7053 gfc_array_info *lss_array;
7060 gfc_start_block (&block);
7062 /* Initialize the scalarizer. */
7063 gfc_init_loopinfo (&loop);
7065 gfc_init_se (&lse, NULL);
7066 gfc_init_se (&rse, NULL);
7069 rss = gfc_walk_expr (expr);
7070 if (rss == gfc_ss_terminator)
7071 /* The rhs is scalar. Add a ss for the expression. */
7072 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7074 /* Create a SS for the destination. */
7075 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7077 lss_array = &lss->info->data.array;
7078 lss_array->shape = gfc_get_shape (cm->as->rank);
7079 lss_array->descriptor = dest;
7080 lss_array->data = gfc_conv_array_data (dest);
7081 lss_array->offset = gfc_conv_array_offset (dest);
7082 for (n = 0; n < cm->as->rank; n++)
7084 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7085 lss_array->stride[n] = gfc_index_one_node;
7087 mpz_init (lss_array->shape[n]);
7088 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7089 cm->as->lower[n]->value.integer);
7090 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7093 /* Associate the SS with the loop. */
7094 gfc_add_ss_to_loop (&loop, lss);
7095 gfc_add_ss_to_loop (&loop, rss);
7097 /* Calculate the bounds of the scalarization. */
7098 gfc_conv_ss_startstride (&loop);
7100 /* Setup the scalarizing loops. */
7101 gfc_conv_loop_setup (&loop, &expr->where);
7103 /* Setup the gfc_se structures. */
7104 gfc_copy_loopinfo_to_se (&lse, &loop);
7105 gfc_copy_loopinfo_to_se (&rse, &loop);
7108 gfc_mark_ss_chain_used (rss, 1);
7110 gfc_mark_ss_chain_used (lss, 1);
7112 /* Start the scalarized loop body. */
7113 gfc_start_scalarized_body (&loop, &body);
7115 gfc_conv_tmp_array_ref (&lse);
7116 if (cm->ts.type == BT_CHARACTER)
7117 lse.string_length = cm->ts.u.cl->backend_decl;
7119 gfc_conv_expr (&rse, expr);
7121 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7122 gfc_add_expr_to_block (&body, tmp);
7124 gcc_assert (rse.ss == gfc_ss_terminator);
7126 /* Generate the copying loops. */
7127 gfc_trans_scalarizing_loops (&loop, &body);
7129 /* Wrap the whole thing up. */
7130 gfc_add_block_to_block (&block, &loop.pre);
7131 gfc_add_block_to_block (&block, &loop.post);
7133 gcc_assert (lss_array->shape != NULL);
7134 gfc_free_shape (&lss_array->shape, cm->as->rank);
7135 gfc_cleanup_loop (&loop);
7137 return gfc_finish_block (&block);
7142 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7152 gfc_expr *arg = NULL;
7154 gfc_start_block (&block);
7155 gfc_init_se (&se, NULL);
7157 /* Get the descriptor for the expressions. */
7158 se.want_pointer = 0;
7159 gfc_conv_expr_descriptor (&se, expr);
7160 gfc_add_block_to_block (&block, &se.pre);
7161 gfc_add_modify (&block, dest, se.expr);
7163 /* Deal with arrays of derived types with allocatable components. */
7164 if (gfc_bt_struct (cm->ts.type)
7165 && cm->ts.u.derived->attr.alloc_comp)
7166 // TODO: Fix caf_mode
7167 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7170 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7171 && CLASS_DATA(cm)->attr.allocatable)
7173 if (cm->ts.u.derived->attr.alloc_comp)
7174 // TODO: Fix caf_mode
7175 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7180 tmp = TREE_TYPE (dest);
7181 tmp = gfc_duplicate_allocatable (dest, se.expr,
7182 tmp, expr->rank, NULL_TREE);
7186 tmp = gfc_duplicate_allocatable (dest, se.expr,
7187 TREE_TYPE(cm->backend_decl),
7188 cm->as->rank, NULL_TREE);
7190 gfc_add_expr_to_block (&block, tmp);
7191 gfc_add_block_to_block (&block, &se.post);
7193 if (expr->expr_type != EXPR_VARIABLE)
7194 gfc_conv_descriptor_data_set (&block, se.expr,
7197 /* We need to know if the argument of a conversion function is a
7198 variable, so that the correct lower bound can be used. */
7199 if (expr->expr_type == EXPR_FUNCTION
7200 && expr->value.function.isym
7201 && expr->value.function.isym->conversion
7202 && expr->value.function.actual->expr
7203 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7204 arg = expr->value.function.actual->expr;
7206 /* Obtain the array spec of full array references. */
7208 as = gfc_get_full_arrayspec_from_expr (arg);
7210 as = gfc_get_full_arrayspec_from_expr (expr);
7212 /* Shift the lbound and ubound of temporaries to being unity,
7213 rather than zero, based. Always calculate the offset. */
7214 offset = gfc_conv_descriptor_offset_get (dest);
7215 gfc_add_modify (&block, offset, gfc_index_zero_node);
7216 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7218 for (n = 0; n < expr->rank; n++)
7223 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7224 TODO It looks as if gfc_conv_expr_descriptor should return
7225 the correct bounds and that the following should not be
7226 necessary. This would simplify gfc_conv_intrinsic_bound
7228 if (as && as->lower[n])
7231 gfc_init_se (&lbse, NULL);
7232 gfc_conv_expr (&lbse, as->lower[n]);
7233 gfc_add_block_to_block (&block, &lbse.pre);
7234 lbound = gfc_evaluate_now (lbse.expr, &block);
7238 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7239 lbound = gfc_conv_descriptor_lbound_get (tmp,
7243 lbound = gfc_conv_descriptor_lbound_get (dest,
7246 lbound = gfc_index_one_node;
7248 lbound = fold_convert (gfc_array_index_type, lbound);
7250 /* Shift the bounds and set the offset accordingly. */
7251 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7252 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7253 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7254 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7256 gfc_conv_descriptor_ubound_set (&block, dest,
7257 gfc_rank_cst[n], tmp);
7258 gfc_conv_descriptor_lbound_set (&block, dest,
7259 gfc_rank_cst[n], lbound);
7261 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7262 gfc_conv_descriptor_lbound_get (dest,
7264 gfc_conv_descriptor_stride_get (dest,
7266 gfc_add_modify (&block, tmp2, tmp);
7267 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7269 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7274 /* If a conversion expression has a null data pointer
7275 argument, nullify the allocatable component. */
7279 if (arg->symtree->n.sym->attr.allocatable
7280 || arg->symtree->n.sym->attr.pointer)
7282 non_null_expr = gfc_finish_block (&block);
7283 gfc_start_block (&block);
7284 gfc_conv_descriptor_data_set (&block, dest,
7286 null_expr = gfc_finish_block (&block);
7287 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7288 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7289 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7290 return build3_v (COND_EXPR, tmp,
7291 null_expr, non_null_expr);
7295 return gfc_finish_block (&block);
7299 /* Allocate or reallocate scalar component, as necessary. */
7302 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7312 tree lhs_cl_size = NULL_TREE;
7317 if (!expr2 || expr2->rank)
7320 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7322 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7324 char name[GFC_MAX_SYMBOL_LEN+9];
7325 gfc_component *strlen;
7326 /* Use the rhs string length and the lhs element size. */
7327 gcc_assert (expr2->ts.type == BT_CHARACTER);
7328 if (!expr2->ts.u.cl->backend_decl)
7330 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7331 gcc_assert (expr2->ts.u.cl->backend_decl);
7334 size = expr2->ts.u.cl->backend_decl;
7336 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7338 sprintf (name, "_%s_length", cm->name);
7339 strlen = gfc_find_component (sym, name, true, true, NULL);
7340 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7341 gfc_charlen_type_node,
7342 TREE_OPERAND (comp, 0),
7343 strlen->backend_decl, NULL_TREE);
7345 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7346 tmp = TYPE_SIZE_UNIT (tmp);
7347 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7348 TREE_TYPE (tmp), tmp,
7349 fold_convert (TREE_TYPE (tmp), size));
7351 else if (cm->ts.type == BT_CLASS)
7353 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7354 if (expr2->ts.type == BT_DERIVED)
7356 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7357 size = TYPE_SIZE_UNIT (tmp);
7363 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7364 gfc_add_vptr_component (e2vtab);
7365 gfc_add_size_component (e2vtab);
7366 gfc_init_se (&se, NULL);
7367 gfc_conv_expr (&se, e2vtab);
7368 gfc_add_block_to_block (block, &se.pre);
7369 size = fold_convert (size_type_node, se.expr);
7370 gfc_free_expr (e2vtab);
7372 size_in_bytes = size;
7376 /* Otherwise use the length in bytes of the rhs. */
7377 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7378 size_in_bytes = size;
7381 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7382 size_in_bytes, size_one_node);
7384 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7386 tmp = build_call_expr_loc (input_location,
7387 builtin_decl_explicit (BUILT_IN_CALLOC),
7388 2, build_one_cst (size_type_node),
7390 tmp = fold_convert (TREE_TYPE (comp), tmp);
7391 gfc_add_modify (block, comp, tmp);
7395 tmp = build_call_expr_loc (input_location,
7396 builtin_decl_explicit (BUILT_IN_MALLOC),
7398 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7399 ptr = gfc_class_data_get (comp);
7402 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7403 gfc_add_modify (block, ptr, tmp);
7406 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7407 /* Update the lhs character length. */
7408 gfc_add_modify (block, lhs_cl_size,
7409 fold_convert (TREE_TYPE (lhs_cl_size), size));
7413 /* Assign a single component of a derived type constructor. */
7416 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7417 gfc_symbol *sym, bool init)
7425 gfc_start_block (&block);
7427 if (cm->attr.pointer || cm->attr.proc_pointer)
7429 /* Only care about pointers here, not about allocatables. */
7430 gfc_init_se (&se, NULL);
7431 /* Pointer component. */
7432 if ((cm->attr.dimension || cm->attr.codimension)
7433 && !cm->attr.proc_pointer)
7435 /* Array pointer. */
7436 if (expr->expr_type == EXPR_NULL)
7437 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7440 se.direct_byref = 1;
7442 gfc_conv_expr_descriptor (&se, expr);
7443 gfc_add_block_to_block (&block, &se.pre);
7444 gfc_add_block_to_block (&block, &se.post);
7449 /* Scalar pointers. */
7450 se.want_pointer = 1;
7451 gfc_conv_expr (&se, expr);
7452 gfc_add_block_to_block (&block, &se.pre);
7454 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7455 && expr->symtree->n.sym->attr.dummy)
7456 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7458 gfc_add_modify (&block, dest,
7459 fold_convert (TREE_TYPE (dest), se.expr));
7460 gfc_add_block_to_block (&block, &se.post);
7463 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7465 /* NULL initialization for CLASS components. */
7466 tmp = gfc_trans_structure_assign (dest,
7467 gfc_class_initializer (&cm->ts, expr),
7469 gfc_add_expr_to_block (&block, tmp);
7471 else if ((cm->attr.dimension || cm->attr.codimension)
7472 && !cm->attr.proc_pointer)
7474 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7475 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7476 else if (cm->attr.allocatable || cm->attr.pdt_array)
7478 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7479 gfc_add_expr_to_block (&block, tmp);
7483 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7484 gfc_add_expr_to_block (&block, tmp);
7487 else if (cm->ts.type == BT_CLASS
7488 && CLASS_DATA (cm)->attr.dimension
7489 && CLASS_DATA (cm)->attr.allocatable
7490 && expr->ts.type == BT_DERIVED)
7492 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7493 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7494 tmp = gfc_class_vptr_get (dest);
7495 gfc_add_modify (&block, tmp,
7496 fold_convert (TREE_TYPE (tmp), vtab));
7497 tmp = gfc_class_data_get (dest);
7498 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7499 gfc_add_expr_to_block (&block, tmp);
7501 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7503 /* NULL initialization for allocatable components. */
7504 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7505 null_pointer_node));
7507 else if (init && (cm->attr.allocatable
7508 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7509 && expr->ts.type != BT_CLASS)))
7511 /* Take care about non-array allocatable components here. The alloc_*
7512 routine below is motivated by the alloc_scalar_allocatable_for_
7513 assignment() routine, but with the realloc portions removed and
7515 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7520 /* The remainder of these instructions follow the if (cm->attr.pointer)
7521 if (!cm->attr.dimension) part above. */
7522 gfc_init_se (&se, NULL);
7523 gfc_conv_expr (&se, expr);
7524 gfc_add_block_to_block (&block, &se.pre);
7526 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7527 && expr->symtree->n.sym->attr.dummy)
7528 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7530 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7532 tmp = gfc_class_data_get (dest);
7533 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7534 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7535 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7536 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7537 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7540 tmp = build_fold_indirect_ref_loc (input_location, dest);
7542 /* For deferred strings insert a memcpy. */
7543 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7546 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7547 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7549 : expr->ts.u.cl->backend_decl);
7550 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7551 gfc_add_expr_to_block (&block, tmp);
7554 gfc_add_modify (&block, tmp,
7555 fold_convert (TREE_TYPE (tmp), se.expr));
7556 gfc_add_block_to_block (&block, &se.post);
7558 else if (expr->ts.type == BT_UNION)
7561 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7562 /* We mark that the entire union should be initialized with a contrived
7563 EXPR_NULL expression at the beginning. */
7564 if (c != NULL && c->n.component == NULL
7565 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7567 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7568 dest, build_constructor (TREE_TYPE (dest), NULL));
7569 gfc_add_expr_to_block (&block, tmp);
7570 c = gfc_constructor_next (c);
7572 /* The following constructor expression, if any, represents a specific
7573 map intializer, as given by the user. */
7574 if (c != NULL && c->expr != NULL)
7576 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7577 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7578 gfc_add_expr_to_block (&block, tmp);
7581 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7583 if (expr->expr_type != EXPR_STRUCTURE)
7585 tree dealloc = NULL_TREE;
7586 gfc_init_se (&se, NULL);
7587 gfc_conv_expr (&se, expr);
7588 gfc_add_block_to_block (&block, &se.pre);
7589 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7590 expression in a temporary variable and deallocate the allocatable
7591 components. Then we can the copy the expression to the result. */
7592 if (cm->ts.u.derived->attr.alloc_comp
7593 && expr->expr_type != EXPR_VARIABLE)
7595 se.expr = gfc_evaluate_now (se.expr, &block);
7596 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7599 gfc_add_modify (&block, dest,
7600 fold_convert (TREE_TYPE (dest), se.expr));
7601 if (cm->ts.u.derived->attr.alloc_comp
7602 && expr->expr_type != EXPR_NULL)
7604 // TODO: Fix caf_mode
7605 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7606 dest, expr->rank, 0);
7607 gfc_add_expr_to_block (&block, tmp);
7608 if (dealloc != NULL_TREE)
7609 gfc_add_expr_to_block (&block, dealloc);
7611 gfc_add_block_to_block (&block, &se.post);
7615 /* Nested constructors. */
7616 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7617 gfc_add_expr_to_block (&block, tmp);
7620 else if (gfc_deferred_strlen (cm, &tmp))
7624 gcc_assert (strlen);
7625 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7627 TREE_OPERAND (dest, 0),
7630 if (expr->expr_type == EXPR_NULL)
7632 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7633 gfc_add_modify (&block, dest, tmp);
7634 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7635 gfc_add_modify (&block, strlen, tmp);
7640 gfc_init_se (&se, NULL);
7641 gfc_conv_expr (&se, expr);
7642 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
7643 tmp = build_call_expr_loc (input_location,
7644 builtin_decl_explicit (BUILT_IN_MALLOC),
7646 gfc_add_modify (&block, dest,
7647 fold_convert (TREE_TYPE (dest), tmp));
7648 gfc_add_modify (&block, strlen,
7649 fold_convert (TREE_TYPE (strlen), se.string_length));
7650 tmp = gfc_build_memcpy_call (dest, se.expr, size);
7651 gfc_add_expr_to_block (&block, tmp);
7654 else if (!cm->attr.artificial)
7656 /* Scalar component (excluding deferred parameters). */
7657 gfc_init_se (&se, NULL);
7658 gfc_init_se (&lse, NULL);
7660 gfc_conv_expr (&se, expr);
7661 if (cm->ts.type == BT_CHARACTER)
7662 lse.string_length = cm->ts.u.cl->backend_decl;
7664 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
7665 gfc_add_expr_to_block (&block, tmp);
7667 return gfc_finish_block (&block);
7670 /* Assign a derived type constructor to a variable. */
7673 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
7682 gfc_start_block (&block);
7683 cm = expr->ts.u.derived->components;
7685 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
7686 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7687 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
7691 gfc_init_se (&se, NULL);
7692 gfc_init_se (&lse, NULL);
7693 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
7695 gfc_add_modify (&block, lse.expr,
7696 fold_convert (TREE_TYPE (lse.expr), se.expr));
7698 return gfc_finish_block (&block);
7702 gfc_init_se (&se, NULL);
7704 for (c = gfc_constructor_first (expr->value.constructor);
7705 c; c = gfc_constructor_next (c), cm = cm->next)
7707 /* Skip absent members in default initializers. */
7708 if (!c->expr && !cm->attr.allocatable)
7711 /* Register the component with the caf-lib before it is initialized.
7712 Register only allocatable components, that are not coarray'ed
7713 components (%comp[*]). Only register when the constructor is not the
7715 if (coarray && !cm->attr.codimension
7716 && (cm->attr.allocatable || cm->attr.pointer)
7717 && (!c->expr || c->expr->expr_type == EXPR_NULL))
7719 tree token, desc, size;
7720 bool is_array = cm->ts.type == BT_CLASS
7721 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
7723 field = cm->backend_decl;
7724 field = fold_build3_loc (input_location, COMPONENT_REF,
7725 TREE_TYPE (field), dest, field, NULL_TREE);
7726 if (cm->ts.type == BT_CLASS)
7727 field = gfc_class_data_get (field);
7729 token = is_array ? gfc_conv_descriptor_token (field)
7730 : fold_build3_loc (input_location, COMPONENT_REF,
7731 TREE_TYPE (cm->caf_token), dest,
7732 cm->caf_token, NULL_TREE);
7736 /* The _caf_register routine looks at the rank of the array
7737 descriptor to decide whether the data registered is an array
7739 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
7741 /* When the rank is not known just set a positive rank, which
7742 suffices to recognize the data as array. */
7745 size = build_zero_cst (size_type_node);
7747 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
7748 build_int_cst (signed_char_type_node, rank));
7752 desc = gfc_conv_scalar_to_descriptor (&se, field,
7753 cm->ts.type == BT_CLASS
7754 ? CLASS_DATA (cm)->attr
7756 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
7758 gfc_add_block_to_block (&block, &se.pre);
7759 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
7760 7, size, build_int_cst (
7762 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
7763 gfc_build_addr_expr (pvoid_type_node,
7765 gfc_build_addr_expr (NULL_TREE, desc),
7766 null_pointer_node, null_pointer_node,
7768 gfc_add_expr_to_block (&block, tmp);
7770 field = cm->backend_decl;
7771 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7772 dest, field, NULL_TREE);
7775 gfc_expr *e = gfc_get_null_expr (NULL);
7776 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
7781 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
7782 expr->ts.u.derived, init);
7783 gfc_add_expr_to_block (&block, tmp);
7785 return gfc_finish_block (&block);
7789 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
7790 gfc_component *un, gfc_expr *init)
7792 gfc_constructor *ctor;
7794 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
7797 ctor = gfc_constructor_first (init->value.constructor);
7799 if (ctor == NULL || ctor->expr == NULL)
7802 gcc_assert (init->expr_type == EXPR_STRUCTURE);
7804 /* If we have an 'initialize all' constructor, do it first. */
7805 if (ctor->expr->expr_type == EXPR_NULL)
7807 tree union_type = TREE_TYPE (un->backend_decl);
7808 tree val = build_constructor (union_type, NULL);
7809 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7810 ctor = gfc_constructor_next (ctor);
7813 /* Add the map initializer on top. */
7814 if (ctor != NULL && ctor->expr != NULL)
7816 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
7817 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
7818 TREE_TYPE (un->backend_decl),
7819 un->attr.dimension, un->attr.pointer,
7820 un->attr.proc_pointer);
7821 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7825 /* Build an expression for a constructor. If init is nonzero then
7826 this is part of a static variable initializer. */
7829 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
7836 vec<constructor_elt, va_gc> *v = NULL;
7838 gcc_assert (se->ss == NULL);
7839 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7840 type = gfc_typenode_for_spec (&expr->ts);
7844 /* Create a temporary variable and fill it in. */
7845 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
7846 /* The symtree in expr is NULL, if the code to generate is for
7847 initializing the static members only. */
7848 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
7850 gfc_add_expr_to_block (&se->pre, tmp);
7854 cm = expr->ts.u.derived->components;
7856 for (c = gfc_constructor_first (expr->value.constructor);
7857 c; c = gfc_constructor_next (c), cm = cm->next)
7859 /* Skip absent members in default initializers and allocatable
7860 components. Although the latter have a default initializer
7861 of EXPR_NULL,... by default, the static nullify is not needed
7862 since this is done every time we come into scope. */
7863 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
7866 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
7867 && strcmp (cm->name, "_extends") == 0
7868 && cm->initializer->symtree)
7872 vtabs = cm->initializer->symtree->n.sym;
7873 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
7874 vtab = unshare_expr_without_location (vtab);
7875 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
7877 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
7879 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
7880 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7881 fold_convert (TREE_TYPE (cm->backend_decl),
7884 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
7885 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7886 fold_convert (TREE_TYPE (cm->backend_decl),
7887 integer_zero_node));
7888 else if (cm->ts.type == BT_UNION)
7889 gfc_conv_union_initializer (v, cm, c->expr);
7892 val = gfc_conv_initializer (c->expr, &cm->ts,
7893 TREE_TYPE (cm->backend_decl),
7894 cm->attr.dimension, cm->attr.pointer,
7895 cm->attr.proc_pointer);
7896 val = unshare_expr_without_location (val);
7898 /* Append it to the constructor list. */
7899 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
7903 se->expr = build_constructor (type, v);
7905 TREE_CONSTANT (se->expr) = 1;
7909 /* Translate a substring expression. */
7912 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
7918 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
7920 se->expr = gfc_build_wide_string_const (expr->ts.kind,
7921 expr->value.character.length,
7922 expr->value.character.string);
7924 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
7925 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
7928 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
7932 /* Entry point for expression translation. Evaluates a scalar quantity.
7933 EXPR is the expression to be translated, and SE is the state structure if
7934 called from within the scalarized. */
7937 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
7942 if (ss && ss->info->expr == expr
7943 && (ss->info->type == GFC_SS_SCALAR
7944 || ss->info->type == GFC_SS_REFERENCE))
7946 gfc_ss_info *ss_info;
7949 /* Substitute a scalar expression evaluated outside the scalarization
7951 se->expr = ss_info->data.scalar.value;
7952 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
7953 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7955 se->string_length = ss_info->string_length;
7956 gfc_advance_se_ss_chain (se);
7960 /* We need to convert the expressions for the iso_c_binding derived types.
7961 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7962 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7963 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7964 updated to be an integer with a kind equal to the size of a (void *). */
7965 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
7966 && expr->ts.u.derived->attr.is_bind_c)
7968 if (expr->expr_type == EXPR_VARIABLE
7969 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
7970 || expr->symtree->n.sym->intmod_sym_id
7971 == ISOCBINDING_NULL_FUNPTR))
7973 /* Set expr_type to EXPR_NULL, which will result in
7974 null_pointer_node being used below. */
7975 expr->expr_type = EXPR_NULL;
7979 /* Update the type/kind of the expression to be what the new
7980 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7981 expr->ts.type = BT_INTEGER;
7982 expr->ts.f90_type = BT_VOID;
7983 expr->ts.kind = gfc_index_integer_kind;
7987 gfc_fix_class_refs (expr);
7989 switch (expr->expr_type)
7992 gfc_conv_expr_op (se, expr);
7996 gfc_conv_function_expr (se, expr);
8000 gfc_conv_constant (se, expr);
8004 gfc_conv_variable (se, expr);
8008 se->expr = null_pointer_node;
8011 case EXPR_SUBSTRING:
8012 gfc_conv_substring_expr (se, expr);
8015 case EXPR_STRUCTURE:
8016 gfc_conv_structure (se, expr, 0);
8020 gfc_conv_array_constructor_expr (se, expr);
8029 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8030 of an assignment. */
8032 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8034 gfc_conv_expr (se, expr);
8035 /* All numeric lvalues should have empty post chains. If not we need to
8036 figure out a way of rewriting an lvalue so that it has no post chain. */
8037 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8040 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8041 numeric expressions. Used for scalar values where inserting cleanup code
8044 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8048 gcc_assert (expr->ts.type != BT_CHARACTER);
8049 gfc_conv_expr (se, expr);
8052 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8053 gfc_add_modify (&se->pre, val, se->expr);
8055 gfc_add_block_to_block (&se->pre, &se->post);
8059 /* Helper to translate an expression and convert it to a particular type. */
8061 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8063 gfc_conv_expr_val (se, expr);
8064 se->expr = convert (type, se->expr);
8068 /* Converts an expression so that it can be passed by reference. Scalar
8072 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8078 if (ss && ss->info->expr == expr
8079 && ss->info->type == GFC_SS_REFERENCE)
8081 /* Returns a reference to the scalar evaluated outside the loop
8083 gfc_conv_expr (se, expr);
8085 if (expr->ts.type == BT_CHARACTER
8086 && expr->expr_type != EXPR_FUNCTION)
8087 gfc_conv_string_parameter (se);
8089 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8094 if (expr->ts.type == BT_CHARACTER)
8096 gfc_conv_expr (se, expr);
8097 gfc_conv_string_parameter (se);
8101 if (expr->expr_type == EXPR_VARIABLE)
8103 se->want_pointer = 1;
8104 gfc_conv_expr (se, expr);
8107 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8108 gfc_add_modify (&se->pre, var, se->expr);
8109 gfc_add_block_to_block (&se->pre, &se->post);
8112 else if (add_clobber)
8116 /* FIXME: This fails if var is passed by reference, see PR
8118 var = expr->symtree->n.sym->backend_decl;
8119 clobber = build_clobber (TREE_TYPE (var));
8120 gfc_add_modify (&se->pre, var, clobber);
8125 if (expr->expr_type == EXPR_FUNCTION
8126 && ((expr->value.function.esym
8127 && expr->value.function.esym->result->attr.pointer
8128 && !expr->value.function.esym->result->attr.dimension)
8129 || (!expr->value.function.esym && !expr->ref
8130 && expr->symtree->n.sym->attr.pointer
8131 && !expr->symtree->n.sym->attr.dimension)))
8133 se->want_pointer = 1;
8134 gfc_conv_expr (se, expr);
8135 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8136 gfc_add_modify (&se->pre, var, se->expr);
8141 gfc_conv_expr (se, expr);
8143 /* Create a temporary var to hold the value. */
8144 if (TREE_CONSTANT (se->expr))
8146 tree tmp = se->expr;
8147 STRIP_TYPE_NOPS (tmp);
8148 var = build_decl (input_location,
8149 CONST_DECL, NULL, TREE_TYPE (tmp));
8150 DECL_INITIAL (var) = tmp;
8151 TREE_STATIC (var) = 1;
8156 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8157 gfc_add_modify (&se->pre, var, se->expr);
8160 if (!expr->must_finalize)
8161 gfc_add_block_to_block (&se->pre, &se->post);
8163 /* Take the address of that value. */
8164 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8168 /* Get the _len component for an unlimited polymorphic expression. */
8171 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8174 gfc_ref *ref = expr->ref;
8176 gfc_init_se (&se, NULL);
8177 while (ref && ref->next)
8179 gfc_add_len_component (expr);
8180 gfc_conv_expr (&se, expr);
8181 gfc_add_block_to_block (block, &se.pre);
8182 gcc_assert (se.post.head == NULL_TREE);
8185 gfc_free_ref_list (ref->next);
8190 gfc_free_ref_list (expr->ref);
8197 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8198 statement-list outside of the scalarizer-loop. When code is generated, that
8199 depends on the scalarized expression, it is added to RSE.PRE.
8200 Returns le's _vptr tree and when set the len expressions in to_lenp and
8201 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8205 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8206 gfc_expr * re, gfc_se *rse,
8207 tree * to_lenp, tree * from_lenp)
8210 gfc_expr * vptr_expr;
8211 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8212 bool set_vptr = false, temp_rhs = false;
8213 stmtblock_t *pre = block;
8215 /* Create a temporary for complicated expressions. */
8216 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8217 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8219 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8221 gfc_add_modify (&rse->pre, tmp, rse->expr);
8226 /* Get the _vptr for the left-hand side expression. */
8227 gfc_init_se (&se, NULL);
8228 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8229 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8231 /* Care about _len for unlimited polymorphic entities. */
8232 if (UNLIMITED_POLY (vptr_expr)
8233 || (vptr_expr->ts.type == BT_DERIVED
8234 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8235 to_len = trans_get_upoly_len (block, vptr_expr);
8236 gfc_add_vptr_component (vptr_expr);
8240 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8241 se.want_pointer = 1;
8242 gfc_conv_expr (&se, vptr_expr);
8243 gfc_free_expr (vptr_expr);
8244 gfc_add_block_to_block (block, &se.pre);
8245 gcc_assert (se.post.head == NULL_TREE);
8247 STRIP_NOPS (lhs_vptr);
8249 /* Set the _vptr only when the left-hand side of the assignment is a
8253 /* Get the vptr from the rhs expression only, when it is variable.
8254 Functions are expected to be assigned to a temporary beforehand. */
8255 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8256 ? gfc_find_and_cut_at_last_class_ref (re)
8258 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8260 if (to_len != NULL_TREE)
8262 /* Get the _len information from the rhs. */
8263 if (UNLIMITED_POLY (vptr_expr)
8264 || (vptr_expr->ts.type == BT_DERIVED
8265 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8266 from_len = trans_get_upoly_len (block, vptr_expr);
8268 gfc_add_vptr_component (vptr_expr);
8272 if (re->expr_type == EXPR_VARIABLE
8273 && DECL_P (re->symtree->n.sym->backend_decl)
8274 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8275 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8276 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8277 re->symtree->n.sym->backend_decl))))
8280 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8281 re->symtree->n.sym->backend_decl));
8283 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8284 re->symtree->n.sym->backend_decl));
8286 else if (temp_rhs && re->ts.type == BT_CLASS)
8289 se.expr = gfc_class_vptr_get (rse->expr);
8290 if (UNLIMITED_POLY (re))
8291 from_len = gfc_class_len_get (rse->expr);
8293 else if (re->expr_type != EXPR_NULL)
8294 /* Only when rhs is non-NULL use its declared type for vptr
8296 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8298 /* When the rhs is NULL use the vtab of lhs' declared type. */
8299 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8304 gfc_init_se (&se, NULL);
8305 se.want_pointer = 1;
8306 gfc_conv_expr (&se, vptr_expr);
8307 gfc_free_expr (vptr_expr);
8308 gfc_add_block_to_block (block, &se.pre);
8309 gcc_assert (se.post.head == NULL_TREE);
8311 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8314 if (to_len != NULL_TREE)
8316 /* The _len component needs to be set. Figure how to get the
8317 value of the right-hand side. */
8318 if (from_len == NULL_TREE)
8320 if (rse->string_length != NULL_TREE)
8321 from_len = rse->string_length;
8322 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8324 from_len = gfc_get_expr_charlen (re);
8325 gfc_init_se (&se, NULL);
8326 gfc_conv_expr (&se, re->ts.u.cl->length);
8327 gfc_add_block_to_block (block, &se.pre);
8328 gcc_assert (se.post.head == NULL_TREE);
8329 from_len = gfc_evaluate_now (se.expr, block);
8332 from_len = build_zero_cst (gfc_charlen_type_node);
8334 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8339 /* Return the _len trees only, when requested. */
8343 *from_lenp = from_len;
8348 /* Assign tokens for pointer components. */
8351 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8354 symbol_attribute lhs_attr, rhs_attr;
8355 tree tmp, lhs_tok, rhs_tok;
8356 /* Flag to indicated component refs on the rhs. */
8359 lhs_attr = gfc_caf_attr (expr1);
8360 if (expr2->expr_type != EXPR_NULL)
8362 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8363 if (lhs_attr.codimension && rhs_attr.codimension)
8365 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8366 lhs_tok = build_fold_indirect_ref (lhs_tok);
8369 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8373 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8374 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8377 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8379 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8380 gfc_prepend_expr_to_block (&lse->post, tmp);
8383 else if (lhs_attr.codimension)
8385 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8386 lhs_tok = build_fold_indirect_ref (lhs_tok);
8387 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8388 lhs_tok, null_pointer_node);
8389 gfc_prepend_expr_to_block (&lse->post, tmp);
8393 /* Indentify class valued proc_pointer assignments. */
8396 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8401 while (ref && ref->next)
8404 return ref && ref->type == REF_COMPONENT
8405 && ref->u.c.component->attr.proc_pointer
8406 && expr2->expr_type == EXPR_VARIABLE
8407 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8411 /* Do everything that is needed for a CLASS function expr2. */
8414 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8415 gfc_expr *expr1, gfc_expr *expr2)
8417 tree expr1_vptr = NULL_TREE;
8420 gfc_conv_function_expr (rse, expr2);
8421 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8423 if (expr1->ts.type != BT_CLASS)
8424 rse->expr = gfc_class_data_get (rse->expr);
8427 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8430 gfc_add_block_to_block (block, &rse->pre);
8431 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8432 gfc_add_modify (&lse->pre, tmp, rse->expr);
8434 gfc_add_modify (&lse->pre, expr1_vptr,
8435 fold_convert (TREE_TYPE (expr1_vptr),
8436 gfc_class_vptr_get (tmp)));
8437 rse->expr = gfc_class_data_get (tmp);
8445 gfc_trans_pointer_assign (gfc_code * code)
8447 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8451 /* Generate code for a pointer assignment. */
8454 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8461 tree expr1_vptr = NULL_TREE;
8462 bool scalar, non_proc_pointer_assign;
8465 gfc_start_block (&block);
8467 gfc_init_se (&lse, NULL);
8469 /* Usually testing whether this is not a proc pointer assignment. */
8470 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8472 /* Check whether the expression is a scalar or not; we cannot use
8473 expr1->rank as it can be nonzero for proc pointers. */
8474 ss = gfc_walk_expr (expr1);
8475 scalar = ss == gfc_ss_terminator;
8477 gfc_free_ss_chain (ss);
8479 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8480 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8482 gfc_add_data_component (expr2);
8483 /* The following is required as gfc_add_data_component doesn't
8484 update ts.type if there is a tailing REF_ARRAY. */
8485 expr2->ts.type = BT_DERIVED;
8490 /* Scalar pointers. */
8491 lse.want_pointer = 1;
8492 gfc_conv_expr (&lse, expr1);
8493 gfc_init_se (&rse, NULL);
8494 rse.want_pointer = 1;
8495 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8496 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8498 gfc_conv_expr (&rse, expr2);
8500 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8502 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8504 lse.expr = gfc_class_data_get (lse.expr);
8507 if (expr1->symtree->n.sym->attr.proc_pointer
8508 && expr1->symtree->n.sym->attr.dummy)
8509 lse.expr = build_fold_indirect_ref_loc (input_location,
8512 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8513 && expr2->symtree->n.sym->attr.dummy)
8514 rse.expr = build_fold_indirect_ref_loc (input_location,
8517 gfc_add_block_to_block (&block, &lse.pre);
8518 gfc_add_block_to_block (&block, &rse.pre);
8520 /* Check character lengths if character expression. The test is only
8521 really added if -fbounds-check is enabled. Exclude deferred
8522 character length lefthand sides. */
8523 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8524 && !expr1->ts.deferred
8525 && !expr1->symtree->n.sym->attr.proc_pointer
8526 && !gfc_is_proc_ptr_comp (expr1))
8528 gcc_assert (expr2->ts.type == BT_CHARACTER);
8529 gcc_assert (lse.string_length && rse.string_length);
8530 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8531 lse.string_length, rse.string_length,
8535 /* The assignment to an deferred character length sets the string
8536 length to that of the rhs. */
8537 if (expr1->ts.deferred)
8539 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8540 gfc_add_modify (&block, lse.string_length,
8541 fold_convert (TREE_TYPE (lse.string_length),
8542 rse.string_length));
8543 else if (lse.string_length != NULL)
8544 gfc_add_modify (&block, lse.string_length,
8545 build_zero_cst (TREE_TYPE (lse.string_length)));
8548 gfc_add_modify (&block, lse.expr,
8549 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8551 /* Also set the tokens for pointer components in derived typed
8553 if (flag_coarray == GFC_FCOARRAY_LIB)
8554 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8556 gfc_add_block_to_block (&block, &rse.post);
8557 gfc_add_block_to_block (&block, &lse.post);
8564 tree strlen_rhs = NULL_TREE;
8566 /* Array pointer. Find the last reference on the LHS and if it is an
8567 array section ref, we're dealing with bounds remapping. In this case,
8568 set it to AR_FULL so that gfc_conv_expr_descriptor does
8569 not see it and process the bounds remapping afterwards explicitly. */
8570 for (remap = expr1->ref; remap; remap = remap->next)
8571 if (!remap->next && remap->type == REF_ARRAY
8572 && remap->u.ar.type == AR_SECTION)
8574 rank_remap = (remap && remap->u.ar.end[0]);
8576 gfc_init_se (&lse, NULL);
8578 lse.descriptor_only = 1;
8579 gfc_conv_expr_descriptor (&lse, expr1);
8580 strlen_lhs = lse.string_length;
8583 if (expr2->expr_type == EXPR_NULL)
8585 /* Just set the data pointer to null. */
8586 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8588 else if (rank_remap)
8590 /* If we are rank-remapping, just get the RHS's descriptor and
8591 process this later on. */
8592 gfc_init_se (&rse, NULL);
8593 rse.direct_byref = 1;
8594 rse.byref_noassign = 1;
8596 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8597 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8599 else if (expr2->expr_type == EXPR_FUNCTION)
8601 tree bound[GFC_MAX_DIMENSIONS];
8604 for (i = 0; i < expr2->rank; i++)
8605 bound[i] = NULL_TREE;
8606 tmp = gfc_typenode_for_spec (&expr2->ts);
8607 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8609 GFC_ARRAY_POINTER_CONT, false);
8610 tmp = gfc_create_var (tmp, "ptrtemp");
8611 rse.descriptor_only = 0;
8613 rse.direct_byref = 1;
8614 gfc_conv_expr_descriptor (&rse, expr2);
8615 strlen_rhs = rse.string_length;
8620 gfc_conv_expr_descriptor (&rse, expr2);
8621 strlen_rhs = rse.string_length;
8622 if (expr1->ts.type == BT_CLASS)
8623 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8628 else if (expr2->expr_type == EXPR_VARIABLE)
8630 /* Assign directly to the LHS's descriptor. */
8631 lse.descriptor_only = 0;
8632 lse.direct_byref = 1;
8633 gfc_conv_expr_descriptor (&lse, expr2);
8634 strlen_rhs = lse.string_length;
8636 if (expr1->ts.type == BT_CLASS)
8638 rse.expr = NULL_TREE;
8639 rse.string_length = NULL_TREE;
8640 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8646 /* If the target is not a whole array, use the target array
8647 reference for remap. */
8648 for (remap = expr2->ref; remap; remap = remap->next)
8649 if (remap->type == REF_ARRAY
8650 && remap->u.ar.type == AR_FULL
8655 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8657 gfc_init_se (&rse, NULL);
8658 rse.want_pointer = 1;
8659 gfc_conv_function_expr (&rse, expr2);
8660 if (expr1->ts.type != BT_CLASS)
8662 rse.expr = gfc_class_data_get (rse.expr);
8663 gfc_add_modify (&lse.pre, desc, rse.expr);
8664 /* Set the lhs span. */
8665 tmp = TREE_TYPE (rse.expr);
8666 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8667 tmp = fold_convert (gfc_array_index_type, tmp);
8668 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
8672 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8675 gfc_add_block_to_block (&block, &rse.pre);
8676 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8677 gfc_add_modify (&lse.pre, tmp, rse.expr);
8679 gfc_add_modify (&lse.pre, expr1_vptr,
8680 fold_convert (TREE_TYPE (expr1_vptr),
8681 gfc_class_vptr_get (tmp)));
8682 rse.expr = gfc_class_data_get (tmp);
8683 gfc_add_modify (&lse.pre, desc, rse.expr);
8688 /* Assign to a temporary descriptor and then copy that
8689 temporary to the pointer. */
8690 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
8691 lse.descriptor_only = 0;
8693 lse.direct_byref = 1;
8694 gfc_conv_expr_descriptor (&lse, expr2);
8695 strlen_rhs = lse.string_length;
8696 gfc_add_modify (&lse.pre, desc, tmp);
8699 gfc_add_block_to_block (&block, &lse.pre);
8701 gfc_add_block_to_block (&block, &rse.pre);
8703 /* If we do bounds remapping, update LHS descriptor accordingly. */
8707 gcc_assert (remap->u.ar.dimen == expr1->rank);
8711 /* Do rank remapping. We already have the RHS's descriptor
8712 converted in rse and now have to build the correct LHS
8713 descriptor for it. */
8715 tree dtype, data, span;
8717 tree lbound, ubound;
8720 dtype = gfc_conv_descriptor_dtype (desc);
8721 tmp = gfc_get_dtype (TREE_TYPE (desc));
8722 gfc_add_modify (&block, dtype, tmp);
8724 /* Copy data pointer. */
8725 data = gfc_conv_descriptor_data_get (rse.expr);
8726 gfc_conv_descriptor_data_set (&block, desc, data);
8728 /* Copy the span. */
8729 if (TREE_CODE (rse.expr) == VAR_DECL
8730 && GFC_DECL_PTR_ARRAY_P (rse.expr))
8731 span = gfc_conv_descriptor_span_get (rse.expr);
8734 tmp = TREE_TYPE (rse.expr);
8735 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8736 span = fold_convert (gfc_array_index_type, tmp);
8738 gfc_conv_descriptor_span_set (&block, desc, span);
8740 /* Copy offset but adjust it such that it would correspond
8741 to a lbound of zero. */
8742 offs = gfc_conv_descriptor_offset_get (rse.expr);
8743 for (dim = 0; dim < expr2->rank; ++dim)
8745 stride = gfc_conv_descriptor_stride_get (rse.expr,
8747 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
8749 tmp = fold_build2_loc (input_location, MULT_EXPR,
8750 gfc_array_index_type, stride, lbound);
8751 offs = fold_build2_loc (input_location, PLUS_EXPR,
8752 gfc_array_index_type, offs, tmp);
8754 gfc_conv_descriptor_offset_set (&block, desc, offs);
8756 /* Set the bounds as declared for the LHS and calculate strides as
8757 well as another offset update accordingly. */
8758 stride = gfc_conv_descriptor_stride_get (rse.expr,
8760 for (dim = 0; dim < expr1->rank; ++dim)
8765 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
8767 /* Convert declared bounds. */
8768 gfc_init_se (&lower_se, NULL);
8769 gfc_init_se (&upper_se, NULL);
8770 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
8771 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
8773 gfc_add_block_to_block (&block, &lower_se.pre);
8774 gfc_add_block_to_block (&block, &upper_se.pre);
8776 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
8777 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
8779 lbound = gfc_evaluate_now (lbound, &block);
8780 ubound = gfc_evaluate_now (ubound, &block);
8782 gfc_add_block_to_block (&block, &lower_se.post);
8783 gfc_add_block_to_block (&block, &upper_se.post);
8785 /* Set bounds in descriptor. */
8786 gfc_conv_descriptor_lbound_set (&block, desc,
8787 gfc_rank_cst[dim], lbound);
8788 gfc_conv_descriptor_ubound_set (&block, desc,
8789 gfc_rank_cst[dim], ubound);
8792 stride = gfc_evaluate_now (stride, &block);
8793 gfc_conv_descriptor_stride_set (&block, desc,
8794 gfc_rank_cst[dim], stride);
8796 /* Update offset. */
8797 offs = gfc_conv_descriptor_offset_get (desc);
8798 tmp = fold_build2_loc (input_location, MULT_EXPR,
8799 gfc_array_index_type, lbound, stride);
8800 offs = fold_build2_loc (input_location, MINUS_EXPR,
8801 gfc_array_index_type, offs, tmp);
8802 offs = gfc_evaluate_now (offs, &block);
8803 gfc_conv_descriptor_offset_set (&block, desc, offs);
8805 /* Update stride. */
8806 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
8807 stride = fold_build2_loc (input_location, MULT_EXPR,
8808 gfc_array_index_type, stride, tmp);
8813 /* Bounds remapping. Just shift the lower bounds. */
8815 gcc_assert (expr1->rank == expr2->rank);
8817 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
8821 gcc_assert (!remap->u.ar.end[dim]);
8822 gfc_init_se (&lbound_se, NULL);
8823 if (remap->u.ar.start[dim])
8825 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
8826 gfc_add_block_to_block (&block, &lbound_se.pre);
8829 /* This remap arises from a target that is not a whole
8830 array. The start expressions will be NULL but we need
8831 the lbounds to be one. */
8832 lbound_se.expr = gfc_index_one_node;
8833 gfc_conv_shift_descriptor_lbound (&block, desc,
8834 dim, lbound_se.expr);
8835 gfc_add_block_to_block (&block, &lbound_se.post);
8840 /* Check string lengths if applicable. The check is only really added
8841 to the output code if -fbounds-check is enabled. */
8842 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
8844 gcc_assert (expr2->ts.type == BT_CHARACTER);
8845 gcc_assert (strlen_lhs && strlen_rhs);
8846 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8847 strlen_lhs, strlen_rhs, &block);
8850 /* If rank remapping was done, check with -fcheck=bounds that
8851 the target is at least as large as the pointer. */
8852 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
8858 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
8859 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
8861 lsize = gfc_evaluate_now (lsize, &block);
8862 rsize = gfc_evaluate_now (rsize, &block);
8863 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
8866 msg = _("Target of rank remapping is too small (%ld < %ld)");
8867 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
8871 gfc_add_block_to_block (&block, &lse.post);
8873 gfc_add_block_to_block (&block, &rse.post);
8876 return gfc_finish_block (&block);
8880 /* Makes sure se is suitable for passing as a function string parameter. */
8881 /* TODO: Need to check all callers of this function. It may be abused. */
8884 gfc_conv_string_parameter (gfc_se * se)
8888 if (TREE_CODE (se->expr) == STRING_CST)
8890 type = TREE_TYPE (TREE_TYPE (se->expr));
8891 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8895 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
8897 if (TREE_CODE (se->expr) != INDIRECT_REF)
8899 type = TREE_TYPE (se->expr);
8900 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8904 type = gfc_get_character_type_len (gfc_default_character_kind,
8906 type = build_pointer_type (type);
8907 se->expr = gfc_build_addr_expr (type, se->expr);
8911 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
8915 /* Generate code for assignment of scalar variables. Includes character
8916 strings and derived types with allocatable components.
8917 If you know that the LHS has no allocations, set dealloc to false.
8919 DEEP_COPY has no effect if the typespec TS is not a derived type with
8920 allocatable components. Otherwise, if it is set, an explicit copy of each
8921 allocatable component is made. This is necessary as a simple copy of the
8922 whole object would copy array descriptors as is, so that the lhs's
8923 allocatable components would point to the rhs's after the assignment.
8924 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8925 necessary if the rhs is a non-pointer function, as the allocatable components
8926 are not accessible by other means than the function's result after the
8927 function has returned. It is even more subtle when temporaries are involved,
8928 as the two following examples show:
8929 1. When we evaluate an array constructor, a temporary is created. Thus
8930 there is theoretically no alias possible. However, no deep copy is
8931 made for this temporary, so that if the constructor is made of one or
8932 more variable with allocatable components, those components still point
8933 to the variable's: DEEP_COPY should be set for the assignment from the
8934 temporary to the lhs in that case.
8935 2. When assigning a scalar to an array, we evaluate the scalar value out
8936 of the loop, store it into a temporary variable, and assign from that.
8937 In that case, deep copying when assigning to the temporary would be a
8938 waste of resources; however deep copies should happen when assigning from
8939 the temporary to each array element: again DEEP_COPY should be set for
8940 the assignment from the temporary to the lhs. */
8943 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
8944 bool deep_copy, bool dealloc, bool in_coarray)
8950 gfc_init_block (&block);
8952 if (ts.type == BT_CHARACTER)
8957 if (lse->string_length != NULL_TREE)
8959 gfc_conv_string_parameter (lse);
8960 gfc_add_block_to_block (&block, &lse->pre);
8961 llen = lse->string_length;
8964 if (rse->string_length != NULL_TREE)
8966 gfc_conv_string_parameter (rse);
8967 gfc_add_block_to_block (&block, &rse->pre);
8968 rlen = rse->string_length;
8971 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
8972 rse->expr, ts.kind);
8974 else if (gfc_bt_struct (ts.type)
8975 && (ts.u.derived->attr.alloc_comp
8976 || (deep_copy && ts.u.derived->attr.pdt_type)))
8978 tree tmp_var = NULL_TREE;
8981 /* Are the rhs and the lhs the same? */
8984 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
8985 gfc_build_addr_expr (NULL_TREE, lse->expr),
8986 gfc_build_addr_expr (NULL_TREE, rse->expr));
8987 cond = gfc_evaluate_now (cond, &lse->pre);
8990 /* Deallocate the lhs allocated components as long as it is not
8991 the same as the rhs. This must be done following the assignment
8992 to prevent deallocating data that could be used in the rhs
8996 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
8997 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
8999 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9001 gfc_add_expr_to_block (&lse->post, tmp);
9004 gfc_add_block_to_block (&block, &rse->pre);
9005 gfc_add_block_to_block (&block, &lse->pre);
9007 gfc_add_modify (&block, lse->expr,
9008 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9010 /* Restore pointer address of coarray components. */
9011 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9013 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9014 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9016 gfc_add_expr_to_block (&block, tmp);
9019 /* Do a deep copy if the rhs is a variable, if it is not the
9023 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9024 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9025 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9027 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9029 gfc_add_expr_to_block (&block, tmp);
9032 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9034 gfc_add_block_to_block (&block, &lse->pre);
9035 gfc_add_block_to_block (&block, &rse->pre);
9036 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9037 TREE_TYPE (lse->expr), rse->expr);
9038 gfc_add_modify (&block, lse->expr, tmp);
9042 gfc_add_block_to_block (&block, &lse->pre);
9043 gfc_add_block_to_block (&block, &rse->pre);
9045 gfc_add_modify (&block, lse->expr,
9046 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9049 gfc_add_block_to_block (&block, &lse->post);
9050 gfc_add_block_to_block (&block, &rse->post);
9052 return gfc_finish_block (&block);
9056 /* There are quite a lot of restrictions on the optimisation in using an
9057 array function assign without a temporary. */
9060 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9063 bool seen_array_ref;
9065 gfc_symbol *sym = expr1->symtree->n.sym;
9067 /* Play it safe with class functions assigned to a derived type. */
9068 if (gfc_is_class_array_function (expr2)
9069 && expr1->ts.type == BT_DERIVED)
9072 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9073 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9076 /* Elemental functions are scalarized so that they don't need a
9077 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9078 they would need special treatment in gfc_trans_arrayfunc_assign. */
9079 if (expr2->value.function.esym != NULL
9080 && expr2->value.function.esym->attr.elemental)
9083 /* Need a temporary if rhs is not FULL or a contiguous section. */
9084 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9087 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9088 if (gfc_ref_needs_temporary_p (expr1->ref))
9091 /* Functions returning pointers or allocatables need temporaries. */
9092 c = expr2->value.function.esym
9093 ? (expr2->value.function.esym->attr.pointer
9094 || expr2->value.function.esym->attr.allocatable)
9095 : (expr2->symtree->n.sym->attr.pointer
9096 || expr2->symtree->n.sym->attr.allocatable);
9100 /* Character array functions need temporaries unless the
9101 character lengths are the same. */
9102 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9104 if (expr1->ts.u.cl->length == NULL
9105 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9108 if (expr2->ts.u.cl->length == NULL
9109 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9112 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9113 expr2->ts.u.cl->length->value.integer) != 0)
9117 /* Check that no LHS component references appear during an array
9118 reference. This is needed because we do not have the means to
9119 span any arbitrary stride with an array descriptor. This check
9120 is not needed for the rhs because the function result has to be
9122 seen_array_ref = false;
9123 for (ref = expr1->ref; ref; ref = ref->next)
9125 if (ref->type == REF_ARRAY)
9126 seen_array_ref= true;
9127 else if (ref->type == REF_COMPONENT && seen_array_ref)
9131 /* Check for a dependency. */
9132 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9133 expr2->value.function.esym,
9134 expr2->value.function.actual,
9138 /* If we have reached here with an intrinsic function, we do not
9139 need a temporary except in the particular case that reallocation
9140 on assignment is active and the lhs is allocatable and a target. */
9141 if (expr2->value.function.isym)
9142 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9144 /* If the LHS is a dummy, we need a temporary if it is not
9146 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9149 /* If the lhs has been host_associated, is in common, a pointer or is
9150 a target and the function is not using a RESULT variable, aliasing
9151 can occur and a temporary is needed. */
9152 if ((sym->attr.host_assoc
9153 || sym->attr.in_common
9154 || sym->attr.pointer
9155 || sym->attr.cray_pointee
9156 || sym->attr.target)
9157 && expr2->symtree != NULL
9158 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9161 /* A PURE function can unconditionally be called without a temporary. */
9162 if (expr2->value.function.esym != NULL
9163 && expr2->value.function.esym->attr.pure)
9166 /* Implicit_pure functions are those which could legally be declared
9168 if (expr2->value.function.esym != NULL
9169 && expr2->value.function.esym->attr.implicit_pure)
9172 if (!sym->attr.use_assoc
9173 && !sym->attr.in_common
9174 && !sym->attr.pointer
9175 && !sym->attr.target
9176 && !sym->attr.cray_pointee
9177 && expr2->value.function.esym)
9179 /* A temporary is not needed if the function is not contained and
9180 the variable is local or host associated and not a pointer or
9182 if (!expr2->value.function.esym->attr.contained)
9185 /* A temporary is not needed if the lhs has never been host
9186 associated and the procedure is contained. */
9187 else if (!sym->attr.host_assoc)
9190 /* A temporary is not needed if the variable is local and not
9191 a pointer, a target or a result. */
9193 && expr2->value.function.esym->ns == sym->ns->parent)
9197 /* Default to temporary use. */
9202 /* Provide the loop info so that the lhs descriptor can be built for
9203 reallocatable assignments from extrinsic function calls. */
9206 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9209 /* Signal that the function call should not be made by
9210 gfc_conv_loop_setup. */
9211 se->ss->is_alloc_lhs = 1;
9212 gfc_init_loopinfo (loop);
9213 gfc_add_ss_to_loop (loop, *ss);
9214 gfc_add_ss_to_loop (loop, se->ss);
9215 gfc_conv_ss_startstride (loop);
9216 gfc_conv_loop_setup (loop, where);
9217 gfc_copy_loopinfo_to_se (se, loop);
9218 gfc_add_block_to_block (&se->pre, &loop->pre);
9219 gfc_add_block_to_block (&se->pre, &loop->post);
9220 se->ss->is_alloc_lhs = 0;
9224 /* For assignment to a reallocatable lhs from intrinsic functions,
9225 replace the se.expr (ie. the result) with a temporary descriptor.
9226 Null the data field so that the library allocates space for the
9227 result. Free the data of the original descriptor after the function,
9228 in case it appears in an argument expression and transfer the
9229 result to the original descriptor. */
9232 fcncall_realloc_result (gfc_se *se, int rank)
9241 /* Use the allocation done by the library. Substitute the lhs
9242 descriptor with a copy, whose data field is nulled.*/
9243 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9244 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9245 desc = build_fold_indirect_ref_loc (input_location, desc);
9247 /* Unallocated, the descriptor does not have a dtype. */
9248 tmp = gfc_conv_descriptor_dtype (desc);
9249 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9251 res_desc = gfc_evaluate_now (desc, &se->pre);
9252 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9253 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9255 /* Free the lhs after the function call and copy the result data to
9256 the lhs descriptor. */
9257 tmp = gfc_conv_descriptor_data_get (desc);
9258 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9259 logical_type_node, tmp,
9260 build_int_cst (TREE_TYPE (tmp), 0));
9261 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9262 tmp = gfc_call_free (tmp);
9263 gfc_add_expr_to_block (&se->post, tmp);
9265 tmp = gfc_conv_descriptor_data_get (res_desc);
9266 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9268 /* Check that the shapes are the same between lhs and expression. */
9269 for (n = 0 ; n < rank; n++)
9272 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9273 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9274 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9275 gfc_array_index_type, tmp, tmp1);
9276 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9277 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9278 gfc_array_index_type, tmp, tmp1);
9279 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9280 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9281 gfc_array_index_type, tmp, tmp1);
9282 tmp = fold_build2_loc (input_location, NE_EXPR,
9283 logical_type_node, tmp,
9284 gfc_index_zero_node);
9285 tmp = gfc_evaluate_now (tmp, &se->post);
9286 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9287 logical_type_node, tmp,
9291 /* 'zero_cond' being true is equal to lhs not being allocated or the
9292 shapes being different. */
9293 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9295 /* Now reset the bounds returned from the function call to bounds based
9296 on the lhs lbounds, except where the lhs is not allocated or the shapes
9297 of 'variable and 'expr' are different. Set the offset accordingly. */
9298 offset = gfc_index_zero_node;
9299 for (n = 0 ; n < rank; n++)
9303 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9304 lbound = fold_build3_loc (input_location, COND_EXPR,
9305 gfc_array_index_type, zero_cond,
9306 gfc_index_one_node, lbound);
9307 lbound = gfc_evaluate_now (lbound, &se->post);
9309 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9310 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9311 gfc_array_index_type, tmp, lbound);
9312 gfc_conv_descriptor_lbound_set (&se->post, desc,
9313 gfc_rank_cst[n], lbound);
9314 gfc_conv_descriptor_ubound_set (&se->post, desc,
9315 gfc_rank_cst[n], tmp);
9317 /* Set stride and accumulate the offset. */
9318 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9319 gfc_conv_descriptor_stride_set (&se->post, desc,
9320 gfc_rank_cst[n], tmp);
9321 tmp = fold_build2_loc (input_location, MULT_EXPR,
9322 gfc_array_index_type, lbound, tmp);
9323 offset = fold_build2_loc (input_location, MINUS_EXPR,
9324 gfc_array_index_type, offset, tmp);
9325 offset = gfc_evaluate_now (offset, &se->post);
9328 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9333 /* Try to translate array(:) = func (...), where func is a transformational
9334 array function, without using a temporary. Returns NULL if this isn't the
9338 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9342 gfc_component *comp = NULL;
9345 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9348 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9350 comp = gfc_get_proc_ptr_comp (expr2);
9352 if (!(expr2->value.function.isym
9353 || (comp && comp->attr.dimension)
9354 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9355 && expr2->value.function.esym->result->attr.dimension)))
9358 gfc_init_se (&se, NULL);
9359 gfc_start_block (&se.pre);
9360 se.want_pointer = 1;
9362 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9364 if (expr1->ts.type == BT_DERIVED
9365 && expr1->ts.u.derived->attr.alloc_comp)
9368 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9370 gfc_add_expr_to_block (&se.pre, tmp);
9373 se.direct_byref = 1;
9374 se.ss = gfc_walk_expr (expr2);
9375 gcc_assert (se.ss != gfc_ss_terminator);
9377 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9378 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9379 Clearly, this cannot be done for an allocatable function result, since
9380 the shape of the result is unknown and, in any case, the function must
9381 correctly take care of the reallocation internally. For intrinsic
9382 calls, the array data is freed and the library takes care of allocation.
9383 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9385 if (flag_realloc_lhs
9386 && gfc_is_reallocatable_lhs (expr1)
9387 && !gfc_expr_attr (expr1).codimension
9388 && !gfc_is_coindexed (expr1)
9389 && !(expr2->value.function.esym
9390 && expr2->value.function.esym->result->attr.allocatable))
9392 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9394 if (!expr2->value.function.isym)
9396 ss = gfc_walk_expr (expr1);
9397 gcc_assert (ss != gfc_ss_terminator);
9399 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9400 ss->is_alloc_lhs = 1;
9403 fcncall_realloc_result (&se, expr1->rank);
9406 gfc_conv_function_expr (&se, expr2);
9407 gfc_add_block_to_block (&se.pre, &se.post);
9410 gfc_cleanup_loop (&loop);
9412 gfc_free_ss_chain (se.ss);
9414 return gfc_finish_block (&se.pre);
9418 /* Try to efficiently translate array(:) = 0. Return NULL if this
9422 gfc_trans_zero_assign (gfc_expr * expr)
9424 tree dest, len, type;
9428 sym = expr->symtree->n.sym;
9429 dest = gfc_get_symbol_decl (sym);
9431 type = TREE_TYPE (dest);
9432 if (POINTER_TYPE_P (type))
9433 type = TREE_TYPE (type);
9434 if (!GFC_ARRAY_TYPE_P (type))
9437 /* Determine the length of the array. */
9438 len = GFC_TYPE_ARRAY_SIZE (type);
9439 if (!len || TREE_CODE (len) != INTEGER_CST)
9442 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9443 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9444 fold_convert (gfc_array_index_type, tmp));
9446 /* If we are zeroing a local array avoid taking its address by emitting
9448 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9449 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9450 dest, build_constructor (TREE_TYPE (dest),
9453 /* Convert arguments to the correct types. */
9454 dest = fold_convert (pvoid_type_node, dest);
9455 len = fold_convert (size_type_node, len);
9457 /* Construct call to __builtin_memset. */
9458 tmp = build_call_expr_loc (input_location,
9459 builtin_decl_explicit (BUILT_IN_MEMSET),
9460 3, dest, integer_zero_node, len);
9461 return fold_convert (void_type_node, tmp);
9465 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9466 that constructs the call to __builtin_memcpy. */
9469 gfc_build_memcpy_call (tree dst, tree src, tree len)
9473 /* Convert arguments to the correct types. */
9474 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9475 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9477 dst = fold_convert (pvoid_type_node, dst);
9479 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9480 src = gfc_build_addr_expr (pvoid_type_node, src);
9482 src = fold_convert (pvoid_type_node, src);
9484 len = fold_convert (size_type_node, len);
9486 /* Construct call to __builtin_memcpy. */
9487 tmp = build_call_expr_loc (input_location,
9488 builtin_decl_explicit (BUILT_IN_MEMCPY),
9490 return fold_convert (void_type_node, tmp);
9494 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9495 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9496 source/rhs, both are gfc_full_array_ref_p which have been checked for
9500 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9502 tree dst, dlen, dtype;
9503 tree src, slen, stype;
9506 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9507 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9509 dtype = TREE_TYPE (dst);
9510 if (POINTER_TYPE_P (dtype))
9511 dtype = TREE_TYPE (dtype);
9512 stype = TREE_TYPE (src);
9513 if (POINTER_TYPE_P (stype))
9514 stype = TREE_TYPE (stype);
9516 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9519 /* Determine the lengths of the arrays. */
9520 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9521 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9523 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9524 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9525 dlen, fold_convert (gfc_array_index_type, tmp));
9527 slen = GFC_TYPE_ARRAY_SIZE (stype);
9528 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9530 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9531 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9532 slen, fold_convert (gfc_array_index_type, tmp));
9534 /* Sanity check that they are the same. This should always be
9535 the case, as we should already have checked for conformance. */
9536 if (!tree_int_cst_equal (slen, dlen))
9539 return gfc_build_memcpy_call (dst, src, dlen);
9543 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9544 this can't be done. EXPR1 is the destination/lhs for which
9545 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9548 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9550 unsigned HOST_WIDE_INT nelem;
9556 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9560 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9561 dtype = TREE_TYPE (dst);
9562 if (POINTER_TYPE_P (dtype))
9563 dtype = TREE_TYPE (dtype);
9564 if (!GFC_ARRAY_TYPE_P (dtype))
9567 /* Determine the lengths of the array. */
9568 len = GFC_TYPE_ARRAY_SIZE (dtype);
9569 if (!len || TREE_CODE (len) != INTEGER_CST)
9572 /* Confirm that the constructor is the same size. */
9573 if (compare_tree_int (len, nelem) != 0)
9576 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9577 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9578 fold_convert (gfc_array_index_type, tmp));
9580 stype = gfc_typenode_for_spec (&expr2->ts);
9581 src = gfc_build_constant_array_constructor (expr2, stype);
9583 stype = TREE_TYPE (src);
9584 if (POINTER_TYPE_P (stype))
9585 stype = TREE_TYPE (stype);
9587 return gfc_build_memcpy_call (dst, src, len);
9591 /* Tells whether the expression is to be treated as a variable reference. */
9594 gfc_expr_is_variable (gfc_expr *expr)
9597 gfc_component *comp;
9598 gfc_symbol *func_ifc;
9600 if (expr->expr_type == EXPR_VARIABLE)
9603 arg = gfc_get_noncopying_intrinsic_argument (expr);
9606 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9607 return gfc_expr_is_variable (arg);
9610 /* A data-pointer-returning function should be considered as a variable
9612 if (expr->expr_type == EXPR_FUNCTION
9613 && expr->ref == NULL)
9615 if (expr->value.function.isym != NULL)
9618 if (expr->value.function.esym != NULL)
9620 func_ifc = expr->value.function.esym;
9625 gcc_assert (expr->symtree);
9626 func_ifc = expr->symtree->n.sym;
9633 comp = gfc_get_proc_ptr_comp (expr);
9634 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
9637 func_ifc = comp->ts.interface;
9641 if (expr->expr_type == EXPR_COMPCALL)
9643 gcc_assert (!expr->value.compcall.tbp->is_generic);
9644 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
9651 gcc_assert (func_ifc->attr.function
9652 && func_ifc->result != NULL);
9653 return func_ifc->result->attr.pointer;
9657 /* Is the lhs OK for automatic reallocation? */
9660 is_scalar_reallocatable_lhs (gfc_expr *expr)
9664 /* An allocatable variable with no reference. */
9665 if (expr->symtree->n.sym->attr.allocatable
9669 /* All that can be left are allocatable components. However, we do
9670 not check for allocatable components here because the expression
9671 could be an allocatable component of a pointer component. */
9672 if (expr->symtree->n.sym->ts.type != BT_DERIVED
9673 && expr->symtree->n.sym->ts.type != BT_CLASS)
9676 /* Find an allocatable component ref last. */
9677 for (ref = expr->ref; ref; ref = ref->next)
9678 if (ref->type == REF_COMPONENT
9680 && ref->u.c.component->attr.allocatable)
9687 /* Allocate or reallocate scalar lhs, as necessary. */
9690 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
9705 if (!expr1 || expr1->rank)
9708 if (!expr2 || expr2->rank)
9711 for (ref = expr1->ref; ref; ref = ref->next)
9712 if (ref->type == REF_SUBSTRING)
9715 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9717 /* Since this is a scalar lhs, we can afford to do this. That is,
9718 there is no risk of side effects being repeated. */
9719 gfc_init_se (&lse, NULL);
9720 lse.want_pointer = 1;
9721 gfc_conv_expr (&lse, expr1);
9723 jump_label1 = gfc_build_label_decl (NULL_TREE);
9724 jump_label2 = gfc_build_label_decl (NULL_TREE);
9726 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9727 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
9728 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9730 tmp = build3_v (COND_EXPR, cond,
9731 build1_v (GOTO_EXPR, jump_label1),
9732 build_empty_stmt (input_location));
9733 gfc_add_expr_to_block (block, tmp);
9735 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9737 /* Use the rhs string length and the lhs element size. */
9738 size = string_length;
9739 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
9740 tmp = TYPE_SIZE_UNIT (tmp);
9741 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9742 TREE_TYPE (tmp), tmp,
9743 fold_convert (TREE_TYPE (tmp), size));
9747 /* Otherwise use the length in bytes of the rhs. */
9748 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
9749 size_in_bytes = size;
9752 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9753 size_in_bytes, size_one_node);
9755 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
9757 tree caf_decl, token;
9759 symbol_attribute attr;
9761 gfc_clear_attr (&attr);
9762 gfc_init_se (&caf_se, NULL);
9764 caf_decl = gfc_get_tree_for_caf_expr (expr1);
9765 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
9767 gfc_add_block_to_block (block, &caf_se.pre);
9768 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
9769 gfc_build_addr_expr (NULL_TREE, token),
9770 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
9773 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
9775 tmp = build_call_expr_loc (input_location,
9776 builtin_decl_explicit (BUILT_IN_CALLOC),
9777 2, build_one_cst (size_type_node),
9779 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9780 gfc_add_modify (block, lse.expr, tmp);
9784 tmp = build_call_expr_loc (input_location,
9785 builtin_decl_explicit (BUILT_IN_MALLOC),
9787 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9788 gfc_add_modify (block, lse.expr, tmp);
9791 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9793 /* Deferred characters need checking for lhs and rhs string
9794 length. Other deferred parameter variables will have to
9796 tmp = build1_v (GOTO_EXPR, jump_label2);
9797 gfc_add_expr_to_block (block, tmp);
9799 tmp = build1_v (LABEL_EXPR, jump_label1);
9800 gfc_add_expr_to_block (block, tmp);
9802 /* For a deferred length character, reallocate if lengths of lhs and
9803 rhs are different. */
9804 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9806 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9808 fold_convert (TREE_TYPE (lse.string_length),
9810 /* Jump past the realloc if the lengths are the same. */
9811 tmp = build3_v (COND_EXPR, cond,
9812 build1_v (GOTO_EXPR, jump_label2),
9813 build_empty_stmt (input_location));
9814 gfc_add_expr_to_block (block, tmp);
9815 tmp = build_call_expr_loc (input_location,
9816 builtin_decl_explicit (BUILT_IN_REALLOC),
9817 2, fold_convert (pvoid_type_node, lse.expr),
9819 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9820 gfc_add_modify (block, lse.expr, tmp);
9821 tmp = build1_v (LABEL_EXPR, jump_label2);
9822 gfc_add_expr_to_block (block, tmp);
9824 /* Update the lhs character length. */
9825 size = string_length;
9826 gfc_add_modify (block, lse.string_length,
9827 fold_convert (TREE_TYPE (lse.string_length), size));
9831 /* Check for assignments of the type
9835 to make sure we do not check for reallocation unneccessarily. */
9839 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
9841 gfc_actual_arglist *a;
9844 switch (expr2->expr_type)
9847 return gfc_dep_compare_expr (expr1, expr2) == 0;
9850 if (expr2->value.function.esym
9851 && expr2->value.function.esym->attr.elemental)
9853 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9856 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9861 else if (expr2->value.function.isym
9862 && expr2->value.function.isym->elemental)
9864 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9867 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9876 switch (expr2->value.op.op)
9879 case INTRINSIC_UPLUS:
9880 case INTRINSIC_UMINUS:
9881 case INTRINSIC_PARENTHESES:
9882 return is_runtime_conformable (expr1, expr2->value.op.op1);
9884 case INTRINSIC_PLUS:
9885 case INTRINSIC_MINUS:
9886 case INTRINSIC_TIMES:
9887 case INTRINSIC_DIVIDE:
9888 case INTRINSIC_POWER:
9892 case INTRINSIC_NEQV:
9899 case INTRINSIC_EQ_OS:
9900 case INTRINSIC_NE_OS:
9901 case INTRINSIC_GT_OS:
9902 case INTRINSIC_GE_OS:
9903 case INTRINSIC_LT_OS:
9904 case INTRINSIC_LE_OS:
9906 e1 = expr2->value.op.op1;
9907 e2 = expr2->value.op.op2;
9909 if (e1->rank == 0 && e2->rank > 0)
9910 return is_runtime_conformable (expr1, e2);
9911 else if (e1->rank > 0 && e2->rank == 0)
9912 return is_runtime_conformable (expr1, e1);
9913 else if (e1->rank > 0 && e2->rank > 0)
9914 return is_runtime_conformable (expr1, e1)
9915 && is_runtime_conformable (expr1, e2);
9933 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
9934 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
9937 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
9938 vec<tree, va_gc> *args = NULL;
9940 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
9943 /* Generate allocation of the lhs. */
9949 tmp = gfc_vptr_size_get (vptr);
9950 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9951 ? gfc_class_data_get (lse->expr) : lse->expr;
9952 gfc_init_block (&alloc);
9953 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
9954 tmp = fold_build2_loc (input_location, EQ_EXPR,
9955 logical_type_node, class_han,
9956 build_int_cst (prvoid_type_node, 0));
9957 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
9959 PRED_FORTRAN_FAIL_ALLOC),
9960 gfc_finish_block (&alloc),
9961 build_empty_stmt (input_location));
9962 gfc_add_expr_to_block (&lse->pre, tmp);
9965 fcn = gfc_vptr_copy_get (vptr);
9967 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
9968 ? gfc_class_data_get (rse->expr) : rse->expr;
9971 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9972 || INDIRECT_REF_P (tmp)
9973 || (rhs->ts.type == BT_DERIVED
9974 && rhs->ts.u.derived->attr.unlimited_polymorphic
9975 && !rhs->ts.u.derived->attr.pointer
9976 && !rhs->ts.u.derived->attr.allocatable)
9977 || (UNLIMITED_POLY (rhs)
9978 && !CLASS_DATA (rhs)->attr.pointer
9979 && !CLASS_DATA (rhs)->attr.allocatable))
9980 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9982 vec_safe_push (args, tmp);
9983 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9984 ? gfc_class_data_get (lse->expr) : lse->expr;
9985 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9986 || INDIRECT_REF_P (tmp)
9987 || (lhs->ts.type == BT_DERIVED
9988 && lhs->ts.u.derived->attr.unlimited_polymorphic
9989 && !lhs->ts.u.derived->attr.pointer
9990 && !lhs->ts.u.derived->attr.allocatable)
9991 || (UNLIMITED_POLY (lhs)
9992 && !CLASS_DATA (lhs)->attr.pointer
9993 && !CLASS_DATA (lhs)->attr.allocatable))
9994 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9996 vec_safe_push (args, tmp);
9998 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10000 if (to_len != NULL_TREE && !integer_zerop (from_len))
10003 vec_safe_push (args, from_len);
10004 vec_safe_push (args, to_len);
10005 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10007 tmp = fold_build2_loc (input_location, GT_EXPR,
10008 logical_type_node, from_len,
10009 build_zero_cst (TREE_TYPE (from_len)));
10010 return fold_build3_loc (input_location, COND_EXPR,
10011 void_type_node, tmp,
10019 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10020 ? gfc_class_data_get (lse->expr) : lse->expr;
10021 stmtblock_t tblock;
10022 gfc_init_block (&tblock);
10023 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10024 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10025 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10026 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10027 /* When coming from a ptr_copy lhs and rhs are swapped. */
10028 gfc_add_modify_loc (input_location, &tblock, rhst,
10029 fold_convert (TREE_TYPE (rhst), tmp));
10030 return gfc_finish_block (&tblock);
10034 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10035 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10036 init_flag indicates initialization expressions and dealloc that no
10037 deallocate prior assignment is needed (if in doubt, set true).
10038 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10039 routine instead of a pointer assignment. Alias resolution is only done,
10040 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10041 where it is known, that newly allocated memory on the lhs can never be
10042 an alias of the rhs. */
10045 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10046 bool dealloc, bool use_vptr_copy, bool may_alias)
10051 gfc_ss *lss_section;
10058 bool scalar_to_array;
10059 tree string_length;
10061 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10062 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10063 bool is_poly_assign;
10065 /* Assignment of the form lhs = rhs. */
10066 gfc_start_block (&block);
10068 gfc_init_se (&lse, NULL);
10069 gfc_init_se (&rse, NULL);
10071 /* Walk the lhs. */
10072 lss = gfc_walk_expr (expr1);
10073 if (gfc_is_reallocatable_lhs (expr1))
10075 lss->no_bounds_check = 1;
10076 if (!(expr2->expr_type == EXPR_FUNCTION
10077 && expr2->value.function.isym != NULL
10078 && !(expr2->value.function.isym->elemental
10079 || expr2->value.function.isym->conversion)))
10080 lss->is_alloc_lhs = 1;
10083 lss->no_bounds_check = expr1->no_bounds_check;
10087 if ((expr1->ts.type == BT_DERIVED)
10088 && (gfc_is_class_array_function (expr2)
10089 || gfc_is_alloc_class_scalar_function (expr2)))
10090 expr2->must_finalize = 1;
10092 /* Checking whether a class assignment is desired is quite complicated and
10093 needed at two locations, so do it once only before the information is
10095 lhs_attr = gfc_expr_attr (expr1);
10096 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10097 || (lhs_attr.allocatable && !lhs_attr.dimension))
10098 && (expr1->ts.type == BT_CLASS
10099 || gfc_is_class_array_ref (expr1, NULL)
10100 || gfc_is_class_scalar_expr (expr1)
10101 || gfc_is_class_array_ref (expr2, NULL)
10102 || gfc_is_class_scalar_expr (expr2));
10105 /* Only analyze the expressions for coarray properties, when in coarray-lib
10107 if (flag_coarray == GFC_FCOARRAY_LIB)
10109 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10110 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10113 if (lss != gfc_ss_terminator)
10115 /* The assignment needs scalarization. */
10118 /* Find a non-scalar SS from the lhs. */
10119 while (lss_section != gfc_ss_terminator
10120 && lss_section->info->type != GFC_SS_SECTION)
10121 lss_section = lss_section->next;
10123 gcc_assert (lss_section != gfc_ss_terminator);
10125 /* Initialize the scalarizer. */
10126 gfc_init_loopinfo (&loop);
10128 /* Walk the rhs. */
10129 rss = gfc_walk_expr (expr2);
10130 if (rss == gfc_ss_terminator)
10131 /* The rhs is scalar. Add a ss for the expression. */
10132 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10133 /* When doing a class assign, then the handle to the rhs needs to be a
10134 pointer to allow for polymorphism. */
10135 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10136 rss->info->type = GFC_SS_REFERENCE;
10138 rss->no_bounds_check = expr2->no_bounds_check;
10139 /* Associate the SS with the loop. */
10140 gfc_add_ss_to_loop (&loop, lss);
10141 gfc_add_ss_to_loop (&loop, rss);
10143 /* Calculate the bounds of the scalarization. */
10144 gfc_conv_ss_startstride (&loop);
10145 /* Enable loop reversal. */
10146 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10147 loop.reverse[n] = GFC_ENABLE_REVERSE;
10148 /* Resolve any data dependencies in the statement. */
10150 gfc_conv_resolve_dependencies (&loop, lss, rss);
10151 /* Setup the scalarizing loops. */
10152 gfc_conv_loop_setup (&loop, &expr2->where);
10154 /* Setup the gfc_se structures. */
10155 gfc_copy_loopinfo_to_se (&lse, &loop);
10156 gfc_copy_loopinfo_to_se (&rse, &loop);
10159 gfc_mark_ss_chain_used (rss, 1);
10160 if (loop.temp_ss == NULL)
10163 gfc_mark_ss_chain_used (lss, 1);
10167 lse.ss = loop.temp_ss;
10168 gfc_mark_ss_chain_used (lss, 3);
10169 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10172 /* Allow the scalarizer to workshare array assignments. */
10173 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10174 == OMPWS_WORKSHARE_FLAG
10175 && loop.temp_ss == NULL)
10177 maybe_workshare = true;
10178 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10181 /* Start the scalarized loop body. */
10182 gfc_start_scalarized_body (&loop, &body);
10185 gfc_init_block (&body);
10187 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10189 /* Translate the expression. */
10190 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10191 && lhs_caf_attr.codimension;
10192 gfc_conv_expr (&rse, expr2);
10194 /* Deal with the case of a scalar class function assigned to a derived type. */
10195 if (gfc_is_alloc_class_scalar_function (expr2)
10196 && expr1->ts.type == BT_DERIVED)
10198 rse.expr = gfc_class_data_get (rse.expr);
10199 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10202 /* Stabilize a string length for temporaries. */
10203 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10204 && !(VAR_P (rse.string_length)
10205 || TREE_CODE (rse.string_length) == PARM_DECL
10206 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10207 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10208 else if (expr2->ts.type == BT_CHARACTER)
10209 string_length = rse.string_length;
10211 string_length = NULL_TREE;
10215 gfc_conv_tmp_array_ref (&lse);
10216 if (expr2->ts.type == BT_CHARACTER)
10217 lse.string_length = string_length;
10221 gfc_conv_expr (&lse, expr1);
10222 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10224 && gfc_expr_attr (expr1).allocatable
10231 tmp = INDIRECT_REF_P (lse.expr)
10232 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10234 /* We should only get array references here. */
10235 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10236 || TREE_CODE (tmp) == ARRAY_REF);
10238 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10239 or the array itself(ARRAY_REF). */
10240 tmp = TREE_OPERAND (tmp, 0);
10242 /* Provide the address of the array. */
10243 if (TREE_CODE (lse.expr) == ARRAY_REF)
10244 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10246 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10247 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10248 msg = _("Assignment of scalar to unallocated array");
10249 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10250 &expr1->where, msg);
10253 /* Deallocate the lhs parameterized components if required. */
10254 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10255 && !expr1->symtree->n.sym->attr.associate_var)
10257 if (expr1->ts.type == BT_DERIVED
10258 && expr1->ts.u.derived
10259 && expr1->ts.u.derived->attr.pdt_type)
10261 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10263 gfc_add_expr_to_block (&lse.pre, tmp);
10265 else if (expr1->ts.type == BT_CLASS
10266 && CLASS_DATA (expr1)->ts.u.derived
10267 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10269 tmp = gfc_class_data_get (lse.expr);
10270 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10272 gfc_add_expr_to_block (&lse.pre, tmp);
10277 /* Assignments of scalar derived types with allocatable components
10278 to arrays must be done with a deep copy and the rhs temporary
10279 must have its components deallocated afterwards. */
10280 scalar_to_array = (expr2->ts.type == BT_DERIVED
10281 && expr2->ts.u.derived->attr.alloc_comp
10282 && !gfc_expr_is_variable (expr2)
10283 && expr1->rank && !expr2->rank);
10284 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10286 && expr1->ts.u.derived->attr.alloc_comp
10287 && gfc_is_alloc_class_scalar_function (expr2));
10288 if (scalar_to_array && dealloc)
10290 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10291 gfc_prepend_expr_to_block (&loop.post, tmp);
10294 /* When assigning a character function result to a deferred-length variable,
10295 the function call must happen before the (re)allocation of the lhs -
10296 otherwise the character length of the result is not known.
10297 NOTE 1: This relies on having the exact dependence of the length type
10298 parameter available to the caller; gfortran saves it in the .mod files.
10299 NOTE 2: Vector array references generate an index temporary that must
10300 not go outside the loop. Otherwise, variables should not generate
10302 NOTE 3: The concatenation operation generates a temporary pointer,
10303 whose allocation must go to the innermost loop.
10304 NOTE 4: Elemental functions may generate a temporary, too. */
10305 if (flag_realloc_lhs
10306 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10307 && !(lss != gfc_ss_terminator
10308 && rss != gfc_ss_terminator
10309 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10310 || (expr2->expr_type == EXPR_FUNCTION
10311 && expr2->value.function.esym != NULL
10312 && expr2->value.function.esym->attr.elemental)
10313 || (expr2->expr_type == EXPR_FUNCTION
10314 && expr2->value.function.isym != NULL
10315 && expr2->value.function.isym->elemental)
10316 || (expr2->expr_type == EXPR_OP
10317 && expr2->value.op.op == INTRINSIC_CONCAT))))
10318 gfc_add_block_to_block (&block, &rse.pre);
10320 /* Nullify the allocatable components corresponding to those of the lhs
10321 derived type, so that the finalization of the function result does not
10322 affect the lhs of the assignment. Prepend is used to ensure that the
10323 nullification occurs before the call to the finalizer. In the case of
10324 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10325 as part of the deep copy. */
10326 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10327 && (gfc_is_class_array_function (expr2)
10328 || gfc_is_alloc_class_scalar_function (expr2)))
10331 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10332 gfc_prepend_expr_to_block (&rse.post, tmp);
10333 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10334 gfc_add_block_to_block (&loop.post, &rse.post);
10339 if (is_poly_assign)
10340 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10341 use_vptr_copy || (lhs_attr.allocatable
10342 && !lhs_attr.dimension),
10343 flag_realloc_lhs && !lhs_attr.pointer);
10344 else if (flag_coarray == GFC_FCOARRAY_LIB
10345 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10346 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10347 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10349 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10350 allocatable component, because those need to be accessed via the
10351 caf-runtime. No need to check for coindexes here, because resolve
10352 has rewritten those already. */
10354 gfc_actual_arglist a1, a2;
10355 /* Clear the structures to prevent accessing garbage. */
10356 memset (&code, '\0', sizeof (gfc_code));
10357 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10358 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10363 code.ext.actual = &a1;
10364 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10365 tmp = gfc_conv_intrinsic_subroutine (&code);
10367 else if (!is_poly_assign && expr2->must_finalize
10368 && expr1->ts.type == BT_CLASS
10369 && expr2->ts.type == BT_CLASS)
10371 /* This case comes about when the scalarizer provides array element
10372 references. Use the vptr copy function, since this does a deep
10373 copy of allocatable components, without which the finalizer call */
10374 tmp = gfc_get_vptr_from_expr (rse.expr);
10375 if (tmp != NULL_TREE)
10377 tree fcn = gfc_vptr_copy_get (tmp);
10378 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10379 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10380 tmp = build_call_expr_loc (input_location,
10382 gfc_build_addr_expr (NULL, rse.expr),
10383 gfc_build_addr_expr (NULL, lse.expr));
10387 /* If nothing else works, do it the old fashioned way! */
10388 if (tmp == NULL_TREE)
10389 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10390 gfc_expr_is_variable (expr2)
10392 || expr2->expr_type == EXPR_ARRAY,
10393 !(l_is_temp || init_flag) && dealloc,
10394 expr1->symtree->n.sym->attr.codimension);
10396 /* Add the pre blocks to the body. */
10397 gfc_add_block_to_block (&body, &rse.pre);
10398 gfc_add_block_to_block (&body, &lse.pre);
10399 gfc_add_expr_to_block (&body, tmp);
10400 /* Add the post blocks to the body. */
10401 gfc_add_block_to_block (&body, &rse.post);
10402 gfc_add_block_to_block (&body, &lse.post);
10404 if (lss == gfc_ss_terminator)
10406 /* F2003: Add the code for reallocation on assignment. */
10407 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10408 && !is_poly_assign)
10409 alloc_scalar_allocatable_for_assignment (&block, string_length,
10412 /* Use the scalar assignment as is. */
10413 gfc_add_block_to_block (&block, &body);
10417 gcc_assert (lse.ss == gfc_ss_terminator
10418 && rse.ss == gfc_ss_terminator);
10422 gfc_trans_scalarized_loop_boundary (&loop, &body);
10424 /* We need to copy the temporary to the actual lhs. */
10425 gfc_init_se (&lse, NULL);
10426 gfc_init_se (&rse, NULL);
10427 gfc_copy_loopinfo_to_se (&lse, &loop);
10428 gfc_copy_loopinfo_to_se (&rse, &loop);
10430 rse.ss = loop.temp_ss;
10433 gfc_conv_tmp_array_ref (&rse);
10434 gfc_conv_expr (&lse, expr1);
10436 gcc_assert (lse.ss == gfc_ss_terminator
10437 && rse.ss == gfc_ss_terminator);
10439 if (expr2->ts.type == BT_CHARACTER)
10440 rse.string_length = string_length;
10442 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10444 gfc_add_expr_to_block (&body, tmp);
10447 /* F2003: Allocate or reallocate lhs of allocatable array. */
10448 if (flag_realloc_lhs
10449 && gfc_is_reallocatable_lhs (expr1)
10451 && !is_runtime_conformable (expr1, expr2))
10453 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10454 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10455 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10456 if (tmp != NULL_TREE)
10457 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10460 if (maybe_workshare)
10461 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10463 /* Generate the copying loops. */
10464 gfc_trans_scalarizing_loops (&loop, &body);
10466 /* Wrap the whole thing up. */
10467 gfc_add_block_to_block (&block, &loop.pre);
10468 gfc_add_block_to_block (&block, &loop.post);
10470 gfc_cleanup_loop (&loop);
10473 return gfc_finish_block (&block);
10477 /* Check whether EXPR is a copyable array. */
10480 copyable_array_p (gfc_expr * expr)
10482 if (expr->expr_type != EXPR_VARIABLE)
10485 /* First check it's an array. */
10486 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10489 if (!gfc_full_array_ref_p (expr->ref, NULL))
10492 /* Next check that it's of a simple enough type. */
10493 switch (expr->ts.type)
10505 return !expr->ts.u.derived->attr.alloc_comp;
10514 /* Translate an assignment. */
10517 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10518 bool dealloc, bool use_vptr_copy, bool may_alias)
10522 /* Special case a single function returning an array. */
10523 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10525 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10530 /* Special case assigning an array to zero. */
10531 if (copyable_array_p (expr1)
10532 && is_zero_initializer_p (expr2))
10534 tmp = gfc_trans_zero_assign (expr1);
10539 /* Special case copying one array to another. */
10540 if (copyable_array_p (expr1)
10541 && copyable_array_p (expr2)
10542 && gfc_compare_types (&expr1->ts, &expr2->ts)
10543 && !gfc_check_dependency (expr1, expr2, 0))
10545 tmp = gfc_trans_array_copy (expr1, expr2);
10550 /* Special case initializing an array from a constant array constructor. */
10551 if (copyable_array_p (expr1)
10552 && expr2->expr_type == EXPR_ARRAY
10553 && gfc_compare_types (&expr1->ts, &expr2->ts))
10555 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10560 if (UNLIMITED_POLY (expr1) && expr1->rank
10561 && expr2->ts.type != BT_CLASS)
10562 use_vptr_copy = true;
10564 /* Fallback to the scalarizer to generate explicit loops. */
10565 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10566 use_vptr_copy, may_alias);
10570 gfc_trans_init_assign (gfc_code * code)
10572 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10576 gfc_trans_assign (gfc_code * code)
10578 return gfc_trans_assignment (code->expr1, code->expr2, false, true);