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_copy_expr (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 && (UNLIMITED_POLY (e) || VAR_P (tmp)))
1136 gfc_add_modify (&parmse->post, tmp,
1137 fold_convert (TREE_TYPE (tmp), ctree));
1144 cond = gfc_conv_expr_present (e->symtree->n.sym);
1145 /* parmse->pre may contain some preparatory instructions for the
1146 temporary array descriptor. Those may only be executed when the
1147 optional argument is set, therefore add parmse->pre's instructions
1148 to block, which is later guarded by an if (optional_arg_given). */
1149 gfc_add_block_to_block (&parmse->pre, &block);
1150 block.head = parmse->pre.head;
1151 parmse->pre.head = NULL_TREE;
1152 tmp = gfc_finish_block (&block);
1154 if (optional_alloc_ptr)
1155 tmp2 = build_empty_stmt (input_location);
1158 gfc_init_block (&block);
1160 tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var));
1161 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2),
1162 null_pointer_node));
1163 tmp2 = gfc_finish_block (&block);
1166 tmp = build3_loc (input_location, COND_EXPR, void_type_node,
1168 gfc_add_expr_to_block (&parmse->pre, tmp);
1171 gfc_add_block_to_block (&parmse->pre, &block);
1173 /* Pass the address of the class object. */
1174 parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
1176 if (optional && optional_alloc_ptr)
1177 parmse->expr = build3_loc (input_location, COND_EXPR,
1178 TREE_TYPE (parmse->expr),
1180 fold_convert (TREE_TYPE (parmse->expr),
1181 null_pointer_node));
1185 /* Given a class array declaration and an index, returns the address
1186 of the referenced element. */
1189 gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp,
1192 tree data, size, tmp, ctmp, offset, ptr;
1194 data = data_comp != NULL_TREE ? data_comp :
1195 gfc_class_data_get (class_decl);
1196 size = gfc_class_vtab_size_get (class_decl);
1200 tmp = fold_convert (gfc_array_index_type,
1201 gfc_class_len_get (class_decl));
1202 ctmp = fold_build2_loc (input_location, MULT_EXPR,
1203 gfc_array_index_type, size, tmp);
1204 tmp = fold_build2_loc (input_location, GT_EXPR,
1205 logical_type_node, tmp,
1206 build_zero_cst (TREE_TYPE (tmp)));
1207 size = fold_build3_loc (input_location, COND_EXPR,
1208 gfc_array_index_type, tmp, ctmp, size);
1211 offset = fold_build2_loc (input_location, MULT_EXPR,
1212 gfc_array_index_type,
1215 data = gfc_conv_descriptor_data_get (data);
1216 ptr = fold_convert (pvoid_type_node, data);
1217 ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
1218 return fold_convert (TREE_TYPE (data), ptr);
1222 /* Copies one class expression to another, assuming that if either
1223 'to' or 'from' are arrays they are packed. Should 'from' be
1224 NULL_TREE, the initialization expression for 'to' is used, assuming
1225 that the _vptr is set. */
1228 gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
1238 vec<tree, va_gc> *args;
1243 bool is_from_desc = false, is_to_class = false;
1246 /* To prevent warnings on uninitialized variables. */
1247 from_len = to_len = NULL_TREE;
1249 if (from != NULL_TREE)
1250 fcn = gfc_class_vtab_copy_get (from);
1252 fcn = gfc_class_vtab_copy_get (to);
1254 fcn_type = TREE_TYPE (TREE_TYPE (fcn));
1256 if (from != NULL_TREE)
1258 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
1262 from = GFC_DECL_SAVED_DESCRIPTOR (from);
1266 /* Check that from is a class. When the class is part of a coarray,
1267 then from is a common pointer and is to be used as is. */
1268 tmp = POINTER_TYPE_P (TREE_TYPE (from))
1269 ? build_fold_indirect_ref (from) : from;
1271 (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
1272 || (DECL_P (tmp) && GFC_DECL_CLASS (tmp)))
1273 ? gfc_class_data_get (from) : from;
1274 is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
1278 from_data = gfc_class_vtab_def_init_get (to);
1282 if (from != NULL_TREE && unlimited)
1283 from_len = gfc_class_len_or_zero_get (from);
1285 from_len = build_zero_cst (size_type_node);
1288 if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
1291 to_data = gfc_class_data_get (to);
1293 to_len = gfc_class_len_get (to);
1296 /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */
1299 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
1301 stmtblock_t loopbody;
1305 tree orig_nelems = nelems; /* Needed for bounds check. */
1307 gfc_init_block (&body);
1308 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1309 gfc_array_index_type, nelems,
1310 gfc_index_one_node);
1311 nelems = gfc_evaluate_now (tmp, &body);
1312 index = gfc_create_var (gfc_array_index_type, "S");
1316 from_ref = gfc_get_class_array_ref (index, from, from_data,
1318 vec_safe_push (args, from_ref);
1321 vec_safe_push (args, from_data);
1324 to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited);
1327 tmp = gfc_conv_array_data (to);
1328 tmp = build_fold_indirect_ref_loc (input_location, tmp);
1329 to_ref = gfc_build_addr_expr (NULL_TREE,
1330 gfc_build_array_ref (tmp, index, to));
1332 vec_safe_push (args, to_ref);
1334 /* Add bounds check. */
1335 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
1338 const char *name = "<<unknown>>";
1342 name = (const char *)(DECL_NAME (to)->identifier.id.str);
1344 from_len = gfc_conv_descriptor_size (from_data, 1);
1345 tmp = fold_build2_loc (input_location, NE_EXPR,
1346 logical_type_node, from_len, orig_nelems);
1347 msg = xasprintf ("Array bound mismatch for dimension %d "
1348 "of array '%s' (%%ld/%%ld)",
1351 gfc_trans_runtime_check (true, false, tmp, &body,
1352 &gfc_current_locus, msg,
1353 fold_convert (long_integer_type_node, orig_nelems),
1354 fold_convert (long_integer_type_node, from_len));
1359 tmp = build_call_vec (fcn_type, fcn, args);
1361 /* Build the body of the loop. */
1362 gfc_init_block (&loopbody);
1363 gfc_add_expr_to_block (&loopbody, tmp);
1365 /* Build the loop and return. */
1366 gfc_init_loopinfo (&loop);
1368 loop.from[0] = gfc_index_zero_node;
1369 loop.loopvar[0] = index;
1370 loop.to[0] = nelems;
1371 gfc_trans_scalarizing_loops (&loop, &loopbody);
1372 gfc_init_block (&ifbody);
1373 gfc_add_block_to_block (&ifbody, &loop.pre);
1374 stdcopy = gfc_finish_block (&ifbody);
1375 /* In initialization mode from_len is a constant zero. */
1376 if (unlimited && !integer_zerop (from_len))
1378 vec_safe_push (args, from_len);
1379 vec_safe_push (args, to_len);
1380 tmp = build_call_vec (fcn_type, fcn, args);
1381 /* Build the body of the loop. */
1382 gfc_init_block (&loopbody);
1383 gfc_add_expr_to_block (&loopbody, tmp);
1385 /* Build the loop and return. */
1386 gfc_init_loopinfo (&loop);
1388 loop.from[0] = gfc_index_zero_node;
1389 loop.loopvar[0] = index;
1390 loop.to[0] = nelems;
1391 gfc_trans_scalarizing_loops (&loop, &loopbody);
1392 gfc_init_block (&ifbody);
1393 gfc_add_block_to_block (&ifbody, &loop.pre);
1394 extcopy = gfc_finish_block (&ifbody);
1396 tmp = fold_build2_loc (input_location, GT_EXPR,
1397 logical_type_node, from_len,
1398 build_zero_cst (TREE_TYPE (from_len)));
1399 tmp = fold_build3_loc (input_location, COND_EXPR,
1400 void_type_node, tmp, extcopy, stdcopy);
1401 gfc_add_expr_to_block (&body, tmp);
1402 tmp = gfc_finish_block (&body);
1406 gfc_add_expr_to_block (&body, stdcopy);
1407 tmp = gfc_finish_block (&body);
1409 gfc_cleanup_loop (&loop);
1413 gcc_assert (!is_from_desc);
1414 vec_safe_push (args, from_data);
1415 vec_safe_push (args, to_data);
1416 stdcopy = build_call_vec (fcn_type, fcn, args);
1418 /* In initialization mode from_len is a constant zero. */
1419 if (unlimited && !integer_zerop (from_len))
1421 vec_safe_push (args, from_len);
1422 vec_safe_push (args, to_len);
1423 extcopy = build_call_vec (fcn_type, fcn, args);
1424 tmp = fold_build2_loc (input_location, GT_EXPR,
1425 logical_type_node, from_len,
1426 build_zero_cst (TREE_TYPE (from_len)));
1427 tmp = fold_build3_loc (input_location, COND_EXPR,
1428 void_type_node, tmp, extcopy, stdcopy);
1434 /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
1435 if (from == NULL_TREE)
1438 cond = fold_build2_loc (input_location, NE_EXPR,
1440 from_data, null_pointer_node);
1441 tmp = fold_build3_loc (input_location, COND_EXPR,
1442 void_type_node, cond,
1443 tmp, build_empty_stmt (input_location));
1451 gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
1453 gfc_actual_arglist *actual;
1458 actual = gfc_get_actual_arglist ();
1459 actual->expr = gfc_copy_expr (rhs);
1460 actual->next = gfc_get_actual_arglist ();
1461 actual->next->expr = gfc_copy_expr (lhs);
1462 ppc = gfc_copy_expr (obj);
1463 gfc_add_vptr_component (ppc);
1464 gfc_add_component_ref (ppc, "_copy");
1465 ppc_code = gfc_get_code (EXEC_CALL);
1466 ppc_code->resolved_sym = ppc->symtree->n.sym;
1467 /* Although '_copy' is set to be elemental in class.c, it is
1468 not staying that way. Find out why, sometime.... */
1469 ppc_code->resolved_sym->attr.elemental = 1;
1470 ppc_code->ext.actual = actual;
1471 ppc_code->expr1 = ppc;
1472 /* Since '_copy' is elemental, the scalarizer will take care
1473 of arrays in gfc_trans_call. */
1474 res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
1475 gfc_free_statements (ppc_code);
1477 if (UNLIMITED_POLY(obj))
1479 /* Check if rhs is non-NULL. */
1481 gfc_init_se (&src, NULL);
1482 gfc_conv_expr (&src, rhs);
1483 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1484 tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1485 src.expr, fold_convert (TREE_TYPE (src.expr),
1486 null_pointer_node));
1487 res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res,
1488 build_empty_stmt (input_location));
1494 /* Special case for initializing a polymorphic dummy with INTENT(OUT).
1495 A MEMCPY is needed to copy the full data from the default initializer
1496 of the dynamic type. */
1499 gfc_trans_class_init_assign (gfc_code *code)
1503 gfc_se dst,src,memsz;
1504 gfc_expr *lhs, *rhs, *sz;
1506 gfc_start_block (&block);
1508 lhs = gfc_copy_expr (code->expr1);
1510 rhs = gfc_copy_expr (code->expr1);
1511 gfc_add_vptr_component (rhs);
1513 /* Make sure that the component backend_decls have been built, which
1514 will not have happened if the derived types concerned have not
1516 gfc_get_derived_type (rhs->ts.u.derived);
1517 gfc_add_def_init_component (rhs);
1518 /* The _def_init is always scalar. */
1521 if (code->expr1->ts.type == BT_CLASS
1522 && CLASS_DATA (code->expr1)->attr.dimension)
1524 gfc_array_spec *tmparr = gfc_get_array_spec ();
1525 *tmparr = *CLASS_DATA (code->expr1)->as;
1526 /* Adding the array ref to the class expression results in correct
1527 indexing to the dynamic type. */
1528 gfc_add_full_array_ref (lhs, tmparr);
1529 tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
1533 /* Scalar initialization needs the _data component. */
1534 gfc_add_data_component (lhs);
1535 sz = gfc_copy_expr (code->expr1);
1536 gfc_add_vptr_component (sz);
1537 gfc_add_size_component (sz);
1539 gfc_init_se (&dst, NULL);
1540 gfc_init_se (&src, NULL);
1541 gfc_init_se (&memsz, NULL);
1542 gfc_conv_expr (&dst, lhs);
1543 gfc_conv_expr (&src, rhs);
1544 gfc_conv_expr (&memsz, sz);
1545 gfc_add_block_to_block (&block, &src.pre);
1546 src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
1548 tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
1550 if (UNLIMITED_POLY(code->expr1))
1552 /* Check if _def_init is non-NULL. */
1553 tree cond = fold_build2_loc (input_location, NE_EXPR,
1554 logical_type_node, src.expr,
1555 fold_convert (TREE_TYPE (src.expr),
1556 null_pointer_node));
1557 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond,
1558 tmp, build_empty_stmt (input_location));
1562 if (code->expr1->symtree->n.sym->attr.optional
1563 || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)
1565 tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym);
1566 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
1568 build_empty_stmt (input_location));
1571 gfc_add_expr_to_block (&block, tmp);
1573 return gfc_finish_block (&block);
1577 /* End of prototype trans-class.c */
1581 realloc_lhs_warning (bt type, bool array, locus *where)
1583 if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs)
1584 gfc_warning (OPT_Wrealloc_lhs,
1585 "Code for reallocating the allocatable array at %L will "
1587 else if (warn_realloc_lhs_all)
1588 gfc_warning (OPT_Wrealloc_lhs_all,
1589 "Code for reallocating the allocatable variable at %L "
1590 "will be added", where);
1594 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1597 /* Copy the scalarization loop variables. */
1600 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
1603 dest->loop = src->loop;
1607 /* Initialize a simple expression holder.
1609 Care must be taken when multiple se are created with the same parent.
1610 The child se must be kept in sync. The easiest way is to delay creation
1611 of a child se until after after the previous se has been translated. */
1614 gfc_init_se (gfc_se * se, gfc_se * parent)
1616 memset (se, 0, sizeof (gfc_se));
1617 gfc_init_block (&se->pre);
1618 gfc_init_block (&se->post);
1620 se->parent = parent;
1623 gfc_copy_se_loopvars (se, parent);
1627 /* Advances to the next SS in the chain. Use this rather than setting
1628 se->ss = se->ss->next because all the parents needs to be kept in sync.
1632 gfc_advance_se_ss_chain (gfc_se * se)
1637 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
1640 /* Walk down the parent chain. */
1643 /* Simple consistency check. */
1644 gcc_assert (p->parent == NULL || p->parent->ss == p->ss
1645 || p->parent->ss->nested_ss == p->ss);
1647 /* If we were in a nested loop, the next scalarized expression can be
1648 on the parent ss' next pointer. Thus we should not take the next
1649 pointer blindly, but rather go up one nest level as long as next
1650 is the end of chain. */
1652 while (ss->next == gfc_ss_terminator && ss->parent != NULL)
1662 /* Ensures the result of the expression as either a temporary variable
1663 or a constant so that it can be used repeatedly. */
1666 gfc_make_safe_expr (gfc_se * se)
1670 if (CONSTANT_CLASS_P (se->expr))
1673 /* We need a temporary for this result. */
1674 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
1675 gfc_add_modify (&se->pre, var, se->expr);
1680 /* Return an expression which determines if a dummy parameter is present.
1681 Also used for arguments to procedures with multiple entry points. */
1684 gfc_conv_expr_present (gfc_symbol * sym)
1688 gcc_assert (sym->attr.dummy);
1689 decl = gfc_get_symbol_decl (sym);
1691 /* Intrinsic scalars with VALUE attribute which are passed by value
1692 use a hidden argument to denote the present status. */
1693 if (sym->attr.value && sym->ts.type != BT_CHARACTER
1694 && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED
1695 && !sym->attr.dimension)
1697 char name[GFC_MAX_SYMBOL_LEN + 2];
1700 gcc_assert (TREE_CODE (decl) == PARM_DECL);
1702 strcpy (&name[1], sym->name);
1703 tree_name = get_identifier (name);
1705 /* Walk function argument list to find hidden arg. */
1706 cond = DECL_ARGUMENTS (DECL_CONTEXT (decl));
1707 for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond))
1708 if (DECL_NAME (cond) == tree_name)
1715 if (TREE_CODE (decl) != PARM_DECL)
1717 /* Array parameters use a temporary descriptor, we want the real
1719 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
1720 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
1721 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
1724 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl,
1725 fold_convert (TREE_TYPE (decl), null_pointer_node));
1727 /* Fortran 2008 allows to pass null pointers and non-associated pointers
1728 as actual argument to denote absent dummies. For array descriptors,
1729 we thus also need to check the array descriptor. For BT_CLASS, it
1730 can also occur for scalars and F2003 due to type->class wrapping and
1731 class->class wrapping. Note further that BT_CLASS always uses an
1732 array descriptor for arrays, also for explicit-shape/assumed-size. */
1734 if (!sym->attr.allocatable
1735 && ((sym->ts.type != BT_CLASS && !sym->attr.pointer)
1736 || (sym->ts.type == BT_CLASS
1737 && !CLASS_DATA (sym)->attr.allocatable
1738 && !CLASS_DATA (sym)->attr.class_pointer))
1739 && ((gfc_option.allow_std & GFC_STD_F2008) != 0
1740 || sym->ts.type == BT_CLASS))
1744 if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE
1745 || sym->as->type == AS_ASSUMED_RANK
1746 || sym->attr.codimension))
1747 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as))
1749 tmp = build_fold_indirect_ref_loc (input_location, decl);
1750 if (sym->ts.type == BT_CLASS)
1751 tmp = gfc_class_data_get (tmp);
1752 tmp = gfc_conv_array_data (tmp);
1754 else if (sym->ts.type == BT_CLASS)
1755 tmp = gfc_class_data_get (decl);
1759 if (tmp != NULL_TREE)
1761 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
1762 fold_convert (TREE_TYPE (tmp), null_pointer_node));
1763 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
1764 logical_type_node, cond, tmp);
1772 /* Converts a missing, dummy argument into a null or zero. */
1775 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
1780 present = gfc_conv_expr_present (arg->symtree->n.sym);
1784 /* Create a temporary and convert it to the correct type. */
1785 tmp = gfc_get_int_type (kind);
1786 tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
1789 /* Test for a NULL value. */
1790 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
1791 tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
1792 tmp = gfc_evaluate_now (tmp, &se->pre);
1793 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
1797 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
1799 build_zero_cst (TREE_TYPE (se->expr)));
1800 tmp = gfc_evaluate_now (tmp, &se->pre);
1804 if (ts.type == BT_CHARACTER)
1806 tmp = build_int_cst (gfc_charlen_type_node, 0);
1807 tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node,
1808 present, se->string_length, tmp);
1809 tmp = gfc_evaluate_now (tmp, &se->pre);
1810 se->string_length = tmp;
1816 /* Get the character length of an expression, looking through gfc_refs
1820 gfc_get_expr_charlen (gfc_expr *e)
1825 gcc_assert (e->expr_type == EXPR_VARIABLE
1826 && e->ts.type == BT_CHARACTER);
1828 length = NULL; /* To silence compiler warning. */
1830 if (is_subref_array (e) && e->ts.u.cl->length)
1833 gfc_init_se (&tmpse, NULL);
1834 gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
1835 e->ts.u.cl->backend_decl = tmpse.expr;
1839 /* First candidate: if the variable is of type CHARACTER, the
1840 expression's length could be the length of the character
1842 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
1843 length = e->symtree->n.sym->ts.u.cl->backend_decl;
1845 /* Look through the reference chain for component references. */
1846 for (r = e->ref; r; r = r->next)
1851 if (r->u.c.component->ts.type == BT_CHARACTER)
1852 length = r->u.c.component->ts.u.cl->backend_decl;
1860 /* We should never got substring references here. These will be
1861 broken down by the scalarizer. */
1867 gcc_assert (length != NULL);
1872 /* Return for an expression the backend decl of the coarray. */
1875 gfc_get_tree_for_caf_expr (gfc_expr *expr)
1881 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
1883 /* Not-implemented diagnostic. */
1884 if (expr->symtree->n.sym->ts.type == BT_CLASS
1885 && UNLIMITED_POLY (expr->symtree->n.sym)
1886 && CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1887 gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at "
1888 "%L is not supported", &expr->where);
1890 for (ref = expr->ref; ref; ref = ref->next)
1891 if (ref->type == REF_COMPONENT)
1893 if (ref->u.c.component->ts.type == BT_CLASS
1894 && UNLIMITED_POLY (ref->u.c.component)
1895 && CLASS_DATA (ref->u.c.component)->attr.codimension)
1896 gfc_error ("Sorry, coindexed access to an unlimited polymorphic "
1897 "component at %L is not supported", &expr->where);
1900 /* Make sure the backend_decl is present before accessing it. */
1901 caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE
1902 ? gfc_get_symbol_decl (expr->symtree->n.sym)
1903 : expr->symtree->n.sym->backend_decl;
1905 if (expr->symtree->n.sym->ts.type == BT_CLASS)
1907 if (expr->ref && expr->ref->type == REF_ARRAY)
1909 caf_decl = gfc_class_data_get (caf_decl);
1910 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1913 for (ref = expr->ref; ref; ref = ref->next)
1915 if (ref->type == REF_COMPONENT
1916 && strcmp (ref->u.c.component->name, "_data") != 0)
1918 caf_decl = gfc_class_data_get (caf_decl);
1919 if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension)
1923 else if (ref->type == REF_ARRAY && ref->u.ar.dimen)
1927 if (expr->symtree->n.sym->attr.codimension)
1930 /* The following code assumes that the coarray is a component reachable via
1931 only scalar components/variables; the Fortran standard guarantees this. */
1933 for (ref = expr->ref; ref; ref = ref->next)
1934 if (ref->type == REF_COMPONENT)
1936 gfc_component *comp = ref->u.c.component;
1938 if (POINTER_TYPE_P (TREE_TYPE (caf_decl)))
1939 caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1940 caf_decl = fold_build3_loc (input_location, COMPONENT_REF,
1941 TREE_TYPE (comp->backend_decl), caf_decl,
1942 comp->backend_decl, NULL_TREE);
1943 if (comp->ts.type == BT_CLASS)
1945 caf_decl = gfc_class_data_get (caf_decl);
1946 if (CLASS_DATA (comp)->attr.codimension)
1952 if (comp->attr.codimension)
1958 gcc_assert (found && caf_decl);
1963 /* Obtain the Coarray token - and optionally also the offset. */
1966 gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
1967 tree se_expr, gfc_expr *expr)
1971 /* Coarray token. */
1972 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
1974 gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
1975 == GFC_ARRAY_ALLOCATABLE
1976 || expr->symtree->n.sym->attr.select_type_temporary);
1977 *token = gfc_conv_descriptor_token (caf_decl);
1979 else if (DECL_LANG_SPECIFIC (caf_decl)
1980 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
1981 *token = GFC_DECL_TOKEN (caf_decl);
1984 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
1985 && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
1986 *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
1992 /* Offset between the coarray base address and the address wanted. */
1993 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
1994 && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
1995 || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
1996 *offset = build_int_cst (gfc_array_index_type, 0);
1997 else if (DECL_LANG_SPECIFIC (caf_decl)
1998 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
1999 *offset = GFC_DECL_CAF_OFFSET (caf_decl);
2000 else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
2001 *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
2003 *offset = build_int_cst (gfc_array_index_type, 0);
2005 if (POINTER_TYPE_P (TREE_TYPE (se_expr))
2006 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
2008 tmp = build_fold_indirect_ref_loc (input_location, se_expr);
2009 tmp = gfc_conv_descriptor_data_get (tmp);
2011 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
2012 tmp = gfc_conv_descriptor_data_get (se_expr);
2015 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
2019 *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2020 *offset, fold_convert (gfc_array_index_type, tmp));
2022 if (expr->symtree->n.sym->ts.type == BT_DERIVED
2023 && expr->symtree->n.sym->attr.codimension
2024 && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
2026 gfc_expr *base_expr = gfc_copy_expr (expr);
2027 gfc_ref *ref = base_expr->ref;
2030 // Iterate through the refs until the last one.
2034 if (ref->type == REF_ARRAY
2035 && ref->u.ar.type != AR_FULL)
2037 const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen;
2039 for (i = 0; i < ranksum; ++i)
2041 ref->u.ar.start[i] = NULL;
2042 ref->u.ar.end[i] = NULL;
2044 ref->u.ar.type = AR_FULL;
2046 gfc_init_se (&base_se, NULL);
2047 if (gfc_caf_attr (base_expr).dimension)
2049 gfc_conv_expr_descriptor (&base_se, base_expr);
2050 tmp = gfc_conv_descriptor_data_get (base_se.expr);
2054 gfc_conv_expr (&base_se, base_expr);
2058 gfc_free_expr (base_expr);
2059 gfc_add_block_to_block (&se->pre, &base_se.pre);
2060 gfc_add_block_to_block (&se->post, &base_se.post);
2062 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
2063 tmp = gfc_conv_descriptor_data_get (caf_decl);
2066 gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
2070 *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2071 fold_convert (gfc_array_index_type, *offset),
2072 fold_convert (gfc_array_index_type, tmp));
2076 /* Convert the coindex of a coarray into an image index; the result is
2077 image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1)
2078 + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */
2081 gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
2084 tree lbound, ubound, extent, tmp, img_idx;
2088 for (ref = e->ref; ref; ref = ref->next)
2089 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
2091 gcc_assert (ref != NULL);
2093 if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
2095 return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2099 img_idx = build_zero_cst (gfc_array_index_type);
2100 extent = build_one_cst (gfc_array_index_type);
2101 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
2102 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2104 gfc_init_se (&se, NULL);
2105 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2106 gfc_add_block_to_block (block, &se.pre);
2107 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
2108 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2109 TREE_TYPE (lbound), se.expr, lbound);
2110 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2112 img_idx = fold_build2_loc (input_location, PLUS_EXPR,
2113 TREE_TYPE (tmp), img_idx, tmp);
2114 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2116 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
2117 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2118 extent = fold_build2_loc (input_location, MULT_EXPR,
2119 TREE_TYPE (tmp), extent, tmp);
2123 for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
2125 gfc_init_se (&se, NULL);
2126 gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type);
2127 gfc_add_block_to_block (block, &se.pre);
2128 lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
2129 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2130 TREE_TYPE (lbound), se.expr, lbound);
2131 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
2133 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2135 if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
2137 ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
2138 tmp = fold_build2_loc (input_location, MINUS_EXPR,
2139 TREE_TYPE (ubound), ubound, lbound);
2140 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
2141 tmp, build_one_cst (TREE_TYPE (tmp)));
2142 extent = fold_build2_loc (input_location, MULT_EXPR,
2143 TREE_TYPE (tmp), extent, tmp);
2146 img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx),
2147 img_idx, build_one_cst (TREE_TYPE (img_idx)));
2148 return fold_convert (integer_type_node, img_idx);
2152 /* For each character array constructor subexpression without a ts.u.cl->length,
2153 replace it by its first element (if there aren't any elements, the length
2154 should already be set to zero). */
2157 flatten_array_ctors_without_strlen (gfc_expr* e)
2159 gfc_actual_arglist* arg;
2165 switch (e->expr_type)
2169 flatten_array_ctors_without_strlen (e->value.op.op1);
2170 flatten_array_ctors_without_strlen (e->value.op.op2);
2174 /* TODO: Implement as with EXPR_FUNCTION when needed. */
2178 for (arg = e->value.function.actual; arg; arg = arg->next)
2179 flatten_array_ctors_without_strlen (arg->expr);
2184 /* We've found what we're looking for. */
2185 if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
2190 gcc_assert (e->value.constructor);
2192 c = gfc_constructor_first (e->value.constructor);
2196 flatten_array_ctors_without_strlen (new_expr);
2197 gfc_replace_expr (e, new_expr);
2201 /* Otherwise, fall through to handle constructor elements. */
2203 case EXPR_STRUCTURE:
2204 for (c = gfc_constructor_first (e->value.constructor);
2205 c; c = gfc_constructor_next (c))
2206 flatten_array_ctors_without_strlen (c->expr);
2216 /* Generate code to initialize a string length variable. Returns the
2217 value. For array constructors, cl->length might be NULL and in this case,
2218 the first element of the constructor is needed. expr is the original
2219 expression so we can access it but can be NULL if this is not needed. */
2222 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
2226 gfc_init_se (&se, NULL);
2228 if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl))
2231 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
2232 "flatten" array constructors by taking their first element; all elements
2233 should be the same length or a cl->length should be present. */
2236 gfc_expr* expr_flat;
2239 expr_flat = gfc_copy_expr (expr);
2240 flatten_array_ctors_without_strlen (expr_flat);
2241 gfc_resolve_expr (expr_flat);
2243 gfc_conv_expr (&se, expr_flat);
2244 gfc_add_block_to_block (pblock, &se.pre);
2245 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
2247 gfc_free_expr (expr_flat);
2251 /* Convert cl->length. */
2253 gcc_assert (cl->length);
2255 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
2256 se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2257 se.expr, build_zero_cst (TREE_TYPE (se.expr)));
2258 gfc_add_block_to_block (pblock, &se.pre);
2260 if (cl->backend_decl)
2261 gfc_add_modify (pblock, cl->backend_decl, se.expr);
2263 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
2268 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
2269 const char *name, locus *where)
2279 type = gfc_get_character_type (kind, ref->u.ss.length);
2280 type = build_pointer_type (type);
2282 gfc_init_se (&start, se);
2283 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
2284 gfc_add_block_to_block (&se->pre, &start.pre);
2286 if (integer_onep (start.expr))
2287 gfc_conv_string_parameter (se);
2292 /* Avoid multiple evaluation of substring start. */
2293 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2294 start.expr = gfc_evaluate_now (start.expr, &se->pre);
2296 /* Change the start of the string. */
2297 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
2300 tmp = build_fold_indirect_ref_loc (input_location,
2302 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
2303 se->expr = gfc_build_addr_expr (type, tmp);
2306 /* Length = end + 1 - start. */
2307 gfc_init_se (&end, se);
2308 if (ref->u.ss.end == NULL)
2309 end.expr = se->string_length;
2312 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
2313 gfc_add_block_to_block (&se->pre, &end.pre);
2317 if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
2318 end.expr = gfc_evaluate_now (end.expr, &se->pre);
2320 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2322 tree nonempty = fold_build2_loc (input_location, LE_EXPR,
2323 logical_type_node, start.expr,
2326 /* Check lower bound. */
2327 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
2329 build_one_cst (TREE_TYPE (start.expr)));
2330 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2331 logical_type_node, nonempty, fault);
2333 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' "
2334 "is less than one", name);
2336 msg = xasprintf ("Substring out of bounds: lower bound (%%ld) "
2337 "is less than one");
2338 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2339 fold_convert (long_integer_type_node,
2343 /* Check upper bound. */
2344 fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
2345 end.expr, se->string_length);
2346 fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
2347 logical_type_node, nonempty, fault);
2349 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' "
2350 "exceeds string length (%%ld)", name);
2352 msg = xasprintf ("Substring out of bounds: upper bound (%%ld) "
2353 "exceeds string length (%%ld)");
2354 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
2355 fold_convert (long_integer_type_node, end.expr),
2356 fold_convert (long_integer_type_node,
2357 se->string_length));
2361 /* Try to calculate the length from the start and end expressions. */
2363 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
2365 HOST_WIDE_INT i_len;
2367 i_len = gfc_mpz_get_hwi (length) + 1;
2371 tmp = build_int_cst (gfc_charlen_type_node, i_len);
2372 mpz_clear (length); /* Was initialized by gfc_dep_difference. */
2376 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,
2377 fold_convert (gfc_charlen_type_node, end.expr),
2378 fold_convert (gfc_charlen_type_node, start.expr));
2379 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node,
2380 build_int_cst (gfc_charlen_type_node, 1), tmp);
2381 tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node,
2382 tmp, build_int_cst (gfc_charlen_type_node, 0));
2385 se->string_length = tmp;
2389 /* Convert a derived type component reference. */
2392 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
2400 c = ref->u.c.component;
2402 if (c->backend_decl == NULL_TREE
2403 && ref->u.c.sym != NULL)
2404 gfc_get_derived_type (ref->u.c.sym);
2406 field = c->backend_decl;
2407 gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2409 context = DECL_FIELD_CONTEXT (field);
2411 /* Components can correspond to fields of different containing
2412 types, as components are created without context, whereas
2413 a concrete use of a component has the type of decl as context.
2414 So, if the type doesn't match, we search the corresponding
2415 FIELD_DECL in the parent type. To not waste too much time
2416 we cache this result in norestrict_decl.
2417 On the other hand, if the context is a UNION or a MAP (a
2418 RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
2420 if (context != TREE_TYPE (decl)
2421 && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
2422 || TREE_CODE (context) == UNION_TYPE)) /* Field is map */
2424 tree f2 = c->norestrict_decl;
2425 if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
2426 for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
2427 if (TREE_CODE (f2) == FIELD_DECL
2428 && DECL_NAME (f2) == DECL_NAME (field))
2431 c->norestrict_decl = f2;
2435 if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
2436 && strcmp ("_data", c->name) == 0)
2438 /* Found a ref to the _data component. Store the associated ref to
2439 the vptr in se->class_vptr. */
2440 se->class_vptr = gfc_class_vptr_get (decl);
2443 se->class_vptr = NULL_TREE;
2445 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
2446 decl, field, NULL_TREE);
2450 /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
2451 strlen () conditional below. */
2452 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
2453 && !(c->attr.allocatable && c->ts.deferred)
2454 && !c->attr.pdt_string)
2456 tmp = c->ts.u.cl->backend_decl;
2457 /* Components must always be constant length. */
2458 gcc_assert (tmp && INTEGER_CST_P (tmp));
2459 se->string_length = tmp;
2462 if (gfc_deferred_strlen (c, &field))
2464 tmp = fold_build3_loc (input_location, COMPONENT_REF,
2466 decl, field, NULL_TREE);
2467 se->string_length = tmp;
2470 if (((c->attr.pointer || c->attr.allocatable)
2471 && (!c->attr.dimension && !c->attr.codimension)
2472 && c->ts.type != BT_CHARACTER)
2473 || c->attr.proc_pointer)
2474 se->expr = build_fold_indirect_ref_loc (input_location,
2479 /* This function deals with component references to components of the
2480 parent type for derived type extensions. */
2482 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
2490 c = ref->u.c.component;
2492 /* Return if the component is in the parent type. */
2493 for (cmp = dt->components; cmp; cmp = cmp->next)
2494 if (strcmp (c->name, cmp->name) == 0)
2497 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
2498 parent.type = REF_COMPONENT;
2500 parent.u.c.sym = dt;
2501 parent.u.c.component = dt->components;
2503 if (dt->backend_decl == NULL)
2504 gfc_get_derived_type (dt);
2506 /* Build the reference and call self. */
2507 gfc_conv_component_ref (se, &parent);
2508 parent.u.c.sym = dt->components->ts.u.derived;
2509 parent.u.c.component = c;
2510 conv_parent_component_references (se, &parent);
2513 /* Return the contents of a variable. Also handles reference/pointer
2514 variables (all Fortran pointer references are implicit). */
2517 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2522 tree parent_decl = NULL_TREE;
2525 bool alternate_entry;
2528 bool first_time = true;
2530 sym = expr->symtree->n.sym;
2531 is_classarray = IS_CLASS_ARRAY (sym);
2535 gfc_ss_info *ss_info = ss->info;
2537 /* Check that something hasn't gone horribly wrong. */
2538 gcc_assert (ss != gfc_ss_terminator);
2539 gcc_assert (ss_info->expr == expr);
2541 /* A scalarized term. We already know the descriptor. */
2542 se->expr = ss_info->data.array.descriptor;
2543 se->string_length = ss_info->string_length;
2544 ref = ss_info->data.array.ref;
2546 gcc_assert (ref->type == REF_ARRAY
2547 && ref->u.ar.type != AR_ELEMENT);
2549 gfc_conv_tmp_array_ref (se);
2553 tree se_expr = NULL_TREE;
2555 se->expr = gfc_get_symbol_decl (sym);
2557 /* Deal with references to a parent results or entries by storing
2558 the current_function_decl and moving to the parent_decl. */
2559 return_value = sym->attr.function && sym->result == sym;
2560 alternate_entry = sym->attr.function && sym->attr.entry
2561 && sym->result == sym;
2562 entry_master = sym->attr.result
2563 && sym->ns->proc_name->attr.entry_master
2564 && !gfc_return_by_reference (sym->ns->proc_name);
2565 if (current_function_decl)
2566 parent_decl = DECL_CONTEXT (current_function_decl);
2568 if ((se->expr == parent_decl && return_value)
2569 || (sym->ns && sym->ns->proc_name
2571 && sym->ns->proc_name->backend_decl == parent_decl
2572 && (alternate_entry || entry_master)))
2577 /* Special case for assigning the return value of a function.
2578 Self recursive functions must have an explicit return value. */
2579 if (return_value && (se->expr == current_function_decl || parent_flag))
2580 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2582 /* Similarly for alternate entry points. */
2583 else if (alternate_entry
2584 && (sym->ns->proc_name->backend_decl == current_function_decl
2587 gfc_entry_list *el = NULL;
2589 for (el = sym->ns->entries; el; el = el->next)
2592 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2597 else if (entry_master
2598 && (sym->ns->proc_name->backend_decl == current_function_decl
2600 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2605 /* Procedure actual arguments. Look out for temporary variables
2606 with the same attributes as function values. */
2607 else if (!sym->attr.temporary
2608 && sym->attr.flavor == FL_PROCEDURE
2609 && se->expr != current_function_decl)
2611 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2613 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2614 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2620 /* Dereference the expression, where needed. Since characters
2621 are entirely different from other types, they are treated
2623 if (sym->ts.type == BT_CHARACTER)
2625 /* Dereference character pointer dummy arguments
2627 if ((sym->attr.pointer || sym->attr.allocatable)
2629 || sym->attr.function
2630 || sym->attr.result))
2631 se->expr = build_fold_indirect_ref_loc (input_location,
2635 else if (!sym->attr.value)
2637 /* Dereference temporaries for class array dummy arguments. */
2638 if (sym->attr.dummy && is_classarray
2639 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2641 if (!se->descriptor_only)
2642 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2644 se->expr = build_fold_indirect_ref_loc (input_location,
2648 /* Dereference non-character scalar dummy arguments. */
2649 if (sym->attr.dummy && !sym->attr.dimension
2650 && !(sym->attr.codimension && sym->attr.allocatable)
2651 && (sym->ts.type != BT_CLASS
2652 || (!CLASS_DATA (sym)->attr.dimension
2653 && !(CLASS_DATA (sym)->attr.codimension
2654 && CLASS_DATA (sym)->attr.allocatable))))
2655 se->expr = build_fold_indirect_ref_loc (input_location,
2658 /* Dereference scalar hidden result. */
2659 if (flag_f2c && sym->ts.type == BT_COMPLEX
2660 && (sym->attr.function || sym->attr.result)
2661 && !sym->attr.dimension && !sym->attr.pointer
2662 && !sym->attr.always_explicit)
2663 se->expr = build_fold_indirect_ref_loc (input_location,
2666 /* Dereference non-character, non-class pointer variables.
2667 These must be dummies, results, or scalars. */
2669 && (sym->attr.pointer || sym->attr.allocatable
2670 || gfc_is_associate_pointer (sym)
2671 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2673 || sym->attr.function
2675 || (!sym->attr.dimension
2676 && (!sym->attr.codimension || !sym->attr.allocatable))))
2677 se->expr = build_fold_indirect_ref_loc (input_location,
2679 /* Now treat the class array pointer variables accordingly. */
2680 else if (sym->ts.type == BT_CLASS
2682 && (CLASS_DATA (sym)->attr.dimension
2683 || CLASS_DATA (sym)->attr.codimension)
2684 && ((CLASS_DATA (sym)->as
2685 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2686 || CLASS_DATA (sym)->attr.allocatable
2687 || CLASS_DATA (sym)->attr.class_pointer))
2688 se->expr = build_fold_indirect_ref_loc (input_location,
2690 /* And the case where a non-dummy, non-result, non-function,
2691 non-allotable and non-pointer classarray is present. This case was
2692 previously covered by the first if, but with introducing the
2693 condition !is_classarray there, that case has to be covered
2695 else if (sym->ts.type == BT_CLASS
2697 && !sym->attr.function
2698 && !sym->attr.result
2699 && (CLASS_DATA (sym)->attr.dimension
2700 || CLASS_DATA (sym)->attr.codimension)
2702 || !CLASS_DATA (sym)->attr.allocatable)
2703 && !CLASS_DATA (sym)->attr.class_pointer)
2704 se->expr = build_fold_indirect_ref_loc (input_location,
2711 /* For character variables, also get the length. */
2712 if (sym->ts.type == BT_CHARACTER)
2714 /* If the character length of an entry isn't set, get the length from
2715 the master function instead. */
2716 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2717 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2719 se->string_length = sym->ts.u.cl->backend_decl;
2720 gcc_assert (se->string_length);
2728 /* Return the descriptor if that's what we want and this is an array
2729 section reference. */
2730 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2732 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2733 /* Return the descriptor for array pointers and allocations. */
2734 if (se->want_pointer
2735 && ref->next == NULL && (se->descriptor_only))
2738 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2739 /* Return a pointer to an element. */
2743 if (first_time && is_classarray && sym->attr.dummy
2744 && se->descriptor_only
2745 && !CLASS_DATA (sym)->attr.allocatable
2746 && !CLASS_DATA (sym)->attr.class_pointer
2747 && CLASS_DATA (sym)->as
2748 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2749 && strcmp ("_data", ref->u.c.component->name) == 0)
2750 /* Skip the first ref of a _data component, because for class
2751 arrays that one is already done by introducing a temporary
2752 array descriptor. */
2755 if (ref->u.c.sym->attr.extension)
2756 conv_parent_component_references (se, ref);
2758 gfc_conv_component_ref (se, ref);
2759 if (!ref->next && ref->u.c.sym->attr.codimension
2760 && se->want_pointer && se->descriptor_only)
2766 gfc_conv_substring (se, ref, expr->ts.kind,
2767 expr->symtree->name, &expr->where);
2777 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2779 if (se->want_pointer)
2781 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2782 gfc_conv_string_parameter (se);
2784 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2789 /* Unary ops are easy... Or they would be if ! was a valid op. */
2792 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2797 gcc_assert (expr->ts.type != BT_CHARACTER);
2798 /* Initialize the operand. */
2799 gfc_init_se (&operand, se);
2800 gfc_conv_expr_val (&operand, expr->value.op.op1);
2801 gfc_add_block_to_block (&se->pre, &operand.pre);
2803 type = gfc_typenode_for_spec (&expr->ts);
2805 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2806 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2807 All other unary operators have an equivalent GIMPLE unary operator. */
2808 if (code == TRUTH_NOT_EXPR)
2809 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2810 build_int_cst (type, 0));
2812 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2816 /* Expand power operator to optimal multiplications when a value is raised
2817 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2818 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2819 Programming", 3rd Edition, 1998. */
2821 /* This code is mostly duplicated from expand_powi in the backend.
2822 We establish the "optimal power tree" lookup table with the defined size.
2823 The items in the table are the exponents used to calculate the index
2824 exponents. Any integer n less than the value can get an "addition chain",
2825 with the first node being one. */
2826 #define POWI_TABLE_SIZE 256
2828 /* The table is from builtins.c. */
2829 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2831 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2832 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2833 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2834 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2835 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2836 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2837 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2838 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2839 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2840 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2841 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2842 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2843 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2844 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2845 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2846 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2847 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2848 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2849 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2850 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2851 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2852 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2853 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2854 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2855 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2856 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2857 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2858 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2859 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2860 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2861 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2862 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2865 /* If n is larger than lookup table's max index, we use the "window
2867 #define POWI_WINDOW_SIZE 3
2869 /* Recursive function to expand the power operator. The temporary
2870 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2872 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2879 if (n < POWI_TABLE_SIZE)
2884 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2885 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2889 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2890 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2891 op1 = gfc_conv_powi (se, digit, tmpvar);
2895 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2899 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2900 tmp = gfc_evaluate_now (tmp, &se->pre);
2902 if (n < POWI_TABLE_SIZE)
2909 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2910 return 1. Else return 0 and a call to runtime library functions
2911 will have to be built. */
2913 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2918 tree vartmp[POWI_TABLE_SIZE];
2920 unsigned HOST_WIDE_INT n;
2922 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2924 /* If exponent is too large, we won't expand it anyway, so don't bother
2925 with large integer values. */
2926 if (!wi::fits_shwi_p (wrhs))
2929 m = wrhs.to_shwi ();
2930 /* Use the wide_int's routine to reliably get the absolute value on all
2931 platforms. Then convert it to a HOST_WIDE_INT like above. */
2932 n = wi::abs (wrhs).to_shwi ();
2934 type = TREE_TYPE (lhs);
2935 sgn = tree_int_cst_sgn (rhs);
2937 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2938 || optimize_size) && (m > 2 || m < -1))
2944 se->expr = gfc_build_const (type, integer_one_node);
2948 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2949 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2951 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2952 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2953 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2954 lhs, build_int_cst (TREE_TYPE (lhs), 1));
2957 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
2960 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2961 logical_type_node, tmp, cond);
2962 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2963 tmp, build_int_cst (type, 1),
2964 build_int_cst (type, 0));
2968 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
2969 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
2970 build_int_cst (type, -1),
2971 build_int_cst (type, 0));
2972 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
2973 cond, build_int_cst (type, 1), tmp);
2977 memset (vartmp, 0, sizeof (vartmp));
2981 tmp = gfc_build_const (type, integer_one_node);
2982 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
2986 se->expr = gfc_conv_powi (se, n, vartmp);
2992 /* Power op (**). Constant integer exponent has special handling. */
2995 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
2997 tree gfc_int4_type_node;
3000 int res_ikind_1, res_ikind_2;
3005 gfc_init_se (&lse, se);
3006 gfc_conv_expr_val (&lse, expr->value.op.op1);
3007 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3008 gfc_add_block_to_block (&se->pre, &lse.pre);
3010 gfc_init_se (&rse, se);
3011 gfc_conv_expr_val (&rse, expr->value.op.op2);
3012 gfc_add_block_to_block (&se->pre, &rse.pre);
3014 if (expr->value.op.op2->ts.type == BT_INTEGER
3015 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3016 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3019 gfc_int4_type_node = gfc_get_int_type (4);
3021 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3022 library routine. But in the end, we have to convert the result back
3023 if this case applies -- with res_ikind_K, we keep track whether operand K
3024 falls into this case. */
3028 kind = expr->value.op.op1->ts.kind;
3029 switch (expr->value.op.op2->ts.type)
3032 ikind = expr->value.op.op2->ts.kind;
3037 rse.expr = convert (gfc_int4_type_node, rse.expr);
3038 res_ikind_2 = ikind;
3060 if (expr->value.op.op1->ts.type == BT_INTEGER)
3062 lse.expr = convert (gfc_int4_type_node, lse.expr);
3089 switch (expr->value.op.op1->ts.type)
3092 if (kind == 3) /* Case 16 was not handled properly above. */
3094 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3098 /* Use builtins for real ** int4. */
3104 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3108 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3112 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3116 /* Use the __builtin_powil() only if real(kind=16) is
3117 actually the C long double type. */
3118 if (!gfc_real16_is_float128)
3119 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3127 /* If we don't have a good builtin for this, go for the
3128 library function. */
3130 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3134 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3143 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3147 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3155 se->expr = build_call_expr_loc (input_location,
3156 fndecl, 2, lse.expr, rse.expr);
3158 /* Convert the result back if it is of wrong integer kind. */
3159 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3161 /* We want the maximum of both operand kinds as result. */
3162 if (res_ikind_1 < res_ikind_2)
3163 res_ikind_1 = res_ikind_2;
3164 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3169 /* Generate code to allocate a string temporary. */
3172 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3177 if (gfc_can_put_var_on_stack (len))
3179 /* Create a temporary variable to hold the result. */
3180 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3181 TREE_TYPE (len), len,
3182 build_int_cst (TREE_TYPE (len), 1));
3183 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3185 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3186 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3188 tmp = build_array_type (TREE_TYPE (type), tmp);
3190 var = gfc_create_var (tmp, "str");
3191 var = gfc_build_addr_expr (type, var);
3195 /* Allocate a temporary to hold the result. */
3196 var = gfc_create_var (type, "pstr");
3197 gcc_assert (POINTER_TYPE_P (type));
3198 tmp = TREE_TYPE (type);
3199 if (TREE_CODE (tmp) == ARRAY_TYPE)
3200 tmp = TREE_TYPE (tmp);
3201 tmp = TYPE_SIZE_UNIT (tmp);
3202 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3203 fold_convert (size_type_node, len),
3204 fold_convert (size_type_node, tmp));
3205 tmp = gfc_call_malloc (&se->pre, type, tmp);
3206 gfc_add_modify (&se->pre, var, tmp);
3208 /* Free the temporary afterwards. */
3209 tmp = gfc_call_free (var);
3210 gfc_add_expr_to_block (&se->post, tmp);
3217 /* Handle a string concatenation operation. A temporary will be allocated to
3221 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3224 tree len, type, var, tmp, fndecl;
3226 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3227 && expr->value.op.op2->ts.type == BT_CHARACTER);
3228 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3230 gfc_init_se (&lse, se);
3231 gfc_conv_expr (&lse, expr->value.op.op1);
3232 gfc_conv_string_parameter (&lse);
3233 gfc_init_se (&rse, se);
3234 gfc_conv_expr (&rse, expr->value.op.op2);
3235 gfc_conv_string_parameter (&rse);
3237 gfc_add_block_to_block (&se->pre, &lse.pre);
3238 gfc_add_block_to_block (&se->pre, &rse.pre);
3240 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3241 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3242 if (len == NULL_TREE)
3244 len = fold_build2_loc (input_location, PLUS_EXPR,
3245 gfc_charlen_type_node,
3246 fold_convert (gfc_charlen_type_node,
3248 fold_convert (gfc_charlen_type_node,
3249 rse.string_length));
3252 type = build_pointer_type (type);
3254 var = gfc_conv_string_tmp (se, type, len);
3256 /* Do the actual concatenation. */
3257 if (expr->ts.kind == 1)
3258 fndecl = gfor_fndecl_concat_string;
3259 else if (expr->ts.kind == 4)
3260 fndecl = gfor_fndecl_concat_string_char4;
3264 tmp = build_call_expr_loc (input_location,
3265 fndecl, 6, len, var, lse.string_length, lse.expr,
3266 rse.string_length, rse.expr);
3267 gfc_add_expr_to_block (&se->pre, tmp);
3269 /* Add the cleanup for the operands. */
3270 gfc_add_block_to_block (&se->pre, &rse.post);
3271 gfc_add_block_to_block (&se->pre, &lse.post);
3274 se->string_length = len;
3277 /* Translates an op expression. Common (binary) cases are handled by this
3278 function, others are passed on. Recursion is used in either case.
3279 We use the fact that (op1.ts == op2.ts) (except for the power
3281 Operators need no special handling for scalarized expressions as long as
3282 they call gfc_conv_simple_val to get their operands.
3283 Character strings get special handling. */
3286 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3288 enum tree_code code;
3297 switch (expr->value.op.op)
3299 case INTRINSIC_PARENTHESES:
3300 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3301 && flag_protect_parens)
3303 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3304 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3309 case INTRINSIC_UPLUS:
3310 gfc_conv_expr (se, expr->value.op.op1);
3313 case INTRINSIC_UMINUS:
3314 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3318 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3321 case INTRINSIC_PLUS:
3325 case INTRINSIC_MINUS:
3329 case INTRINSIC_TIMES:
3333 case INTRINSIC_DIVIDE:
3334 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3335 an integer, we must round towards zero, so we use a
3337 if (expr->ts.type == BT_INTEGER)
3338 code = TRUNC_DIV_EXPR;
3343 case INTRINSIC_POWER:
3344 gfc_conv_power_op (se, expr);
3347 case INTRINSIC_CONCAT:
3348 gfc_conv_concat_op (se, expr);
3352 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3357 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3361 /* EQV and NEQV only work on logicals, but since we represent them
3362 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3364 case INTRINSIC_EQ_OS:
3372 case INTRINSIC_NE_OS:
3373 case INTRINSIC_NEQV:
3380 case INTRINSIC_GT_OS:
3387 case INTRINSIC_GE_OS:
3394 case INTRINSIC_LT_OS:
3401 case INTRINSIC_LE_OS:
3407 case INTRINSIC_USER:
3408 case INTRINSIC_ASSIGN:
3409 /* These should be converted into function calls by the frontend. */
3413 fatal_error (input_location, "Unknown intrinsic op");
3417 /* The only exception to this is **, which is handled separately anyway. */
3418 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3420 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3424 gfc_init_se (&lse, se);
3425 gfc_conv_expr (&lse, expr->value.op.op1);
3426 gfc_add_block_to_block (&se->pre, &lse.pre);
3429 gfc_init_se (&rse, se);
3430 gfc_conv_expr (&rse, expr->value.op.op2);
3431 gfc_add_block_to_block (&se->pre, &rse.pre);
3435 gfc_conv_string_parameter (&lse);
3436 gfc_conv_string_parameter (&rse);
3438 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3439 rse.string_length, rse.expr,
3440 expr->value.op.op1->ts.kind,
3442 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3443 gfc_add_block_to_block (&lse.post, &rse.post);
3446 type = gfc_typenode_for_spec (&expr->ts);
3450 /* The result of logical ops is always logical_type_node. */
3451 tmp = fold_build2_loc (input_location, code, logical_type_node,
3452 lse.expr, rse.expr);
3453 se->expr = convert (type, tmp);
3456 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3458 /* Add the post blocks. */
3459 gfc_add_block_to_block (&se->post, &rse.post);
3460 gfc_add_block_to_block (&se->post, &lse.post);
3463 /* If a string's length is one, we convert it to a single character. */
3466 gfc_string_to_single_character (tree len, tree str, int kind)
3470 || !tree_fits_uhwi_p (len)
3471 || !POINTER_TYPE_P (TREE_TYPE (str)))
3474 if (TREE_INT_CST_LOW (len) == 1)
3476 str = fold_convert (gfc_get_pchar_type (kind), str);
3477 return build_fold_indirect_ref_loc (input_location, str);
3481 && TREE_CODE (str) == ADDR_EXPR
3482 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3483 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3484 && array_ref_low_bound (TREE_OPERAND (str, 0))
3485 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3486 && TREE_INT_CST_LOW (len) > 1
3487 && TREE_INT_CST_LOW (len)
3488 == (unsigned HOST_WIDE_INT)
3489 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3491 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3492 ret = build_fold_indirect_ref_loc (input_location, ret);
3493 if (TREE_CODE (ret) == INTEGER_CST)
3495 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3496 int i, length = TREE_STRING_LENGTH (string_cst);
3497 const char *ptr = TREE_STRING_POINTER (string_cst);
3499 for (i = 1; i < length; i++)
3512 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3515 if (sym->backend_decl)
3517 /* This becomes the nominal_type in
3518 function.c:assign_parm_find_data_types. */
3519 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3520 /* This becomes the passed_type in
3521 function.c:assign_parm_find_data_types. C promotes char to
3522 integer for argument passing. */
3523 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3525 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3530 /* If we have a constant character expression, make it into an
3532 if ((*expr)->expr_type == EXPR_CONSTANT)
3537 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3538 (int)(*expr)->value.character.string[0]);
3539 if ((*expr)->ts.kind != gfc_c_int_kind)
3541 /* The expr needs to be compatible with a C int. If the
3542 conversion fails, then the 2 causes an ICE. */
3543 ts.type = BT_INTEGER;
3544 ts.kind = gfc_c_int_kind;
3545 gfc_convert_type (*expr, &ts, 2);
3548 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3550 if ((*expr)->ref == NULL)
3552 se->expr = gfc_string_to_single_character
3553 (build_int_cst (integer_type_node, 1),
3554 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3556 ((*expr)->symtree->n.sym)),
3561 gfc_conv_variable (se, *expr);
3562 se->expr = gfc_string_to_single_character
3563 (build_int_cst (integer_type_node, 1),
3564 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3572 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3573 if STR is a string literal, otherwise return -1. */
3576 gfc_optimize_len_trim (tree len, tree str, int kind)
3579 && TREE_CODE (str) == ADDR_EXPR
3580 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3581 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3582 && array_ref_low_bound (TREE_OPERAND (str, 0))
3583 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3584 && tree_fits_uhwi_p (len)
3585 && tree_to_uhwi (len) >= 1
3586 && tree_to_uhwi (len)
3587 == (unsigned HOST_WIDE_INT)
3588 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3590 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3591 folded = build_fold_indirect_ref_loc (input_location, folded);
3592 if (TREE_CODE (folded) == INTEGER_CST)
3594 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3595 int length = TREE_STRING_LENGTH (string_cst);
3596 const char *ptr = TREE_STRING_POINTER (string_cst);
3598 for (; length > 0; length--)
3599 if (ptr[length - 1] != ' ')
3608 /* Helper to build a call to memcmp. */
3611 build_memcmp_call (tree s1, tree s2, tree n)
3615 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3616 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3618 s1 = fold_convert (pvoid_type_node, s1);
3620 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3621 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3623 s2 = fold_convert (pvoid_type_node, s2);
3625 n = fold_convert (size_type_node, n);
3627 tmp = build_call_expr_loc (input_location,
3628 builtin_decl_explicit (BUILT_IN_MEMCMP),
3631 return fold_convert (integer_type_node, tmp);
3634 /* Compare two strings. If they are all single characters, the result is the
3635 subtraction of them. Otherwise, we build a library call. */
3638 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3639 enum tree_code code)
3645 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3646 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3648 sc1 = gfc_string_to_single_character (len1, str1, kind);
3649 sc2 = gfc_string_to_single_character (len2, str2, kind);
3651 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3653 /* Deal with single character specially. */
3654 sc1 = fold_convert (integer_type_node, sc1);
3655 sc2 = fold_convert (integer_type_node, sc2);
3656 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3660 if ((code == EQ_EXPR || code == NE_EXPR)
3662 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3664 /* If one string is a string literal with LEN_TRIM longer
3665 than the length of the second string, the strings
3667 int len = gfc_optimize_len_trim (len1, str1, kind);
3668 if (len > 0 && compare_tree_int (len2, len) < 0)
3669 return integer_one_node;
3670 len = gfc_optimize_len_trim (len2, str2, kind);
3671 if (len > 0 && compare_tree_int (len1, len) < 0)
3672 return integer_one_node;
3675 /* We can compare via memcpy if the strings are known to be equal
3676 in length and they are
3678 - kind=4 and the comparison is for (in)equality. */
3680 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3681 && tree_int_cst_equal (len1, len2)
3682 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3687 chartype = gfc_get_char_type (kind);
3688 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3689 fold_convert (TREE_TYPE(len1),
3690 TYPE_SIZE_UNIT(chartype)),
3692 return build_memcmp_call (str1, str2, tmp);
3695 /* Build a call for the comparison. */
3697 fndecl = gfor_fndecl_compare_string;
3699 fndecl = gfor_fndecl_compare_string_char4;
3703 return build_call_expr_loc (input_location, fndecl, 4,
3704 len1, str1, len2, str2);
3708 /* Return the backend_decl for a procedure pointer component. */
3711 get_proc_ptr_comp (gfc_expr *e)
3717 gfc_init_se (&comp_se, NULL);
3718 e2 = gfc_copy_expr (e);
3719 /* We have to restore the expr type later so that gfc_free_expr frees
3720 the exact same thing that was allocated.
3721 TODO: This is ugly. */
3722 old_type = e2->expr_type;
3723 e2->expr_type = EXPR_VARIABLE;
3724 gfc_conv_expr (&comp_se, e2);
3725 e2->expr_type = old_type;
3727 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3731 /* Convert a typebound function reference from a class object. */
3733 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3738 if (!VAR_P (base_object))
3740 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3741 gfc_add_modify (&se->pre, var, base_object);
3743 se->expr = gfc_class_vptr_get (base_object);
3744 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3746 while (ref && ref->next)
3748 gcc_assert (ref && ref->type == REF_COMPONENT);
3749 if (ref->u.c.sym->attr.extension)
3750 conv_parent_component_references (se, ref);
3751 gfc_conv_component_ref (se, ref);
3752 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3757 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
3761 if (gfc_is_proc_ptr_comp (expr))
3762 tmp = get_proc_ptr_comp (expr);
3763 else if (sym->attr.dummy)
3765 tmp = gfc_get_symbol_decl (sym);
3766 if (sym->attr.proc_pointer)
3767 tmp = build_fold_indirect_ref_loc (input_location,
3769 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3770 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3774 if (!sym->backend_decl)
3775 sym->backend_decl = gfc_get_extern_function_decl (sym);
3777 TREE_USED (sym->backend_decl) = 1;
3779 tmp = sym->backend_decl;
3781 if (sym->attr.cray_pointee)
3783 /* TODO - make the cray pointee a pointer to a procedure,
3784 assign the pointer to it and use it for the call. This
3786 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3787 gfc_get_symbol_decl (sym->cp_pointer));
3788 tmp = gfc_evaluate_now (tmp, &se->pre);
3791 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3793 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3794 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3801 /* Initialize MAPPING. */
3804 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3806 mapping->syms = NULL;
3807 mapping->charlens = NULL;
3811 /* Free all memory held by MAPPING (but not MAPPING itself). */
3814 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3816 gfc_interface_sym_mapping *sym;
3817 gfc_interface_sym_mapping *nextsym;
3819 gfc_charlen *nextcl;
3821 for (sym = mapping->syms; sym; sym = nextsym)
3823 nextsym = sym->next;
3824 sym->new_sym->n.sym->formal = NULL;
3825 gfc_free_symbol (sym->new_sym->n.sym);
3826 gfc_free_expr (sym->expr);
3827 free (sym->new_sym);
3830 for (cl = mapping->charlens; cl; cl = nextcl)
3833 gfc_free_expr (cl->length);
3839 /* Return a copy of gfc_charlen CL. Add the returned structure to
3840 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3842 static gfc_charlen *
3843 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3846 gfc_charlen *new_charlen;
3848 new_charlen = gfc_get_charlen ();
3849 new_charlen->next = mapping->charlens;
3850 new_charlen->length = gfc_copy_expr (cl->length);
3852 mapping->charlens = new_charlen;
3857 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3858 array variable that can be used as the actual argument for dummy
3859 argument SYM. Add any initialization code to BLOCK. PACKED is as
3860 for gfc_get_nodesc_array_type and DATA points to the first element
3861 in the passed array. */
3864 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
3865 gfc_packed packed, tree data)
3870 type = gfc_typenode_for_spec (&sym->ts);
3871 type = gfc_get_nodesc_array_type (type, sym->as, packed,
3872 !sym->attr.target && !sym->attr.pointer
3873 && !sym->attr.proc_pointer);
3875 var = gfc_create_var (type, "ifm");
3876 gfc_add_modify (block, var, fold_convert (type, data));
3882 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3883 and offset of descriptorless array type TYPE given that it has the same
3884 size as DESC. Add any set-up code to BLOCK. */
3887 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
3894 offset = gfc_index_zero_node;
3895 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
3897 dim = gfc_rank_cst[n];
3898 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
3899 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
3901 GFC_TYPE_ARRAY_LBOUND (type, n)
3902 = gfc_conv_descriptor_lbound_get (desc, dim);
3903 GFC_TYPE_ARRAY_UBOUND (type, n)
3904 = gfc_conv_descriptor_ubound_get (desc, dim);
3906 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
3908 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3909 gfc_array_index_type,
3910 gfc_conv_descriptor_ubound_get (desc, dim),
3911 gfc_conv_descriptor_lbound_get (desc, dim));
3912 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3913 gfc_array_index_type,
3914 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
3915 tmp = gfc_evaluate_now (tmp, block);
3916 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
3918 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3919 GFC_TYPE_ARRAY_LBOUND (type, n),
3920 GFC_TYPE_ARRAY_STRIDE (type, n));
3921 offset = fold_build2_loc (input_location, MINUS_EXPR,
3922 gfc_array_index_type, offset, tmp);
3924 offset = gfc_evaluate_now (offset, block);
3925 GFC_TYPE_ARRAY_OFFSET (type) = offset;
3929 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3930 in SE. The caller may still use se->expr and se->string_length after
3931 calling this function. */
3934 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
3935 gfc_symbol * sym, gfc_se * se,
3938 gfc_interface_sym_mapping *sm;
3942 gfc_symbol *new_sym;
3944 gfc_symtree *new_symtree;
3946 /* Create a new symbol to represent the actual argument. */
3947 new_sym = gfc_new_symbol (sym->name, NULL);
3948 new_sym->ts = sym->ts;
3949 new_sym->as = gfc_copy_array_spec (sym->as);
3950 new_sym->attr.referenced = 1;
3951 new_sym->attr.dimension = sym->attr.dimension;
3952 new_sym->attr.contiguous = sym->attr.contiguous;
3953 new_sym->attr.codimension = sym->attr.codimension;
3954 new_sym->attr.pointer = sym->attr.pointer;
3955 new_sym->attr.allocatable = sym->attr.allocatable;
3956 new_sym->attr.flavor = sym->attr.flavor;
3957 new_sym->attr.function = sym->attr.function;
3959 /* Ensure that the interface is available and that
3960 descriptors are passed for array actual arguments. */
3961 if (sym->attr.flavor == FL_PROCEDURE)
3963 new_sym->formal = expr->symtree->n.sym->formal;
3964 new_sym->attr.always_explicit
3965 = expr->symtree->n.sym->attr.always_explicit;
3968 /* Create a fake symtree for it. */
3970 new_symtree = gfc_new_symtree (&root, sym->name);
3971 new_symtree->n.sym = new_sym;
3972 gcc_assert (new_symtree == root);
3974 /* Create a dummy->actual mapping. */
3975 sm = XCNEW (gfc_interface_sym_mapping);
3976 sm->next = mapping->syms;
3978 sm->new_sym = new_symtree;
3979 sm->expr = gfc_copy_expr (expr);
3982 /* Stabilize the argument's value. */
3983 if (!sym->attr.function && se)
3984 se->expr = gfc_evaluate_now (se->expr, &se->pre);
3986 if (sym->ts.type == BT_CHARACTER)
3988 /* Create a copy of the dummy argument's length. */
3989 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
3990 sm->expr->ts.u.cl = new_sym->ts.u.cl;
3992 /* If the length is specified as "*", record the length that
3993 the caller is passing. We should use the callee's length
3994 in all other cases. */
3995 if (!new_sym->ts.u.cl->length && se)
3997 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
3998 new_sym->ts.u.cl->backend_decl = se->string_length;
4005 /* Use the passed value as-is if the argument is a function. */
4006 if (sym->attr.flavor == FL_PROCEDURE)
4009 /* If the argument is a pass-by-value scalar, use the value as is. */
4010 else if (!sym->attr.dimension && sym->attr.value)
4013 /* If the argument is either a string or a pointer to a string,
4014 convert it to a boundless character type. */
4015 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4017 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4018 tmp = build_pointer_type (tmp);
4019 if (sym->attr.pointer)
4020 value = build_fold_indirect_ref_loc (input_location,
4024 value = fold_convert (tmp, value);
4027 /* If the argument is a scalar, a pointer to an array or an allocatable,
4029 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4030 value = build_fold_indirect_ref_loc (input_location,
4033 /* For character(*), use the actual argument's descriptor. */
4034 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4035 value = build_fold_indirect_ref_loc (input_location,
4038 /* If the argument is an array descriptor, use it to determine
4039 information about the actual argument's shape. */
4040 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4041 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4043 /* Get the actual argument's descriptor. */
4044 desc = build_fold_indirect_ref_loc (input_location,
4047 /* Create the replacement variable. */
4048 tmp = gfc_conv_descriptor_data_get (desc);
4049 value = gfc_get_interface_mapping_array (&se->pre, sym,
4052 /* Use DESC to work out the upper bounds, strides and offset. */
4053 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4056 /* Otherwise we have a packed array. */
4057 value = gfc_get_interface_mapping_array (&se->pre, sym,
4058 PACKED_FULL, se->expr);
4060 new_sym->backend_decl = value;
4064 /* Called once all dummy argument mappings have been added to MAPPING,
4065 but before the mapping is used to evaluate expressions. Pre-evaluate
4066 the length of each argument, adding any initialization code to PRE and
4067 any finalization code to POST. */
4070 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4071 stmtblock_t * pre, stmtblock_t * post)
4073 gfc_interface_sym_mapping *sym;
4077 for (sym = mapping->syms; sym; sym = sym->next)
4078 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4079 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4081 expr = sym->new_sym->n.sym->ts.u.cl->length;
4082 gfc_apply_interface_mapping_to_expr (mapping, expr);
4083 gfc_init_se (&se, NULL);
4084 gfc_conv_expr (&se, expr);
4085 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4086 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4087 gfc_add_block_to_block (pre, &se.pre);
4088 gfc_add_block_to_block (post, &se.post);
4090 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4095 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4099 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4100 gfc_constructor_base base)
4103 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4105 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4108 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4109 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4110 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4116 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4120 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4125 for (; ref; ref = ref->next)
4129 for (n = 0; n < ref->u.ar.dimen; n++)
4131 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4132 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4133 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4141 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4142 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4148 /* Convert intrinsic function calls into result expressions. */
4151 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4159 arg1 = expr->value.function.actual->expr;
4160 if (expr->value.function.actual->next)
4161 arg2 = expr->value.function.actual->next->expr;
4165 sym = arg1->symtree->n.sym;
4167 if (sym->attr.dummy)
4172 switch (expr->value.function.isym->id)
4175 /* TODO figure out why this condition is necessary. */
4176 if (sym->attr.function
4177 && (arg1->ts.u.cl->length == NULL
4178 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4179 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4182 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4185 case GFC_ISYM_LEN_TRIM:
4186 new_expr = gfc_copy_expr (arg1);
4187 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4192 gfc_replace_expr (arg1, new_expr);
4196 if (!sym->as || sym->as->rank == 0)
4199 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4201 dup = mpz_get_si (arg2->value.integer);
4206 dup = sym->as->rank;
4210 for (; d < dup; d++)
4214 if (!sym->as->upper[d] || !sym->as->lower[d])
4216 gfc_free_expr (new_expr);
4220 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4221 gfc_get_int_expr (gfc_default_integer_kind,
4223 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4225 new_expr = gfc_multiply (new_expr, tmp);
4231 case GFC_ISYM_LBOUND:
4232 case GFC_ISYM_UBOUND:
4233 /* TODO These implementations of lbound and ubound do not limit if
4234 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4236 if (!sym->as || sym->as->rank == 0)
4239 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4240 d = mpz_get_si (arg2->value.integer) - 1;
4244 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4246 if (sym->as->lower[d])
4247 new_expr = gfc_copy_expr (sym->as->lower[d]);
4251 if (sym->as->upper[d])
4252 new_expr = gfc_copy_expr (sym->as->upper[d]);
4260 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4264 gfc_replace_expr (expr, new_expr);
4270 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4271 gfc_interface_mapping * mapping)
4273 gfc_formal_arglist *f;
4274 gfc_actual_arglist *actual;
4276 actual = expr->value.function.actual;
4277 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4279 for (; f && actual; f = f->next, actual = actual->next)
4284 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4287 if (map_expr->symtree->n.sym->attr.dimension)
4292 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4294 for (d = 0; d < as->rank; d++)
4296 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4297 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4300 expr->value.function.esym->as = as;
4303 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4305 expr->value.function.esym->ts.u.cl->length
4306 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4308 gfc_apply_interface_mapping_to_expr (mapping,
4309 expr->value.function.esym->ts.u.cl->length);
4314 /* EXPR is a copy of an expression that appeared in the interface
4315 associated with MAPPING. Walk it recursively looking for references to
4316 dummy arguments that MAPPING maps to actual arguments. Replace each such
4317 reference with a reference to the associated actual argument. */
4320 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4323 gfc_interface_sym_mapping *sym;
4324 gfc_actual_arglist *actual;
4329 /* Copying an expression does not copy its length, so do that here. */
4330 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4332 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4333 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4336 /* Apply the mapping to any references. */
4337 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4339 /* ...and to the expression's symbol, if it has one. */
4340 /* TODO Find out why the condition on expr->symtree had to be moved into
4341 the loop rather than being outside it, as originally. */
4342 for (sym = mapping->syms; sym; sym = sym->next)
4343 if (expr->symtree && sym->old == expr->symtree->n.sym)
4345 if (sym->new_sym->n.sym->backend_decl)
4346 expr->symtree = sym->new_sym;
4348 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4351 /* ...and to subexpressions in expr->value. */
4352 switch (expr->expr_type)
4357 case EXPR_SUBSTRING:
4361 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4362 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4366 for (actual = expr->value.function.actual; actual; actual = actual->next)
4367 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4369 if (expr->value.function.esym == NULL
4370 && expr->value.function.isym != NULL
4371 && expr->value.function.actual
4372 && expr->value.function.actual->expr
4373 && expr->value.function.actual->expr->symtree
4374 && gfc_map_intrinsic_function (expr, mapping))
4377 for (sym = mapping->syms; sym; sym = sym->next)
4378 if (sym->old == expr->value.function.esym)
4380 expr->value.function.esym = sym->new_sym->n.sym;
4381 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4382 expr->value.function.esym->result = sym->new_sym->n.sym;
4387 case EXPR_STRUCTURE:
4388 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4401 /* Evaluate interface expression EXPR using MAPPING. Store the result
4405 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4406 gfc_se * se, gfc_expr * expr)
4408 expr = gfc_copy_expr (expr);
4409 gfc_apply_interface_mapping_to_expr (mapping, expr);
4410 gfc_conv_expr (se, expr);
4411 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4412 gfc_free_expr (expr);
4416 /* Returns a reference to a temporary array into which a component of
4417 an actual argument derived type array is copied and then returned
4418 after the function call. */
4420 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4421 sym_intent intent, bool formal_ptr)
4429 gfc_array_info *info;
4439 gfc_init_se (&lse, NULL);
4440 gfc_init_se (&rse, NULL);
4442 /* Walk the argument expression. */
4443 rss = gfc_walk_expr (expr);
4445 gcc_assert (rss != gfc_ss_terminator);
4447 /* Initialize the scalarizer. */
4448 gfc_init_loopinfo (&loop);
4449 gfc_add_ss_to_loop (&loop, rss);
4451 /* Calculate the bounds of the scalarization. */
4452 gfc_conv_ss_startstride (&loop);
4454 /* Build an ss for the temporary. */
4455 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4456 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4458 base_type = gfc_typenode_for_spec (&expr->ts);
4459 if (GFC_ARRAY_TYPE_P (base_type)
4460 || GFC_DESCRIPTOR_TYPE_P (base_type))
4461 base_type = gfc_get_element_type (base_type);
4463 if (expr->ts.type == BT_CLASS)
4464 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4466 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4467 ? expr->ts.u.cl->backend_decl
4471 parmse->string_length = loop.temp_ss->info->string_length;
4473 /* Associate the SS with the loop. */
4474 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4476 /* Setup the scalarizing loops. */
4477 gfc_conv_loop_setup (&loop, &expr->where);
4479 /* Pass the temporary descriptor back to the caller. */
4480 info = &loop.temp_ss->info->data.array;
4481 parmse->expr = info->descriptor;
4483 /* Setup the gfc_se structures. */
4484 gfc_copy_loopinfo_to_se (&lse, &loop);
4485 gfc_copy_loopinfo_to_se (&rse, &loop);
4488 lse.ss = loop.temp_ss;
4489 gfc_mark_ss_chain_used (rss, 1);
4490 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4492 /* Start the scalarized loop body. */
4493 gfc_start_scalarized_body (&loop, &body);
4495 /* Translate the expression. */
4496 gfc_conv_expr (&rse, expr);
4498 /* Reset the offset for the function call since the loop
4499 is zero based on the data pointer. Note that the temp
4500 comes first in the loop chain since it is added second. */
4501 if (gfc_is_class_array_function (expr))
4503 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4504 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4505 gfc_index_zero_node);
4508 gfc_conv_tmp_array_ref (&lse);
4510 if (intent != INTENT_OUT)
4512 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4513 gfc_add_expr_to_block (&body, tmp);
4514 gcc_assert (rse.ss == gfc_ss_terminator);
4515 gfc_trans_scalarizing_loops (&loop, &body);
4519 /* Make sure that the temporary declaration survives by merging
4520 all the loop declarations into the current context. */
4521 for (n = 0; n < loop.dimen; n++)
4523 gfc_merge_block_scope (&body);
4524 body = loop.code[loop.order[n]];
4526 gfc_merge_block_scope (&body);
4529 /* Add the post block after the second loop, so that any
4530 freeing of allocated memory is done at the right time. */
4531 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4533 /**********Copy the temporary back again.*********/
4535 gfc_init_se (&lse, NULL);
4536 gfc_init_se (&rse, NULL);
4538 /* Walk the argument expression. */
4539 lss = gfc_walk_expr (expr);
4540 rse.ss = loop.temp_ss;
4543 /* Initialize the scalarizer. */
4544 gfc_init_loopinfo (&loop2);
4545 gfc_add_ss_to_loop (&loop2, lss);
4547 dimen = rse.ss->dimen;
4549 /* Skip the write-out loop for this case. */
4550 if (gfc_is_class_array_function (expr))
4551 goto class_array_fcn;
4553 /* Calculate the bounds of the scalarization. */
4554 gfc_conv_ss_startstride (&loop2);
4556 /* Setup the scalarizing loops. */
4557 gfc_conv_loop_setup (&loop2, &expr->where);
4559 gfc_copy_loopinfo_to_se (&lse, &loop2);
4560 gfc_copy_loopinfo_to_se (&rse, &loop2);
4562 gfc_mark_ss_chain_used (lss, 1);
4563 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4565 /* Declare the variable to hold the temporary offset and start the
4566 scalarized loop body. */
4567 offset = gfc_create_var (gfc_array_index_type, NULL);
4568 gfc_start_scalarized_body (&loop2, &body);
4570 /* Build the offsets for the temporary from the loop variables. The
4571 temporary array has lbounds of zero and strides of one in all
4572 dimensions, so this is very simple. The offset is only computed
4573 outside the innermost loop, so the overall transfer could be
4574 optimized further. */
4575 info = &rse.ss->info->data.array;
4577 tmp_index = gfc_index_zero_node;
4578 for (n = dimen - 1; n > 0; n--)
4581 tmp = rse.loop->loopvar[n];
4582 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4583 tmp, rse.loop->from[n]);
4584 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4587 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4588 gfc_array_index_type,
4589 rse.loop->to[n-1], rse.loop->from[n-1]);
4590 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4591 gfc_array_index_type,
4592 tmp_str, gfc_index_one_node);
4594 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4595 gfc_array_index_type, tmp, tmp_str);
4598 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4599 gfc_array_index_type,
4600 tmp_index, rse.loop->from[0]);
4601 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4603 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4604 gfc_array_index_type,
4605 rse.loop->loopvar[0], offset);
4607 /* Now use the offset for the reference. */
4608 tmp = build_fold_indirect_ref_loc (input_location,
4610 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4612 if (expr->ts.type == BT_CHARACTER)
4613 rse.string_length = expr->ts.u.cl->backend_decl;
4615 gfc_conv_expr (&lse, expr);
4617 gcc_assert (lse.ss == gfc_ss_terminator);
4619 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4620 gfc_add_expr_to_block (&body, tmp);
4622 /* Generate the copying loops. */
4623 gfc_trans_scalarizing_loops (&loop2, &body);
4625 /* Wrap the whole thing up by adding the second loop to the post-block
4626 and following it by the post-block of the first loop. In this way,
4627 if the temporary needs freeing, it is done after use! */
4628 if (intent != INTENT_IN)
4630 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4631 gfc_add_block_to_block (&parmse->post, &loop2.post);
4636 gfc_add_block_to_block (&parmse->post, &loop.post);
4638 gfc_cleanup_loop (&loop);
4639 gfc_cleanup_loop (&loop2);
4641 /* Pass the string length to the argument expression. */
4642 if (expr->ts.type == BT_CHARACTER)
4643 parmse->string_length = expr->ts.u.cl->backend_decl;
4645 /* Determine the offset for pointer formal arguments and set the
4649 size = gfc_index_one_node;
4650 offset = gfc_index_zero_node;
4651 for (n = 0; n < dimen; n++)
4653 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4655 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4656 gfc_array_index_type, tmp,
4657 gfc_index_one_node);
4658 gfc_conv_descriptor_ubound_set (&parmse->pre,
4662 gfc_conv_descriptor_lbound_set (&parmse->pre,
4665 gfc_index_one_node);
4666 size = gfc_evaluate_now (size, &parmse->pre);
4667 offset = fold_build2_loc (input_location, MINUS_EXPR,
4668 gfc_array_index_type,
4670 offset = gfc_evaluate_now (offset, &parmse->pre);
4671 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4672 gfc_array_index_type,
4673 rse.loop->to[n], rse.loop->from[n]);
4674 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4675 gfc_array_index_type,
4676 tmp, gfc_index_one_node);
4677 size = fold_build2_loc (input_location, MULT_EXPR,
4678 gfc_array_index_type, size, tmp);
4681 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4685 /* We want either the address for the data or the address of the descriptor,
4686 depending on the mode of passing array arguments. */
4688 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4690 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4696 /* Generate the code for argument list functions. */
4699 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4701 /* Pass by value for g77 %VAL(arg), pass the address
4702 indirectly for %LOC, else by reference. Thus %REF
4703 is a "do-nothing" and %LOC is the same as an F95
4705 if (strcmp (name, "%VAL") == 0)
4706 gfc_conv_expr (se, expr);
4707 else if (strcmp (name, "%LOC") == 0)
4709 gfc_conv_expr_reference (se, expr);
4710 se->expr = gfc_build_addr_expr (NULL, se->expr);
4712 else if (strcmp (name, "%REF") == 0)
4713 gfc_conv_expr_reference (se, expr);
4715 gfc_error ("Unknown argument list function at %L", &expr->where);
4719 /* This function tells whether the middle-end representation of the expression
4720 E given as input may point to data otherwise accessible through a variable
4722 It is assumed that the only expressions that may alias are variables,
4723 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4725 This function is used to decide whether freeing an expression's allocatable
4726 components is safe or should be avoided.
4728 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4729 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4730 is necessary because for array constructors, aliasing depends on how
4732 - If E is an array constructor used as argument to an elemental procedure,
4733 the array, which is generated through shallow copy by the scalarizer,
4734 is used directly and can alias the expressions it was copied from.
4735 - If E is an array constructor used as argument to a non-elemental
4736 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4737 the array as in the previous case, but then that array is used
4738 to initialize a new descriptor through deep copy. There is no alias
4739 possible in that case.
4740 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4744 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4748 if (e->expr_type == EXPR_VARIABLE)
4750 else if (e->expr_type == EXPR_FUNCTION)
4752 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4754 if (proc_ifc->result != NULL
4755 && ((proc_ifc->result->ts.type == BT_CLASS
4756 && proc_ifc->result->ts.u.derived->attr.is_class
4757 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4758 || proc_ifc->result->attr.pointer))
4763 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4766 for (c = gfc_constructor_first (e->value.constructor);
4767 c; c = gfc_constructor_next (c))
4769 && expr_may_alias_variables (c->expr, array_may_alias))
4776 /* Generate code for a procedure call. Note can return se->post != NULL.
4777 If se->direct_byref is set then se->expr contains the return parameter.
4778 Return nonzero, if the call has alternate specifiers.
4779 'expr' is only needed for procedure pointer components. */
4782 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
4783 gfc_actual_arglist * args, gfc_expr * expr,
4784 vec<tree, va_gc> *append_args)
4786 gfc_interface_mapping mapping;
4787 vec<tree, va_gc> *arglist;
4788 vec<tree, va_gc> *retargs;
4792 gfc_array_info *info;
4799 vec<tree, va_gc> *stringargs;
4800 vec<tree, va_gc> *optionalargs;
4802 gfc_formal_arglist *formal;
4803 gfc_actual_arglist *arg;
4804 int has_alternate_specifier = 0;
4805 bool need_interface_mapping;
4813 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
4814 gfc_component *comp = NULL;
4821 optionalargs = NULL;
4826 comp = gfc_get_proc_ptr_comp (expr);
4828 bool elemental_proc = (comp
4829 && comp->ts.interface
4830 && comp->ts.interface->attr.elemental)
4831 || (comp && comp->attr.elemental)
4832 || sym->attr.elemental;
4836 if (!elemental_proc)
4838 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
4839 if (se->ss->info->useflags)
4841 gcc_assert ((!comp && gfc_return_by_reference (sym)
4842 && sym->result->attr.dimension)
4843 || (comp && comp->attr.dimension)
4844 || gfc_is_class_array_function (expr));
4845 gcc_assert (se->loop != NULL);
4846 /* Access the previously obtained result. */
4847 gfc_conv_tmp_array_ref (se);
4851 info = &se->ss->info->data.array;
4856 gfc_init_block (&post);
4857 gfc_init_interface_mapping (&mapping);
4860 formal = gfc_sym_get_dummy_args (sym);
4861 need_interface_mapping = sym->attr.dimension ||
4862 (sym->ts.type == BT_CHARACTER
4863 && sym->ts.u.cl->length
4864 && sym->ts.u.cl->length->expr_type
4869 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
4870 need_interface_mapping = comp->attr.dimension ||
4871 (comp->ts.type == BT_CHARACTER
4872 && comp->ts.u.cl->length
4873 && comp->ts.u.cl->length->expr_type
4877 base_object = NULL_TREE;
4878 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4879 is the third and fourth argument to such a function call a value
4880 denoting the number of elements to copy (i.e., most of the time the
4881 length of a deferred length string). */
4882 ulim_copy = (formal == NULL)
4883 && UNLIMITED_POLY (sym)
4884 && comp && (strcmp ("_copy", comp->name) == 0);
4886 /* Evaluate the arguments. */
4887 for (arg = args, argc = 0; arg != NULL;
4888 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
4890 bool finalized = false;
4893 fsym = formal ? formal->sym : NULL;
4894 parm_kind = MISSING;
4896 /* If the procedure requires an explicit interface, the actual
4897 argument is passed according to the corresponding formal
4898 argument. If the corresponding formal argument is a POINTER,
4899 ALLOCATABLE or assumed shape, we do not use g77's calling
4900 convention, and pass the address of the array descriptor
4901 instead. Otherwise we use g77's calling convention, in other words
4902 pass the array data pointer without descriptor. */
4903 bool nodesc_arg = fsym != NULL
4904 && !(fsym->attr.pointer || fsym->attr.allocatable)
4906 && fsym->as->type != AS_ASSUMED_SHAPE
4907 && fsym->as->type != AS_ASSUMED_RANK;
4909 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
4911 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
4913 /* Class array expressions are sometimes coming completely unadorned
4914 with either arrayspec or _data component. Correct that here.
4915 OOP-TODO: Move this to the frontend. */
4916 if (e && e->expr_type == EXPR_VARIABLE
4918 && e->ts.type == BT_CLASS
4919 && (CLASS_DATA (e)->attr.codimension
4920 || CLASS_DATA (e)->attr.dimension))
4922 gfc_typespec temp_ts = e->ts;
4923 gfc_add_class_array_ref (e);
4929 if (se->ignore_optional)
4931 /* Some intrinsics have already been resolved to the correct
4935 else if (arg->label)
4937 has_alternate_specifier = 1;
4942 gfc_init_se (&parmse, NULL);
4944 /* For scalar arguments with VALUE attribute which are passed by
4945 value, pass "0" and a hidden argument gives the optional
4947 if (fsym && fsym->attr.optional && fsym->attr.value
4948 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
4949 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
4951 parmse.expr = fold_convert (gfc_sym_type (fsym),
4953 vec_safe_push (optionalargs, boolean_false_node);
4957 /* Pass a NULL pointer for an absent arg. */
4958 parmse.expr = null_pointer_node;
4959 if (arg->missing_arg_type == BT_CHARACTER)
4960 parmse.string_length = build_int_cst (gfc_charlen_type_node,
4965 else if (arg->expr->expr_type == EXPR_NULL
4966 && fsym && !fsym->attr.pointer
4967 && (fsym->ts.type != BT_CLASS
4968 || !CLASS_DATA (fsym)->attr.class_pointer))
4970 /* Pass a NULL pointer to denote an absent arg. */
4971 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
4972 && (fsym->ts.type != BT_CLASS
4973 || !CLASS_DATA (fsym)->attr.allocatable));
4974 gfc_init_se (&parmse, NULL);
4975 parmse.expr = null_pointer_node;
4976 if (arg->missing_arg_type == BT_CHARACTER)
4977 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
4979 else if (fsym && fsym->ts.type == BT_CLASS
4980 && e->ts.type == BT_DERIVED)
4982 /* The derived type needs to be converted to a temporary
4984 gfc_init_se (&parmse, se);
4985 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
4987 && e->expr_type == EXPR_VARIABLE
4988 && e->symtree->n.sym->attr.optional,
4989 CLASS_DATA (fsym)->attr.class_pointer
4990 || CLASS_DATA (fsym)->attr.allocatable);
4992 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
4994 /* The intrinsic type needs to be converted to a temporary
4995 CLASS object for the unlimited polymorphic formal. */
4996 gfc_init_se (&parmse, se);
4997 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
4999 else if (se->ss && se->ss->info->useflags)
5005 /* An elemental function inside a scalarized loop. */
5006 gfc_init_se (&parmse, se);
5007 parm_kind = ELEMENTAL;
5009 /* When no fsym is present, ulim_copy is set and this is a third or
5010 fourth argument, use call-by-value instead of by reference to
5011 hand the length properties to the copy routine (i.e., most of the
5012 time this will be a call to a __copy_character_* routine where the
5013 third and fourth arguments are the lengths of a deferred length
5015 if ((fsym && fsym->attr.value)
5016 || (ulim_copy && (argc == 2 || argc == 3)))
5017 gfc_conv_expr (&parmse, e);
5019 gfc_conv_expr_reference (&parmse, e);
5021 if (e->ts.type == BT_CHARACTER && !e->rank
5022 && e->expr_type == EXPR_FUNCTION)
5023 parmse.expr = build_fold_indirect_ref_loc (input_location,
5026 if (fsym && fsym->ts.type == BT_DERIVED
5027 && gfc_is_class_container_ref (e))
5029 parmse.expr = gfc_class_data_get (parmse.expr);
5031 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5032 && e->symtree->n.sym->attr.optional)
5034 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5035 parmse.expr = build3_loc (input_location, COND_EXPR,
5036 TREE_TYPE (parmse.expr),
5038 fold_convert (TREE_TYPE (parmse.expr),
5039 null_pointer_node));
5043 /* If we are passing an absent array as optional dummy to an
5044 elemental procedure, make sure that we pass NULL when the data
5045 pointer is NULL. We need this extra conditional because of
5046 scalarization which passes arrays elements to the procedure,
5047 ignoring the fact that the array can be absent/unallocated/... */
5048 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5050 tree descriptor_data;
5052 descriptor_data = ss->info->data.array.data;
5053 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5055 fold_convert (TREE_TYPE (descriptor_data),
5056 null_pointer_node));
5058 = fold_build3_loc (input_location, COND_EXPR,
5059 TREE_TYPE (parmse.expr),
5060 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5061 fold_convert (TREE_TYPE (parmse.expr),
5066 /* The scalarizer does not repackage the reference to a class
5067 array - instead it returns a pointer to the data element. */
5068 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5069 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5070 fsym->attr.intent != INTENT_IN
5071 && (CLASS_DATA (fsym)->attr.class_pointer
5072 || CLASS_DATA (fsym)->attr.allocatable),
5074 && e->expr_type == EXPR_VARIABLE
5075 && e->symtree->n.sym->attr.optional,
5076 CLASS_DATA (fsym)->attr.class_pointer
5077 || CLASS_DATA (fsym)->attr.allocatable);
5084 gfc_init_se (&parmse, NULL);
5086 /* Check whether the expression is a scalar or not; we cannot use
5087 e->rank as it can be nonzero for functions arguments. */
5088 argss = gfc_walk_expr (e);
5089 scalar = argss == gfc_ss_terminator;
5091 gfc_free_ss_chain (argss);
5093 /* Special handling for passing scalar polymorphic coarrays;
5094 otherwise one passes "class->_data.data" instead of "&class". */
5095 if (e->rank == 0 && e->ts.type == BT_CLASS
5096 && fsym && fsym->ts.type == BT_CLASS
5097 && CLASS_DATA (fsym)->attr.codimension
5098 && !CLASS_DATA (fsym)->attr.dimension)
5100 gfc_add_class_array_ref (e);
5101 parmse.want_coarray = 1;
5105 /* A scalar or transformational function. */
5108 if (e->expr_type == EXPR_VARIABLE
5109 && e->symtree->n.sym->attr.cray_pointee
5110 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5112 /* The Cray pointer needs to be converted to a pointer to
5113 a type given by the expression. */
5114 gfc_conv_expr (&parmse, e);
5115 type = build_pointer_type (TREE_TYPE (parmse.expr));
5116 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5117 parmse.expr = convert (type, tmp);
5119 else if (fsym && fsym->attr.value)
5121 if (fsym->ts.type == BT_CHARACTER
5122 && fsym->ts.is_c_interop
5123 && fsym->ns->proc_name != NULL
5124 && fsym->ns->proc_name->attr.is_bind_c)
5127 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5128 if (parmse.expr == NULL)
5129 gfc_conv_expr (&parmse, e);
5133 gfc_conv_expr (&parmse, e);
5134 if (fsym->attr.optional
5135 && fsym->ts.type != BT_CLASS
5136 && fsym->ts.type != BT_DERIVED)
5138 if (e->expr_type != EXPR_VARIABLE
5139 || !e->symtree->n.sym->attr.optional
5141 vec_safe_push (optionalargs, boolean_true_node);
5144 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5145 if (!e->symtree->n.sym->attr.value)
5147 = fold_build3_loc (input_location, COND_EXPR,
5148 TREE_TYPE (parmse.expr),
5150 fold_convert (TREE_TYPE (parmse.expr),
5151 integer_zero_node));
5153 vec_safe_push (optionalargs, tmp);
5158 else if (arg->name && arg->name[0] == '%')
5159 /* Argument list functions %VAL, %LOC and %REF are signalled
5160 through arg->name. */
5161 conv_arglist_function (&parmse, arg->expr, arg->name);
5162 else if ((e->expr_type == EXPR_FUNCTION)
5163 && ((e->value.function.esym
5164 && e->value.function.esym->result->attr.pointer)
5165 || (!e->value.function.esym
5166 && e->symtree->n.sym->attr.pointer))
5167 && fsym && fsym->attr.target)
5169 gfc_conv_expr (&parmse, e);
5170 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5172 else if (e->expr_type == EXPR_FUNCTION
5173 && e->symtree->n.sym->result
5174 && e->symtree->n.sym->result != e->symtree->n.sym
5175 && e->symtree->n.sym->result->attr.proc_pointer)
5177 /* Functions returning procedure pointers. */
5178 gfc_conv_expr (&parmse, e);
5179 if (fsym && fsym->attr.proc_pointer)
5180 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5184 if (e->ts.type == BT_CLASS && fsym
5185 && fsym->ts.type == BT_CLASS
5186 && (!CLASS_DATA (fsym)->as
5187 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5188 && CLASS_DATA (e)->attr.codimension)
5190 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5191 gcc_assert (!CLASS_DATA (fsym)->as);
5192 gfc_add_class_array_ref (e);
5193 parmse.want_coarray = 1;
5194 gfc_conv_expr_reference (&parmse, e);
5195 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5197 && e->expr_type == EXPR_VARIABLE);
5199 else if (e->ts.type == BT_CLASS && fsym
5200 && fsym->ts.type == BT_CLASS
5201 && !CLASS_DATA (fsym)->as
5202 && !CLASS_DATA (e)->as
5203 && strcmp (fsym->ts.u.derived->name,
5204 e->ts.u.derived->name))
5206 type = gfc_typenode_for_spec (&fsym->ts);
5207 var = gfc_create_var (type, fsym->name);
5208 gfc_conv_expr (&parmse, e);
5209 if (fsym->attr.optional
5210 && e->expr_type == EXPR_VARIABLE
5211 && e->symtree->n.sym->attr.optional)
5215 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5216 cond = fold_build2_loc (input_location, NE_EXPR,
5217 logical_type_node, tmp,
5218 fold_convert (TREE_TYPE (tmp),
5219 null_pointer_node));
5220 gfc_start_block (&block);
5221 gfc_add_modify (&block, var,
5222 fold_build1_loc (input_location,
5224 type, parmse.expr));
5225 gfc_add_expr_to_block (&parmse.pre,
5226 fold_build3_loc (input_location,
5227 COND_EXPR, void_type_node,
5228 cond, gfc_finish_block (&block),
5229 build_empty_stmt (input_location)));
5230 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5231 parmse.expr = build3_loc (input_location, COND_EXPR,
5232 TREE_TYPE (parmse.expr),
5234 fold_convert (TREE_TYPE (parmse.expr),
5235 null_pointer_node));
5239 /* Since the internal representation of unlimited
5240 polymorphic expressions includes an extra field
5241 that other class objects do not, a cast to the
5242 formal type does not work. */
5243 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5247 /* Set the _data field. */
5248 tmp = gfc_class_data_get (var);
5249 efield = fold_convert (TREE_TYPE (tmp),
5250 gfc_class_data_get (parmse.expr));
5251 gfc_add_modify (&parmse.pre, tmp, efield);
5253 /* Set the _vptr field. */
5254 tmp = gfc_class_vptr_get (var);
5255 efield = fold_convert (TREE_TYPE (tmp),
5256 gfc_class_vptr_get (parmse.expr));
5257 gfc_add_modify (&parmse.pre, tmp, efield);
5259 /* Set the _len field. */
5260 tmp = gfc_class_len_get (var);
5261 gfc_add_modify (&parmse.pre, tmp,
5262 build_int_cst (TREE_TYPE (tmp), 0));
5266 tmp = fold_build1_loc (input_location,
5269 gfc_add_modify (&parmse.pre, var, tmp);
5272 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5278 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5279 && !fsym->attr.allocatable && !fsym->attr.pointer
5280 && !e->symtree->n.sym->attr.dimension
5281 && !e->symtree->n.sym->attr.pointer
5283 && !e->symtree->n.sym->attr.dummy
5284 /* FIXME - PR 87395 and PR 41453 */
5285 && e->symtree->n.sym->attr.save == SAVE_NONE
5286 && !e->symtree->n.sym->attr.associate_var
5287 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5288 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5290 gfc_conv_expr_reference (&parmse, e, add_clobber);
5292 /* Catch base objects that are not variables. */
5293 if (e->ts.type == BT_CLASS
5294 && e->expr_type != EXPR_VARIABLE
5295 && expr && e == expr->base_expr)
5296 base_object = build_fold_indirect_ref_loc (input_location,
5299 /* A class array element needs converting back to be a
5300 class object, if the formal argument is a class object. */
5301 if (fsym && fsym->ts.type == BT_CLASS
5302 && e->ts.type == BT_CLASS
5303 && ((CLASS_DATA (fsym)->as
5304 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5305 || CLASS_DATA (e)->attr.dimension))
5306 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5307 fsym->attr.intent != INTENT_IN
5308 && (CLASS_DATA (fsym)->attr.class_pointer
5309 || CLASS_DATA (fsym)->attr.allocatable),
5311 && e->expr_type == EXPR_VARIABLE
5312 && e->symtree->n.sym->attr.optional,
5313 CLASS_DATA (fsym)->attr.class_pointer
5314 || CLASS_DATA (fsym)->attr.allocatable);
5316 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5317 allocated on entry, it must be deallocated. */
5318 if (fsym && fsym->attr.intent == INTENT_OUT
5319 && (fsym->attr.allocatable
5320 || (fsym->ts.type == BT_CLASS
5321 && CLASS_DATA (fsym)->attr.allocatable)))
5326 gfc_init_block (&block);
5328 if (e->ts.type == BT_CLASS)
5329 ptr = gfc_class_data_get (ptr);
5331 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5334 gfc_add_expr_to_block (&block, tmp);
5335 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5336 void_type_node, ptr,
5338 gfc_add_expr_to_block (&block, tmp);
5340 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5342 gfc_add_modify (&block, ptr,
5343 fold_convert (TREE_TYPE (ptr),
5344 null_pointer_node));
5345 gfc_add_expr_to_block (&block, tmp);
5347 else if (fsym->ts.type == BT_CLASS)
5350 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5351 tmp = gfc_get_symbol_decl (vtab);
5352 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5353 ptr = gfc_class_vptr_get (parmse.expr);
5354 gfc_add_modify (&block, ptr,
5355 fold_convert (TREE_TYPE (ptr), tmp));
5356 gfc_add_expr_to_block (&block, tmp);
5359 if (fsym->attr.optional
5360 && e->expr_type == EXPR_VARIABLE
5361 && e->symtree->n.sym->attr.optional)
5363 tmp = fold_build3_loc (input_location, COND_EXPR,
5365 gfc_conv_expr_present (e->symtree->n.sym),
5366 gfc_finish_block (&block),
5367 build_empty_stmt (input_location));
5370 tmp = gfc_finish_block (&block);
5372 gfc_add_expr_to_block (&se->pre, tmp);
5375 if (fsym && (fsym->ts.type == BT_DERIVED
5376 || fsym->ts.type == BT_ASSUMED)
5377 && e->ts.type == BT_CLASS
5378 && !CLASS_DATA (e)->attr.dimension
5379 && !CLASS_DATA (e)->attr.codimension)
5381 parmse.expr = gfc_class_data_get (parmse.expr);
5382 /* The result is a class temporary, whose _data component
5383 must be freed to avoid a memory leak. */
5384 if (e->expr_type == EXPR_FUNCTION
5385 && CLASS_DATA (e)->attr.allocatable)
5391 /* Borrow the function symbol to make a call to
5392 gfc_add_finalizer_call and then restore it. */
5393 tmp = e->symtree->n.sym->backend_decl;
5394 e->symtree->n.sym->backend_decl
5395 = TREE_OPERAND (parmse.expr, 0);
5396 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5397 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5398 finalized = gfc_add_finalizer_call (&parmse.post,
5400 gfc_free_expr (var);
5401 e->symtree->n.sym->backend_decl = tmp;
5402 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5404 /* Then free the class _data. */
5405 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5406 tmp = fold_build2_loc (input_location, NE_EXPR,
5409 tmp = build3_v (COND_EXPR, tmp,
5410 gfc_call_free (parmse.expr),
5411 build_empty_stmt (input_location));
5412 gfc_add_expr_to_block (&parmse.post, tmp);
5413 gfc_add_modify (&parmse.post, parmse.expr, zero);
5417 /* Wrap scalar variable in a descriptor. We need to convert
5418 the address of a pointer back to the pointer itself before,
5419 we can assign it to the data field. */
5421 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5422 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5425 if (TREE_CODE (tmp) == ADDR_EXPR)
5426 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5427 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5429 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5432 else if (fsym && e->expr_type != EXPR_NULL
5433 && ((fsym->attr.pointer
5434 && fsym->attr.flavor != FL_PROCEDURE)
5435 || (fsym->attr.proc_pointer
5436 && !(e->expr_type == EXPR_VARIABLE
5437 && e->symtree->n.sym->attr.dummy))
5438 || (fsym->attr.proc_pointer
5439 && e->expr_type == EXPR_VARIABLE
5440 && gfc_is_proc_ptr_comp (e))
5441 || (fsym->attr.allocatable
5442 && fsym->attr.flavor != FL_PROCEDURE)))
5444 /* Scalar pointer dummy args require an extra level of
5445 indirection. The null pointer already contains
5446 this level of indirection. */
5447 parm_kind = SCALAR_POINTER;
5448 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5452 else if (e->ts.type == BT_CLASS
5453 && fsym && fsym->ts.type == BT_CLASS
5454 && (CLASS_DATA (fsym)->attr.dimension
5455 || CLASS_DATA (fsym)->attr.codimension))
5457 /* Pass a class array. */
5458 parmse.use_offset = 1;
5459 gfc_conv_expr_descriptor (&parmse, e);
5461 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5462 allocated on entry, it must be deallocated. */
5463 if (fsym->attr.intent == INTENT_OUT
5464 && CLASS_DATA (fsym)->attr.allocatable)
5469 gfc_init_block (&block);
5471 ptr = gfc_class_data_get (ptr);
5473 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5474 NULL_TREE, NULL_TREE,
5476 GFC_CAF_COARRAY_NOCOARRAY);
5477 gfc_add_expr_to_block (&block, tmp);
5478 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5479 void_type_node, ptr,
5481 gfc_add_expr_to_block (&block, tmp);
5482 gfc_reset_vptr (&block, e);
5484 if (fsym->attr.optional
5485 && e->expr_type == EXPR_VARIABLE
5487 || (e->ref->type == REF_ARRAY
5488 && e->ref->u.ar.type != AR_FULL))
5489 && e->symtree->n.sym->attr.optional)
5491 tmp = fold_build3_loc (input_location, COND_EXPR,
5493 gfc_conv_expr_present (e->symtree->n.sym),
5494 gfc_finish_block (&block),
5495 build_empty_stmt (input_location));
5498 tmp = gfc_finish_block (&block);
5500 gfc_add_expr_to_block (&se->pre, tmp);
5503 /* The conversion does not repackage the reference to a class
5504 array - _data descriptor. */
5505 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5506 fsym->attr.intent != INTENT_IN
5507 && (CLASS_DATA (fsym)->attr.class_pointer
5508 || CLASS_DATA (fsym)->attr.allocatable),
5510 && e->expr_type == EXPR_VARIABLE
5511 && e->symtree->n.sym->attr.optional,
5512 CLASS_DATA (fsym)->attr.class_pointer
5513 || CLASS_DATA (fsym)->attr.allocatable);
5517 /* If the argument is a function call that may not create
5518 a temporary for the result, we have to check that we
5519 can do it, i.e. that there is no alias between this
5520 argument and another one. */
5521 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5527 intent = fsym->attr.intent;
5529 intent = INTENT_UNKNOWN;
5531 if (gfc_check_fncall_dependency (e, intent, sym, args,
5533 parmse.force_tmp = 1;
5535 iarg = e->value.function.actual->expr;
5537 /* Temporary needed if aliasing due to host association. */
5538 if (sym->attr.contained
5540 && !sym->attr.implicit_pure
5541 && !sym->attr.use_assoc
5542 && iarg->expr_type == EXPR_VARIABLE
5543 && sym->ns == iarg->symtree->n.sym->ns)
5544 parmse.force_tmp = 1;
5546 /* Ditto within module. */
5547 if (sym->attr.use_assoc
5549 && !sym->attr.implicit_pure
5550 && iarg->expr_type == EXPR_VARIABLE
5551 && sym->module == iarg->symtree->n.sym->module)
5552 parmse.force_tmp = 1;
5555 if (e->expr_type == EXPR_VARIABLE
5556 && is_subref_array (e)
5557 && !(fsym && fsym->attr.pointer))
5558 /* The actual argument is a component reference to an
5559 array of derived types. In this case, the argument
5560 is converted to a temporary, which is passed and then
5561 written back after the procedure call. */
5562 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5563 fsym ? fsym->attr.intent : INTENT_INOUT,
5564 fsym && fsym->attr.pointer);
5565 else if (gfc_is_class_array_ref (e, NULL)
5566 && fsym && fsym->ts.type == BT_DERIVED)
5567 /* The actual argument is a component reference to an
5568 array of derived types. In this case, the argument
5569 is converted to a temporary, which is passed and then
5570 written back after the procedure call.
5571 OOP-TODO: Insert code so that if the dynamic type is
5572 the same as the declared type, copy-in/copy-out does
5574 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5575 fsym ? fsym->attr.intent : INTENT_INOUT,
5576 fsym && fsym->attr.pointer);
5578 else if (gfc_is_class_array_function (e)
5579 && fsym && fsym->ts.type == BT_DERIVED)
5580 /* See previous comment. For function actual argument,
5581 the write out is not needed so the intent is set as
5584 e->must_finalize = 1;
5585 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5587 fsym && fsym->attr.pointer);
5590 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5593 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5594 allocated on entry, it must be deallocated. */
5595 if (fsym && fsym->attr.allocatable
5596 && fsym->attr.intent == INTENT_OUT)
5598 if (fsym->ts.type == BT_DERIVED
5599 && fsym->ts.u.derived->attr.alloc_comp)
5601 // deallocate the components first
5602 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5603 parmse.expr, e->rank);
5604 if (tmp != NULL_TREE)
5605 gfc_add_expr_to_block (&se->pre, tmp);
5608 tmp = build_fold_indirect_ref_loc (input_location,
5610 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5611 tmp = gfc_conv_descriptor_data_get (tmp);
5612 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5613 NULL_TREE, NULL_TREE, true,
5615 GFC_CAF_COARRAY_NOCOARRAY);
5616 if (fsym->attr.optional
5617 && e->expr_type == EXPR_VARIABLE
5618 && e->symtree->n.sym->attr.optional)
5619 tmp = fold_build3_loc (input_location, COND_EXPR,
5621 gfc_conv_expr_present (e->symtree->n.sym),
5622 tmp, build_empty_stmt (input_location));
5623 gfc_add_expr_to_block (&se->pre, tmp);
5628 /* The case with fsym->attr.optional is that of a user subroutine
5629 with an interface indicating an optional argument. When we call
5630 an intrinsic subroutine, however, fsym is NULL, but we might still
5631 have an optional argument, so we proceed to the substitution
5633 if (e && (fsym == NULL || fsym->attr.optional))
5635 /* If an optional argument is itself an optional dummy argument,
5636 check its presence and substitute a null if absent. This is
5637 only needed when passing an array to an elemental procedure
5638 as then array elements are accessed - or no NULL pointer is
5639 allowed and a "1" or "0" should be passed if not present.
5640 When passing a non-array-descriptor full array to a
5641 non-array-descriptor dummy, no check is needed. For
5642 array-descriptor actual to array-descriptor dummy, see
5643 PR 41911 for why a check has to be inserted.
5644 fsym == NULL is checked as intrinsics required the descriptor
5645 but do not always set fsym. */
5646 if (e->expr_type == EXPR_VARIABLE
5647 && e->symtree->n.sym->attr.optional
5648 && ((e->rank != 0 && elemental_proc)
5649 || e->representation.length || e->ts.type == BT_CHARACTER
5653 && (fsym->as->type == AS_ASSUMED_SHAPE
5654 || fsym->as->type == AS_ASSUMED_RANK
5655 || fsym->as->type == AS_DEFERRED))))))
5656 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
5657 e->representation.length);
5662 /* Obtain the character length of an assumed character length
5663 length procedure from the typespec. */
5664 if (fsym->ts.type == BT_CHARACTER
5665 && parmse.string_length == NULL_TREE
5666 && e->ts.type == BT_PROCEDURE
5667 && e->symtree->n.sym->ts.type == BT_CHARACTER
5668 && e->symtree->n.sym->ts.u.cl->length != NULL
5669 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5671 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
5672 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
5676 if (fsym && need_interface_mapping && e)
5677 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
5679 gfc_add_block_to_block (&se->pre, &parmse.pre);
5680 gfc_add_block_to_block (&post, &parmse.post);
5682 /* Allocated allocatable components of derived types must be
5683 deallocated for non-variable scalars, array arguments to elemental
5684 procedures, and array arguments with descriptor to non-elemental
5685 procedures. As bounds information for descriptorless arrays is no
5686 longer available here, they are dealt with in trans-array.c
5687 (gfc_conv_array_parameter). */
5688 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
5689 && e->ts.u.derived->attr.alloc_comp
5690 && (e->rank == 0 || elemental_proc || !nodesc_arg)
5691 && !expr_may_alias_variables (e, elemental_proc))
5694 /* It is known the e returns a structure type with at least one
5695 allocatable component. When e is a function, ensure that the
5696 function is called once only by using a temporary variable. */
5697 if (!DECL_P (parmse.expr))
5698 parmse.expr = gfc_evaluate_now_loc (input_location,
5699 parmse.expr, &se->pre);
5701 if (fsym && fsym->attr.value)
5704 tmp = build_fold_indirect_ref_loc (input_location,
5707 parm_rank = e->rank;
5715 case (SCALAR_POINTER):
5716 tmp = build_fold_indirect_ref_loc (input_location,
5721 if (e->expr_type == EXPR_OP
5722 && e->value.op.op == INTRINSIC_PARENTHESES
5723 && e->value.op.op1->expr_type == EXPR_VARIABLE)
5726 local_tmp = gfc_evaluate_now (tmp, &se->pre);
5727 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
5729 gfc_add_expr_to_block (&se->post, local_tmp);
5732 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
5734 /* The derived type is passed to gfc_deallocate_alloc_comp.
5735 Therefore, class actuals can handled correctly but derived
5736 types passed to class formals need the _data component. */
5737 tmp = gfc_class_data_get (tmp);
5738 if (!CLASS_DATA (fsym)->attr.dimension)
5739 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5742 if (!finalized && !e->must_finalize)
5744 if ((e->ts.type == BT_CLASS
5745 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
5746 || e->ts.type == BT_DERIVED)
5747 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
5749 else if (e->ts.type == BT_CLASS)
5750 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
5752 gfc_prepend_expr_to_block (&post, tmp);
5756 /* Add argument checking of passing an unallocated/NULL actual to
5757 a nonallocatable/nonpointer dummy. */
5759 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
5761 symbol_attribute attr;
5765 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
5766 attr = gfc_expr_attr (e);
5768 goto end_pointer_check;
5770 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5771 allocatable to an optional dummy, cf. 12.5.2.12. */
5772 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
5773 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5774 goto end_pointer_check;
5778 /* If the actual argument is an optional pointer/allocatable and
5779 the formal argument takes an nonpointer optional value,
5780 it is invalid to pass a non-present argument on, even
5781 though there is no technical reason for this in gfortran.
5782 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5783 tree present, null_ptr, type;
5785 if (attr.allocatable
5786 && (fsym == NULL || !fsym->attr.allocatable))
5787 msg = xasprintf ("Allocatable actual argument '%s' is not "
5788 "allocated or not present",
5789 e->symtree->n.sym->name);
5790 else if (attr.pointer
5791 && (fsym == NULL || !fsym->attr.pointer))
5792 msg = xasprintf ("Pointer actual argument '%s' is not "
5793 "associated or not present",
5794 e->symtree->n.sym->name);
5795 else if (attr.proc_pointer
5796 && (fsym == NULL || !fsym->attr.proc_pointer))
5797 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5798 "associated or not present",
5799 e->symtree->n.sym->name);
5801 goto end_pointer_check;
5803 present = gfc_conv_expr_present (e->symtree->n.sym);
5804 type = TREE_TYPE (present);
5805 present = fold_build2_loc (input_location, EQ_EXPR,
5806 logical_type_node, present,
5808 null_pointer_node));
5809 type = TREE_TYPE (parmse.expr);
5810 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
5811 logical_type_node, parmse.expr,
5813 null_pointer_node));
5814 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
5815 logical_type_node, present, null_ptr);
5819 if (attr.allocatable
5820 && (fsym == NULL || !fsym->attr.allocatable))
5821 msg = xasprintf ("Allocatable actual argument '%s' is not "
5822 "allocated", e->symtree->n.sym->name);
5823 else if (attr.pointer
5824 && (fsym == NULL || !fsym->attr.pointer))
5825 msg = xasprintf ("Pointer actual argument '%s' is not "
5826 "associated", e->symtree->n.sym->name);
5827 else if (attr.proc_pointer
5828 && (fsym == NULL || !fsym->attr.proc_pointer))
5829 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5830 "associated", e->symtree->n.sym->name);
5832 goto end_pointer_check;
5836 /* If the argument is passed by value, we need to strip the
5838 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
5839 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5841 cond = fold_build2_loc (input_location, EQ_EXPR,
5842 logical_type_node, tmp,
5843 fold_convert (TREE_TYPE (tmp),
5844 null_pointer_node));
5847 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
5853 /* Deferred length dummies pass the character length by reference
5854 so that the value can be returned. */
5855 if (parmse.string_length && fsym && fsym->ts.deferred)
5857 if (INDIRECT_REF_P (parmse.string_length))
5858 /* In chains of functions/procedure calls the string_length already
5859 is a pointer to the variable holding the length. Therefore
5860 remove the deref on call. */
5861 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
5864 tmp = parmse.string_length;
5865 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
5866 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
5867 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
5871 /* Character strings are passed as two parameters, a length and a
5872 pointer - except for Bind(c) which only passes the pointer.
5873 An unlimited polymorphic formal argument likewise does not
5875 if (parmse.string_length != NULL_TREE
5876 && !sym->attr.is_bind_c
5877 && !(fsym && UNLIMITED_POLY (fsym)))
5878 vec_safe_push (stringargs, parmse.string_length);
5880 /* When calling __copy for character expressions to unlimited
5881 polymorphic entities, the dst argument needs a string length. */
5882 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
5883 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
5884 && arg->next && arg->next->expr
5885 && (arg->next->expr->ts.type == BT_DERIVED
5886 || arg->next->expr->ts.type == BT_CLASS)
5887 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
5888 vec_safe_push (stringargs, parmse.string_length);
5890 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5891 pass the token and the offset as additional arguments. */
5892 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
5893 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5894 && !fsym->attr.allocatable)
5895 || (fsym->ts.type == BT_CLASS
5896 && CLASS_DATA (fsym)->attr.codimension
5897 && !CLASS_DATA (fsym)->attr.allocatable)))
5899 /* Token and offset. */
5900 vec_safe_push (stringargs, null_pointer_node);
5901 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
5902 gcc_assert (fsym->attr.optional);
5904 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
5905 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5906 && !fsym->attr.allocatable)
5907 || (fsym->ts.type == BT_CLASS
5908 && CLASS_DATA (fsym)->attr.codimension
5909 && !CLASS_DATA (fsym)->attr.allocatable)))
5911 tree caf_decl, caf_type;
5914 caf_decl = gfc_get_tree_for_caf_expr (e);
5915 caf_type = TREE_TYPE (caf_decl);
5917 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5918 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
5919 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
5920 tmp = gfc_conv_descriptor_token (caf_decl);
5921 else if (DECL_LANG_SPECIFIC (caf_decl)
5922 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
5923 tmp = GFC_DECL_TOKEN (caf_decl);
5926 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
5927 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
5928 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
5931 vec_safe_push (stringargs, tmp);
5933 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5934 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
5935 offset = build_int_cst (gfc_array_index_type, 0);
5936 else if (DECL_LANG_SPECIFIC (caf_decl)
5937 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
5938 offset = GFC_DECL_CAF_OFFSET (caf_decl);
5939 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
5940 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
5942 offset = build_int_cst (gfc_array_index_type, 0);
5944 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
5945 tmp = gfc_conv_descriptor_data_get (caf_decl);
5948 gcc_assert (POINTER_TYPE_P (caf_type));
5952 tmp2 = fsym->ts.type == BT_CLASS
5953 ? gfc_class_data_get (parmse.expr) : parmse.expr;
5954 if ((fsym->ts.type != BT_CLASS
5955 && (fsym->as->type == AS_ASSUMED_SHAPE
5956 || fsym->as->type == AS_ASSUMED_RANK))
5957 || (fsym->ts.type == BT_CLASS
5958 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
5959 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
5961 if (fsym->ts.type == BT_CLASS)
5962 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
5965 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5966 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
5968 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
5969 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5971 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
5972 tmp2 = gfc_conv_descriptor_data_get (tmp2);
5975 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
5978 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5979 gfc_array_index_type,
5980 fold_convert (gfc_array_index_type, tmp2),
5981 fold_convert (gfc_array_index_type, tmp));
5982 offset = fold_build2_loc (input_location, PLUS_EXPR,
5983 gfc_array_index_type, offset, tmp);
5985 vec_safe_push (stringargs, offset);
5988 vec_safe_push (arglist, parmse.expr);
5990 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
5994 else if (sym->ts.type == BT_CLASS)
5995 ts = CLASS_DATA (sym)->ts;
5999 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6000 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6001 else if (ts.type == BT_CHARACTER)
6003 if (ts.u.cl->length == NULL)
6005 /* Assumed character length results are not allowed by C418 of the 2003
6006 standard and are trapped in resolve.c; except in the case of SPREAD
6007 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6008 we take the character length of the first argument for the result.
6009 For dummies, we have to look through the formal argument list for
6010 this function and use the character length found there.*/
6012 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6013 else if (!sym->attr.dummy)
6014 cl.backend_decl = (*stringargs)[0];
6017 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6018 for (; formal; formal = formal->next)
6019 if (strcmp (formal->sym->name, sym->name) == 0)
6020 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6022 len = cl.backend_decl;
6028 /* Calculate the length of the returned string. */
6029 gfc_init_se (&parmse, NULL);
6030 if (need_interface_mapping)
6031 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6033 gfc_conv_expr (&parmse, ts.u.cl->length);
6034 gfc_add_block_to_block (&se->pre, &parmse.pre);
6035 gfc_add_block_to_block (&se->post, &parmse.post);
6037 /* TODO: It would be better to have the charlens as
6038 gfc_charlen_type_node already when the interface is
6039 created instead of converting it here (see PR 84615). */
6040 tmp = fold_build2_loc (input_location, MAX_EXPR,
6041 gfc_charlen_type_node,
6042 fold_convert (gfc_charlen_type_node, tmp),
6043 build_zero_cst (gfc_charlen_type_node));
6044 cl.backend_decl = tmp;
6047 /* Set up a charlen structure for it. */
6052 len = cl.backend_decl;
6055 byref = (comp && (comp->attr.dimension
6056 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6057 || (!comp && gfc_return_by_reference (sym));
6060 if (se->direct_byref)
6062 /* Sometimes, too much indirection can be applied; e.g. for
6063 function_result = array_valued_recursive_function. */
6064 if (TREE_TYPE (TREE_TYPE (se->expr))
6065 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6066 && GFC_DESCRIPTOR_TYPE_P
6067 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6068 se->expr = build_fold_indirect_ref_loc (input_location,
6071 /* If the lhs of an assignment x = f(..) is allocatable and
6072 f2003 is allowed, we must do the automatic reallocation.
6073 TODO - deal with intrinsics, without using a temporary. */
6074 if (flag_realloc_lhs
6075 && se->ss && se->ss->loop_chain
6076 && se->ss->loop_chain->is_alloc_lhs
6077 && !expr->value.function.isym
6078 && sym->result->as != NULL)
6080 /* Evaluate the bounds of the result, if known. */
6081 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6084 /* Perform the automatic reallocation. */
6085 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6087 gfc_add_expr_to_block (&se->pre, tmp);
6089 /* Pass the temporary as the first argument. */
6090 result = info->descriptor;
6093 result = build_fold_indirect_ref_loc (input_location,
6095 vec_safe_push (retargs, se->expr);
6097 else if (comp && comp->attr.dimension)
6099 gcc_assert (se->loop && info);
6101 /* Set the type of the array. */
6102 tmp = gfc_typenode_for_spec (&comp->ts);
6103 gcc_assert (se->ss->dimen == se->loop->dimen);
6105 /* Evaluate the bounds of the result, if known. */
6106 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6108 /* If the lhs of an assignment x = f(..) is allocatable and
6109 f2003 is allowed, we must not generate the function call
6110 here but should just send back the results of the mapping.
6111 This is signalled by the function ss being flagged. */
6112 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6114 gfc_free_interface_mapping (&mapping);
6115 return has_alternate_specifier;
6118 /* Create a temporary to store the result. In case the function
6119 returns a pointer, the temporary will be a shallow copy and
6120 mustn't be deallocated. */
6121 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6122 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6123 tmp, NULL_TREE, false,
6124 !comp->attr.pointer, callee_alloc,
6125 &se->ss->info->expr->where);
6127 /* Pass the temporary as the first argument. */
6128 result = info->descriptor;
6129 tmp = gfc_build_addr_expr (NULL_TREE, result);
6130 vec_safe_push (retargs, tmp);
6132 else if (!comp && sym->result->attr.dimension)
6134 gcc_assert (se->loop && info);
6136 /* Set the type of the array. */
6137 tmp = gfc_typenode_for_spec (&ts);
6138 gcc_assert (se->ss->dimen == se->loop->dimen);
6140 /* Evaluate the bounds of the result, if known. */
6141 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6143 /* If the lhs of an assignment x = f(..) is allocatable and
6144 f2003 is allowed, we must not generate the function call
6145 here but should just send back the results of the mapping.
6146 This is signalled by the function ss being flagged. */
6147 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6149 gfc_free_interface_mapping (&mapping);
6150 return has_alternate_specifier;
6153 /* Create a temporary to store the result. In case the function
6154 returns a pointer, the temporary will be a shallow copy and
6155 mustn't be deallocated. */
6156 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6157 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6158 tmp, NULL_TREE, false,
6159 !sym->attr.pointer, callee_alloc,
6160 &se->ss->info->expr->where);
6162 /* Pass the temporary as the first argument. */
6163 result = info->descriptor;
6164 tmp = gfc_build_addr_expr (NULL_TREE, result);
6165 vec_safe_push (retargs, tmp);
6167 else if (ts.type == BT_CHARACTER)
6169 /* Pass the string length. */
6170 type = gfc_get_character_type (ts.kind, ts.u.cl);
6171 type = build_pointer_type (type);
6173 /* Emit a DECL_EXPR for the VLA type. */
6174 tmp = TREE_TYPE (type);
6176 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6178 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6179 DECL_ARTIFICIAL (tmp) = 1;
6180 DECL_IGNORED_P (tmp) = 1;
6181 tmp = fold_build1_loc (input_location, DECL_EXPR,
6182 TREE_TYPE (tmp), tmp);
6183 gfc_add_expr_to_block (&se->pre, tmp);
6186 /* Return an address to a char[0:len-1]* temporary for
6187 character pointers. */
6188 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6189 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6191 var = gfc_create_var (type, "pstr");
6193 if ((!comp && sym->attr.allocatable)
6194 || (comp && comp->attr.allocatable))
6196 gfc_add_modify (&se->pre, var,
6197 fold_convert (TREE_TYPE (var),
6198 null_pointer_node));
6199 tmp = gfc_call_free (var);
6200 gfc_add_expr_to_block (&se->post, tmp);
6203 /* Provide an address expression for the function arguments. */
6204 var = gfc_build_addr_expr (NULL_TREE, var);
6207 var = gfc_conv_string_tmp (se, type, len);
6209 vec_safe_push (retargs, var);
6213 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6215 type = gfc_get_complex_type (ts.kind);
6216 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6217 vec_safe_push (retargs, var);
6220 /* Add the string length to the argument list. */
6221 if (ts.type == BT_CHARACTER && ts.deferred)
6225 tmp = gfc_evaluate_now (len, &se->pre);
6226 TREE_STATIC (tmp) = 1;
6227 gfc_add_modify (&se->pre, tmp,
6228 build_int_cst (TREE_TYPE (tmp), 0));
6229 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6230 vec_safe_push (retargs, tmp);
6232 else if (ts.type == BT_CHARACTER)
6233 vec_safe_push (retargs, len);
6235 gfc_free_interface_mapping (&mapping);
6237 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6238 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6239 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6240 vec_safe_reserve (retargs, arglen);
6242 /* Add the return arguments. */
6243 vec_safe_splice (retargs, arglist);
6245 /* Add the hidden present status for optional+value to the arguments. */
6246 vec_safe_splice (retargs, optionalargs);
6248 /* Add the hidden string length parameters to the arguments. */
6249 vec_safe_splice (retargs, stringargs);
6251 /* We may want to append extra arguments here. This is used e.g. for
6252 calls to libgfortran_matmul_??, which need extra information. */
6253 vec_safe_splice (retargs, append_args);
6257 /* Generate the actual call. */
6258 if (base_object == NULL_TREE)
6259 conv_function_val (se, sym, expr);
6261 conv_base_obj_fcn_val (se, base_object, expr);
6263 /* If there are alternate return labels, function type should be
6264 integer. Can't modify the type in place though, since it can be shared
6265 with other functions. For dummy arguments, the typing is done to
6266 this result, even if it has to be repeated for each call. */
6267 if (has_alternate_specifier
6268 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6270 if (!sym->attr.dummy)
6272 TREE_TYPE (sym->backend_decl)
6273 = build_function_type (integer_type_node,
6274 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6275 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6278 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6281 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6282 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6284 /* Allocatable scalar function results must be freed and nullified
6285 after use. This necessitates the creation of a temporary to
6286 hold the result to prevent duplicate calls. */
6287 if (!byref && sym->ts.type != BT_CHARACTER
6288 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6289 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6291 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6292 gfc_add_modify (&se->pre, tmp, se->expr);
6294 tmp = gfc_call_free (tmp);
6295 gfc_add_expr_to_block (&post, tmp);
6296 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6299 /* If we have a pointer function, but we don't want a pointer, e.g.
6302 where f is pointer valued, we have to dereference the result. */
6303 if (!se->want_pointer && !byref
6304 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6305 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6306 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6308 /* f2c calling conventions require a scalar default real function to
6309 return a double precision result. Convert this back to default
6310 real. We only care about the cases that can happen in Fortran 77.
6312 if (flag_f2c && sym->ts.type == BT_REAL
6313 && sym->ts.kind == gfc_default_real_kind
6314 && !sym->attr.always_explicit)
6315 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6317 /* A pure function may still have side-effects - it may modify its
6319 TREE_SIDE_EFFECTS (se->expr) = 1;
6321 if (!sym->attr.pure)
6322 TREE_SIDE_EFFECTS (se->expr) = 1;
6327 /* Add the function call to the pre chain. There is no expression. */
6328 gfc_add_expr_to_block (&se->pre, se->expr);
6329 se->expr = NULL_TREE;
6331 if (!se->direct_byref)
6333 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6335 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6337 /* Check the data pointer hasn't been modified. This would
6338 happen in a function returning a pointer. */
6339 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6340 tmp = fold_build2_loc (input_location, NE_EXPR,
6343 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6346 se->expr = info->descriptor;
6347 /* Bundle in the string length. */
6348 se->string_length = len;
6350 else if (ts.type == BT_CHARACTER)
6352 /* Dereference for character pointer results. */
6353 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6354 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6355 se->expr = build_fold_indirect_ref_loc (input_location, var);
6359 se->string_length = len;
6363 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6364 se->expr = build_fold_indirect_ref_loc (input_location, var);
6369 /* Associate the rhs class object's meta-data with the result, when the
6370 result is a temporary. */
6371 if (args && args->expr && args->expr->ts.type == BT_CLASS
6372 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6373 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6376 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6378 gfc_init_se (&parmse, NULL);
6379 parmse.data_not_needed = 1;
6380 gfc_conv_expr (&parmse, class_expr);
6381 if (!DECL_LANG_SPECIFIC (result))
6382 gfc_allocate_lang_decl (result);
6383 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6384 gfc_free_expr (class_expr);
6385 gcc_assert (parmse.pre.head == NULL_TREE
6386 && parmse.post.head == NULL_TREE);
6389 /* Follow the function call with the argument post block. */
6392 gfc_add_block_to_block (&se->pre, &post);
6394 /* Transformational functions of derived types with allocatable
6395 components must have the result allocatable components copied when the
6396 argument is actually given. */
6397 arg = expr->value.function.actual;
6398 if (result && arg && expr->rank
6399 && expr->value.function.isym
6400 && expr->value.function.isym->transformational
6402 && arg->expr->ts.type == BT_DERIVED
6403 && arg->expr->ts.u.derived->attr.alloc_comp)
6406 /* Copy the allocatable components. We have to use a
6407 temporary here to prevent source allocatable components
6408 from being corrupted. */
6409 tmp2 = gfc_evaluate_now (result, &se->pre);
6410 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6411 result, tmp2, expr->rank, 0);
6412 gfc_add_expr_to_block (&se->pre, tmp);
6413 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6415 gfc_add_expr_to_block (&se->pre, tmp);
6417 /* Finally free the temporary's data field. */
6418 tmp = gfc_conv_descriptor_data_get (tmp2);
6419 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6420 NULL_TREE, NULL_TREE, true,
6421 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6422 gfc_add_expr_to_block (&se->pre, tmp);
6427 /* For a function with a class array result, save the result as
6428 a temporary, set the info fields needed by the scalarizer and
6429 call the finalization function of the temporary. Note that the
6430 nullification of allocatable components needed by the result
6431 is done in gfc_trans_assignment_1. */
6432 if (expr && ((gfc_is_class_array_function (expr)
6433 && se->ss && se->ss->loop)
6434 || gfc_is_alloc_class_scalar_function (expr))
6435 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6436 && expr->must_finalize)
6441 if (se->ss && se->ss->loop)
6443 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6444 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6445 tmp = gfc_class_data_get (se->expr);
6446 info->descriptor = tmp;
6447 info->data = gfc_conv_descriptor_data_get (tmp);
6448 info->offset = gfc_conv_descriptor_offset_get (tmp);
6449 for (n = 0; n < se->ss->loop->dimen; n++)
6451 tree dim = gfc_rank_cst[n];
6452 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6453 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6458 /* TODO Eliminate the doubling of temporaries. This
6459 one is necessary to ensure no memory leakage. */
6460 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6461 tmp = gfc_class_data_get (se->expr);
6462 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6463 CLASS_DATA (expr->value.function.esym->result)->attr);
6466 if ((gfc_is_class_array_function (expr)
6467 || gfc_is_alloc_class_scalar_function (expr))
6468 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6469 goto no_finalization;
6471 final_fndecl = gfc_class_vtab_final_get (se->expr);
6472 is_final = fold_build2_loc (input_location, NE_EXPR,
6475 fold_convert (TREE_TYPE (final_fndecl),
6476 null_pointer_node));
6477 final_fndecl = build_fold_indirect_ref_loc (input_location,
6479 tmp = build_call_expr_loc (input_location,
6481 gfc_build_addr_expr (NULL, tmp),
6482 gfc_class_vtab_size_get (se->expr),
6483 boolean_false_node);
6484 tmp = fold_build3_loc (input_location, COND_EXPR,
6485 void_type_node, is_final, tmp,
6486 build_empty_stmt (input_location));
6488 if (se->ss && se->ss->loop)
6490 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
6491 tmp = fold_build2_loc (input_location, NE_EXPR,
6494 fold_convert (TREE_TYPE (info->data),
6495 null_pointer_node));
6496 tmp = fold_build3_loc (input_location, COND_EXPR,
6497 void_type_node, tmp,
6498 gfc_call_free (info->data),
6499 build_empty_stmt (input_location));
6500 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6505 gfc_prepend_expr_to_block (&se->post, tmp);
6506 classdata = gfc_class_data_get (se->expr);
6507 tmp = fold_build2_loc (input_location, NE_EXPR,
6510 fold_convert (TREE_TYPE (classdata),
6511 null_pointer_node));
6512 tmp = fold_build3_loc (input_location, COND_EXPR,
6513 void_type_node, tmp,
6514 gfc_call_free (classdata),
6515 build_empty_stmt (input_location));
6516 gfc_add_expr_to_block (&se->post, tmp);
6521 gfc_add_block_to_block (&se->post, &post);
6524 return has_alternate_specifier;
6528 /* Fill a character string with spaces. */
6531 fill_with_spaces (tree start, tree type, tree size)
6533 stmtblock_t block, loop;
6534 tree i, el, exit_label, cond, tmp;
6536 /* For a simple char type, we can call memset(). */
6537 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6538 return build_call_expr_loc (input_location,
6539 builtin_decl_explicit (BUILT_IN_MEMSET),
6541 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6542 lang_hooks.to_target_charset (' ')),
6543 fold_convert (size_type_node, size));
6545 /* Otherwise, we use a loop:
6546 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6550 /* Initialize variables. */
6551 gfc_init_block (&block);
6552 i = gfc_create_var (sizetype, "i");
6553 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6554 el = gfc_create_var (build_pointer_type (type), "el");
6555 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6556 exit_label = gfc_build_label_decl (NULL_TREE);
6557 TREE_USED (exit_label) = 1;
6561 gfc_init_block (&loop);
6563 /* Exit condition. */
6564 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6565 build_zero_cst (sizetype));
6566 tmp = build1_v (GOTO_EXPR, exit_label);
6567 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6568 build_empty_stmt (input_location));
6569 gfc_add_expr_to_block (&loop, tmp);
6572 gfc_add_modify (&loop,
6573 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6574 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6576 /* Increment loop variables. */
6577 gfc_add_modify (&loop, i,
6578 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6579 TYPE_SIZE_UNIT (type)));
6580 gfc_add_modify (&loop, el,
6581 fold_build_pointer_plus_loc (input_location,
6582 el, TYPE_SIZE_UNIT (type)));
6584 /* Making the loop... actually loop! */
6585 tmp = gfc_finish_block (&loop);
6586 tmp = build1_v (LOOP_EXPR, tmp);
6587 gfc_add_expr_to_block (&block, tmp);
6589 /* The exit label. */
6590 tmp = build1_v (LABEL_EXPR, exit_label);
6591 gfc_add_expr_to_block (&block, tmp);
6594 return gfc_finish_block (&block);
6598 /* Generate code to copy a string. */
6601 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6602 int dkind, tree slength, tree src, int skind)
6604 tree tmp, dlen, slen;
6613 stmtblock_t tempblock;
6615 gcc_assert (dkind == skind);
6617 if (slength != NULL_TREE)
6619 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
6620 ssc = gfc_string_to_single_character (slen, src, skind);
6624 slen = build_one_cst (gfc_charlen_type_node);
6628 if (dlength != NULL_TREE)
6630 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
6631 dsc = gfc_string_to_single_character (dlen, dest, dkind);
6635 dlen = build_one_cst (gfc_charlen_type_node);
6639 /* Assign directly if the types are compatible. */
6640 if (dsc != NULL_TREE && ssc != NULL_TREE
6641 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
6643 gfc_add_modify (block, dsc, ssc);
6647 /* The string copy algorithm below generates code like
6651 if (srclen < destlen)
6653 memmove (dest, src, srclen);
6655 memset (&dest[srclen], ' ', destlen - srclen);
6659 // Truncate if too long.
6660 memmove (dest, src, destlen);
6665 /* Do nothing if the destination length is zero. */
6666 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
6667 build_zero_cst (TREE_TYPE (dlen)));
6669 /* For non-default character kinds, we have to multiply the string
6670 length by the base type size. */
6671 chartype = gfc_get_char_type (dkind);
6672 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
6674 fold_convert (TREE_TYPE (slen),
6675 TYPE_SIZE_UNIT (chartype)));
6676 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
6678 fold_convert (TREE_TYPE (dlen),
6679 TYPE_SIZE_UNIT (chartype)));
6681 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
6682 dest = fold_convert (pvoid_type_node, dest);
6684 dest = gfc_build_addr_expr (pvoid_type_node, dest);
6686 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
6687 src = fold_convert (pvoid_type_node, src);
6689 src = gfc_build_addr_expr (pvoid_type_node, src);
6691 /* Truncate string if source is too long. */
6692 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
6695 /* Copy and pad with spaces. */
6696 tmp3 = build_call_expr_loc (input_location,
6697 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6699 fold_convert (size_type_node, slen));
6701 /* Wstringop-overflow appears at -O3 even though this warning is not
6702 explicitly available in fortran nor can it be switched off. If the
6703 source length is a constant, its negative appears as a very large
6704 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6705 the result of the MINUS_EXPR suppresses this spurious warning. */
6706 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6707 TREE_TYPE(dlen), dlen, slen);
6708 if (slength && TREE_CONSTANT (slength))
6709 tmp = gfc_evaluate_now (tmp, block);
6711 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
6712 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
6714 gfc_init_block (&tempblock);
6715 gfc_add_expr_to_block (&tempblock, tmp3);
6716 gfc_add_expr_to_block (&tempblock, tmp4);
6717 tmp3 = gfc_finish_block (&tempblock);
6719 /* The truncated memmove if the slen >= dlen. */
6720 tmp2 = build_call_expr_loc (input_location,
6721 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6723 fold_convert (size_type_node, dlen));
6725 /* The whole copy_string function is there. */
6726 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
6728 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6729 build_empty_stmt (input_location));
6730 gfc_add_expr_to_block (block, tmp);
6734 /* Translate a statement function.
6735 The value of a statement function reference is obtained by evaluating the
6736 expression using the values of the actual arguments for the values of the
6737 corresponding dummy arguments. */
6740 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
6744 gfc_formal_arglist *fargs;
6745 gfc_actual_arglist *args;
6748 gfc_saved_var *saved_vars;
6754 sym = expr->symtree->n.sym;
6755 args = expr->value.function.actual;
6756 gfc_init_se (&lse, NULL);
6757 gfc_init_se (&rse, NULL);
6760 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
6762 saved_vars = XCNEWVEC (gfc_saved_var, n);
6763 temp_vars = XCNEWVEC (tree, n);
6765 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6766 fargs = fargs->next, n++)
6768 /* Each dummy shall be specified, explicitly or implicitly, to be
6770 gcc_assert (fargs->sym->attr.dimension == 0);
6773 if (fsym->ts.type == BT_CHARACTER)
6775 /* Copy string arguments. */
6778 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
6779 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
6781 /* Create a temporary to hold the value. */
6782 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
6783 fsym->ts.u.cl->backend_decl
6784 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
6786 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
6787 temp_vars[n] = gfc_create_var (type, fsym->name);
6789 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
6791 gfc_conv_expr (&rse, args->expr);
6792 gfc_conv_string_parameter (&rse);
6793 gfc_add_block_to_block (&se->pre, &lse.pre);
6794 gfc_add_block_to_block (&se->pre, &rse.pre);
6796 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
6797 rse.string_length, rse.expr, fsym->ts.kind);
6798 gfc_add_block_to_block (&se->pre, &lse.post);
6799 gfc_add_block_to_block (&se->pre, &rse.post);
6803 /* For everything else, just evaluate the expression. */
6805 /* Create a temporary to hold the value. */
6806 type = gfc_typenode_for_spec (&fsym->ts);
6807 temp_vars[n] = gfc_create_var (type, fsym->name);
6809 gfc_conv_expr (&lse, args->expr);
6811 gfc_add_block_to_block (&se->pre, &lse.pre);
6812 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
6813 gfc_add_block_to_block (&se->pre, &lse.post);
6819 /* Use the temporary variables in place of the real ones. */
6820 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6821 fargs = fargs->next, n++)
6822 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
6824 gfc_conv_expr (se, sym->value);
6826 if (sym->ts.type == BT_CHARACTER)
6828 gfc_conv_const_charlen (sym->ts.u.cl);
6830 /* Force the expression to the correct length. */
6831 if (!INTEGER_CST_P (se->string_length)
6832 || tree_int_cst_lt (se->string_length,
6833 sym->ts.u.cl->backend_decl))
6835 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
6836 tmp = gfc_create_var (type, sym->name);
6837 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
6838 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
6839 sym->ts.kind, se->string_length, se->expr,
6843 se->string_length = sym->ts.u.cl->backend_decl;
6846 /* Restore the original variables. */
6847 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6848 fargs = fargs->next, n++)
6849 gfc_restore_sym (fargs->sym, &saved_vars[n]);
6855 /* Translate a function expression. */
6858 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
6862 if (expr->value.function.isym)
6864 gfc_conv_intrinsic_function (se, expr);
6868 /* expr.value.function.esym is the resolved (specific) function symbol for
6869 most functions. However this isn't set for dummy procedures. */
6870 sym = expr->value.function.esym;
6872 sym = expr->symtree->n.sym;
6874 /* The IEEE_ARITHMETIC functions are caught here. */
6875 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6876 if (gfc_conv_ieee_arithmetic_function (se, expr))
6879 /* We distinguish statement functions from general functions to improve
6880 runtime performance. */
6881 if (sym->attr.proc == PROC_ST_FUNCTION)
6883 gfc_conv_statement_function (se, expr);
6887 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6892 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6895 is_zero_initializer_p (gfc_expr * expr)
6897 if (expr->expr_type != EXPR_CONSTANT)
6900 /* We ignore constants with prescribed memory representations for now. */
6901 if (expr->representation.string)
6904 switch (expr->ts.type)
6907 return mpz_cmp_si (expr->value.integer, 0) == 0;
6910 return mpfr_zero_p (expr->value.real)
6911 && MPFR_SIGN (expr->value.real) >= 0;
6914 return expr->value.logical == 0;
6917 return mpfr_zero_p (mpc_realref (expr->value.complex))
6918 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
6919 && mpfr_zero_p (mpc_imagref (expr->value.complex))
6920 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
6930 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
6935 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
6936 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
6938 gfc_conv_tmp_array_ref (se);
6942 /* Build a static initializer. EXPR is the expression for the initial value.
6943 The other parameters describe the variable of the component being
6944 initialized. EXPR may be null. */
6947 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
6948 bool array, bool pointer, bool procptr)
6952 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
6953 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6954 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
6955 return build_constructor (type, NULL);
6957 if (!(expr || pointer || procptr))
6960 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
6961 (these are the only two iso_c_binding derived types that can be
6962 used as initialization expressions). If so, we need to modify
6963 the 'expr' to be that for a (void *). */
6964 if (expr != NULL && expr->ts.type == BT_DERIVED
6965 && expr->ts.is_iso_c && expr->ts.u.derived)
6967 gfc_symbol *derived = expr->ts.u.derived;
6969 /* The derived symbol has already been converted to a (void *). Use
6971 if (derived->ts.kind == 0)
6972 derived->ts.kind = gfc_default_integer_kind;
6973 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
6974 expr->ts.f90_type = derived->ts.f90_type;
6976 gfc_init_se (&se, NULL);
6977 gfc_conv_constant (&se, expr);
6978 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
6982 if (array && !procptr)
6985 /* Arrays need special handling. */
6987 ctor = gfc_build_null_descriptor (type);
6988 /* Special case assigning an array to zero. */
6989 else if (is_zero_initializer_p (expr))
6990 ctor = build_constructor (type, NULL);
6992 ctor = gfc_conv_array_initializer (type, expr);
6993 TREE_STATIC (ctor) = 1;
6996 else if (pointer || procptr)
6998 if (ts->type == BT_CLASS && !procptr)
7000 gfc_init_se (&se, NULL);
7001 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7002 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7003 TREE_STATIC (se.expr) = 1;
7006 else if (!expr || expr->expr_type == EXPR_NULL)
7007 return fold_convert (type, null_pointer_node);
7010 gfc_init_se (&se, NULL);
7011 se.want_pointer = 1;
7012 gfc_conv_expr (&se, expr);
7013 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7023 gfc_init_se (&se, NULL);
7024 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7025 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7027 gfc_conv_structure (&se, expr, 1);
7028 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7029 TREE_STATIC (se.expr) = 1;
7034 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7035 TREE_STATIC (ctor) = 1;
7040 gfc_init_se (&se, NULL);
7041 gfc_conv_constant (&se, expr);
7042 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7049 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7055 gfc_array_info *lss_array;
7062 gfc_start_block (&block);
7064 /* Initialize the scalarizer. */
7065 gfc_init_loopinfo (&loop);
7067 gfc_init_se (&lse, NULL);
7068 gfc_init_se (&rse, NULL);
7071 rss = gfc_walk_expr (expr);
7072 if (rss == gfc_ss_terminator)
7073 /* The rhs is scalar. Add a ss for the expression. */
7074 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7076 /* Create a SS for the destination. */
7077 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7079 lss_array = &lss->info->data.array;
7080 lss_array->shape = gfc_get_shape (cm->as->rank);
7081 lss_array->descriptor = dest;
7082 lss_array->data = gfc_conv_array_data (dest);
7083 lss_array->offset = gfc_conv_array_offset (dest);
7084 for (n = 0; n < cm->as->rank; n++)
7086 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7087 lss_array->stride[n] = gfc_index_one_node;
7089 mpz_init (lss_array->shape[n]);
7090 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7091 cm->as->lower[n]->value.integer);
7092 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7095 /* Associate the SS with the loop. */
7096 gfc_add_ss_to_loop (&loop, lss);
7097 gfc_add_ss_to_loop (&loop, rss);
7099 /* Calculate the bounds of the scalarization. */
7100 gfc_conv_ss_startstride (&loop);
7102 /* Setup the scalarizing loops. */
7103 gfc_conv_loop_setup (&loop, &expr->where);
7105 /* Setup the gfc_se structures. */
7106 gfc_copy_loopinfo_to_se (&lse, &loop);
7107 gfc_copy_loopinfo_to_se (&rse, &loop);
7110 gfc_mark_ss_chain_used (rss, 1);
7112 gfc_mark_ss_chain_used (lss, 1);
7114 /* Start the scalarized loop body. */
7115 gfc_start_scalarized_body (&loop, &body);
7117 gfc_conv_tmp_array_ref (&lse);
7118 if (cm->ts.type == BT_CHARACTER)
7119 lse.string_length = cm->ts.u.cl->backend_decl;
7121 gfc_conv_expr (&rse, expr);
7123 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7124 gfc_add_expr_to_block (&body, tmp);
7126 gcc_assert (rse.ss == gfc_ss_terminator);
7128 /* Generate the copying loops. */
7129 gfc_trans_scalarizing_loops (&loop, &body);
7131 /* Wrap the whole thing up. */
7132 gfc_add_block_to_block (&block, &loop.pre);
7133 gfc_add_block_to_block (&block, &loop.post);
7135 gcc_assert (lss_array->shape != NULL);
7136 gfc_free_shape (&lss_array->shape, cm->as->rank);
7137 gfc_cleanup_loop (&loop);
7139 return gfc_finish_block (&block);
7144 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7154 gfc_expr *arg = NULL;
7156 gfc_start_block (&block);
7157 gfc_init_se (&se, NULL);
7159 /* Get the descriptor for the expressions. */
7160 se.want_pointer = 0;
7161 gfc_conv_expr_descriptor (&se, expr);
7162 gfc_add_block_to_block (&block, &se.pre);
7163 gfc_add_modify (&block, dest, se.expr);
7165 /* Deal with arrays of derived types with allocatable components. */
7166 if (gfc_bt_struct (cm->ts.type)
7167 && cm->ts.u.derived->attr.alloc_comp)
7168 // TODO: Fix caf_mode
7169 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7172 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7173 && CLASS_DATA(cm)->attr.allocatable)
7175 if (cm->ts.u.derived->attr.alloc_comp)
7176 // TODO: Fix caf_mode
7177 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7182 tmp = TREE_TYPE (dest);
7183 tmp = gfc_duplicate_allocatable (dest, se.expr,
7184 tmp, expr->rank, NULL_TREE);
7188 tmp = gfc_duplicate_allocatable (dest, se.expr,
7189 TREE_TYPE(cm->backend_decl),
7190 cm->as->rank, NULL_TREE);
7192 gfc_add_expr_to_block (&block, tmp);
7193 gfc_add_block_to_block (&block, &se.post);
7195 if (expr->expr_type != EXPR_VARIABLE)
7196 gfc_conv_descriptor_data_set (&block, se.expr,
7199 /* We need to know if the argument of a conversion function is a
7200 variable, so that the correct lower bound can be used. */
7201 if (expr->expr_type == EXPR_FUNCTION
7202 && expr->value.function.isym
7203 && expr->value.function.isym->conversion
7204 && expr->value.function.actual->expr
7205 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7206 arg = expr->value.function.actual->expr;
7208 /* Obtain the array spec of full array references. */
7210 as = gfc_get_full_arrayspec_from_expr (arg);
7212 as = gfc_get_full_arrayspec_from_expr (expr);
7214 /* Shift the lbound and ubound of temporaries to being unity,
7215 rather than zero, based. Always calculate the offset. */
7216 offset = gfc_conv_descriptor_offset_get (dest);
7217 gfc_add_modify (&block, offset, gfc_index_zero_node);
7218 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7220 for (n = 0; n < expr->rank; n++)
7225 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7226 TODO It looks as if gfc_conv_expr_descriptor should return
7227 the correct bounds and that the following should not be
7228 necessary. This would simplify gfc_conv_intrinsic_bound
7230 if (as && as->lower[n])
7233 gfc_init_se (&lbse, NULL);
7234 gfc_conv_expr (&lbse, as->lower[n]);
7235 gfc_add_block_to_block (&block, &lbse.pre);
7236 lbound = gfc_evaluate_now (lbse.expr, &block);
7240 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7241 lbound = gfc_conv_descriptor_lbound_get (tmp,
7245 lbound = gfc_conv_descriptor_lbound_get (dest,
7248 lbound = gfc_index_one_node;
7250 lbound = fold_convert (gfc_array_index_type, lbound);
7252 /* Shift the bounds and set the offset accordingly. */
7253 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7254 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7255 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7256 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7258 gfc_conv_descriptor_ubound_set (&block, dest,
7259 gfc_rank_cst[n], tmp);
7260 gfc_conv_descriptor_lbound_set (&block, dest,
7261 gfc_rank_cst[n], lbound);
7263 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7264 gfc_conv_descriptor_lbound_get (dest,
7266 gfc_conv_descriptor_stride_get (dest,
7268 gfc_add_modify (&block, tmp2, tmp);
7269 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7271 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7276 /* If a conversion expression has a null data pointer
7277 argument, nullify the allocatable component. */
7281 if (arg->symtree->n.sym->attr.allocatable
7282 || arg->symtree->n.sym->attr.pointer)
7284 non_null_expr = gfc_finish_block (&block);
7285 gfc_start_block (&block);
7286 gfc_conv_descriptor_data_set (&block, dest,
7288 null_expr = gfc_finish_block (&block);
7289 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7290 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7291 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7292 return build3_v (COND_EXPR, tmp,
7293 null_expr, non_null_expr);
7297 return gfc_finish_block (&block);
7301 /* Allocate or reallocate scalar component, as necessary. */
7304 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7314 tree lhs_cl_size = NULL_TREE;
7319 if (!expr2 || expr2->rank)
7322 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7324 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7326 char name[GFC_MAX_SYMBOL_LEN+9];
7327 gfc_component *strlen;
7328 /* Use the rhs string length and the lhs element size. */
7329 gcc_assert (expr2->ts.type == BT_CHARACTER);
7330 if (!expr2->ts.u.cl->backend_decl)
7332 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7333 gcc_assert (expr2->ts.u.cl->backend_decl);
7336 size = expr2->ts.u.cl->backend_decl;
7338 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7340 sprintf (name, "_%s_length", cm->name);
7341 strlen = gfc_find_component (sym, name, true, true, NULL);
7342 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7343 gfc_charlen_type_node,
7344 TREE_OPERAND (comp, 0),
7345 strlen->backend_decl, NULL_TREE);
7347 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7348 tmp = TYPE_SIZE_UNIT (tmp);
7349 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7350 TREE_TYPE (tmp), tmp,
7351 fold_convert (TREE_TYPE (tmp), size));
7353 else if (cm->ts.type == BT_CLASS)
7355 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7356 if (expr2->ts.type == BT_DERIVED)
7358 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7359 size = TYPE_SIZE_UNIT (tmp);
7365 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7366 gfc_add_vptr_component (e2vtab);
7367 gfc_add_size_component (e2vtab);
7368 gfc_init_se (&se, NULL);
7369 gfc_conv_expr (&se, e2vtab);
7370 gfc_add_block_to_block (block, &se.pre);
7371 size = fold_convert (size_type_node, se.expr);
7372 gfc_free_expr (e2vtab);
7374 size_in_bytes = size;
7378 /* Otherwise use the length in bytes of the rhs. */
7379 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7380 size_in_bytes = size;
7383 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7384 size_in_bytes, size_one_node);
7386 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7388 tmp = build_call_expr_loc (input_location,
7389 builtin_decl_explicit (BUILT_IN_CALLOC),
7390 2, build_one_cst (size_type_node),
7392 tmp = fold_convert (TREE_TYPE (comp), tmp);
7393 gfc_add_modify (block, comp, tmp);
7397 tmp = build_call_expr_loc (input_location,
7398 builtin_decl_explicit (BUILT_IN_MALLOC),
7400 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7401 ptr = gfc_class_data_get (comp);
7404 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7405 gfc_add_modify (block, ptr, tmp);
7408 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7409 /* Update the lhs character length. */
7410 gfc_add_modify (block, lhs_cl_size,
7411 fold_convert (TREE_TYPE (lhs_cl_size), size));
7415 /* Assign a single component of a derived type constructor. */
7418 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7419 gfc_symbol *sym, bool init)
7427 gfc_start_block (&block);
7429 if (cm->attr.pointer || cm->attr.proc_pointer)
7431 /* Only care about pointers here, not about allocatables. */
7432 gfc_init_se (&se, NULL);
7433 /* Pointer component. */
7434 if ((cm->attr.dimension || cm->attr.codimension)
7435 && !cm->attr.proc_pointer)
7437 /* Array pointer. */
7438 if (expr->expr_type == EXPR_NULL)
7439 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7442 se.direct_byref = 1;
7444 gfc_conv_expr_descriptor (&se, expr);
7445 gfc_add_block_to_block (&block, &se.pre);
7446 gfc_add_block_to_block (&block, &se.post);
7451 /* Scalar pointers. */
7452 se.want_pointer = 1;
7453 gfc_conv_expr (&se, expr);
7454 gfc_add_block_to_block (&block, &se.pre);
7456 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7457 && expr->symtree->n.sym->attr.dummy)
7458 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7460 gfc_add_modify (&block, dest,
7461 fold_convert (TREE_TYPE (dest), se.expr));
7462 gfc_add_block_to_block (&block, &se.post);
7465 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7467 /* NULL initialization for CLASS components. */
7468 tmp = gfc_trans_structure_assign (dest,
7469 gfc_class_initializer (&cm->ts, expr),
7471 gfc_add_expr_to_block (&block, tmp);
7473 else if ((cm->attr.dimension || cm->attr.codimension)
7474 && !cm->attr.proc_pointer)
7476 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7477 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7478 else if (cm->attr.allocatable || cm->attr.pdt_array)
7480 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7481 gfc_add_expr_to_block (&block, tmp);
7485 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7486 gfc_add_expr_to_block (&block, tmp);
7489 else if (cm->ts.type == BT_CLASS
7490 && CLASS_DATA (cm)->attr.dimension
7491 && CLASS_DATA (cm)->attr.allocatable
7492 && expr->ts.type == BT_DERIVED)
7494 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7495 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7496 tmp = gfc_class_vptr_get (dest);
7497 gfc_add_modify (&block, tmp,
7498 fold_convert (TREE_TYPE (tmp), vtab));
7499 tmp = gfc_class_data_get (dest);
7500 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7501 gfc_add_expr_to_block (&block, tmp);
7503 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7505 /* NULL initialization for allocatable components. */
7506 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7507 null_pointer_node));
7509 else if (init && (cm->attr.allocatable
7510 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7511 && expr->ts.type != BT_CLASS)))
7513 /* Take care about non-array allocatable components here. The alloc_*
7514 routine below is motivated by the alloc_scalar_allocatable_for_
7515 assignment() routine, but with the realloc portions removed and
7517 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7522 /* The remainder of these instructions follow the if (cm->attr.pointer)
7523 if (!cm->attr.dimension) part above. */
7524 gfc_init_se (&se, NULL);
7525 gfc_conv_expr (&se, expr);
7526 gfc_add_block_to_block (&block, &se.pre);
7528 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7529 && expr->symtree->n.sym->attr.dummy)
7530 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7532 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7534 tmp = gfc_class_data_get (dest);
7535 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7536 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7537 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7538 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7539 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7542 tmp = build_fold_indirect_ref_loc (input_location, dest);
7544 /* For deferred strings insert a memcpy. */
7545 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7548 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7549 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7551 : expr->ts.u.cl->backend_decl);
7552 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7553 gfc_add_expr_to_block (&block, tmp);
7556 gfc_add_modify (&block, tmp,
7557 fold_convert (TREE_TYPE (tmp), se.expr));
7558 gfc_add_block_to_block (&block, &se.post);
7560 else if (expr->ts.type == BT_UNION)
7563 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7564 /* We mark that the entire union should be initialized with a contrived
7565 EXPR_NULL expression at the beginning. */
7566 if (c != NULL && c->n.component == NULL
7567 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7569 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7570 dest, build_constructor (TREE_TYPE (dest), NULL));
7571 gfc_add_expr_to_block (&block, tmp);
7572 c = gfc_constructor_next (c);
7574 /* The following constructor expression, if any, represents a specific
7575 map intializer, as given by the user. */
7576 if (c != NULL && c->expr != NULL)
7578 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7579 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7580 gfc_add_expr_to_block (&block, tmp);
7583 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7585 if (expr->expr_type != EXPR_STRUCTURE)
7587 tree dealloc = NULL_TREE;
7588 gfc_init_se (&se, NULL);
7589 gfc_conv_expr (&se, expr);
7590 gfc_add_block_to_block (&block, &se.pre);
7591 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7592 expression in a temporary variable and deallocate the allocatable
7593 components. Then we can the copy the expression to the result. */
7594 if (cm->ts.u.derived->attr.alloc_comp
7595 && expr->expr_type != EXPR_VARIABLE)
7597 se.expr = gfc_evaluate_now (se.expr, &block);
7598 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7601 gfc_add_modify (&block, dest,
7602 fold_convert (TREE_TYPE (dest), se.expr));
7603 if (cm->ts.u.derived->attr.alloc_comp
7604 && expr->expr_type != EXPR_NULL)
7606 // TODO: Fix caf_mode
7607 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7608 dest, expr->rank, 0);
7609 gfc_add_expr_to_block (&block, tmp);
7610 if (dealloc != NULL_TREE)
7611 gfc_add_expr_to_block (&block, dealloc);
7613 gfc_add_block_to_block (&block, &se.post);
7617 /* Nested constructors. */
7618 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7619 gfc_add_expr_to_block (&block, tmp);
7622 else if (gfc_deferred_strlen (cm, &tmp))
7626 gcc_assert (strlen);
7627 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7629 TREE_OPERAND (dest, 0),
7632 if (expr->expr_type == EXPR_NULL)
7634 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7635 gfc_add_modify (&block, dest, tmp);
7636 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7637 gfc_add_modify (&block, strlen, tmp);
7642 gfc_init_se (&se, NULL);
7643 gfc_conv_expr (&se, expr);
7644 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
7645 tmp = build_call_expr_loc (input_location,
7646 builtin_decl_explicit (BUILT_IN_MALLOC),
7648 gfc_add_modify (&block, dest,
7649 fold_convert (TREE_TYPE (dest), tmp));
7650 gfc_add_modify (&block, strlen,
7651 fold_convert (TREE_TYPE (strlen), se.string_length));
7652 tmp = gfc_build_memcpy_call (dest, se.expr, size);
7653 gfc_add_expr_to_block (&block, tmp);
7656 else if (!cm->attr.artificial)
7658 /* Scalar component (excluding deferred parameters). */
7659 gfc_init_se (&se, NULL);
7660 gfc_init_se (&lse, NULL);
7662 gfc_conv_expr (&se, expr);
7663 if (cm->ts.type == BT_CHARACTER)
7664 lse.string_length = cm->ts.u.cl->backend_decl;
7666 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
7667 gfc_add_expr_to_block (&block, tmp);
7669 return gfc_finish_block (&block);
7672 /* Assign a derived type constructor to a variable. */
7675 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
7684 gfc_start_block (&block);
7685 cm = expr->ts.u.derived->components;
7687 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
7688 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7689 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
7693 gfc_init_se (&se, NULL);
7694 gfc_init_se (&lse, NULL);
7695 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
7697 gfc_add_modify (&block, lse.expr,
7698 fold_convert (TREE_TYPE (lse.expr), se.expr));
7700 return gfc_finish_block (&block);
7704 gfc_init_se (&se, NULL);
7706 for (c = gfc_constructor_first (expr->value.constructor);
7707 c; c = gfc_constructor_next (c), cm = cm->next)
7709 /* Skip absent members in default initializers. */
7710 if (!c->expr && !cm->attr.allocatable)
7713 /* Register the component with the caf-lib before it is initialized.
7714 Register only allocatable components, that are not coarray'ed
7715 components (%comp[*]). Only register when the constructor is not the
7717 if (coarray && !cm->attr.codimension
7718 && (cm->attr.allocatable || cm->attr.pointer)
7719 && (!c->expr || c->expr->expr_type == EXPR_NULL))
7721 tree token, desc, size;
7722 bool is_array = cm->ts.type == BT_CLASS
7723 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
7725 field = cm->backend_decl;
7726 field = fold_build3_loc (input_location, COMPONENT_REF,
7727 TREE_TYPE (field), dest, field, NULL_TREE);
7728 if (cm->ts.type == BT_CLASS)
7729 field = gfc_class_data_get (field);
7731 token = is_array ? gfc_conv_descriptor_token (field)
7732 : fold_build3_loc (input_location, COMPONENT_REF,
7733 TREE_TYPE (cm->caf_token), dest,
7734 cm->caf_token, NULL_TREE);
7738 /* The _caf_register routine looks at the rank of the array
7739 descriptor to decide whether the data registered is an array
7741 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
7743 /* When the rank is not known just set a positive rank, which
7744 suffices to recognize the data as array. */
7747 size = build_zero_cst (size_type_node);
7749 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
7750 build_int_cst (signed_char_type_node, rank));
7754 desc = gfc_conv_scalar_to_descriptor (&se, field,
7755 cm->ts.type == BT_CLASS
7756 ? CLASS_DATA (cm)->attr
7758 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
7760 gfc_add_block_to_block (&block, &se.pre);
7761 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
7762 7, size, build_int_cst (
7764 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
7765 gfc_build_addr_expr (pvoid_type_node,
7767 gfc_build_addr_expr (NULL_TREE, desc),
7768 null_pointer_node, null_pointer_node,
7770 gfc_add_expr_to_block (&block, tmp);
7772 field = cm->backend_decl;
7773 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7774 dest, field, NULL_TREE);
7777 gfc_expr *e = gfc_get_null_expr (NULL);
7778 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
7783 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
7784 expr->ts.u.derived, init);
7785 gfc_add_expr_to_block (&block, tmp);
7787 return gfc_finish_block (&block);
7791 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
7792 gfc_component *un, gfc_expr *init)
7794 gfc_constructor *ctor;
7796 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
7799 ctor = gfc_constructor_first (init->value.constructor);
7801 if (ctor == NULL || ctor->expr == NULL)
7804 gcc_assert (init->expr_type == EXPR_STRUCTURE);
7806 /* If we have an 'initialize all' constructor, do it first. */
7807 if (ctor->expr->expr_type == EXPR_NULL)
7809 tree union_type = TREE_TYPE (un->backend_decl);
7810 tree val = build_constructor (union_type, NULL);
7811 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7812 ctor = gfc_constructor_next (ctor);
7815 /* Add the map initializer on top. */
7816 if (ctor != NULL && ctor->expr != NULL)
7818 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
7819 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
7820 TREE_TYPE (un->backend_decl),
7821 un->attr.dimension, un->attr.pointer,
7822 un->attr.proc_pointer);
7823 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7827 /* Build an expression for a constructor. If init is nonzero then
7828 this is part of a static variable initializer. */
7831 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
7838 vec<constructor_elt, va_gc> *v = NULL;
7840 gcc_assert (se->ss == NULL);
7841 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7842 type = gfc_typenode_for_spec (&expr->ts);
7846 /* Create a temporary variable and fill it in. */
7847 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
7848 /* The symtree in expr is NULL, if the code to generate is for
7849 initializing the static members only. */
7850 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
7852 gfc_add_expr_to_block (&se->pre, tmp);
7856 cm = expr->ts.u.derived->components;
7858 for (c = gfc_constructor_first (expr->value.constructor);
7859 c; c = gfc_constructor_next (c), cm = cm->next)
7861 /* Skip absent members in default initializers and allocatable
7862 components. Although the latter have a default initializer
7863 of EXPR_NULL,... by default, the static nullify is not needed
7864 since this is done every time we come into scope. */
7865 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
7868 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
7869 && strcmp (cm->name, "_extends") == 0
7870 && cm->initializer->symtree)
7874 vtabs = cm->initializer->symtree->n.sym;
7875 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
7876 vtab = unshare_expr_without_location (vtab);
7877 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
7879 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
7881 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
7882 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7883 fold_convert (TREE_TYPE (cm->backend_decl),
7886 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
7887 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7888 fold_convert (TREE_TYPE (cm->backend_decl),
7889 integer_zero_node));
7890 else if (cm->ts.type == BT_UNION)
7891 gfc_conv_union_initializer (v, cm, c->expr);
7894 val = gfc_conv_initializer (c->expr, &cm->ts,
7895 TREE_TYPE (cm->backend_decl),
7896 cm->attr.dimension, cm->attr.pointer,
7897 cm->attr.proc_pointer);
7898 val = unshare_expr_without_location (val);
7900 /* Append it to the constructor list. */
7901 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
7905 se->expr = build_constructor (type, v);
7907 TREE_CONSTANT (se->expr) = 1;
7911 /* Translate a substring expression. */
7914 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
7920 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
7922 se->expr = gfc_build_wide_string_const (expr->ts.kind,
7923 expr->value.character.length,
7924 expr->value.character.string);
7926 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
7927 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
7930 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
7934 /* Entry point for expression translation. Evaluates a scalar quantity.
7935 EXPR is the expression to be translated, and SE is the state structure if
7936 called from within the scalarized. */
7939 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
7944 if (ss && ss->info->expr == expr
7945 && (ss->info->type == GFC_SS_SCALAR
7946 || ss->info->type == GFC_SS_REFERENCE))
7948 gfc_ss_info *ss_info;
7951 /* Substitute a scalar expression evaluated outside the scalarization
7953 se->expr = ss_info->data.scalar.value;
7954 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
7955 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7957 se->string_length = ss_info->string_length;
7958 gfc_advance_se_ss_chain (se);
7962 /* We need to convert the expressions for the iso_c_binding derived types.
7963 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
7964 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
7965 typespec for the C_PTR and C_FUNPTR symbols, which has already been
7966 updated to be an integer with a kind equal to the size of a (void *). */
7967 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
7968 && expr->ts.u.derived->attr.is_bind_c)
7970 if (expr->expr_type == EXPR_VARIABLE
7971 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
7972 || expr->symtree->n.sym->intmod_sym_id
7973 == ISOCBINDING_NULL_FUNPTR))
7975 /* Set expr_type to EXPR_NULL, which will result in
7976 null_pointer_node being used below. */
7977 expr->expr_type = EXPR_NULL;
7981 /* Update the type/kind of the expression to be what the new
7982 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
7983 expr->ts.type = BT_INTEGER;
7984 expr->ts.f90_type = BT_VOID;
7985 expr->ts.kind = gfc_index_integer_kind;
7989 gfc_fix_class_refs (expr);
7991 switch (expr->expr_type)
7994 gfc_conv_expr_op (se, expr);
7998 gfc_conv_function_expr (se, expr);
8002 gfc_conv_constant (se, expr);
8006 gfc_conv_variable (se, expr);
8010 se->expr = null_pointer_node;
8013 case EXPR_SUBSTRING:
8014 gfc_conv_substring_expr (se, expr);
8017 case EXPR_STRUCTURE:
8018 gfc_conv_structure (se, expr, 0);
8022 gfc_conv_array_constructor_expr (se, expr);
8031 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8032 of an assignment. */
8034 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8036 gfc_conv_expr (se, expr);
8037 /* All numeric lvalues should have empty post chains. If not we need to
8038 figure out a way of rewriting an lvalue so that it has no post chain. */
8039 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8042 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8043 numeric expressions. Used for scalar values where inserting cleanup code
8046 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8050 gcc_assert (expr->ts.type != BT_CHARACTER);
8051 gfc_conv_expr (se, expr);
8054 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8055 gfc_add_modify (&se->pre, val, se->expr);
8057 gfc_add_block_to_block (&se->pre, &se->post);
8061 /* Helper to translate an expression and convert it to a particular type. */
8063 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8065 gfc_conv_expr_val (se, expr);
8066 se->expr = convert (type, se->expr);
8070 /* Converts an expression so that it can be passed by reference. Scalar
8074 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8080 if (ss && ss->info->expr == expr
8081 && ss->info->type == GFC_SS_REFERENCE)
8083 /* Returns a reference to the scalar evaluated outside the loop
8085 gfc_conv_expr (se, expr);
8087 if (expr->ts.type == BT_CHARACTER
8088 && expr->expr_type != EXPR_FUNCTION)
8089 gfc_conv_string_parameter (se);
8091 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8096 if (expr->ts.type == BT_CHARACTER)
8098 gfc_conv_expr (se, expr);
8099 gfc_conv_string_parameter (se);
8103 if (expr->expr_type == EXPR_VARIABLE)
8105 se->want_pointer = 1;
8106 gfc_conv_expr (se, expr);
8109 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8110 gfc_add_modify (&se->pre, var, se->expr);
8111 gfc_add_block_to_block (&se->pre, &se->post);
8114 else if (add_clobber)
8118 /* FIXME: This fails if var is passed by reference, see PR
8120 var = expr->symtree->n.sym->backend_decl;
8121 clobber = build_clobber (TREE_TYPE (var));
8122 gfc_add_modify (&se->pre, var, clobber);
8127 if (expr->expr_type == EXPR_FUNCTION
8128 && ((expr->value.function.esym
8129 && expr->value.function.esym->result->attr.pointer
8130 && !expr->value.function.esym->result->attr.dimension)
8131 || (!expr->value.function.esym && !expr->ref
8132 && expr->symtree->n.sym->attr.pointer
8133 && !expr->symtree->n.sym->attr.dimension)))
8135 se->want_pointer = 1;
8136 gfc_conv_expr (se, expr);
8137 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8138 gfc_add_modify (&se->pre, var, se->expr);
8143 gfc_conv_expr (se, expr);
8145 /* Create a temporary var to hold the value. */
8146 if (TREE_CONSTANT (se->expr))
8148 tree tmp = se->expr;
8149 STRIP_TYPE_NOPS (tmp);
8150 var = build_decl (input_location,
8151 CONST_DECL, NULL, TREE_TYPE (tmp));
8152 DECL_INITIAL (var) = tmp;
8153 TREE_STATIC (var) = 1;
8158 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8159 gfc_add_modify (&se->pre, var, se->expr);
8162 if (!expr->must_finalize)
8163 gfc_add_block_to_block (&se->pre, &se->post);
8165 /* Take the address of that value. */
8166 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8170 /* Get the _len component for an unlimited polymorphic expression. */
8173 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8176 gfc_ref *ref = expr->ref;
8178 gfc_init_se (&se, NULL);
8179 while (ref && ref->next)
8181 gfc_add_len_component (expr);
8182 gfc_conv_expr (&se, expr);
8183 gfc_add_block_to_block (block, &se.pre);
8184 gcc_assert (se.post.head == NULL_TREE);
8187 gfc_free_ref_list (ref->next);
8192 gfc_free_ref_list (expr->ref);
8199 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8200 statement-list outside of the scalarizer-loop. When code is generated, that
8201 depends on the scalarized expression, it is added to RSE.PRE.
8202 Returns le's _vptr tree and when set the len expressions in to_lenp and
8203 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8207 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8208 gfc_expr * re, gfc_se *rse,
8209 tree * to_lenp, tree * from_lenp)
8212 gfc_expr * vptr_expr;
8213 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8214 bool set_vptr = false, temp_rhs = false;
8215 stmtblock_t *pre = block;
8217 /* Create a temporary for complicated expressions. */
8218 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8219 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8221 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8223 gfc_add_modify (&rse->pre, tmp, rse->expr);
8228 /* Get the _vptr for the left-hand side expression. */
8229 gfc_init_se (&se, NULL);
8230 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8231 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8233 /* Care about _len for unlimited polymorphic entities. */
8234 if (UNLIMITED_POLY (vptr_expr)
8235 || (vptr_expr->ts.type == BT_DERIVED
8236 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8237 to_len = trans_get_upoly_len (block, vptr_expr);
8238 gfc_add_vptr_component (vptr_expr);
8242 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8243 se.want_pointer = 1;
8244 gfc_conv_expr (&se, vptr_expr);
8245 gfc_free_expr (vptr_expr);
8246 gfc_add_block_to_block (block, &se.pre);
8247 gcc_assert (se.post.head == NULL_TREE);
8249 STRIP_NOPS (lhs_vptr);
8251 /* Set the _vptr only when the left-hand side of the assignment is a
8255 /* Get the vptr from the rhs expression only, when it is variable.
8256 Functions are expected to be assigned to a temporary beforehand. */
8257 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8258 ? gfc_find_and_cut_at_last_class_ref (re)
8260 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8262 if (to_len != NULL_TREE)
8264 /* Get the _len information from the rhs. */
8265 if (UNLIMITED_POLY (vptr_expr)
8266 || (vptr_expr->ts.type == BT_DERIVED
8267 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8268 from_len = trans_get_upoly_len (block, vptr_expr);
8270 gfc_add_vptr_component (vptr_expr);
8274 if (re->expr_type == EXPR_VARIABLE
8275 && DECL_P (re->symtree->n.sym->backend_decl)
8276 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8277 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8278 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8279 re->symtree->n.sym->backend_decl))))
8282 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8283 re->symtree->n.sym->backend_decl));
8285 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8286 re->symtree->n.sym->backend_decl));
8288 else if (temp_rhs && re->ts.type == BT_CLASS)
8291 se.expr = gfc_class_vptr_get (rse->expr);
8292 if (UNLIMITED_POLY (re))
8293 from_len = gfc_class_len_get (rse->expr);
8295 else if (re->expr_type != EXPR_NULL)
8296 /* Only when rhs is non-NULL use its declared type for vptr
8298 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8300 /* When the rhs is NULL use the vtab of lhs' declared type. */
8301 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8306 gfc_init_se (&se, NULL);
8307 se.want_pointer = 1;
8308 gfc_conv_expr (&se, vptr_expr);
8309 gfc_free_expr (vptr_expr);
8310 gfc_add_block_to_block (block, &se.pre);
8311 gcc_assert (se.post.head == NULL_TREE);
8313 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8316 if (to_len != NULL_TREE)
8318 /* The _len component needs to be set. Figure how to get the
8319 value of the right-hand side. */
8320 if (from_len == NULL_TREE)
8322 if (rse->string_length != NULL_TREE)
8323 from_len = rse->string_length;
8324 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8326 from_len = gfc_get_expr_charlen (re);
8327 gfc_init_se (&se, NULL);
8328 gfc_conv_expr (&se, re->ts.u.cl->length);
8329 gfc_add_block_to_block (block, &se.pre);
8330 gcc_assert (se.post.head == NULL_TREE);
8331 from_len = gfc_evaluate_now (se.expr, block);
8334 from_len = build_zero_cst (gfc_charlen_type_node);
8336 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8341 /* Return the _len trees only, when requested. */
8345 *from_lenp = from_len;
8350 /* Assign tokens for pointer components. */
8353 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8356 symbol_attribute lhs_attr, rhs_attr;
8357 tree tmp, lhs_tok, rhs_tok;
8358 /* Flag to indicated component refs on the rhs. */
8361 lhs_attr = gfc_caf_attr (expr1);
8362 if (expr2->expr_type != EXPR_NULL)
8364 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8365 if (lhs_attr.codimension && rhs_attr.codimension)
8367 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8368 lhs_tok = build_fold_indirect_ref (lhs_tok);
8371 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8375 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8376 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8379 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8381 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8382 gfc_prepend_expr_to_block (&lse->post, tmp);
8385 else if (lhs_attr.codimension)
8387 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8388 lhs_tok = build_fold_indirect_ref (lhs_tok);
8389 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8390 lhs_tok, null_pointer_node);
8391 gfc_prepend_expr_to_block (&lse->post, tmp);
8395 /* Indentify class valued proc_pointer assignments. */
8398 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8403 while (ref && ref->next)
8406 return ref && ref->type == REF_COMPONENT
8407 && ref->u.c.component->attr.proc_pointer
8408 && expr2->expr_type == EXPR_VARIABLE
8409 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8413 /* Do everything that is needed for a CLASS function expr2. */
8416 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8417 gfc_expr *expr1, gfc_expr *expr2)
8419 tree expr1_vptr = NULL_TREE;
8422 gfc_conv_function_expr (rse, expr2);
8423 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8425 if (expr1->ts.type != BT_CLASS)
8426 rse->expr = gfc_class_data_get (rse->expr);
8429 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8432 gfc_add_block_to_block (block, &rse->pre);
8433 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8434 gfc_add_modify (&lse->pre, tmp, rse->expr);
8436 gfc_add_modify (&lse->pre, expr1_vptr,
8437 fold_convert (TREE_TYPE (expr1_vptr),
8438 gfc_class_vptr_get (tmp)));
8439 rse->expr = gfc_class_data_get (tmp);
8447 gfc_trans_pointer_assign (gfc_code * code)
8449 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8453 /* Generate code for a pointer assignment. */
8456 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8463 tree expr1_vptr = NULL_TREE;
8464 bool scalar, non_proc_pointer_assign;
8467 gfc_start_block (&block);
8469 gfc_init_se (&lse, NULL);
8471 /* Usually testing whether this is not a proc pointer assignment. */
8472 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8474 /* Check whether the expression is a scalar or not; we cannot use
8475 expr1->rank as it can be nonzero for proc pointers. */
8476 ss = gfc_walk_expr (expr1);
8477 scalar = ss == gfc_ss_terminator;
8479 gfc_free_ss_chain (ss);
8481 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8482 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8484 gfc_add_data_component (expr2);
8485 /* The following is required as gfc_add_data_component doesn't
8486 update ts.type if there is a tailing REF_ARRAY. */
8487 expr2->ts.type = BT_DERIVED;
8492 /* Scalar pointers. */
8493 lse.want_pointer = 1;
8494 gfc_conv_expr (&lse, expr1);
8495 gfc_init_se (&rse, NULL);
8496 rse.want_pointer = 1;
8497 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8498 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8500 gfc_conv_expr (&rse, expr2);
8502 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8504 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8506 lse.expr = gfc_class_data_get (lse.expr);
8509 if (expr1->symtree->n.sym->attr.proc_pointer
8510 && expr1->symtree->n.sym->attr.dummy)
8511 lse.expr = build_fold_indirect_ref_loc (input_location,
8514 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8515 && expr2->symtree->n.sym->attr.dummy)
8516 rse.expr = build_fold_indirect_ref_loc (input_location,
8519 gfc_add_block_to_block (&block, &lse.pre);
8520 gfc_add_block_to_block (&block, &rse.pre);
8522 /* Check character lengths if character expression. The test is only
8523 really added if -fbounds-check is enabled. Exclude deferred
8524 character length lefthand sides. */
8525 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8526 && !expr1->ts.deferred
8527 && !expr1->symtree->n.sym->attr.proc_pointer
8528 && !gfc_is_proc_ptr_comp (expr1))
8530 gcc_assert (expr2->ts.type == BT_CHARACTER);
8531 gcc_assert (lse.string_length && rse.string_length);
8532 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8533 lse.string_length, rse.string_length,
8537 /* The assignment to an deferred character length sets the string
8538 length to that of the rhs. */
8539 if (expr1->ts.deferred)
8541 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8542 gfc_add_modify (&block, lse.string_length,
8543 fold_convert (TREE_TYPE (lse.string_length),
8544 rse.string_length));
8545 else if (lse.string_length != NULL)
8546 gfc_add_modify (&block, lse.string_length,
8547 build_zero_cst (TREE_TYPE (lse.string_length)));
8550 gfc_add_modify (&block, lse.expr,
8551 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8553 /* Also set the tokens for pointer components in derived typed
8555 if (flag_coarray == GFC_FCOARRAY_LIB)
8556 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8558 gfc_add_block_to_block (&block, &rse.post);
8559 gfc_add_block_to_block (&block, &lse.post);
8566 tree strlen_rhs = NULL_TREE;
8568 /* Array pointer. Find the last reference on the LHS and if it is an
8569 array section ref, we're dealing with bounds remapping. In this case,
8570 set it to AR_FULL so that gfc_conv_expr_descriptor does
8571 not see it and process the bounds remapping afterwards explicitly. */
8572 for (remap = expr1->ref; remap; remap = remap->next)
8573 if (!remap->next && remap->type == REF_ARRAY
8574 && remap->u.ar.type == AR_SECTION)
8576 rank_remap = (remap && remap->u.ar.end[0]);
8578 gfc_init_se (&lse, NULL);
8580 lse.descriptor_only = 1;
8581 gfc_conv_expr_descriptor (&lse, expr1);
8582 strlen_lhs = lse.string_length;
8585 if (expr2->expr_type == EXPR_NULL)
8587 /* Just set the data pointer to null. */
8588 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8590 else if (rank_remap)
8592 /* If we are rank-remapping, just get the RHS's descriptor and
8593 process this later on. */
8594 gfc_init_se (&rse, NULL);
8595 rse.direct_byref = 1;
8596 rse.byref_noassign = 1;
8598 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8599 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8601 else if (expr2->expr_type == EXPR_FUNCTION)
8603 tree bound[GFC_MAX_DIMENSIONS];
8606 for (i = 0; i < expr2->rank; i++)
8607 bound[i] = NULL_TREE;
8608 tmp = gfc_typenode_for_spec (&expr2->ts);
8609 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8611 GFC_ARRAY_POINTER_CONT, false);
8612 tmp = gfc_create_var (tmp, "ptrtemp");
8613 rse.descriptor_only = 0;
8615 rse.direct_byref = 1;
8616 gfc_conv_expr_descriptor (&rse, expr2);
8617 strlen_rhs = rse.string_length;
8622 gfc_conv_expr_descriptor (&rse, expr2);
8623 strlen_rhs = rse.string_length;
8624 if (expr1->ts.type == BT_CLASS)
8625 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8630 else if (expr2->expr_type == EXPR_VARIABLE)
8632 /* Assign directly to the LHS's descriptor. */
8633 lse.descriptor_only = 0;
8634 lse.direct_byref = 1;
8635 gfc_conv_expr_descriptor (&lse, expr2);
8636 strlen_rhs = lse.string_length;
8638 if (expr1->ts.type == BT_CLASS)
8640 rse.expr = NULL_TREE;
8641 rse.string_length = NULL_TREE;
8642 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8648 /* If the target is not a whole array, use the target array
8649 reference for remap. */
8650 for (remap = expr2->ref; remap; remap = remap->next)
8651 if (remap->type == REF_ARRAY
8652 && remap->u.ar.type == AR_FULL
8657 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8659 gfc_init_se (&rse, NULL);
8660 rse.want_pointer = 1;
8661 gfc_conv_function_expr (&rse, expr2);
8662 if (expr1->ts.type != BT_CLASS)
8664 rse.expr = gfc_class_data_get (rse.expr);
8665 gfc_add_modify (&lse.pre, desc, rse.expr);
8666 /* Set the lhs span. */
8667 tmp = TREE_TYPE (rse.expr);
8668 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8669 tmp = fold_convert (gfc_array_index_type, tmp);
8670 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
8674 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8677 gfc_add_block_to_block (&block, &rse.pre);
8678 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8679 gfc_add_modify (&lse.pre, tmp, rse.expr);
8681 gfc_add_modify (&lse.pre, expr1_vptr,
8682 fold_convert (TREE_TYPE (expr1_vptr),
8683 gfc_class_vptr_get (tmp)));
8684 rse.expr = gfc_class_data_get (tmp);
8685 gfc_add_modify (&lse.pre, desc, rse.expr);
8690 /* Assign to a temporary descriptor and then copy that
8691 temporary to the pointer. */
8692 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
8693 lse.descriptor_only = 0;
8695 lse.direct_byref = 1;
8696 gfc_conv_expr_descriptor (&lse, expr2);
8697 strlen_rhs = lse.string_length;
8698 gfc_add_modify (&lse.pre, desc, tmp);
8701 gfc_add_block_to_block (&block, &lse.pre);
8703 gfc_add_block_to_block (&block, &rse.pre);
8705 /* If we do bounds remapping, update LHS descriptor accordingly. */
8709 gcc_assert (remap->u.ar.dimen == expr1->rank);
8713 /* Do rank remapping. We already have the RHS's descriptor
8714 converted in rse and now have to build the correct LHS
8715 descriptor for it. */
8717 tree dtype, data, span;
8719 tree lbound, ubound;
8722 dtype = gfc_conv_descriptor_dtype (desc);
8723 tmp = gfc_get_dtype (TREE_TYPE (desc));
8724 gfc_add_modify (&block, dtype, tmp);
8726 /* Copy data pointer. */
8727 data = gfc_conv_descriptor_data_get (rse.expr);
8728 gfc_conv_descriptor_data_set (&block, desc, data);
8730 /* Copy the span. */
8731 if (TREE_CODE (rse.expr) == VAR_DECL
8732 && GFC_DECL_PTR_ARRAY_P (rse.expr))
8733 span = gfc_conv_descriptor_span_get (rse.expr);
8736 tmp = TREE_TYPE (rse.expr);
8737 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8738 span = fold_convert (gfc_array_index_type, tmp);
8740 gfc_conv_descriptor_span_set (&block, desc, span);
8742 /* Copy offset but adjust it such that it would correspond
8743 to a lbound of zero. */
8744 offs = gfc_conv_descriptor_offset_get (rse.expr);
8745 for (dim = 0; dim < expr2->rank; ++dim)
8747 stride = gfc_conv_descriptor_stride_get (rse.expr,
8749 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
8751 tmp = fold_build2_loc (input_location, MULT_EXPR,
8752 gfc_array_index_type, stride, lbound);
8753 offs = fold_build2_loc (input_location, PLUS_EXPR,
8754 gfc_array_index_type, offs, tmp);
8756 gfc_conv_descriptor_offset_set (&block, desc, offs);
8758 /* Set the bounds as declared for the LHS and calculate strides as
8759 well as another offset update accordingly. */
8760 stride = gfc_conv_descriptor_stride_get (rse.expr,
8762 for (dim = 0; dim < expr1->rank; ++dim)
8767 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
8769 /* Convert declared bounds. */
8770 gfc_init_se (&lower_se, NULL);
8771 gfc_init_se (&upper_se, NULL);
8772 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
8773 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
8775 gfc_add_block_to_block (&block, &lower_se.pre);
8776 gfc_add_block_to_block (&block, &upper_se.pre);
8778 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
8779 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
8781 lbound = gfc_evaluate_now (lbound, &block);
8782 ubound = gfc_evaluate_now (ubound, &block);
8784 gfc_add_block_to_block (&block, &lower_se.post);
8785 gfc_add_block_to_block (&block, &upper_se.post);
8787 /* Set bounds in descriptor. */
8788 gfc_conv_descriptor_lbound_set (&block, desc,
8789 gfc_rank_cst[dim], lbound);
8790 gfc_conv_descriptor_ubound_set (&block, desc,
8791 gfc_rank_cst[dim], ubound);
8794 stride = gfc_evaluate_now (stride, &block);
8795 gfc_conv_descriptor_stride_set (&block, desc,
8796 gfc_rank_cst[dim], stride);
8798 /* Update offset. */
8799 offs = gfc_conv_descriptor_offset_get (desc);
8800 tmp = fold_build2_loc (input_location, MULT_EXPR,
8801 gfc_array_index_type, lbound, stride);
8802 offs = fold_build2_loc (input_location, MINUS_EXPR,
8803 gfc_array_index_type, offs, tmp);
8804 offs = gfc_evaluate_now (offs, &block);
8805 gfc_conv_descriptor_offset_set (&block, desc, offs);
8807 /* Update stride. */
8808 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
8809 stride = fold_build2_loc (input_location, MULT_EXPR,
8810 gfc_array_index_type, stride, tmp);
8815 /* Bounds remapping. Just shift the lower bounds. */
8817 gcc_assert (expr1->rank == expr2->rank);
8819 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
8823 gcc_assert (!remap->u.ar.end[dim]);
8824 gfc_init_se (&lbound_se, NULL);
8825 if (remap->u.ar.start[dim])
8827 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
8828 gfc_add_block_to_block (&block, &lbound_se.pre);
8831 /* This remap arises from a target that is not a whole
8832 array. The start expressions will be NULL but we need
8833 the lbounds to be one. */
8834 lbound_se.expr = gfc_index_one_node;
8835 gfc_conv_shift_descriptor_lbound (&block, desc,
8836 dim, lbound_se.expr);
8837 gfc_add_block_to_block (&block, &lbound_se.post);
8842 /* Check string lengths if applicable. The check is only really added
8843 to the output code if -fbounds-check is enabled. */
8844 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
8846 gcc_assert (expr2->ts.type == BT_CHARACTER);
8847 gcc_assert (strlen_lhs && strlen_rhs);
8848 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8849 strlen_lhs, strlen_rhs, &block);
8852 /* If rank remapping was done, check with -fcheck=bounds that
8853 the target is at least as large as the pointer. */
8854 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
8860 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
8861 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
8863 lsize = gfc_evaluate_now (lsize, &block);
8864 rsize = gfc_evaluate_now (rsize, &block);
8865 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
8868 msg = _("Target of rank remapping is too small (%ld < %ld)");
8869 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
8873 if (expr1->ts.type == BT_CHARACTER
8874 && expr1->symtree->n.sym->ts.deferred
8875 && expr1->symtree->n.sym->ts.u.cl->backend_decl
8876 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
8878 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
8879 if (expr2->expr_type != EXPR_NULL)
8880 gfc_add_modify (&block, tmp,
8881 fold_convert (TREE_TYPE (tmp), strlen_rhs));
8883 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
8886 gfc_add_block_to_block (&block, &lse.post);
8888 gfc_add_block_to_block (&block, &rse.post);
8891 return gfc_finish_block (&block);
8895 /* Makes sure se is suitable for passing as a function string parameter. */
8896 /* TODO: Need to check all callers of this function. It may be abused. */
8899 gfc_conv_string_parameter (gfc_se * se)
8903 if (TREE_CODE (se->expr) == STRING_CST)
8905 type = TREE_TYPE (TREE_TYPE (se->expr));
8906 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8910 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
8912 if (TREE_CODE (se->expr) != INDIRECT_REF)
8914 type = TREE_TYPE (se->expr);
8915 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8919 type = gfc_get_character_type_len (gfc_default_character_kind,
8921 type = build_pointer_type (type);
8922 se->expr = gfc_build_addr_expr (type, se->expr);
8926 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
8930 /* Generate code for assignment of scalar variables. Includes character
8931 strings and derived types with allocatable components.
8932 If you know that the LHS has no allocations, set dealloc to false.
8934 DEEP_COPY has no effect if the typespec TS is not a derived type with
8935 allocatable components. Otherwise, if it is set, an explicit copy of each
8936 allocatable component is made. This is necessary as a simple copy of the
8937 whole object would copy array descriptors as is, so that the lhs's
8938 allocatable components would point to the rhs's after the assignment.
8939 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8940 necessary if the rhs is a non-pointer function, as the allocatable components
8941 are not accessible by other means than the function's result after the
8942 function has returned. It is even more subtle when temporaries are involved,
8943 as the two following examples show:
8944 1. When we evaluate an array constructor, a temporary is created. Thus
8945 there is theoretically no alias possible. However, no deep copy is
8946 made for this temporary, so that if the constructor is made of one or
8947 more variable with allocatable components, those components still point
8948 to the variable's: DEEP_COPY should be set for the assignment from the
8949 temporary to the lhs in that case.
8950 2. When assigning a scalar to an array, we evaluate the scalar value out
8951 of the loop, store it into a temporary variable, and assign from that.
8952 In that case, deep copying when assigning to the temporary would be a
8953 waste of resources; however deep copies should happen when assigning from
8954 the temporary to each array element: again DEEP_COPY should be set for
8955 the assignment from the temporary to the lhs. */
8958 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
8959 bool deep_copy, bool dealloc, bool in_coarray)
8965 gfc_init_block (&block);
8967 if (ts.type == BT_CHARACTER)
8972 if (lse->string_length != NULL_TREE)
8974 gfc_conv_string_parameter (lse);
8975 gfc_add_block_to_block (&block, &lse->pre);
8976 llen = lse->string_length;
8979 if (rse->string_length != NULL_TREE)
8981 gfc_conv_string_parameter (rse);
8982 gfc_add_block_to_block (&block, &rse->pre);
8983 rlen = rse->string_length;
8986 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
8987 rse->expr, ts.kind);
8989 else if (gfc_bt_struct (ts.type)
8990 && (ts.u.derived->attr.alloc_comp
8991 || (deep_copy && ts.u.derived->attr.pdt_type)))
8993 tree tmp_var = NULL_TREE;
8996 /* Are the rhs and the lhs the same? */
8999 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9000 gfc_build_addr_expr (NULL_TREE, lse->expr),
9001 gfc_build_addr_expr (NULL_TREE, rse->expr));
9002 cond = gfc_evaluate_now (cond, &lse->pre);
9005 /* Deallocate the lhs allocated components as long as it is not
9006 the same as the rhs. This must be done following the assignment
9007 to prevent deallocating data that could be used in the rhs
9011 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9012 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9014 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9016 gfc_add_expr_to_block (&lse->post, tmp);
9019 gfc_add_block_to_block (&block, &rse->pre);
9020 gfc_add_block_to_block (&block, &lse->pre);
9022 gfc_add_modify (&block, lse->expr,
9023 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9025 /* Restore pointer address of coarray components. */
9026 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9028 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9029 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9031 gfc_add_expr_to_block (&block, tmp);
9034 /* Do a deep copy if the rhs is a variable, if it is not the
9038 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9039 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9040 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9042 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9044 gfc_add_expr_to_block (&block, tmp);
9047 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9049 gfc_add_block_to_block (&block, &lse->pre);
9050 gfc_add_block_to_block (&block, &rse->pre);
9051 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9052 TREE_TYPE (lse->expr), rse->expr);
9053 gfc_add_modify (&block, lse->expr, tmp);
9057 gfc_add_block_to_block (&block, &lse->pre);
9058 gfc_add_block_to_block (&block, &rse->pre);
9060 gfc_add_modify (&block, lse->expr,
9061 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9064 gfc_add_block_to_block (&block, &lse->post);
9065 gfc_add_block_to_block (&block, &rse->post);
9067 return gfc_finish_block (&block);
9071 /* There are quite a lot of restrictions on the optimisation in using an
9072 array function assign without a temporary. */
9075 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9078 bool seen_array_ref;
9080 gfc_symbol *sym = expr1->symtree->n.sym;
9082 /* Play it safe with class functions assigned to a derived type. */
9083 if (gfc_is_class_array_function (expr2)
9084 && expr1->ts.type == BT_DERIVED)
9087 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9088 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9091 /* Elemental functions are scalarized so that they don't need a
9092 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9093 they would need special treatment in gfc_trans_arrayfunc_assign. */
9094 if (expr2->value.function.esym != NULL
9095 && expr2->value.function.esym->attr.elemental)
9098 /* Need a temporary if rhs is not FULL or a contiguous section. */
9099 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9102 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9103 if (gfc_ref_needs_temporary_p (expr1->ref))
9106 /* Functions returning pointers or allocatables need temporaries. */
9107 c = expr2->value.function.esym
9108 ? (expr2->value.function.esym->attr.pointer
9109 || expr2->value.function.esym->attr.allocatable)
9110 : (expr2->symtree->n.sym->attr.pointer
9111 || expr2->symtree->n.sym->attr.allocatable);
9115 /* Character array functions need temporaries unless the
9116 character lengths are the same. */
9117 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9119 if (expr1->ts.u.cl->length == NULL
9120 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9123 if (expr2->ts.u.cl->length == NULL
9124 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9127 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9128 expr2->ts.u.cl->length->value.integer) != 0)
9132 /* Check that no LHS component references appear during an array
9133 reference. This is needed because we do not have the means to
9134 span any arbitrary stride with an array descriptor. This check
9135 is not needed for the rhs because the function result has to be
9137 seen_array_ref = false;
9138 for (ref = expr1->ref; ref; ref = ref->next)
9140 if (ref->type == REF_ARRAY)
9141 seen_array_ref= true;
9142 else if (ref->type == REF_COMPONENT && seen_array_ref)
9146 /* Check for a dependency. */
9147 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9148 expr2->value.function.esym,
9149 expr2->value.function.actual,
9153 /* If we have reached here with an intrinsic function, we do not
9154 need a temporary except in the particular case that reallocation
9155 on assignment is active and the lhs is allocatable and a target. */
9156 if (expr2->value.function.isym)
9157 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9159 /* If the LHS is a dummy, we need a temporary if it is not
9161 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9164 /* If the lhs has been host_associated, is in common, a pointer or is
9165 a target and the function is not using a RESULT variable, aliasing
9166 can occur and a temporary is needed. */
9167 if ((sym->attr.host_assoc
9168 || sym->attr.in_common
9169 || sym->attr.pointer
9170 || sym->attr.cray_pointee
9171 || sym->attr.target)
9172 && expr2->symtree != NULL
9173 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9176 /* A PURE function can unconditionally be called without a temporary. */
9177 if (expr2->value.function.esym != NULL
9178 && expr2->value.function.esym->attr.pure)
9181 /* Implicit_pure functions are those which could legally be declared
9183 if (expr2->value.function.esym != NULL
9184 && expr2->value.function.esym->attr.implicit_pure)
9187 if (!sym->attr.use_assoc
9188 && !sym->attr.in_common
9189 && !sym->attr.pointer
9190 && !sym->attr.target
9191 && !sym->attr.cray_pointee
9192 && expr2->value.function.esym)
9194 /* A temporary is not needed if the function is not contained and
9195 the variable is local or host associated and not a pointer or
9197 if (!expr2->value.function.esym->attr.contained)
9200 /* A temporary is not needed if the lhs has never been host
9201 associated and the procedure is contained. */
9202 else if (!sym->attr.host_assoc)
9205 /* A temporary is not needed if the variable is local and not
9206 a pointer, a target or a result. */
9208 && expr2->value.function.esym->ns == sym->ns->parent)
9212 /* Default to temporary use. */
9217 /* Provide the loop info so that the lhs descriptor can be built for
9218 reallocatable assignments from extrinsic function calls. */
9221 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9224 /* Signal that the function call should not be made by
9225 gfc_conv_loop_setup. */
9226 se->ss->is_alloc_lhs = 1;
9227 gfc_init_loopinfo (loop);
9228 gfc_add_ss_to_loop (loop, *ss);
9229 gfc_add_ss_to_loop (loop, se->ss);
9230 gfc_conv_ss_startstride (loop);
9231 gfc_conv_loop_setup (loop, where);
9232 gfc_copy_loopinfo_to_se (se, loop);
9233 gfc_add_block_to_block (&se->pre, &loop->pre);
9234 gfc_add_block_to_block (&se->pre, &loop->post);
9235 se->ss->is_alloc_lhs = 0;
9239 /* For assignment to a reallocatable lhs from intrinsic functions,
9240 replace the se.expr (ie. the result) with a temporary descriptor.
9241 Null the data field so that the library allocates space for the
9242 result. Free the data of the original descriptor after the function,
9243 in case it appears in an argument expression and transfer the
9244 result to the original descriptor. */
9247 fcncall_realloc_result (gfc_se *se, int rank)
9256 /* Use the allocation done by the library. Substitute the lhs
9257 descriptor with a copy, whose data field is nulled.*/
9258 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9259 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9260 desc = build_fold_indirect_ref_loc (input_location, desc);
9262 /* Unallocated, the descriptor does not have a dtype. */
9263 tmp = gfc_conv_descriptor_dtype (desc);
9264 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9266 res_desc = gfc_evaluate_now (desc, &se->pre);
9267 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9268 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9270 /* Free the lhs after the function call and copy the result data to
9271 the lhs descriptor. */
9272 tmp = gfc_conv_descriptor_data_get (desc);
9273 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9274 logical_type_node, tmp,
9275 build_int_cst (TREE_TYPE (tmp), 0));
9276 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9277 tmp = gfc_call_free (tmp);
9278 gfc_add_expr_to_block (&se->post, tmp);
9280 tmp = gfc_conv_descriptor_data_get (res_desc);
9281 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9283 /* Check that the shapes are the same between lhs and expression. */
9284 for (n = 0 ; n < rank; n++)
9287 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9288 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9289 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9290 gfc_array_index_type, tmp, tmp1);
9291 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9292 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9293 gfc_array_index_type, tmp, tmp1);
9294 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9295 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9296 gfc_array_index_type, tmp, tmp1);
9297 tmp = fold_build2_loc (input_location, NE_EXPR,
9298 logical_type_node, tmp,
9299 gfc_index_zero_node);
9300 tmp = gfc_evaluate_now (tmp, &se->post);
9301 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9302 logical_type_node, tmp,
9306 /* 'zero_cond' being true is equal to lhs not being allocated or the
9307 shapes being different. */
9308 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9310 /* Now reset the bounds returned from the function call to bounds based
9311 on the lhs lbounds, except where the lhs is not allocated or the shapes
9312 of 'variable and 'expr' are different. Set the offset accordingly. */
9313 offset = gfc_index_zero_node;
9314 for (n = 0 ; n < rank; n++)
9318 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9319 lbound = fold_build3_loc (input_location, COND_EXPR,
9320 gfc_array_index_type, zero_cond,
9321 gfc_index_one_node, lbound);
9322 lbound = gfc_evaluate_now (lbound, &se->post);
9324 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9325 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9326 gfc_array_index_type, tmp, lbound);
9327 gfc_conv_descriptor_lbound_set (&se->post, desc,
9328 gfc_rank_cst[n], lbound);
9329 gfc_conv_descriptor_ubound_set (&se->post, desc,
9330 gfc_rank_cst[n], tmp);
9332 /* Set stride and accumulate the offset. */
9333 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9334 gfc_conv_descriptor_stride_set (&se->post, desc,
9335 gfc_rank_cst[n], tmp);
9336 tmp = fold_build2_loc (input_location, MULT_EXPR,
9337 gfc_array_index_type, lbound, tmp);
9338 offset = fold_build2_loc (input_location, MINUS_EXPR,
9339 gfc_array_index_type, offset, tmp);
9340 offset = gfc_evaluate_now (offset, &se->post);
9343 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9348 /* Try to translate array(:) = func (...), where func is a transformational
9349 array function, without using a temporary. Returns NULL if this isn't the
9353 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9357 gfc_component *comp = NULL;
9360 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9363 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9365 comp = gfc_get_proc_ptr_comp (expr2);
9367 if (!(expr2->value.function.isym
9368 || (comp && comp->attr.dimension)
9369 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9370 && expr2->value.function.esym->result->attr.dimension)))
9373 gfc_init_se (&se, NULL);
9374 gfc_start_block (&se.pre);
9375 se.want_pointer = 1;
9377 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9379 if (expr1->ts.type == BT_DERIVED
9380 && expr1->ts.u.derived->attr.alloc_comp)
9383 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9385 gfc_add_expr_to_block (&se.pre, tmp);
9388 se.direct_byref = 1;
9389 se.ss = gfc_walk_expr (expr2);
9390 gcc_assert (se.ss != gfc_ss_terminator);
9392 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9393 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9394 Clearly, this cannot be done for an allocatable function result, since
9395 the shape of the result is unknown and, in any case, the function must
9396 correctly take care of the reallocation internally. For intrinsic
9397 calls, the array data is freed and the library takes care of allocation.
9398 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9400 if (flag_realloc_lhs
9401 && gfc_is_reallocatable_lhs (expr1)
9402 && !gfc_expr_attr (expr1).codimension
9403 && !gfc_is_coindexed (expr1)
9404 && !(expr2->value.function.esym
9405 && expr2->value.function.esym->result->attr.allocatable))
9407 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9409 if (!expr2->value.function.isym)
9411 ss = gfc_walk_expr (expr1);
9412 gcc_assert (ss != gfc_ss_terminator);
9414 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9415 ss->is_alloc_lhs = 1;
9418 fcncall_realloc_result (&se, expr1->rank);
9421 gfc_conv_function_expr (&se, expr2);
9422 gfc_add_block_to_block (&se.pre, &se.post);
9425 gfc_cleanup_loop (&loop);
9427 gfc_free_ss_chain (se.ss);
9429 return gfc_finish_block (&se.pre);
9433 /* Try to efficiently translate array(:) = 0. Return NULL if this
9437 gfc_trans_zero_assign (gfc_expr * expr)
9439 tree dest, len, type;
9443 sym = expr->symtree->n.sym;
9444 dest = gfc_get_symbol_decl (sym);
9446 type = TREE_TYPE (dest);
9447 if (POINTER_TYPE_P (type))
9448 type = TREE_TYPE (type);
9449 if (!GFC_ARRAY_TYPE_P (type))
9452 /* Determine the length of the array. */
9453 len = GFC_TYPE_ARRAY_SIZE (type);
9454 if (!len || TREE_CODE (len) != INTEGER_CST)
9457 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9458 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9459 fold_convert (gfc_array_index_type, tmp));
9461 /* If we are zeroing a local array avoid taking its address by emitting
9463 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9464 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9465 dest, build_constructor (TREE_TYPE (dest),
9468 /* Convert arguments to the correct types. */
9469 dest = fold_convert (pvoid_type_node, dest);
9470 len = fold_convert (size_type_node, len);
9472 /* Construct call to __builtin_memset. */
9473 tmp = build_call_expr_loc (input_location,
9474 builtin_decl_explicit (BUILT_IN_MEMSET),
9475 3, dest, integer_zero_node, len);
9476 return fold_convert (void_type_node, tmp);
9480 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9481 that constructs the call to __builtin_memcpy. */
9484 gfc_build_memcpy_call (tree dst, tree src, tree len)
9488 /* Convert arguments to the correct types. */
9489 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9490 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9492 dst = fold_convert (pvoid_type_node, dst);
9494 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9495 src = gfc_build_addr_expr (pvoid_type_node, src);
9497 src = fold_convert (pvoid_type_node, src);
9499 len = fold_convert (size_type_node, len);
9501 /* Construct call to __builtin_memcpy. */
9502 tmp = build_call_expr_loc (input_location,
9503 builtin_decl_explicit (BUILT_IN_MEMCPY),
9505 return fold_convert (void_type_node, tmp);
9509 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9510 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9511 source/rhs, both are gfc_full_array_ref_p which have been checked for
9515 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9517 tree dst, dlen, dtype;
9518 tree src, slen, stype;
9521 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9522 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9524 dtype = TREE_TYPE (dst);
9525 if (POINTER_TYPE_P (dtype))
9526 dtype = TREE_TYPE (dtype);
9527 stype = TREE_TYPE (src);
9528 if (POINTER_TYPE_P (stype))
9529 stype = TREE_TYPE (stype);
9531 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9534 /* Determine the lengths of the arrays. */
9535 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9536 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9538 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9539 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9540 dlen, fold_convert (gfc_array_index_type, tmp));
9542 slen = GFC_TYPE_ARRAY_SIZE (stype);
9543 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9545 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9546 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9547 slen, fold_convert (gfc_array_index_type, tmp));
9549 /* Sanity check that they are the same. This should always be
9550 the case, as we should already have checked for conformance. */
9551 if (!tree_int_cst_equal (slen, dlen))
9554 return gfc_build_memcpy_call (dst, src, dlen);
9558 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9559 this can't be done. EXPR1 is the destination/lhs for which
9560 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9563 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9565 unsigned HOST_WIDE_INT nelem;
9571 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9575 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9576 dtype = TREE_TYPE (dst);
9577 if (POINTER_TYPE_P (dtype))
9578 dtype = TREE_TYPE (dtype);
9579 if (!GFC_ARRAY_TYPE_P (dtype))
9582 /* Determine the lengths of the array. */
9583 len = GFC_TYPE_ARRAY_SIZE (dtype);
9584 if (!len || TREE_CODE (len) != INTEGER_CST)
9587 /* Confirm that the constructor is the same size. */
9588 if (compare_tree_int (len, nelem) != 0)
9591 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9592 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9593 fold_convert (gfc_array_index_type, tmp));
9595 stype = gfc_typenode_for_spec (&expr2->ts);
9596 src = gfc_build_constant_array_constructor (expr2, stype);
9598 stype = TREE_TYPE (src);
9599 if (POINTER_TYPE_P (stype))
9600 stype = TREE_TYPE (stype);
9602 return gfc_build_memcpy_call (dst, src, len);
9606 /* Tells whether the expression is to be treated as a variable reference. */
9609 gfc_expr_is_variable (gfc_expr *expr)
9612 gfc_component *comp;
9613 gfc_symbol *func_ifc;
9615 if (expr->expr_type == EXPR_VARIABLE)
9618 arg = gfc_get_noncopying_intrinsic_argument (expr);
9621 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9622 return gfc_expr_is_variable (arg);
9625 /* A data-pointer-returning function should be considered as a variable
9627 if (expr->expr_type == EXPR_FUNCTION
9628 && expr->ref == NULL)
9630 if (expr->value.function.isym != NULL)
9633 if (expr->value.function.esym != NULL)
9635 func_ifc = expr->value.function.esym;
9640 gcc_assert (expr->symtree);
9641 func_ifc = expr->symtree->n.sym;
9648 comp = gfc_get_proc_ptr_comp (expr);
9649 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
9652 func_ifc = comp->ts.interface;
9656 if (expr->expr_type == EXPR_COMPCALL)
9658 gcc_assert (!expr->value.compcall.tbp->is_generic);
9659 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
9666 gcc_assert (func_ifc->attr.function
9667 && func_ifc->result != NULL);
9668 return func_ifc->result->attr.pointer;
9672 /* Is the lhs OK for automatic reallocation? */
9675 is_scalar_reallocatable_lhs (gfc_expr *expr)
9679 /* An allocatable variable with no reference. */
9680 if (expr->symtree->n.sym->attr.allocatable
9684 /* All that can be left are allocatable components. However, we do
9685 not check for allocatable components here because the expression
9686 could be an allocatable component of a pointer component. */
9687 if (expr->symtree->n.sym->ts.type != BT_DERIVED
9688 && expr->symtree->n.sym->ts.type != BT_CLASS)
9691 /* Find an allocatable component ref last. */
9692 for (ref = expr->ref; ref; ref = ref->next)
9693 if (ref->type == REF_COMPONENT
9695 && ref->u.c.component->attr.allocatable)
9702 /* Allocate or reallocate scalar lhs, as necessary. */
9705 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
9720 if (!expr1 || expr1->rank)
9723 if (!expr2 || expr2->rank)
9726 for (ref = expr1->ref; ref; ref = ref->next)
9727 if (ref->type == REF_SUBSTRING)
9730 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9732 /* Since this is a scalar lhs, we can afford to do this. That is,
9733 there is no risk of side effects being repeated. */
9734 gfc_init_se (&lse, NULL);
9735 lse.want_pointer = 1;
9736 gfc_conv_expr (&lse, expr1);
9738 jump_label1 = gfc_build_label_decl (NULL_TREE);
9739 jump_label2 = gfc_build_label_decl (NULL_TREE);
9741 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9742 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
9743 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9745 tmp = build3_v (COND_EXPR, cond,
9746 build1_v (GOTO_EXPR, jump_label1),
9747 build_empty_stmt (input_location));
9748 gfc_add_expr_to_block (block, tmp);
9750 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9752 /* Use the rhs string length and the lhs element size. */
9753 size = string_length;
9754 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
9755 tmp = TYPE_SIZE_UNIT (tmp);
9756 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9757 TREE_TYPE (tmp), tmp,
9758 fold_convert (TREE_TYPE (tmp), size));
9762 /* Otherwise use the length in bytes of the rhs. */
9763 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
9764 size_in_bytes = size;
9767 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9768 size_in_bytes, size_one_node);
9770 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
9772 tree caf_decl, token;
9774 symbol_attribute attr;
9776 gfc_clear_attr (&attr);
9777 gfc_init_se (&caf_se, NULL);
9779 caf_decl = gfc_get_tree_for_caf_expr (expr1);
9780 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
9782 gfc_add_block_to_block (block, &caf_se.pre);
9783 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
9784 gfc_build_addr_expr (NULL_TREE, token),
9785 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
9788 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
9790 tmp = build_call_expr_loc (input_location,
9791 builtin_decl_explicit (BUILT_IN_CALLOC),
9792 2, build_one_cst (size_type_node),
9794 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9795 gfc_add_modify (block, lse.expr, tmp);
9799 tmp = build_call_expr_loc (input_location,
9800 builtin_decl_explicit (BUILT_IN_MALLOC),
9802 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9803 gfc_add_modify (block, lse.expr, tmp);
9806 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9808 /* Deferred characters need checking for lhs and rhs string
9809 length. Other deferred parameter variables will have to
9811 tmp = build1_v (GOTO_EXPR, jump_label2);
9812 gfc_add_expr_to_block (block, tmp);
9814 tmp = build1_v (LABEL_EXPR, jump_label1);
9815 gfc_add_expr_to_block (block, tmp);
9817 /* For a deferred length character, reallocate if lengths of lhs and
9818 rhs are different. */
9819 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9821 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9823 fold_convert (TREE_TYPE (lse.string_length),
9825 /* Jump past the realloc if the lengths are the same. */
9826 tmp = build3_v (COND_EXPR, cond,
9827 build1_v (GOTO_EXPR, jump_label2),
9828 build_empty_stmt (input_location));
9829 gfc_add_expr_to_block (block, tmp);
9830 tmp = build_call_expr_loc (input_location,
9831 builtin_decl_explicit (BUILT_IN_REALLOC),
9832 2, fold_convert (pvoid_type_node, lse.expr),
9834 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9835 gfc_add_modify (block, lse.expr, tmp);
9836 tmp = build1_v (LABEL_EXPR, jump_label2);
9837 gfc_add_expr_to_block (block, tmp);
9839 /* Update the lhs character length. */
9840 size = string_length;
9841 gfc_add_modify (block, lse.string_length,
9842 fold_convert (TREE_TYPE (lse.string_length), size));
9846 /* Check for assignments of the type
9850 to make sure we do not check for reallocation unneccessarily. */
9854 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
9856 gfc_actual_arglist *a;
9859 switch (expr2->expr_type)
9862 return gfc_dep_compare_expr (expr1, expr2) == 0;
9865 if (expr2->value.function.esym
9866 && expr2->value.function.esym->attr.elemental)
9868 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9871 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9876 else if (expr2->value.function.isym
9877 && expr2->value.function.isym->elemental)
9879 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9882 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9891 switch (expr2->value.op.op)
9894 case INTRINSIC_UPLUS:
9895 case INTRINSIC_UMINUS:
9896 case INTRINSIC_PARENTHESES:
9897 return is_runtime_conformable (expr1, expr2->value.op.op1);
9899 case INTRINSIC_PLUS:
9900 case INTRINSIC_MINUS:
9901 case INTRINSIC_TIMES:
9902 case INTRINSIC_DIVIDE:
9903 case INTRINSIC_POWER:
9907 case INTRINSIC_NEQV:
9914 case INTRINSIC_EQ_OS:
9915 case INTRINSIC_NE_OS:
9916 case INTRINSIC_GT_OS:
9917 case INTRINSIC_GE_OS:
9918 case INTRINSIC_LT_OS:
9919 case INTRINSIC_LE_OS:
9921 e1 = expr2->value.op.op1;
9922 e2 = expr2->value.op.op2;
9924 if (e1->rank == 0 && e2->rank > 0)
9925 return is_runtime_conformable (expr1, e2);
9926 else if (e1->rank > 0 && e2->rank == 0)
9927 return is_runtime_conformable (expr1, e1);
9928 else if (e1->rank > 0 && e2->rank > 0)
9929 return is_runtime_conformable (expr1, e1)
9930 && is_runtime_conformable (expr1, e2);
9948 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
9949 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
9952 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
9953 vec<tree, va_gc> *args = NULL;
9955 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
9958 /* Generate allocation of the lhs. */
9964 tmp = gfc_vptr_size_get (vptr);
9965 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9966 ? gfc_class_data_get (lse->expr) : lse->expr;
9967 gfc_init_block (&alloc);
9968 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
9969 tmp = fold_build2_loc (input_location, EQ_EXPR,
9970 logical_type_node, class_han,
9971 build_int_cst (prvoid_type_node, 0));
9972 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
9974 PRED_FORTRAN_FAIL_ALLOC),
9975 gfc_finish_block (&alloc),
9976 build_empty_stmt (input_location));
9977 gfc_add_expr_to_block (&lse->pre, tmp);
9980 fcn = gfc_vptr_copy_get (vptr);
9982 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
9983 ? gfc_class_data_get (rse->expr) : rse->expr;
9986 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
9987 || INDIRECT_REF_P (tmp)
9988 || (rhs->ts.type == BT_DERIVED
9989 && rhs->ts.u.derived->attr.unlimited_polymorphic
9990 && !rhs->ts.u.derived->attr.pointer
9991 && !rhs->ts.u.derived->attr.allocatable)
9992 || (UNLIMITED_POLY (rhs)
9993 && !CLASS_DATA (rhs)->attr.pointer
9994 && !CLASS_DATA (rhs)->attr.allocatable))
9995 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
9997 vec_safe_push (args, tmp);
9998 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
9999 ? gfc_class_data_get (lse->expr) : lse->expr;
10000 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10001 || INDIRECT_REF_P (tmp)
10002 || (lhs->ts.type == BT_DERIVED
10003 && lhs->ts.u.derived->attr.unlimited_polymorphic
10004 && !lhs->ts.u.derived->attr.pointer
10005 && !lhs->ts.u.derived->attr.allocatable)
10006 || (UNLIMITED_POLY (lhs)
10007 && !CLASS_DATA (lhs)->attr.pointer
10008 && !CLASS_DATA (lhs)->attr.allocatable))
10009 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10011 vec_safe_push (args, tmp);
10013 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10015 if (to_len != NULL_TREE && !integer_zerop (from_len))
10018 vec_safe_push (args, from_len);
10019 vec_safe_push (args, to_len);
10020 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10022 tmp = fold_build2_loc (input_location, GT_EXPR,
10023 logical_type_node, from_len,
10024 build_zero_cst (TREE_TYPE (from_len)));
10025 return fold_build3_loc (input_location, COND_EXPR,
10026 void_type_node, tmp,
10034 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10035 ? gfc_class_data_get (lse->expr) : lse->expr;
10036 stmtblock_t tblock;
10037 gfc_init_block (&tblock);
10038 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10039 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10040 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10041 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10042 /* When coming from a ptr_copy lhs and rhs are swapped. */
10043 gfc_add_modify_loc (input_location, &tblock, rhst,
10044 fold_convert (TREE_TYPE (rhst), tmp));
10045 return gfc_finish_block (&tblock);
10049 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10050 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10051 init_flag indicates initialization expressions and dealloc that no
10052 deallocate prior assignment is needed (if in doubt, set true).
10053 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10054 routine instead of a pointer assignment. Alias resolution is only done,
10055 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10056 where it is known, that newly allocated memory on the lhs can never be
10057 an alias of the rhs. */
10060 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10061 bool dealloc, bool use_vptr_copy, bool may_alias)
10066 gfc_ss *lss_section;
10073 bool scalar_to_array;
10074 tree string_length;
10076 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10077 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10078 bool is_poly_assign;
10080 /* Assignment of the form lhs = rhs. */
10081 gfc_start_block (&block);
10083 gfc_init_se (&lse, NULL);
10084 gfc_init_se (&rse, NULL);
10086 /* Walk the lhs. */
10087 lss = gfc_walk_expr (expr1);
10088 if (gfc_is_reallocatable_lhs (expr1))
10090 lss->no_bounds_check = 1;
10091 if (!(expr2->expr_type == EXPR_FUNCTION
10092 && expr2->value.function.isym != NULL
10093 && !(expr2->value.function.isym->elemental
10094 || expr2->value.function.isym->conversion)))
10095 lss->is_alloc_lhs = 1;
10098 lss->no_bounds_check = expr1->no_bounds_check;
10102 if ((expr1->ts.type == BT_DERIVED)
10103 && (gfc_is_class_array_function (expr2)
10104 || gfc_is_alloc_class_scalar_function (expr2)))
10105 expr2->must_finalize = 1;
10107 /* Checking whether a class assignment is desired is quite complicated and
10108 needed at two locations, so do it once only before the information is
10110 lhs_attr = gfc_expr_attr (expr1);
10111 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10112 || (lhs_attr.allocatable && !lhs_attr.dimension))
10113 && (expr1->ts.type == BT_CLASS
10114 || gfc_is_class_array_ref (expr1, NULL)
10115 || gfc_is_class_scalar_expr (expr1)
10116 || gfc_is_class_array_ref (expr2, NULL)
10117 || gfc_is_class_scalar_expr (expr2));
10120 /* Only analyze the expressions for coarray properties, when in coarray-lib
10122 if (flag_coarray == GFC_FCOARRAY_LIB)
10124 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10125 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10128 if (lss != gfc_ss_terminator)
10130 /* The assignment needs scalarization. */
10133 /* Find a non-scalar SS from the lhs. */
10134 while (lss_section != gfc_ss_terminator
10135 && lss_section->info->type != GFC_SS_SECTION)
10136 lss_section = lss_section->next;
10138 gcc_assert (lss_section != gfc_ss_terminator);
10140 /* Initialize the scalarizer. */
10141 gfc_init_loopinfo (&loop);
10143 /* Walk the rhs. */
10144 rss = gfc_walk_expr (expr2);
10145 if (rss == gfc_ss_terminator)
10146 /* The rhs is scalar. Add a ss for the expression. */
10147 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10148 /* When doing a class assign, then the handle to the rhs needs to be a
10149 pointer to allow for polymorphism. */
10150 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10151 rss->info->type = GFC_SS_REFERENCE;
10153 rss->no_bounds_check = expr2->no_bounds_check;
10154 /* Associate the SS with the loop. */
10155 gfc_add_ss_to_loop (&loop, lss);
10156 gfc_add_ss_to_loop (&loop, rss);
10158 /* Calculate the bounds of the scalarization. */
10159 gfc_conv_ss_startstride (&loop);
10160 /* Enable loop reversal. */
10161 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10162 loop.reverse[n] = GFC_ENABLE_REVERSE;
10163 /* Resolve any data dependencies in the statement. */
10165 gfc_conv_resolve_dependencies (&loop, lss, rss);
10166 /* Setup the scalarizing loops. */
10167 gfc_conv_loop_setup (&loop, &expr2->where);
10169 /* Setup the gfc_se structures. */
10170 gfc_copy_loopinfo_to_se (&lse, &loop);
10171 gfc_copy_loopinfo_to_se (&rse, &loop);
10174 gfc_mark_ss_chain_used (rss, 1);
10175 if (loop.temp_ss == NULL)
10178 gfc_mark_ss_chain_used (lss, 1);
10182 lse.ss = loop.temp_ss;
10183 gfc_mark_ss_chain_used (lss, 3);
10184 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10187 /* Allow the scalarizer to workshare array assignments. */
10188 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10189 == OMPWS_WORKSHARE_FLAG
10190 && loop.temp_ss == NULL)
10192 maybe_workshare = true;
10193 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10196 /* Start the scalarized loop body. */
10197 gfc_start_scalarized_body (&loop, &body);
10200 gfc_init_block (&body);
10202 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10204 /* Translate the expression. */
10205 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10206 && lhs_caf_attr.codimension;
10207 gfc_conv_expr (&rse, expr2);
10209 /* Deal with the case of a scalar class function assigned to a derived type. */
10210 if (gfc_is_alloc_class_scalar_function (expr2)
10211 && expr1->ts.type == BT_DERIVED)
10213 rse.expr = gfc_class_data_get (rse.expr);
10214 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10217 /* Stabilize a string length for temporaries. */
10218 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10219 && !(VAR_P (rse.string_length)
10220 || TREE_CODE (rse.string_length) == PARM_DECL
10221 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10222 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10223 else if (expr2->ts.type == BT_CHARACTER)
10225 if (expr1->ts.deferred && gfc_check_dependency (expr1, expr2, true))
10226 rse.string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10227 string_length = rse.string_length;
10230 string_length = NULL_TREE;
10234 gfc_conv_tmp_array_ref (&lse);
10235 if (expr2->ts.type == BT_CHARACTER)
10236 lse.string_length = string_length;
10240 gfc_conv_expr (&lse, expr1);
10241 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10243 && gfc_expr_attr (expr1).allocatable
10250 tmp = INDIRECT_REF_P (lse.expr)
10251 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10253 /* We should only get array references here. */
10254 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10255 || TREE_CODE (tmp) == ARRAY_REF);
10257 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10258 or the array itself(ARRAY_REF). */
10259 tmp = TREE_OPERAND (tmp, 0);
10261 /* Provide the address of the array. */
10262 if (TREE_CODE (lse.expr) == ARRAY_REF)
10263 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10265 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10266 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10267 msg = _("Assignment of scalar to unallocated array");
10268 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10269 &expr1->where, msg);
10272 /* Deallocate the lhs parameterized components if required. */
10273 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10274 && !expr1->symtree->n.sym->attr.associate_var)
10276 if (expr1->ts.type == BT_DERIVED
10277 && expr1->ts.u.derived
10278 && expr1->ts.u.derived->attr.pdt_type)
10280 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10282 gfc_add_expr_to_block (&lse.pre, tmp);
10284 else if (expr1->ts.type == BT_CLASS
10285 && CLASS_DATA (expr1)->ts.u.derived
10286 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10288 tmp = gfc_class_data_get (lse.expr);
10289 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10291 gfc_add_expr_to_block (&lse.pre, tmp);
10296 /* Assignments of scalar derived types with allocatable components
10297 to arrays must be done with a deep copy and the rhs temporary
10298 must have its components deallocated afterwards. */
10299 scalar_to_array = (expr2->ts.type == BT_DERIVED
10300 && expr2->ts.u.derived->attr.alloc_comp
10301 && !gfc_expr_is_variable (expr2)
10302 && expr1->rank && !expr2->rank);
10303 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10305 && expr1->ts.u.derived->attr.alloc_comp
10306 && gfc_is_alloc_class_scalar_function (expr2));
10307 if (scalar_to_array && dealloc)
10309 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10310 gfc_prepend_expr_to_block (&loop.post, tmp);
10313 /* When assigning a character function result to a deferred-length variable,
10314 the function call must happen before the (re)allocation of the lhs -
10315 otherwise the character length of the result is not known.
10316 NOTE 1: This relies on having the exact dependence of the length type
10317 parameter available to the caller; gfortran saves it in the .mod files.
10318 NOTE 2: Vector array references generate an index temporary that must
10319 not go outside the loop. Otherwise, variables should not generate
10321 NOTE 3: The concatenation operation generates a temporary pointer,
10322 whose allocation must go to the innermost loop.
10323 NOTE 4: Elemental functions may generate a temporary, too. */
10324 if (flag_realloc_lhs
10325 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10326 && !(lss != gfc_ss_terminator
10327 && rss != gfc_ss_terminator
10328 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10329 || (expr2->expr_type == EXPR_FUNCTION
10330 && expr2->value.function.esym != NULL
10331 && expr2->value.function.esym->attr.elemental)
10332 || (expr2->expr_type == EXPR_FUNCTION
10333 && expr2->value.function.isym != NULL
10334 && expr2->value.function.isym->elemental)
10335 || (expr2->expr_type == EXPR_OP
10336 && expr2->value.op.op == INTRINSIC_CONCAT))))
10337 gfc_add_block_to_block (&block, &rse.pre);
10339 /* Nullify the allocatable components corresponding to those of the lhs
10340 derived type, so that the finalization of the function result does not
10341 affect the lhs of the assignment. Prepend is used to ensure that the
10342 nullification occurs before the call to the finalizer. In the case of
10343 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10344 as part of the deep copy. */
10345 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10346 && (gfc_is_class_array_function (expr2)
10347 || gfc_is_alloc_class_scalar_function (expr2)))
10350 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10351 gfc_prepend_expr_to_block (&rse.post, tmp);
10352 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10353 gfc_add_block_to_block (&loop.post, &rse.post);
10358 if (is_poly_assign)
10359 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10360 use_vptr_copy || (lhs_attr.allocatable
10361 && !lhs_attr.dimension),
10362 flag_realloc_lhs && !lhs_attr.pointer);
10363 else if (flag_coarray == GFC_FCOARRAY_LIB
10364 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10365 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10366 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10368 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10369 allocatable component, because those need to be accessed via the
10370 caf-runtime. No need to check for coindexes here, because resolve
10371 has rewritten those already. */
10373 gfc_actual_arglist a1, a2;
10374 /* Clear the structures to prevent accessing garbage. */
10375 memset (&code, '\0', sizeof (gfc_code));
10376 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10377 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10382 code.ext.actual = &a1;
10383 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10384 tmp = gfc_conv_intrinsic_subroutine (&code);
10386 else if (!is_poly_assign && expr2->must_finalize
10387 && expr1->ts.type == BT_CLASS
10388 && expr2->ts.type == BT_CLASS)
10390 /* This case comes about when the scalarizer provides array element
10391 references. Use the vptr copy function, since this does a deep
10392 copy of allocatable components, without which the finalizer call */
10393 tmp = gfc_get_vptr_from_expr (rse.expr);
10394 if (tmp != NULL_TREE)
10396 tree fcn = gfc_vptr_copy_get (tmp);
10397 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10398 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10399 tmp = build_call_expr_loc (input_location,
10401 gfc_build_addr_expr (NULL, rse.expr),
10402 gfc_build_addr_expr (NULL, lse.expr));
10406 /* If nothing else works, do it the old fashioned way! */
10407 if (tmp == NULL_TREE)
10408 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10409 gfc_expr_is_variable (expr2)
10411 || expr2->expr_type == EXPR_ARRAY,
10412 !(l_is_temp || init_flag) && dealloc,
10413 expr1->symtree->n.sym->attr.codimension);
10415 /* Add the pre blocks to the body. */
10416 gfc_add_block_to_block (&body, &rse.pre);
10417 gfc_add_block_to_block (&body, &lse.pre);
10418 gfc_add_expr_to_block (&body, tmp);
10419 /* Add the post blocks to the body. */
10420 gfc_add_block_to_block (&body, &rse.post);
10421 gfc_add_block_to_block (&body, &lse.post);
10423 if (lss == gfc_ss_terminator)
10425 /* F2003: Add the code for reallocation on assignment. */
10426 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10427 && !is_poly_assign)
10428 alloc_scalar_allocatable_for_assignment (&block, string_length,
10431 /* Use the scalar assignment as is. */
10432 gfc_add_block_to_block (&block, &body);
10436 gcc_assert (lse.ss == gfc_ss_terminator
10437 && rse.ss == gfc_ss_terminator);
10441 gfc_trans_scalarized_loop_boundary (&loop, &body);
10443 /* We need to copy the temporary to the actual lhs. */
10444 gfc_init_se (&lse, NULL);
10445 gfc_init_se (&rse, NULL);
10446 gfc_copy_loopinfo_to_se (&lse, &loop);
10447 gfc_copy_loopinfo_to_se (&rse, &loop);
10449 rse.ss = loop.temp_ss;
10452 gfc_conv_tmp_array_ref (&rse);
10453 gfc_conv_expr (&lse, expr1);
10455 gcc_assert (lse.ss == gfc_ss_terminator
10456 && rse.ss == gfc_ss_terminator);
10458 if (expr2->ts.type == BT_CHARACTER)
10459 rse.string_length = string_length;
10461 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10463 gfc_add_expr_to_block (&body, tmp);
10466 /* F2003: Allocate or reallocate lhs of allocatable array. */
10467 if (flag_realloc_lhs
10468 && gfc_is_reallocatable_lhs (expr1)
10470 && !is_runtime_conformable (expr1, expr2))
10472 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10473 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10474 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10475 if (tmp != NULL_TREE)
10476 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10479 if (maybe_workshare)
10480 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10482 /* Generate the copying loops. */
10483 gfc_trans_scalarizing_loops (&loop, &body);
10485 /* Wrap the whole thing up. */
10486 gfc_add_block_to_block (&block, &loop.pre);
10487 gfc_add_block_to_block (&block, &loop.post);
10489 gfc_cleanup_loop (&loop);
10492 return gfc_finish_block (&block);
10496 /* Check whether EXPR is a copyable array. */
10499 copyable_array_p (gfc_expr * expr)
10501 if (expr->expr_type != EXPR_VARIABLE)
10504 /* First check it's an array. */
10505 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10508 if (!gfc_full_array_ref_p (expr->ref, NULL))
10511 /* Next check that it's of a simple enough type. */
10512 switch (expr->ts.type)
10524 return !expr->ts.u.derived->attr.alloc_comp;
10533 /* Translate an assignment. */
10536 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10537 bool dealloc, bool use_vptr_copy, bool may_alias)
10541 /* Special case a single function returning an array. */
10542 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10544 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10549 /* Special case assigning an array to zero. */
10550 if (copyable_array_p (expr1)
10551 && is_zero_initializer_p (expr2))
10553 tmp = gfc_trans_zero_assign (expr1);
10558 /* Special case copying one array to another. */
10559 if (copyable_array_p (expr1)
10560 && copyable_array_p (expr2)
10561 && gfc_compare_types (&expr1->ts, &expr2->ts)
10562 && !gfc_check_dependency (expr1, expr2, 0))
10564 tmp = gfc_trans_array_copy (expr1, expr2);
10569 /* Special case initializing an array from a constant array constructor. */
10570 if (copyable_array_p (expr1)
10571 && expr2->expr_type == EXPR_ARRAY
10572 && gfc_compare_types (&expr1->ts, &expr2->ts))
10574 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10579 if (UNLIMITED_POLY (expr1) && expr1->rank
10580 && expr2->ts.type != BT_CLASS)
10581 use_vptr_copy = true;
10583 /* Fallback to the scalarizer to generate explicit loops. */
10584 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10585 use_vptr_copy, may_alias);
10589 gfc_trans_init_assign (gfc_code * code)
10591 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10595 gfc_trans_assign (gfc_code * code)
10597 return gfc_trans_assignment (code->expr1, code->expr2, false, true);