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);
2515 conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts)
2517 tree res = se->expr;
2522 res = fold_build1_loc (input_location, REALPART_EXPR,
2523 TREE_TYPE (TREE_TYPE (res)), res);
2527 res = fold_build1_loc (input_location, IMAGPART_EXPR,
2528 TREE_TYPE (TREE_TYPE (res)), res);
2532 res = build_int_cst (gfc_typenode_for_spec (&expr->ts),
2537 res = fold_convert (gfc_typenode_for_spec (&expr->ts),
2547 /* Return the contents of a variable. Also handles reference/pointer
2548 variables (all Fortran pointer references are implicit). */
2551 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
2556 tree parent_decl = NULL_TREE;
2559 bool alternate_entry;
2562 bool first_time = true;
2564 sym = expr->symtree->n.sym;
2565 is_classarray = IS_CLASS_ARRAY (sym);
2569 gfc_ss_info *ss_info = ss->info;
2571 /* Check that something hasn't gone horribly wrong. */
2572 gcc_assert (ss != gfc_ss_terminator);
2573 gcc_assert (ss_info->expr == expr);
2575 /* A scalarized term. We already know the descriptor. */
2576 se->expr = ss_info->data.array.descriptor;
2577 se->string_length = ss_info->string_length;
2578 ref = ss_info->data.array.ref;
2580 gcc_assert (ref->type == REF_ARRAY
2581 && ref->u.ar.type != AR_ELEMENT);
2583 gfc_conv_tmp_array_ref (se);
2587 tree se_expr = NULL_TREE;
2589 se->expr = gfc_get_symbol_decl (sym);
2591 /* Deal with references to a parent results or entries by storing
2592 the current_function_decl and moving to the parent_decl. */
2593 return_value = sym->attr.function && sym->result == sym;
2594 alternate_entry = sym->attr.function && sym->attr.entry
2595 && sym->result == sym;
2596 entry_master = sym->attr.result
2597 && sym->ns->proc_name->attr.entry_master
2598 && !gfc_return_by_reference (sym->ns->proc_name);
2599 if (current_function_decl)
2600 parent_decl = DECL_CONTEXT (current_function_decl);
2602 if ((se->expr == parent_decl && return_value)
2603 || (sym->ns && sym->ns->proc_name
2605 && sym->ns->proc_name->backend_decl == parent_decl
2606 && (alternate_entry || entry_master)))
2611 /* Special case for assigning the return value of a function.
2612 Self recursive functions must have an explicit return value. */
2613 if (return_value && (se->expr == current_function_decl || parent_flag))
2614 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2616 /* Similarly for alternate entry points. */
2617 else if (alternate_entry
2618 && (sym->ns->proc_name->backend_decl == current_function_decl
2621 gfc_entry_list *el = NULL;
2623 for (el = sym->ns->entries; el; el = el->next)
2626 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2631 else if (entry_master
2632 && (sym->ns->proc_name->backend_decl == current_function_decl
2634 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
2639 /* Procedure actual arguments. Look out for temporary variables
2640 with the same attributes as function values. */
2641 else if (!sym->attr.temporary
2642 && sym->attr.flavor == FL_PROCEDURE
2643 && se->expr != current_function_decl)
2645 if (!sym->attr.dummy && !sym->attr.proc_pointer)
2647 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
2648 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2654 /* Dereference the expression, where needed. Since characters
2655 are entirely different from other types, they are treated
2657 if (sym->ts.type == BT_CHARACTER)
2659 /* Dereference character pointer dummy arguments
2661 if ((sym->attr.pointer || sym->attr.allocatable)
2663 || sym->attr.function
2664 || sym->attr.result))
2665 se->expr = build_fold_indirect_ref_loc (input_location,
2669 else if (!sym->attr.value)
2671 /* Dereference temporaries for class array dummy arguments. */
2672 if (sym->attr.dummy && is_classarray
2673 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
2675 if (!se->descriptor_only)
2676 se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
2678 se->expr = build_fold_indirect_ref_loc (input_location,
2682 /* Dereference non-character scalar dummy arguments. */
2683 if (sym->attr.dummy && !sym->attr.dimension
2684 && !(sym->attr.codimension && sym->attr.allocatable)
2685 && (sym->ts.type != BT_CLASS
2686 || (!CLASS_DATA (sym)->attr.dimension
2687 && !(CLASS_DATA (sym)->attr.codimension
2688 && CLASS_DATA (sym)->attr.allocatable))))
2689 se->expr = build_fold_indirect_ref_loc (input_location,
2692 /* Dereference scalar hidden result. */
2693 if (flag_f2c && sym->ts.type == BT_COMPLEX
2694 && (sym->attr.function || sym->attr.result)
2695 && !sym->attr.dimension && !sym->attr.pointer
2696 && !sym->attr.always_explicit)
2697 se->expr = build_fold_indirect_ref_loc (input_location,
2700 /* Dereference non-character, non-class pointer variables.
2701 These must be dummies, results, or scalars. */
2703 && (sym->attr.pointer || sym->attr.allocatable
2704 || gfc_is_associate_pointer (sym)
2705 || (sym->as && sym->as->type == AS_ASSUMED_RANK))
2707 || sym->attr.function
2709 || (!sym->attr.dimension
2710 && (!sym->attr.codimension || !sym->attr.allocatable))))
2711 se->expr = build_fold_indirect_ref_loc (input_location,
2713 /* Now treat the class array pointer variables accordingly. */
2714 else if (sym->ts.type == BT_CLASS
2716 && (CLASS_DATA (sym)->attr.dimension
2717 || CLASS_DATA (sym)->attr.codimension)
2718 && ((CLASS_DATA (sym)->as
2719 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
2720 || CLASS_DATA (sym)->attr.allocatable
2721 || CLASS_DATA (sym)->attr.class_pointer))
2722 se->expr = build_fold_indirect_ref_loc (input_location,
2724 /* And the case where a non-dummy, non-result, non-function,
2725 non-allotable and non-pointer classarray is present. This case was
2726 previously covered by the first if, but with introducing the
2727 condition !is_classarray there, that case has to be covered
2729 else if (sym->ts.type == BT_CLASS
2731 && !sym->attr.function
2732 && !sym->attr.result
2733 && (CLASS_DATA (sym)->attr.dimension
2734 || CLASS_DATA (sym)->attr.codimension)
2736 || !CLASS_DATA (sym)->attr.allocatable)
2737 && !CLASS_DATA (sym)->attr.class_pointer)
2738 se->expr = build_fold_indirect_ref_loc (input_location,
2745 /* For character variables, also get the length. */
2746 if (sym->ts.type == BT_CHARACTER)
2748 /* If the character length of an entry isn't set, get the length from
2749 the master function instead. */
2750 if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
2751 se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
2753 se->string_length = sym->ts.u.cl->backend_decl;
2754 gcc_assert (se->string_length);
2757 gfc_typespec *ts = &sym->ts;
2763 /* Return the descriptor if that's what we want and this is an array
2764 section reference. */
2765 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
2767 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
2768 /* Return the descriptor for array pointers and allocations. */
2769 if (se->want_pointer
2770 && ref->next == NULL && (se->descriptor_only))
2773 gfc_conv_array_ref (se, &ref->u.ar, expr, &expr->where);
2774 /* Return a pointer to an element. */
2778 ts = &ref->u.c.component->ts;
2779 if (first_time && is_classarray && sym->attr.dummy
2780 && se->descriptor_only
2781 && !CLASS_DATA (sym)->attr.allocatable
2782 && !CLASS_DATA (sym)->attr.class_pointer
2783 && CLASS_DATA (sym)->as
2784 && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
2785 && strcmp ("_data", ref->u.c.component->name) == 0)
2786 /* Skip the first ref of a _data component, because for class
2787 arrays that one is already done by introducing a temporary
2788 array descriptor. */
2791 if (ref->u.c.sym->attr.extension)
2792 conv_parent_component_references (se, ref);
2794 gfc_conv_component_ref (se, ref);
2795 if (!ref->next && ref->u.c.sym->attr.codimension
2796 && se->want_pointer && se->descriptor_only)
2802 gfc_conv_substring (se, ref, expr->ts.kind,
2803 expr->symtree->name, &expr->where);
2807 conv_inquiry (se, ref, expr, ts);
2817 /* Pointer assignment, allocation or pass by reference. Arrays are handled
2819 if (se->want_pointer)
2821 if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr))
2822 gfc_conv_string_parameter (se);
2824 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
2829 /* Unary ops are easy... Or they would be if ! was a valid op. */
2832 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
2837 gcc_assert (expr->ts.type != BT_CHARACTER);
2838 /* Initialize the operand. */
2839 gfc_init_se (&operand, se);
2840 gfc_conv_expr_val (&operand, expr->value.op.op1);
2841 gfc_add_block_to_block (&se->pre, &operand.pre);
2843 type = gfc_typenode_for_spec (&expr->ts);
2845 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
2846 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
2847 All other unary operators have an equivalent GIMPLE unary operator. */
2848 if (code == TRUTH_NOT_EXPR)
2849 se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr,
2850 build_int_cst (type, 0));
2852 se->expr = fold_build1_loc (input_location, code, type, operand.expr);
2856 /* Expand power operator to optimal multiplications when a value is raised
2857 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
2858 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
2859 Programming", 3rd Edition, 1998. */
2861 /* This code is mostly duplicated from expand_powi in the backend.
2862 We establish the "optimal power tree" lookup table with the defined size.
2863 The items in the table are the exponents used to calculate the index
2864 exponents. Any integer n less than the value can get an "addition chain",
2865 with the first node being one. */
2866 #define POWI_TABLE_SIZE 256
2868 /* The table is from builtins.c. */
2869 static const unsigned char powi_table[POWI_TABLE_SIZE] =
2871 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
2872 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
2873 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
2874 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
2875 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
2876 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
2877 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
2878 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
2879 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
2880 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
2881 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
2882 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
2883 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
2884 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
2885 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
2886 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
2887 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
2888 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
2889 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
2890 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
2891 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
2892 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
2893 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
2894 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
2895 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
2896 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
2897 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
2898 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
2899 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
2900 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
2901 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
2902 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
2905 /* If n is larger than lookup table's max index, we use the "window
2907 #define POWI_WINDOW_SIZE 3
2909 /* Recursive function to expand the power operator. The temporary
2910 values are put in tmpvar. The function returns tmpvar[1] ** n. */
2912 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
2919 if (n < POWI_TABLE_SIZE)
2924 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
2925 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
2929 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
2930 op0 = gfc_conv_powi (se, n - digit, tmpvar);
2931 op1 = gfc_conv_powi (se, digit, tmpvar);
2935 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
2939 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (op0), op0, op1);
2940 tmp = gfc_evaluate_now (tmp, &se->pre);
2942 if (n < POWI_TABLE_SIZE)
2949 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
2950 return 1. Else return 0 and a call to runtime library functions
2951 will have to be built. */
2953 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
2958 tree vartmp[POWI_TABLE_SIZE];
2960 unsigned HOST_WIDE_INT n;
2962 wi::tree_to_wide_ref wrhs = wi::to_wide (rhs);
2964 /* If exponent is too large, we won't expand it anyway, so don't bother
2965 with large integer values. */
2966 if (!wi::fits_shwi_p (wrhs))
2969 m = wrhs.to_shwi ();
2970 /* Use the wide_int's routine to reliably get the absolute value on all
2971 platforms. Then convert it to a HOST_WIDE_INT like above. */
2972 n = wi::abs (wrhs).to_shwi ();
2974 type = TREE_TYPE (lhs);
2975 sgn = tree_int_cst_sgn (rhs);
2977 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
2978 || optimize_size) && (m > 2 || m < -1))
2984 se->expr = gfc_build_const (type, integer_one_node);
2988 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
2989 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
2991 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2992 lhs, build_int_cst (TREE_TYPE (lhs), -1));
2993 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
2994 lhs, build_int_cst (TREE_TYPE (lhs), 1));
2997 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
3000 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3001 logical_type_node, tmp, cond);
3002 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3003 tmp, build_int_cst (type, 1),
3004 build_int_cst (type, 0));
3008 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
3009 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp,
3010 build_int_cst (type, -1),
3011 build_int_cst (type, 0));
3012 se->expr = fold_build3_loc (input_location, COND_EXPR, type,
3013 cond, build_int_cst (type, 1), tmp);
3017 memset (vartmp, 0, sizeof (vartmp));
3021 tmp = gfc_build_const (type, integer_one_node);
3022 vartmp[1] = fold_build2_loc (input_location, RDIV_EXPR, type, tmp,
3026 se->expr = gfc_conv_powi (se, n, vartmp);
3032 /* Power op (**). Constant integer exponent has special handling. */
3035 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
3037 tree gfc_int4_type_node;
3040 int res_ikind_1, res_ikind_2;
3045 gfc_init_se (&lse, se);
3046 gfc_conv_expr_val (&lse, expr->value.op.op1);
3047 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
3048 gfc_add_block_to_block (&se->pre, &lse.pre);
3050 gfc_init_se (&rse, se);
3051 gfc_conv_expr_val (&rse, expr->value.op.op2);
3052 gfc_add_block_to_block (&se->pre, &rse.pre);
3054 if (expr->value.op.op2->ts.type == BT_INTEGER
3055 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
3056 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
3059 gfc_int4_type_node = gfc_get_int_type (4);
3061 /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
3062 library routine. But in the end, we have to convert the result back
3063 if this case applies -- with res_ikind_K, we keep track whether operand K
3064 falls into this case. */
3068 kind = expr->value.op.op1->ts.kind;
3069 switch (expr->value.op.op2->ts.type)
3072 ikind = expr->value.op.op2->ts.kind;
3077 rse.expr = convert (gfc_int4_type_node, rse.expr);
3078 res_ikind_2 = ikind;
3100 if (expr->value.op.op1->ts.type == BT_INTEGER)
3102 lse.expr = convert (gfc_int4_type_node, lse.expr);
3129 switch (expr->value.op.op1->ts.type)
3132 if (kind == 3) /* Case 16 was not handled properly above. */
3134 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
3138 /* Use builtins for real ** int4. */
3144 fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
3148 fndecl = builtin_decl_explicit (BUILT_IN_POWI);
3152 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3156 /* Use the __builtin_powil() only if real(kind=16) is
3157 actually the C long double type. */
3158 if (!gfc_real16_is_float128)
3159 fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
3167 /* If we don't have a good builtin for this, go for the
3168 library function. */
3170 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
3174 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
3183 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_POW, kind);
3187 fndecl = gfc_builtin_decl_for_float_kind (BUILT_IN_CPOW, kind);
3195 se->expr = build_call_expr_loc (input_location,
3196 fndecl, 2, lse.expr, rse.expr);
3198 /* Convert the result back if it is of wrong integer kind. */
3199 if (res_ikind_1 != -1 && res_ikind_2 != -1)
3201 /* We want the maximum of both operand kinds as result. */
3202 if (res_ikind_1 < res_ikind_2)
3203 res_ikind_1 = res_ikind_2;
3204 se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
3209 /* Generate code to allocate a string temporary. */
3212 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
3217 if (gfc_can_put_var_on_stack (len))
3219 /* Create a temporary variable to hold the result. */
3220 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3221 TREE_TYPE (len), len,
3222 build_int_cst (TREE_TYPE (len), 1));
3223 tmp = build_range_type (gfc_charlen_type_node, size_zero_node, tmp);
3225 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
3226 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
3228 tmp = build_array_type (TREE_TYPE (type), tmp);
3230 var = gfc_create_var (tmp, "str");
3231 var = gfc_build_addr_expr (type, var);
3235 /* Allocate a temporary to hold the result. */
3236 var = gfc_create_var (type, "pstr");
3237 gcc_assert (POINTER_TYPE_P (type));
3238 tmp = TREE_TYPE (type);
3239 if (TREE_CODE (tmp) == ARRAY_TYPE)
3240 tmp = TREE_TYPE (tmp);
3241 tmp = TYPE_SIZE_UNIT (tmp);
3242 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
3243 fold_convert (size_type_node, len),
3244 fold_convert (size_type_node, tmp));
3245 tmp = gfc_call_malloc (&se->pre, type, tmp);
3246 gfc_add_modify (&se->pre, var, tmp);
3248 /* Free the temporary afterwards. */
3249 tmp = gfc_call_free (var);
3250 gfc_add_expr_to_block (&se->post, tmp);
3257 /* Handle a string concatenation operation. A temporary will be allocated to
3261 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
3264 tree len, type, var, tmp, fndecl;
3266 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
3267 && expr->value.op.op2->ts.type == BT_CHARACTER);
3268 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
3270 gfc_init_se (&lse, se);
3271 gfc_conv_expr (&lse, expr->value.op.op1);
3272 gfc_conv_string_parameter (&lse);
3273 gfc_init_se (&rse, se);
3274 gfc_conv_expr (&rse, expr->value.op.op2);
3275 gfc_conv_string_parameter (&rse);
3277 gfc_add_block_to_block (&se->pre, &lse.pre);
3278 gfc_add_block_to_block (&se->pre, &rse.pre);
3280 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
3281 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3282 if (len == NULL_TREE)
3284 len = fold_build2_loc (input_location, PLUS_EXPR,
3285 gfc_charlen_type_node,
3286 fold_convert (gfc_charlen_type_node,
3288 fold_convert (gfc_charlen_type_node,
3289 rse.string_length));
3292 type = build_pointer_type (type);
3294 var = gfc_conv_string_tmp (se, type, len);
3296 /* Do the actual concatenation. */
3297 if (expr->ts.kind == 1)
3298 fndecl = gfor_fndecl_concat_string;
3299 else if (expr->ts.kind == 4)
3300 fndecl = gfor_fndecl_concat_string_char4;
3304 tmp = build_call_expr_loc (input_location,
3305 fndecl, 6, len, var, lse.string_length, lse.expr,
3306 rse.string_length, rse.expr);
3307 gfc_add_expr_to_block (&se->pre, tmp);
3309 /* Add the cleanup for the operands. */
3310 gfc_add_block_to_block (&se->pre, &rse.post);
3311 gfc_add_block_to_block (&se->pre, &lse.post);
3314 se->string_length = len;
3317 /* Translates an op expression. Common (binary) cases are handled by this
3318 function, others are passed on. Recursion is used in either case.
3319 We use the fact that (op1.ts == op2.ts) (except for the power
3321 Operators need no special handling for scalarized expressions as long as
3322 they call gfc_conv_simple_val to get their operands.
3323 Character strings get special handling. */
3326 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
3328 enum tree_code code;
3337 switch (expr->value.op.op)
3339 case INTRINSIC_PARENTHESES:
3340 if ((expr->ts.type == BT_REAL || expr->ts.type == BT_COMPLEX)
3341 && flag_protect_parens)
3343 gfc_conv_unary_op (PAREN_EXPR, se, expr);
3344 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
3349 case INTRINSIC_UPLUS:
3350 gfc_conv_expr (se, expr->value.op.op1);
3353 case INTRINSIC_UMINUS:
3354 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
3358 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
3361 case INTRINSIC_PLUS:
3365 case INTRINSIC_MINUS:
3369 case INTRINSIC_TIMES:
3373 case INTRINSIC_DIVIDE:
3374 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
3375 an integer, we must round towards zero, so we use a
3377 if (expr->ts.type == BT_INTEGER)
3378 code = TRUNC_DIV_EXPR;
3383 case INTRINSIC_POWER:
3384 gfc_conv_power_op (se, expr);
3387 case INTRINSIC_CONCAT:
3388 gfc_conv_concat_op (se, expr);
3392 code = flag_frontend_optimize ? TRUTH_ANDIF_EXPR : TRUTH_AND_EXPR;
3397 code = flag_frontend_optimize ? TRUTH_ORIF_EXPR : TRUTH_OR_EXPR;
3401 /* EQV and NEQV only work on logicals, but since we represent them
3402 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
3404 case INTRINSIC_EQ_OS:
3412 case INTRINSIC_NE_OS:
3413 case INTRINSIC_NEQV:
3420 case INTRINSIC_GT_OS:
3427 case INTRINSIC_GE_OS:
3434 case INTRINSIC_LT_OS:
3441 case INTRINSIC_LE_OS:
3447 case INTRINSIC_USER:
3448 case INTRINSIC_ASSIGN:
3449 /* These should be converted into function calls by the frontend. */
3453 fatal_error (input_location, "Unknown intrinsic op");
3457 /* The only exception to this is **, which is handled separately anyway. */
3458 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
3460 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
3464 gfc_init_se (&lse, se);
3465 gfc_conv_expr (&lse, expr->value.op.op1);
3466 gfc_add_block_to_block (&se->pre, &lse.pre);
3469 gfc_init_se (&rse, se);
3470 gfc_conv_expr (&rse, expr->value.op.op2);
3471 gfc_add_block_to_block (&se->pre, &rse.pre);
3475 gfc_conv_string_parameter (&lse);
3476 gfc_conv_string_parameter (&rse);
3478 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
3479 rse.string_length, rse.expr,
3480 expr->value.op.op1->ts.kind,
3482 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
3483 gfc_add_block_to_block (&lse.post, &rse.post);
3486 type = gfc_typenode_for_spec (&expr->ts);
3490 /* The result of logical ops is always logical_type_node. */
3491 tmp = fold_build2_loc (input_location, code, logical_type_node,
3492 lse.expr, rse.expr);
3493 se->expr = convert (type, tmp);
3496 se->expr = fold_build2_loc (input_location, code, type, lse.expr, rse.expr);
3498 /* Add the post blocks. */
3499 gfc_add_block_to_block (&se->post, &rse.post);
3500 gfc_add_block_to_block (&se->post, &lse.post);
3503 /* If a string's length is one, we convert it to a single character. */
3506 gfc_string_to_single_character (tree len, tree str, int kind)
3510 || !tree_fits_uhwi_p (len)
3511 || !POINTER_TYPE_P (TREE_TYPE (str)))
3514 if (TREE_INT_CST_LOW (len) == 1)
3516 str = fold_convert (gfc_get_pchar_type (kind), str);
3517 return build_fold_indirect_ref_loc (input_location, str);
3521 && TREE_CODE (str) == ADDR_EXPR
3522 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3523 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3524 && array_ref_low_bound (TREE_OPERAND (str, 0))
3525 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3526 && TREE_INT_CST_LOW (len) > 1
3527 && TREE_INT_CST_LOW (len)
3528 == (unsigned HOST_WIDE_INT)
3529 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3531 tree ret = fold_convert (gfc_get_pchar_type (kind), str);
3532 ret = build_fold_indirect_ref_loc (input_location, ret);
3533 if (TREE_CODE (ret) == INTEGER_CST)
3535 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3536 int i, length = TREE_STRING_LENGTH (string_cst);
3537 const char *ptr = TREE_STRING_POINTER (string_cst);
3539 for (i = 1; i < length; i++)
3552 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
3555 if (sym->backend_decl)
3557 /* This becomes the nominal_type in
3558 function.c:assign_parm_find_data_types. */
3559 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
3560 /* This becomes the passed_type in
3561 function.c:assign_parm_find_data_types. C promotes char to
3562 integer for argument passing. */
3563 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
3565 DECL_BY_REFERENCE (sym->backend_decl) = 0;
3570 /* If we have a constant character expression, make it into an
3572 if ((*expr)->expr_type == EXPR_CONSTANT)
3577 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
3578 (int)(*expr)->value.character.string[0]);
3579 if ((*expr)->ts.kind != gfc_c_int_kind)
3581 /* The expr needs to be compatible with a C int. If the
3582 conversion fails, then the 2 causes an ICE. */
3583 ts.type = BT_INTEGER;
3584 ts.kind = gfc_c_int_kind;
3585 gfc_convert_type (*expr, &ts, 2);
3588 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
3590 if ((*expr)->ref == NULL)
3592 se->expr = gfc_string_to_single_character
3593 (build_int_cst (integer_type_node, 1),
3594 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3596 ((*expr)->symtree->n.sym)),
3601 gfc_conv_variable (se, *expr);
3602 se->expr = gfc_string_to_single_character
3603 (build_int_cst (integer_type_node, 1),
3604 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
3612 /* Helper function for gfc_build_compare_string. Return LEN_TRIM value
3613 if STR is a string literal, otherwise return -1. */
3616 gfc_optimize_len_trim (tree len, tree str, int kind)
3619 && TREE_CODE (str) == ADDR_EXPR
3620 && TREE_CODE (TREE_OPERAND (str, 0)) == ARRAY_REF
3621 && TREE_CODE (TREE_OPERAND (TREE_OPERAND (str, 0), 0)) == STRING_CST
3622 && array_ref_low_bound (TREE_OPERAND (str, 0))
3623 == TREE_OPERAND (TREE_OPERAND (str, 0), 1)
3624 && tree_fits_uhwi_p (len)
3625 && tree_to_uhwi (len) >= 1
3626 && tree_to_uhwi (len)
3627 == (unsigned HOST_WIDE_INT)
3628 TREE_STRING_LENGTH (TREE_OPERAND (TREE_OPERAND (str, 0), 0)))
3630 tree folded = fold_convert (gfc_get_pchar_type (kind), str);
3631 folded = build_fold_indirect_ref_loc (input_location, folded);
3632 if (TREE_CODE (folded) == INTEGER_CST)
3634 tree string_cst = TREE_OPERAND (TREE_OPERAND (str, 0), 0);
3635 int length = TREE_STRING_LENGTH (string_cst);
3636 const char *ptr = TREE_STRING_POINTER (string_cst);
3638 for (; length > 0; length--)
3639 if (ptr[length - 1] != ' ')
3648 /* Helper to build a call to memcmp. */
3651 build_memcmp_call (tree s1, tree s2, tree n)
3655 if (!POINTER_TYPE_P (TREE_TYPE (s1)))
3656 s1 = gfc_build_addr_expr (pvoid_type_node, s1);
3658 s1 = fold_convert (pvoid_type_node, s1);
3660 if (!POINTER_TYPE_P (TREE_TYPE (s2)))
3661 s2 = gfc_build_addr_expr (pvoid_type_node, s2);
3663 s2 = fold_convert (pvoid_type_node, s2);
3665 n = fold_convert (size_type_node, n);
3667 tmp = build_call_expr_loc (input_location,
3668 builtin_decl_explicit (BUILT_IN_MEMCMP),
3671 return fold_convert (integer_type_node, tmp);
3674 /* Compare two strings. If they are all single characters, the result is the
3675 subtraction of them. Otherwise, we build a library call. */
3678 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind,
3679 enum tree_code code)
3685 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
3686 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
3688 sc1 = gfc_string_to_single_character (len1, str1, kind);
3689 sc2 = gfc_string_to_single_character (len2, str2, kind);
3691 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
3693 /* Deal with single character specially. */
3694 sc1 = fold_convert (integer_type_node, sc1);
3695 sc2 = fold_convert (integer_type_node, sc2);
3696 return fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
3700 if ((code == EQ_EXPR || code == NE_EXPR)
3702 && INTEGER_CST_P (len1) && INTEGER_CST_P (len2))
3704 /* If one string is a string literal with LEN_TRIM longer
3705 than the length of the second string, the strings
3707 int len = gfc_optimize_len_trim (len1, str1, kind);
3708 if (len > 0 && compare_tree_int (len2, len) < 0)
3709 return integer_one_node;
3710 len = gfc_optimize_len_trim (len2, str2, kind);
3711 if (len > 0 && compare_tree_int (len1, len) < 0)
3712 return integer_one_node;
3715 /* We can compare via memcpy if the strings are known to be equal
3716 in length and they are
3718 - kind=4 and the comparison is for (in)equality. */
3720 if (INTEGER_CST_P (len1) && INTEGER_CST_P (len2)
3721 && tree_int_cst_equal (len1, len2)
3722 && (kind == 1 || code == EQ_EXPR || code == NE_EXPR))
3727 chartype = gfc_get_char_type (kind);
3728 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE(len1),
3729 fold_convert (TREE_TYPE(len1),
3730 TYPE_SIZE_UNIT(chartype)),
3732 return build_memcmp_call (str1, str2, tmp);
3735 /* Build a call for the comparison. */
3737 fndecl = gfor_fndecl_compare_string;
3739 fndecl = gfor_fndecl_compare_string_char4;
3743 return build_call_expr_loc (input_location, fndecl, 4,
3744 len1, str1, len2, str2);
3748 /* Return the backend_decl for a procedure pointer component. */
3751 get_proc_ptr_comp (gfc_expr *e)
3757 gfc_init_se (&comp_se, NULL);
3758 e2 = gfc_copy_expr (e);
3759 /* We have to restore the expr type later so that gfc_free_expr frees
3760 the exact same thing that was allocated.
3761 TODO: This is ugly. */
3762 old_type = e2->expr_type;
3763 e2->expr_type = EXPR_VARIABLE;
3764 gfc_conv_expr (&comp_se, e2);
3765 e2->expr_type = old_type;
3767 return build_fold_addr_expr_loc (input_location, comp_se.expr);
3771 /* Convert a typebound function reference from a class object. */
3773 conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
3778 if (!VAR_P (base_object))
3780 var = gfc_create_var (TREE_TYPE (base_object), NULL);
3781 gfc_add_modify (&se->pre, var, base_object);
3783 se->expr = gfc_class_vptr_get (base_object);
3784 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
3786 while (ref && ref->next)
3788 gcc_assert (ref && ref->type == REF_COMPONENT);
3789 if (ref->u.c.sym->attr.extension)
3790 conv_parent_component_references (se, ref);
3791 gfc_conv_component_ref (se, ref);
3792 se->expr = build_fold_addr_expr_loc (input_location, se->expr);
3797 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
3801 if (gfc_is_proc_ptr_comp (expr))
3802 tmp = get_proc_ptr_comp (expr);
3803 else if (sym->attr.dummy)
3805 tmp = gfc_get_symbol_decl (sym);
3806 if (sym->attr.proc_pointer)
3807 tmp = build_fold_indirect_ref_loc (input_location,
3809 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3810 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
3814 if (!sym->backend_decl)
3815 sym->backend_decl = gfc_get_extern_function_decl (sym);
3817 TREE_USED (sym->backend_decl) = 1;
3819 tmp = sym->backend_decl;
3821 if (sym->attr.cray_pointee)
3823 /* TODO - make the cray pointee a pointer to a procedure,
3824 assign the pointer to it and use it for the call. This
3826 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
3827 gfc_get_symbol_decl (sym->cp_pointer));
3828 tmp = gfc_evaluate_now (tmp, &se->pre);
3831 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
3833 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
3834 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
3841 /* Initialize MAPPING. */
3844 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
3846 mapping->syms = NULL;
3847 mapping->charlens = NULL;
3851 /* Free all memory held by MAPPING (but not MAPPING itself). */
3854 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
3856 gfc_interface_sym_mapping *sym;
3857 gfc_interface_sym_mapping *nextsym;
3859 gfc_charlen *nextcl;
3861 for (sym = mapping->syms; sym; sym = nextsym)
3863 nextsym = sym->next;
3864 sym->new_sym->n.sym->formal = NULL;
3865 gfc_free_symbol (sym->new_sym->n.sym);
3866 gfc_free_expr (sym->expr);
3867 free (sym->new_sym);
3870 for (cl = mapping->charlens; cl; cl = nextcl)
3873 gfc_free_expr (cl->length);
3879 /* Return a copy of gfc_charlen CL. Add the returned structure to
3880 MAPPING so that it will be freed by gfc_free_interface_mapping. */
3882 static gfc_charlen *
3883 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
3886 gfc_charlen *new_charlen;
3888 new_charlen = gfc_get_charlen ();
3889 new_charlen->next = mapping->charlens;
3890 new_charlen->length = gfc_copy_expr (cl->length);
3892 mapping->charlens = new_charlen;
3897 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
3898 array variable that can be used as the actual argument for dummy
3899 argument SYM. Add any initialization code to BLOCK. PACKED is as
3900 for gfc_get_nodesc_array_type and DATA points to the first element
3901 in the passed array. */
3904 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
3905 gfc_packed packed, tree data)
3910 type = gfc_typenode_for_spec (&sym->ts);
3911 type = gfc_get_nodesc_array_type (type, sym->as, packed,
3912 !sym->attr.target && !sym->attr.pointer
3913 && !sym->attr.proc_pointer);
3915 var = gfc_create_var (type, "ifm");
3916 gfc_add_modify (block, var, fold_convert (type, data));
3922 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
3923 and offset of descriptorless array type TYPE given that it has the same
3924 size as DESC. Add any set-up code to BLOCK. */
3927 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
3934 offset = gfc_index_zero_node;
3935 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
3937 dim = gfc_rank_cst[n];
3938 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
3939 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
3941 GFC_TYPE_ARRAY_LBOUND (type, n)
3942 = gfc_conv_descriptor_lbound_get (desc, dim);
3943 GFC_TYPE_ARRAY_UBOUND (type, n)
3944 = gfc_conv_descriptor_ubound_get (desc, dim);
3946 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
3948 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3949 gfc_array_index_type,
3950 gfc_conv_descriptor_ubound_get (desc, dim),
3951 gfc_conv_descriptor_lbound_get (desc, dim));
3952 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3953 gfc_array_index_type,
3954 GFC_TYPE_ARRAY_LBOUND (type, n), tmp);
3955 tmp = gfc_evaluate_now (tmp, block);
3956 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
3958 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3959 GFC_TYPE_ARRAY_LBOUND (type, n),
3960 GFC_TYPE_ARRAY_STRIDE (type, n));
3961 offset = fold_build2_loc (input_location, MINUS_EXPR,
3962 gfc_array_index_type, offset, tmp);
3964 offset = gfc_evaluate_now (offset, block);
3965 GFC_TYPE_ARRAY_OFFSET (type) = offset;
3969 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
3970 in SE. The caller may still use se->expr and se->string_length after
3971 calling this function. */
3974 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
3975 gfc_symbol * sym, gfc_se * se,
3978 gfc_interface_sym_mapping *sm;
3982 gfc_symbol *new_sym;
3984 gfc_symtree *new_symtree;
3986 /* Create a new symbol to represent the actual argument. */
3987 new_sym = gfc_new_symbol (sym->name, NULL);
3988 new_sym->ts = sym->ts;
3989 new_sym->as = gfc_copy_array_spec (sym->as);
3990 new_sym->attr.referenced = 1;
3991 new_sym->attr.dimension = sym->attr.dimension;
3992 new_sym->attr.contiguous = sym->attr.contiguous;
3993 new_sym->attr.codimension = sym->attr.codimension;
3994 new_sym->attr.pointer = sym->attr.pointer;
3995 new_sym->attr.allocatable = sym->attr.allocatable;
3996 new_sym->attr.flavor = sym->attr.flavor;
3997 new_sym->attr.function = sym->attr.function;
3999 /* Ensure that the interface is available and that
4000 descriptors are passed for array actual arguments. */
4001 if (sym->attr.flavor == FL_PROCEDURE)
4003 new_sym->formal = expr->symtree->n.sym->formal;
4004 new_sym->attr.always_explicit
4005 = expr->symtree->n.sym->attr.always_explicit;
4008 /* Create a fake symtree for it. */
4010 new_symtree = gfc_new_symtree (&root, sym->name);
4011 new_symtree->n.sym = new_sym;
4012 gcc_assert (new_symtree == root);
4014 /* Create a dummy->actual mapping. */
4015 sm = XCNEW (gfc_interface_sym_mapping);
4016 sm->next = mapping->syms;
4018 sm->new_sym = new_symtree;
4019 sm->expr = gfc_copy_expr (expr);
4022 /* Stabilize the argument's value. */
4023 if (!sym->attr.function && se)
4024 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4026 if (sym->ts.type == BT_CHARACTER)
4028 /* Create a copy of the dummy argument's length. */
4029 new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
4030 sm->expr->ts.u.cl = new_sym->ts.u.cl;
4032 /* If the length is specified as "*", record the length that
4033 the caller is passing. We should use the callee's length
4034 in all other cases. */
4035 if (!new_sym->ts.u.cl->length && se)
4037 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
4038 new_sym->ts.u.cl->backend_decl = se->string_length;
4045 /* Use the passed value as-is if the argument is a function. */
4046 if (sym->attr.flavor == FL_PROCEDURE)
4049 /* If the argument is a pass-by-value scalar, use the value as is. */
4050 else if (!sym->attr.dimension && sym->attr.value)
4053 /* If the argument is either a string or a pointer to a string,
4054 convert it to a boundless character type. */
4055 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
4057 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
4058 tmp = build_pointer_type (tmp);
4059 if (sym->attr.pointer)
4060 value = build_fold_indirect_ref_loc (input_location,
4064 value = fold_convert (tmp, value);
4067 /* If the argument is a scalar, a pointer to an array or an allocatable,
4069 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
4070 value = build_fold_indirect_ref_loc (input_location,
4073 /* For character(*), use the actual argument's descriptor. */
4074 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
4075 value = build_fold_indirect_ref_loc (input_location,
4078 /* If the argument is an array descriptor, use it to determine
4079 information about the actual argument's shape. */
4080 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
4081 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
4083 /* Get the actual argument's descriptor. */
4084 desc = build_fold_indirect_ref_loc (input_location,
4087 /* Create the replacement variable. */
4088 tmp = gfc_conv_descriptor_data_get (desc);
4089 value = gfc_get_interface_mapping_array (&se->pre, sym,
4092 /* Use DESC to work out the upper bounds, strides and offset. */
4093 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
4096 /* Otherwise we have a packed array. */
4097 value = gfc_get_interface_mapping_array (&se->pre, sym,
4098 PACKED_FULL, se->expr);
4100 new_sym->backend_decl = value;
4104 /* Called once all dummy argument mappings have been added to MAPPING,
4105 but before the mapping is used to evaluate expressions. Pre-evaluate
4106 the length of each argument, adding any initialization code to PRE and
4107 any finalization code to POST. */
4110 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
4111 stmtblock_t * pre, stmtblock_t * post)
4113 gfc_interface_sym_mapping *sym;
4117 for (sym = mapping->syms; sym; sym = sym->next)
4118 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
4119 && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
4121 expr = sym->new_sym->n.sym->ts.u.cl->length;
4122 gfc_apply_interface_mapping_to_expr (mapping, expr);
4123 gfc_init_se (&se, NULL);
4124 gfc_conv_expr (&se, expr);
4125 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
4126 se.expr = gfc_evaluate_now (se.expr, &se.pre);
4127 gfc_add_block_to_block (pre, &se.pre);
4128 gfc_add_block_to_block (post, &se.post);
4130 sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
4135 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4139 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
4140 gfc_constructor_base base)
4143 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
4145 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
4148 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
4149 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
4150 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
4156 /* Like gfc_apply_interface_mapping_to_expr, but applied to
4160 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
4165 for (; ref; ref = ref->next)
4169 for (n = 0; n < ref->u.ar.dimen; n++)
4171 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
4172 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
4173 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
4182 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
4183 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
4189 /* Convert intrinsic function calls into result expressions. */
4192 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
4200 arg1 = expr->value.function.actual->expr;
4201 if (expr->value.function.actual->next)
4202 arg2 = expr->value.function.actual->next->expr;
4206 sym = arg1->symtree->n.sym;
4208 if (sym->attr.dummy)
4213 switch (expr->value.function.isym->id)
4216 /* TODO figure out why this condition is necessary. */
4217 if (sym->attr.function
4218 && (arg1->ts.u.cl->length == NULL
4219 || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
4220 && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
4223 new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
4226 case GFC_ISYM_LEN_TRIM:
4227 new_expr = gfc_copy_expr (arg1);
4228 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4233 gfc_replace_expr (arg1, new_expr);
4237 if (!sym->as || sym->as->rank == 0)
4240 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4242 dup = mpz_get_si (arg2->value.integer);
4247 dup = sym->as->rank;
4251 for (; d < dup; d++)
4255 if (!sym->as->upper[d] || !sym->as->lower[d])
4257 gfc_free_expr (new_expr);
4261 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
4262 gfc_get_int_expr (gfc_default_integer_kind,
4264 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
4266 new_expr = gfc_multiply (new_expr, tmp);
4272 case GFC_ISYM_LBOUND:
4273 case GFC_ISYM_UBOUND:
4274 /* TODO These implementations of lbound and ubound do not limit if
4275 the size < 0, according to F95's 13.14.53 and 13.14.113. */
4277 if (!sym->as || sym->as->rank == 0)
4280 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
4281 d = mpz_get_si (arg2->value.integer) - 1;
4285 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
4287 if (sym->as->lower[d])
4288 new_expr = gfc_copy_expr (sym->as->lower[d]);
4292 if (sym->as->upper[d])
4293 new_expr = gfc_copy_expr (sym->as->upper[d]);
4301 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
4305 gfc_replace_expr (expr, new_expr);
4311 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
4312 gfc_interface_mapping * mapping)
4314 gfc_formal_arglist *f;
4315 gfc_actual_arglist *actual;
4317 actual = expr->value.function.actual;
4318 f = gfc_sym_get_dummy_args (map_expr->symtree->n.sym);
4320 for (; f && actual; f = f->next, actual = actual->next)
4325 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
4328 if (map_expr->symtree->n.sym->attr.dimension)
4333 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
4335 for (d = 0; d < as->rank; d++)
4337 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
4338 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
4341 expr->value.function.esym->as = as;
4344 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
4346 expr->value.function.esym->ts.u.cl->length
4347 = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
4349 gfc_apply_interface_mapping_to_expr (mapping,
4350 expr->value.function.esym->ts.u.cl->length);
4355 /* EXPR is a copy of an expression that appeared in the interface
4356 associated with MAPPING. Walk it recursively looking for references to
4357 dummy arguments that MAPPING maps to actual arguments. Replace each such
4358 reference with a reference to the associated actual argument. */
4361 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
4364 gfc_interface_sym_mapping *sym;
4365 gfc_actual_arglist *actual;
4370 /* Copying an expression does not copy its length, so do that here. */
4371 if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
4373 expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
4374 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
4377 /* Apply the mapping to any references. */
4378 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
4380 /* ...and to the expression's symbol, if it has one. */
4381 /* TODO Find out why the condition on expr->symtree had to be moved into
4382 the loop rather than being outside it, as originally. */
4383 for (sym = mapping->syms; sym; sym = sym->next)
4384 if (expr->symtree && sym->old == expr->symtree->n.sym)
4386 if (sym->new_sym->n.sym->backend_decl)
4387 expr->symtree = sym->new_sym;
4389 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
4392 /* ...and to subexpressions in expr->value. */
4393 switch (expr->expr_type)
4398 case EXPR_SUBSTRING:
4402 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
4403 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
4407 for (actual = expr->value.function.actual; actual; actual = actual->next)
4408 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
4410 if (expr->value.function.esym == NULL
4411 && expr->value.function.isym != NULL
4412 && expr->value.function.actual
4413 && expr->value.function.actual->expr
4414 && expr->value.function.actual->expr->symtree
4415 && gfc_map_intrinsic_function (expr, mapping))
4418 for (sym = mapping->syms; sym; sym = sym->next)
4419 if (sym->old == expr->value.function.esym)
4421 expr->value.function.esym = sym->new_sym->n.sym;
4422 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
4423 expr->value.function.esym->result = sym->new_sym->n.sym;
4428 case EXPR_STRUCTURE:
4429 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
4442 /* Evaluate interface expression EXPR using MAPPING. Store the result
4446 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
4447 gfc_se * se, gfc_expr * expr)
4449 expr = gfc_copy_expr (expr);
4450 gfc_apply_interface_mapping_to_expr (mapping, expr);
4451 gfc_conv_expr (se, expr);
4452 se->expr = gfc_evaluate_now (se->expr, &se->pre);
4453 gfc_free_expr (expr);
4457 /* Returns a reference to a temporary array into which a component of
4458 an actual argument derived type array is copied and then returned
4459 after the function call. */
4461 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
4462 sym_intent intent, bool formal_ptr)
4470 gfc_array_info *info;
4480 gfc_init_se (&lse, NULL);
4481 gfc_init_se (&rse, NULL);
4483 /* Walk the argument expression. */
4484 rss = gfc_walk_expr (expr);
4486 gcc_assert (rss != gfc_ss_terminator);
4488 /* Initialize the scalarizer. */
4489 gfc_init_loopinfo (&loop);
4490 gfc_add_ss_to_loop (&loop, rss);
4492 /* Calculate the bounds of the scalarization. */
4493 gfc_conv_ss_startstride (&loop);
4495 /* Build an ss for the temporary. */
4496 if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
4497 gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
4499 base_type = gfc_typenode_for_spec (&expr->ts);
4500 if (GFC_ARRAY_TYPE_P (base_type)
4501 || GFC_DESCRIPTOR_TYPE_P (base_type))
4502 base_type = gfc_get_element_type (base_type);
4504 if (expr->ts.type == BT_CLASS)
4505 base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts);
4507 loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
4508 ? expr->ts.u.cl->backend_decl
4512 parmse->string_length = loop.temp_ss->info->string_length;
4514 /* Associate the SS with the loop. */
4515 gfc_add_ss_to_loop (&loop, loop.temp_ss);
4517 /* Setup the scalarizing loops. */
4518 gfc_conv_loop_setup (&loop, &expr->where);
4520 /* Pass the temporary descriptor back to the caller. */
4521 info = &loop.temp_ss->info->data.array;
4522 parmse->expr = info->descriptor;
4524 /* Setup the gfc_se structures. */
4525 gfc_copy_loopinfo_to_se (&lse, &loop);
4526 gfc_copy_loopinfo_to_se (&rse, &loop);
4529 lse.ss = loop.temp_ss;
4530 gfc_mark_ss_chain_used (rss, 1);
4531 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4533 /* Start the scalarized loop body. */
4534 gfc_start_scalarized_body (&loop, &body);
4536 /* Translate the expression. */
4537 gfc_conv_expr (&rse, expr);
4539 /* Reset the offset for the function call since the loop
4540 is zero based on the data pointer. Note that the temp
4541 comes first in the loop chain since it is added second. */
4542 if (gfc_is_class_array_function (expr))
4544 tmp = loop.ss->loop_chain->info->data.array.descriptor;
4545 gfc_conv_descriptor_offset_set (&loop.pre, tmp,
4546 gfc_index_zero_node);
4549 gfc_conv_tmp_array_ref (&lse);
4551 if (intent != INTENT_OUT)
4553 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
4554 gfc_add_expr_to_block (&body, tmp);
4555 gcc_assert (rse.ss == gfc_ss_terminator);
4556 gfc_trans_scalarizing_loops (&loop, &body);
4560 /* Make sure that the temporary declaration survives by merging
4561 all the loop declarations into the current context. */
4562 for (n = 0; n < loop.dimen; n++)
4564 gfc_merge_block_scope (&body);
4565 body = loop.code[loop.order[n]];
4567 gfc_merge_block_scope (&body);
4570 /* Add the post block after the second loop, so that any
4571 freeing of allocated memory is done at the right time. */
4572 gfc_add_block_to_block (&parmse->pre, &loop.pre);
4574 /**********Copy the temporary back again.*********/
4576 gfc_init_se (&lse, NULL);
4577 gfc_init_se (&rse, NULL);
4579 /* Walk the argument expression. */
4580 lss = gfc_walk_expr (expr);
4581 rse.ss = loop.temp_ss;
4584 /* Initialize the scalarizer. */
4585 gfc_init_loopinfo (&loop2);
4586 gfc_add_ss_to_loop (&loop2, lss);
4588 dimen = rse.ss->dimen;
4590 /* Skip the write-out loop for this case. */
4591 if (gfc_is_class_array_function (expr))
4592 goto class_array_fcn;
4594 /* Calculate the bounds of the scalarization. */
4595 gfc_conv_ss_startstride (&loop2);
4597 /* Setup the scalarizing loops. */
4598 gfc_conv_loop_setup (&loop2, &expr->where);
4600 gfc_copy_loopinfo_to_se (&lse, &loop2);
4601 gfc_copy_loopinfo_to_se (&rse, &loop2);
4603 gfc_mark_ss_chain_used (lss, 1);
4604 gfc_mark_ss_chain_used (loop.temp_ss, 1);
4606 /* Declare the variable to hold the temporary offset and start the
4607 scalarized loop body. */
4608 offset = gfc_create_var (gfc_array_index_type, NULL);
4609 gfc_start_scalarized_body (&loop2, &body);
4611 /* Build the offsets for the temporary from the loop variables. The
4612 temporary array has lbounds of zero and strides of one in all
4613 dimensions, so this is very simple. The offset is only computed
4614 outside the innermost loop, so the overall transfer could be
4615 optimized further. */
4616 info = &rse.ss->info->data.array;
4618 tmp_index = gfc_index_zero_node;
4619 for (n = dimen - 1; n > 0; n--)
4622 tmp = rse.loop->loopvar[n];
4623 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4624 tmp, rse.loop->from[n]);
4625 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4628 tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
4629 gfc_array_index_type,
4630 rse.loop->to[n-1], rse.loop->from[n-1]);
4631 tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
4632 gfc_array_index_type,
4633 tmp_str, gfc_index_one_node);
4635 tmp_index = fold_build2_loc (input_location, MULT_EXPR,
4636 gfc_array_index_type, tmp, tmp_str);
4639 tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
4640 gfc_array_index_type,
4641 tmp_index, rse.loop->from[0]);
4642 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
4644 tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
4645 gfc_array_index_type,
4646 rse.loop->loopvar[0], offset);
4648 /* Now use the offset for the reference. */
4649 tmp = build_fold_indirect_ref_loc (input_location,
4651 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
4653 if (expr->ts.type == BT_CHARACTER)
4654 rse.string_length = expr->ts.u.cl->backend_decl;
4656 gfc_conv_expr (&lse, expr);
4658 gcc_assert (lse.ss == gfc_ss_terminator);
4660 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true);
4661 gfc_add_expr_to_block (&body, tmp);
4663 /* Generate the copying loops. */
4664 gfc_trans_scalarizing_loops (&loop2, &body);
4666 /* Wrap the whole thing up by adding the second loop to the post-block
4667 and following it by the post-block of the first loop. In this way,
4668 if the temporary needs freeing, it is done after use! */
4669 if (intent != INTENT_IN)
4671 gfc_add_block_to_block (&parmse->post, &loop2.pre);
4672 gfc_add_block_to_block (&parmse->post, &loop2.post);
4677 gfc_add_block_to_block (&parmse->post, &loop.post);
4679 gfc_cleanup_loop (&loop);
4680 gfc_cleanup_loop (&loop2);
4682 /* Pass the string length to the argument expression. */
4683 if (expr->ts.type == BT_CHARACTER)
4684 parmse->string_length = expr->ts.u.cl->backend_decl;
4686 /* Determine the offset for pointer formal arguments and set the
4690 size = gfc_index_one_node;
4691 offset = gfc_index_zero_node;
4692 for (n = 0; n < dimen; n++)
4694 tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
4696 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4697 gfc_array_index_type, tmp,
4698 gfc_index_one_node);
4699 gfc_conv_descriptor_ubound_set (&parmse->pre,
4703 gfc_conv_descriptor_lbound_set (&parmse->pre,
4706 gfc_index_one_node);
4707 size = gfc_evaluate_now (size, &parmse->pre);
4708 offset = fold_build2_loc (input_location, MINUS_EXPR,
4709 gfc_array_index_type,
4711 offset = gfc_evaluate_now (offset, &parmse->pre);
4712 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4713 gfc_array_index_type,
4714 rse.loop->to[n], rse.loop->from[n]);
4715 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4716 gfc_array_index_type,
4717 tmp, gfc_index_one_node);
4718 size = fold_build2_loc (input_location, MULT_EXPR,
4719 gfc_array_index_type, size, tmp);
4722 gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
4726 /* We want either the address for the data or the address of the descriptor,
4727 depending on the mode of passing array arguments. */
4729 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
4731 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
4737 /* Generate the code for argument list functions. */
4740 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
4742 /* Pass by value for g77 %VAL(arg), pass the address
4743 indirectly for %LOC, else by reference. Thus %REF
4744 is a "do-nothing" and %LOC is the same as an F95
4746 if (strcmp (name, "%VAL") == 0)
4747 gfc_conv_expr (se, expr);
4748 else if (strcmp (name, "%LOC") == 0)
4750 gfc_conv_expr_reference (se, expr);
4751 se->expr = gfc_build_addr_expr (NULL, se->expr);
4753 else if (strcmp (name, "%REF") == 0)
4754 gfc_conv_expr_reference (se, expr);
4756 gfc_error ("Unknown argument list function at %L", &expr->where);
4760 /* This function tells whether the middle-end representation of the expression
4761 E given as input may point to data otherwise accessible through a variable
4763 It is assumed that the only expressions that may alias are variables,
4764 and array constructors if ARRAY_MAY_ALIAS is true and some of its elements
4766 This function is used to decide whether freeing an expression's allocatable
4767 components is safe or should be avoided.
4769 If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of
4770 its elements are copied from a variable. This ARRAY_MAY_ALIAS trick
4771 is necessary because for array constructors, aliasing depends on how
4773 - If E is an array constructor used as argument to an elemental procedure,
4774 the array, which is generated through shallow copy by the scalarizer,
4775 is used directly and can alias the expressions it was copied from.
4776 - If E is an array constructor used as argument to a non-elemental
4777 procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate
4778 the array as in the previous case, but then that array is used
4779 to initialize a new descriptor through deep copy. There is no alias
4780 possible in that case.
4781 Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases
4785 expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
4789 if (e->expr_type == EXPR_VARIABLE)
4791 else if (e->expr_type == EXPR_FUNCTION)
4793 gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e);
4795 if (proc_ifc->result != NULL
4796 && ((proc_ifc->result->ts.type == BT_CLASS
4797 && proc_ifc->result->ts.u.derived->attr.is_class
4798 && CLASS_DATA (proc_ifc->result)->attr.class_pointer)
4799 || proc_ifc->result->attr.pointer))
4804 else if (e->expr_type != EXPR_ARRAY || !array_may_alias)
4807 for (c = gfc_constructor_first (e->value.constructor);
4808 c; c = gfc_constructor_next (c))
4810 && expr_may_alias_variables (c->expr, array_may_alias))
4817 /* Generate code for a procedure call. Note can return se->post != NULL.
4818 If se->direct_byref is set then se->expr contains the return parameter.
4819 Return nonzero, if the call has alternate specifiers.
4820 'expr' is only needed for procedure pointer components. */
4823 gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
4824 gfc_actual_arglist * args, gfc_expr * expr,
4825 vec<tree, va_gc> *append_args)
4827 gfc_interface_mapping mapping;
4828 vec<tree, va_gc> *arglist;
4829 vec<tree, va_gc> *retargs;
4833 gfc_array_info *info;
4840 vec<tree, va_gc> *stringargs;
4841 vec<tree, va_gc> *optionalargs;
4843 gfc_formal_arglist *formal;
4844 gfc_actual_arglist *arg;
4845 int has_alternate_specifier = 0;
4846 bool need_interface_mapping;
4854 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
4855 gfc_component *comp = NULL;
4862 optionalargs = NULL;
4867 comp = gfc_get_proc_ptr_comp (expr);
4869 bool elemental_proc = (comp
4870 && comp->ts.interface
4871 && comp->ts.interface->attr.elemental)
4872 || (comp && comp->attr.elemental)
4873 || sym->attr.elemental;
4877 if (!elemental_proc)
4879 gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
4880 if (se->ss->info->useflags)
4882 gcc_assert ((!comp && gfc_return_by_reference (sym)
4883 && sym->result->attr.dimension)
4884 || (comp && comp->attr.dimension)
4885 || gfc_is_class_array_function (expr));
4886 gcc_assert (se->loop != NULL);
4887 /* Access the previously obtained result. */
4888 gfc_conv_tmp_array_ref (se);
4892 info = &se->ss->info->data.array;
4897 gfc_init_block (&post);
4898 gfc_init_interface_mapping (&mapping);
4901 formal = gfc_sym_get_dummy_args (sym);
4902 need_interface_mapping = sym->attr.dimension ||
4903 (sym->ts.type == BT_CHARACTER
4904 && sym->ts.u.cl->length
4905 && sym->ts.u.cl->length->expr_type
4910 formal = comp->ts.interface ? comp->ts.interface->formal : NULL;
4911 need_interface_mapping = comp->attr.dimension ||
4912 (comp->ts.type == BT_CHARACTER
4913 && comp->ts.u.cl->length
4914 && comp->ts.u.cl->length->expr_type
4918 base_object = NULL_TREE;
4919 /* For _vprt->_copy () routines no formal symbol is present. Nevertheless
4920 is the third and fourth argument to such a function call a value
4921 denoting the number of elements to copy (i.e., most of the time the
4922 length of a deferred length string). */
4923 ulim_copy = (formal == NULL)
4924 && UNLIMITED_POLY (sym)
4925 && comp && (strcmp ("_copy", comp->name) == 0);
4927 /* Evaluate the arguments. */
4928 for (arg = args, argc = 0; arg != NULL;
4929 arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
4931 bool finalized = false;
4934 fsym = formal ? formal->sym : NULL;
4935 parm_kind = MISSING;
4937 /* If the procedure requires an explicit interface, the actual
4938 argument is passed according to the corresponding formal
4939 argument. If the corresponding formal argument is a POINTER,
4940 ALLOCATABLE or assumed shape, we do not use g77's calling
4941 convention, and pass the address of the array descriptor
4942 instead. Otherwise we use g77's calling convention, in other words
4943 pass the array data pointer without descriptor. */
4944 bool nodesc_arg = fsym != NULL
4945 && !(fsym->attr.pointer || fsym->attr.allocatable)
4947 && fsym->as->type != AS_ASSUMED_SHAPE
4948 && fsym->as->type != AS_ASSUMED_RANK;
4950 nodesc_arg = nodesc_arg || !comp->attr.always_explicit;
4952 nodesc_arg = nodesc_arg || !sym->attr.always_explicit;
4954 /* Class array expressions are sometimes coming completely unadorned
4955 with either arrayspec or _data component. Correct that here.
4956 OOP-TODO: Move this to the frontend. */
4957 if (e && e->expr_type == EXPR_VARIABLE
4959 && e->ts.type == BT_CLASS
4960 && (CLASS_DATA (e)->attr.codimension
4961 || CLASS_DATA (e)->attr.dimension))
4963 gfc_typespec temp_ts = e->ts;
4964 gfc_add_class_array_ref (e);
4970 if (se->ignore_optional)
4972 /* Some intrinsics have already been resolved to the correct
4976 else if (arg->label)
4978 has_alternate_specifier = 1;
4983 gfc_init_se (&parmse, NULL);
4985 /* For scalar arguments with VALUE attribute which are passed by
4986 value, pass "0" and a hidden argument gives the optional
4988 if (fsym && fsym->attr.optional && fsym->attr.value
4989 && !fsym->attr.dimension && fsym->ts.type != BT_CHARACTER
4990 && fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED)
4992 parmse.expr = fold_convert (gfc_sym_type (fsym),
4994 vec_safe_push (optionalargs, boolean_false_node);
4998 /* Pass a NULL pointer for an absent arg. */
4999 parmse.expr = null_pointer_node;
5000 if (arg->missing_arg_type == BT_CHARACTER)
5001 parmse.string_length = build_int_cst (gfc_charlen_type_node,
5006 else if (arg->expr->expr_type == EXPR_NULL
5007 && fsym && !fsym->attr.pointer
5008 && (fsym->ts.type != BT_CLASS
5009 || !CLASS_DATA (fsym)->attr.class_pointer))
5011 /* Pass a NULL pointer to denote an absent arg. */
5012 gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
5013 && (fsym->ts.type != BT_CLASS
5014 || !CLASS_DATA (fsym)->attr.allocatable));
5015 gfc_init_se (&parmse, NULL);
5016 parmse.expr = null_pointer_node;
5017 if (arg->missing_arg_type == BT_CHARACTER)
5018 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
5020 else if (fsym && fsym->ts.type == BT_CLASS
5021 && e->ts.type == BT_DERIVED)
5023 /* The derived type needs to be converted to a temporary
5025 gfc_init_se (&parmse, se);
5026 gfc_conv_derived_to_class (&parmse, e, fsym->ts, NULL,
5028 && e->expr_type == EXPR_VARIABLE
5029 && e->symtree->n.sym->attr.optional,
5030 CLASS_DATA (fsym)->attr.class_pointer
5031 || CLASS_DATA (fsym)->attr.allocatable);
5033 else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
5035 /* The intrinsic type needs to be converted to a temporary
5036 CLASS object for the unlimited polymorphic formal. */
5037 gfc_init_se (&parmse, se);
5038 gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
5040 else if (se->ss && se->ss->info->useflags)
5046 /* An elemental function inside a scalarized loop. */
5047 gfc_init_se (&parmse, se);
5048 parm_kind = ELEMENTAL;
5050 /* When no fsym is present, ulim_copy is set and this is a third or
5051 fourth argument, use call-by-value instead of by reference to
5052 hand the length properties to the copy routine (i.e., most of the
5053 time this will be a call to a __copy_character_* routine where the
5054 third and fourth arguments are the lengths of a deferred length
5056 if ((fsym && fsym->attr.value)
5057 || (ulim_copy && (argc == 2 || argc == 3)))
5058 gfc_conv_expr (&parmse, e);
5060 gfc_conv_expr_reference (&parmse, e);
5062 if (e->ts.type == BT_CHARACTER && !e->rank
5063 && e->expr_type == EXPR_FUNCTION)
5064 parmse.expr = build_fold_indirect_ref_loc (input_location,
5067 if (fsym && fsym->ts.type == BT_DERIVED
5068 && gfc_is_class_container_ref (e))
5070 parmse.expr = gfc_class_data_get (parmse.expr);
5072 if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
5073 && e->symtree->n.sym->attr.optional)
5075 tree cond = gfc_conv_expr_present (e->symtree->n.sym);
5076 parmse.expr = build3_loc (input_location, COND_EXPR,
5077 TREE_TYPE (parmse.expr),
5079 fold_convert (TREE_TYPE (parmse.expr),
5080 null_pointer_node));
5084 /* If we are passing an absent array as optional dummy to an
5085 elemental procedure, make sure that we pass NULL when the data
5086 pointer is NULL. We need this extra conditional because of
5087 scalarization which passes arrays elements to the procedure,
5088 ignoring the fact that the array can be absent/unallocated/... */
5089 if (ss->info->can_be_null_ref && ss->info->type != GFC_SS_REFERENCE)
5091 tree descriptor_data;
5093 descriptor_data = ss->info->data.array.data;
5094 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
5096 fold_convert (TREE_TYPE (descriptor_data),
5097 null_pointer_node));
5099 = fold_build3_loc (input_location, COND_EXPR,
5100 TREE_TYPE (parmse.expr),
5101 gfc_unlikely (tmp, PRED_FORTRAN_ABSENT_DUMMY),
5102 fold_convert (TREE_TYPE (parmse.expr),
5107 /* The scalarizer does not repackage the reference to a class
5108 array - instead it returns a pointer to the data element. */
5109 if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
5110 gfc_conv_class_to_class (&parmse, e, fsym->ts, true,
5111 fsym->attr.intent != INTENT_IN
5112 && (CLASS_DATA (fsym)->attr.class_pointer
5113 || CLASS_DATA (fsym)->attr.allocatable),
5115 && e->expr_type == EXPR_VARIABLE
5116 && e->symtree->n.sym->attr.optional,
5117 CLASS_DATA (fsym)->attr.class_pointer
5118 || CLASS_DATA (fsym)->attr.allocatable);
5125 gfc_init_se (&parmse, NULL);
5127 /* Check whether the expression is a scalar or not; we cannot use
5128 e->rank as it can be nonzero for functions arguments. */
5129 argss = gfc_walk_expr (e);
5130 scalar = argss == gfc_ss_terminator;
5132 gfc_free_ss_chain (argss);
5134 /* Special handling for passing scalar polymorphic coarrays;
5135 otherwise one passes "class->_data.data" instead of "&class". */
5136 if (e->rank == 0 && e->ts.type == BT_CLASS
5137 && fsym && fsym->ts.type == BT_CLASS
5138 && CLASS_DATA (fsym)->attr.codimension
5139 && !CLASS_DATA (fsym)->attr.dimension)
5141 gfc_add_class_array_ref (e);
5142 parmse.want_coarray = 1;
5146 /* A scalar or transformational function. */
5149 if (e->expr_type == EXPR_VARIABLE
5150 && e->symtree->n.sym->attr.cray_pointee
5151 && fsym && fsym->attr.flavor == FL_PROCEDURE)
5153 /* The Cray pointer needs to be converted to a pointer to
5154 a type given by the expression. */
5155 gfc_conv_expr (&parmse, e);
5156 type = build_pointer_type (TREE_TYPE (parmse.expr));
5157 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
5158 parmse.expr = convert (type, tmp);
5160 else if (fsym && fsym->attr.value)
5162 if (fsym->ts.type == BT_CHARACTER
5163 && fsym->ts.is_c_interop
5164 && fsym->ns->proc_name != NULL
5165 && fsym->ns->proc_name->attr.is_bind_c)
5168 gfc_conv_scalar_char_value (fsym, &parmse, &e);
5169 if (parmse.expr == NULL)
5170 gfc_conv_expr (&parmse, e);
5174 gfc_conv_expr (&parmse, e);
5175 if (fsym->attr.optional
5176 && fsym->ts.type != BT_CLASS
5177 && fsym->ts.type != BT_DERIVED)
5179 if (e->expr_type != EXPR_VARIABLE
5180 || !e->symtree->n.sym->attr.optional
5182 vec_safe_push (optionalargs, boolean_true_node);
5185 tmp = gfc_conv_expr_present (e->symtree->n.sym);
5186 if (!e->symtree->n.sym->attr.value)
5188 = fold_build3_loc (input_location, COND_EXPR,
5189 TREE_TYPE (parmse.expr),
5191 fold_convert (TREE_TYPE (parmse.expr),
5192 integer_zero_node));
5194 vec_safe_push (optionalargs, tmp);
5199 else if (arg->name && arg->name[0] == '%')
5200 /* Argument list functions %VAL, %LOC and %REF are signalled
5201 through arg->name. */
5202 conv_arglist_function (&parmse, arg->expr, arg->name);
5203 else if ((e->expr_type == EXPR_FUNCTION)
5204 && ((e->value.function.esym
5205 && e->value.function.esym->result->attr.pointer)
5206 || (!e->value.function.esym
5207 && e->symtree->n.sym->attr.pointer))
5208 && fsym && fsym->attr.target)
5210 gfc_conv_expr (&parmse, e);
5211 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5213 else if (e->expr_type == EXPR_FUNCTION
5214 && e->symtree->n.sym->result
5215 && e->symtree->n.sym->result != e->symtree->n.sym
5216 && e->symtree->n.sym->result->attr.proc_pointer)
5218 /* Functions returning procedure pointers. */
5219 gfc_conv_expr (&parmse, e);
5220 if (fsym && fsym->attr.proc_pointer)
5221 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5225 if (e->ts.type == BT_CLASS && fsym
5226 && fsym->ts.type == BT_CLASS
5227 && (!CLASS_DATA (fsym)->as
5228 || CLASS_DATA (fsym)->as->type != AS_ASSUMED_RANK)
5229 && CLASS_DATA (e)->attr.codimension)
5231 gcc_assert (!CLASS_DATA (fsym)->attr.codimension);
5232 gcc_assert (!CLASS_DATA (fsym)->as);
5233 gfc_add_class_array_ref (e);
5234 parmse.want_coarray = 1;
5235 gfc_conv_expr_reference (&parmse, e);
5236 class_scalar_coarray_to_class (&parmse, e, fsym->ts,
5238 && e->expr_type == EXPR_VARIABLE);
5240 else if (e->ts.type == BT_CLASS && fsym
5241 && fsym->ts.type == BT_CLASS
5242 && !CLASS_DATA (fsym)->as
5243 && !CLASS_DATA (e)->as
5244 && strcmp (fsym->ts.u.derived->name,
5245 e->ts.u.derived->name))
5247 type = gfc_typenode_for_spec (&fsym->ts);
5248 var = gfc_create_var (type, fsym->name);
5249 gfc_conv_expr (&parmse, e);
5250 if (fsym->attr.optional
5251 && e->expr_type == EXPR_VARIABLE
5252 && e->symtree->n.sym->attr.optional)
5256 tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5257 cond = fold_build2_loc (input_location, NE_EXPR,
5258 logical_type_node, tmp,
5259 fold_convert (TREE_TYPE (tmp),
5260 null_pointer_node));
5261 gfc_start_block (&block);
5262 gfc_add_modify (&block, var,
5263 fold_build1_loc (input_location,
5265 type, parmse.expr));
5266 gfc_add_expr_to_block (&parmse.pre,
5267 fold_build3_loc (input_location,
5268 COND_EXPR, void_type_node,
5269 cond, gfc_finish_block (&block),
5270 build_empty_stmt (input_location)));
5271 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5272 parmse.expr = build3_loc (input_location, COND_EXPR,
5273 TREE_TYPE (parmse.expr),
5275 fold_convert (TREE_TYPE (parmse.expr),
5276 null_pointer_node));
5280 /* Since the internal representation of unlimited
5281 polymorphic expressions includes an extra field
5282 that other class objects do not, a cast to the
5283 formal type does not work. */
5284 if (!UNLIMITED_POLY (e) && UNLIMITED_POLY (fsym))
5288 /* Set the _data field. */
5289 tmp = gfc_class_data_get (var);
5290 efield = fold_convert (TREE_TYPE (tmp),
5291 gfc_class_data_get (parmse.expr));
5292 gfc_add_modify (&parmse.pre, tmp, efield);
5294 /* Set the _vptr field. */
5295 tmp = gfc_class_vptr_get (var);
5296 efield = fold_convert (TREE_TYPE (tmp),
5297 gfc_class_vptr_get (parmse.expr));
5298 gfc_add_modify (&parmse.pre, tmp, efield);
5300 /* Set the _len field. */
5301 tmp = gfc_class_len_get (var);
5302 gfc_add_modify (&parmse.pre, tmp,
5303 build_int_cst (TREE_TYPE (tmp), 0));
5307 tmp = fold_build1_loc (input_location,
5310 gfc_add_modify (&parmse.pre, var, tmp);
5313 parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
5319 add_clobber = fsym && fsym->attr.intent == INTENT_OUT
5320 && !fsym->attr.allocatable && !fsym->attr.pointer
5321 && !e->symtree->n.sym->attr.dimension
5322 && !e->symtree->n.sym->attr.pointer
5324 && !e->symtree->n.sym->attr.dummy
5325 /* FIXME - PR 87395 and PR 41453 */
5326 && e->symtree->n.sym->attr.save == SAVE_NONE
5327 && !e->symtree->n.sym->attr.associate_var
5328 && e->ts.type != BT_CHARACTER && e->ts.type != BT_DERIVED
5329 && e->ts.type != BT_CLASS && !sym->attr.elemental;
5331 gfc_conv_expr_reference (&parmse, e, add_clobber);
5333 /* Catch base objects that are not variables. */
5334 if (e->ts.type == BT_CLASS
5335 && e->expr_type != EXPR_VARIABLE
5336 && expr && e == expr->base_expr)
5337 base_object = build_fold_indirect_ref_loc (input_location,
5340 /* A class array element needs converting back to be a
5341 class object, if the formal argument is a class object. */
5342 if (fsym && fsym->ts.type == BT_CLASS
5343 && e->ts.type == BT_CLASS
5344 && ((CLASS_DATA (fsym)->as
5345 && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
5346 || CLASS_DATA (e)->attr.dimension))
5347 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5348 fsym->attr.intent != INTENT_IN
5349 && (CLASS_DATA (fsym)->attr.class_pointer
5350 || CLASS_DATA (fsym)->attr.allocatable),
5352 && e->expr_type == EXPR_VARIABLE
5353 && e->symtree->n.sym->attr.optional,
5354 CLASS_DATA (fsym)->attr.class_pointer
5355 || CLASS_DATA (fsym)->attr.allocatable);
5357 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5358 allocated on entry, it must be deallocated. */
5359 if (fsym && fsym->attr.intent == INTENT_OUT
5360 && (fsym->attr.allocatable
5361 || (fsym->ts.type == BT_CLASS
5362 && CLASS_DATA (fsym)->attr.allocatable)))
5367 gfc_init_block (&block);
5369 if (e->ts.type == BT_CLASS)
5370 ptr = gfc_class_data_get (ptr);
5372 tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
5375 gfc_add_expr_to_block (&block, tmp);
5376 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5377 void_type_node, ptr,
5379 gfc_add_expr_to_block (&block, tmp);
5381 if (fsym->ts.type == BT_CLASS && UNLIMITED_POLY (fsym))
5383 gfc_add_modify (&block, ptr,
5384 fold_convert (TREE_TYPE (ptr),
5385 null_pointer_node));
5386 gfc_add_expr_to_block (&block, tmp);
5388 else if (fsym->ts.type == BT_CLASS)
5391 vtab = gfc_find_derived_vtab (fsym->ts.u.derived);
5392 tmp = gfc_get_symbol_decl (vtab);
5393 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5394 ptr = gfc_class_vptr_get (parmse.expr);
5395 gfc_add_modify (&block, ptr,
5396 fold_convert (TREE_TYPE (ptr), tmp));
5397 gfc_add_expr_to_block (&block, tmp);
5400 if (fsym->attr.optional
5401 && e->expr_type == EXPR_VARIABLE
5402 && e->symtree->n.sym->attr.optional)
5404 tmp = fold_build3_loc (input_location, COND_EXPR,
5406 gfc_conv_expr_present (e->symtree->n.sym),
5407 gfc_finish_block (&block),
5408 build_empty_stmt (input_location));
5411 tmp = gfc_finish_block (&block);
5413 gfc_add_expr_to_block (&se->pre, tmp);
5416 if (fsym && (fsym->ts.type == BT_DERIVED
5417 || fsym->ts.type == BT_ASSUMED)
5418 && e->ts.type == BT_CLASS
5419 && !CLASS_DATA (e)->attr.dimension
5420 && !CLASS_DATA (e)->attr.codimension)
5422 parmse.expr = gfc_class_data_get (parmse.expr);
5423 /* The result is a class temporary, whose _data component
5424 must be freed to avoid a memory leak. */
5425 if (e->expr_type == EXPR_FUNCTION
5426 && CLASS_DATA (e)->attr.allocatable)
5432 /* Borrow the function symbol to make a call to
5433 gfc_add_finalizer_call and then restore it. */
5434 tmp = e->symtree->n.sym->backend_decl;
5435 e->symtree->n.sym->backend_decl
5436 = TREE_OPERAND (parmse.expr, 0);
5437 e->symtree->n.sym->attr.flavor = FL_VARIABLE;
5438 var = gfc_lval_expr_from_sym (e->symtree->n.sym);
5439 finalized = gfc_add_finalizer_call (&parmse.post,
5441 gfc_free_expr (var);
5442 e->symtree->n.sym->backend_decl = tmp;
5443 e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5445 /* Then free the class _data. */
5446 zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
5447 tmp = fold_build2_loc (input_location, NE_EXPR,
5450 tmp = build3_v (COND_EXPR, tmp,
5451 gfc_call_free (parmse.expr),
5452 build_empty_stmt (input_location));
5453 gfc_add_expr_to_block (&parmse.post, tmp);
5454 gfc_add_modify (&parmse.post, parmse.expr, zero);
5458 /* Wrap scalar variable in a descriptor. We need to convert
5459 the address of a pointer back to the pointer itself before,
5460 we can assign it to the data field. */
5462 if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
5463 && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
5466 if (TREE_CODE (tmp) == ADDR_EXPR)
5467 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5468 parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
5470 parmse.expr = gfc_build_addr_expr (NULL_TREE,
5473 else if (fsym && e->expr_type != EXPR_NULL
5474 && ((fsym->attr.pointer
5475 && fsym->attr.flavor != FL_PROCEDURE)
5476 || (fsym->attr.proc_pointer
5477 && !(e->expr_type == EXPR_VARIABLE
5478 && e->symtree->n.sym->attr.dummy))
5479 || (fsym->attr.proc_pointer
5480 && e->expr_type == EXPR_VARIABLE
5481 && gfc_is_proc_ptr_comp (e))
5482 || (fsym->attr.allocatable
5483 && fsym->attr.flavor != FL_PROCEDURE)))
5485 /* Scalar pointer dummy args require an extra level of
5486 indirection. The null pointer already contains
5487 this level of indirection. */
5488 parm_kind = SCALAR_POINTER;
5489 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
5493 else if (e->ts.type == BT_CLASS
5494 && fsym && fsym->ts.type == BT_CLASS
5495 && (CLASS_DATA (fsym)->attr.dimension
5496 || CLASS_DATA (fsym)->attr.codimension))
5498 /* Pass a class array. */
5499 parmse.use_offset = 1;
5500 gfc_conv_expr_descriptor (&parmse, e);
5502 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5503 allocated on entry, it must be deallocated. */
5504 if (fsym->attr.intent == INTENT_OUT
5505 && CLASS_DATA (fsym)->attr.allocatable)
5510 gfc_init_block (&block);
5512 ptr = gfc_class_data_get (ptr);
5514 tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
5515 NULL_TREE, NULL_TREE,
5517 GFC_CAF_COARRAY_NOCOARRAY);
5518 gfc_add_expr_to_block (&block, tmp);
5519 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
5520 void_type_node, ptr,
5522 gfc_add_expr_to_block (&block, tmp);
5523 gfc_reset_vptr (&block, e);
5525 if (fsym->attr.optional
5526 && e->expr_type == EXPR_VARIABLE
5528 || (e->ref->type == REF_ARRAY
5529 && e->ref->u.ar.type != AR_FULL))
5530 && e->symtree->n.sym->attr.optional)
5532 tmp = fold_build3_loc (input_location, COND_EXPR,
5534 gfc_conv_expr_present (e->symtree->n.sym),
5535 gfc_finish_block (&block),
5536 build_empty_stmt (input_location));
5539 tmp = gfc_finish_block (&block);
5541 gfc_add_expr_to_block (&se->pre, tmp);
5544 /* The conversion does not repackage the reference to a class
5545 array - _data descriptor. */
5546 gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
5547 fsym->attr.intent != INTENT_IN
5548 && (CLASS_DATA (fsym)->attr.class_pointer
5549 || CLASS_DATA (fsym)->attr.allocatable),
5551 && e->expr_type == EXPR_VARIABLE
5552 && e->symtree->n.sym->attr.optional,
5553 CLASS_DATA (fsym)->attr.class_pointer
5554 || CLASS_DATA (fsym)->attr.allocatable);
5558 /* If the argument is a function call that may not create
5559 a temporary for the result, we have to check that we
5560 can do it, i.e. that there is no alias between this
5561 argument and another one. */
5562 if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
5568 intent = fsym->attr.intent;
5570 intent = INTENT_UNKNOWN;
5572 if (gfc_check_fncall_dependency (e, intent, sym, args,
5574 parmse.force_tmp = 1;
5576 iarg = e->value.function.actual->expr;
5578 /* Temporary needed if aliasing due to host association. */
5579 if (sym->attr.contained
5581 && !sym->attr.implicit_pure
5582 && !sym->attr.use_assoc
5583 && iarg->expr_type == EXPR_VARIABLE
5584 && sym->ns == iarg->symtree->n.sym->ns)
5585 parmse.force_tmp = 1;
5587 /* Ditto within module. */
5588 if (sym->attr.use_assoc
5590 && !sym->attr.implicit_pure
5591 && iarg->expr_type == EXPR_VARIABLE
5592 && sym->module == iarg->symtree->n.sym->module)
5593 parmse.force_tmp = 1;
5596 if (e->expr_type == EXPR_VARIABLE
5597 && is_subref_array (e)
5598 && !(fsym && fsym->attr.pointer))
5599 /* The actual argument is a component reference to an
5600 array of derived types. In this case, the argument
5601 is converted to a temporary, which is passed and then
5602 written back after the procedure call. */
5603 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5604 fsym ? fsym->attr.intent : INTENT_INOUT,
5605 fsym && fsym->attr.pointer);
5606 else if (gfc_is_class_array_ref (e, NULL)
5607 && fsym && fsym->ts.type == BT_DERIVED)
5608 /* The actual argument is a component reference to an
5609 array of derived types. In this case, the argument
5610 is converted to a temporary, which is passed and then
5611 written back after the procedure call.
5612 OOP-TODO: Insert code so that if the dynamic type is
5613 the same as the declared type, copy-in/copy-out does
5615 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5616 fsym ? fsym->attr.intent : INTENT_INOUT,
5617 fsym && fsym->attr.pointer);
5619 else if (gfc_is_class_array_function (e)
5620 && fsym && fsym->ts.type == BT_DERIVED)
5621 /* See previous comment. For function actual argument,
5622 the write out is not needed so the intent is set as
5625 e->must_finalize = 1;
5626 gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
5628 fsym && fsym->attr.pointer);
5631 gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
5634 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
5635 allocated on entry, it must be deallocated. */
5636 if (fsym && fsym->attr.allocatable
5637 && fsym->attr.intent == INTENT_OUT)
5639 if (fsym->ts.type == BT_DERIVED
5640 && fsym->ts.u.derived->attr.alloc_comp)
5642 // deallocate the components first
5643 tmp = gfc_deallocate_alloc_comp (fsym->ts.u.derived,
5644 parmse.expr, e->rank);
5645 if (tmp != NULL_TREE)
5646 gfc_add_expr_to_block (&se->pre, tmp);
5649 tmp = build_fold_indirect_ref_loc (input_location,
5651 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
5652 tmp = gfc_conv_descriptor_data_get (tmp);
5653 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
5654 NULL_TREE, NULL_TREE, true,
5656 GFC_CAF_COARRAY_NOCOARRAY);
5657 if (fsym->attr.optional
5658 && e->expr_type == EXPR_VARIABLE
5659 && e->symtree->n.sym->attr.optional)
5660 tmp = fold_build3_loc (input_location, COND_EXPR,
5662 gfc_conv_expr_present (e->symtree->n.sym),
5663 tmp, build_empty_stmt (input_location));
5664 gfc_add_expr_to_block (&se->pre, tmp);
5669 /* The case with fsym->attr.optional is that of a user subroutine
5670 with an interface indicating an optional argument. When we call
5671 an intrinsic subroutine, however, fsym is NULL, but we might still
5672 have an optional argument, so we proceed to the substitution
5674 if (e && (fsym == NULL || fsym->attr.optional))
5676 /* If an optional argument is itself an optional dummy argument,
5677 check its presence and substitute a null if absent. This is
5678 only needed when passing an array to an elemental procedure
5679 as then array elements are accessed - or no NULL pointer is
5680 allowed and a "1" or "0" should be passed if not present.
5681 When passing a non-array-descriptor full array to a
5682 non-array-descriptor dummy, no check is needed. For
5683 array-descriptor actual to array-descriptor dummy, see
5684 PR 41911 for why a check has to be inserted.
5685 fsym == NULL is checked as intrinsics required the descriptor
5686 but do not always set fsym. */
5687 if (e->expr_type == EXPR_VARIABLE
5688 && e->symtree->n.sym->attr.optional
5689 && ((e->rank != 0 && elemental_proc)
5690 || e->representation.length || e->ts.type == BT_CHARACTER
5694 && (fsym->as->type == AS_ASSUMED_SHAPE
5695 || fsym->as->type == AS_ASSUMED_RANK
5696 || fsym->as->type == AS_DEFERRED))))))
5697 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
5698 e->representation.length);
5703 /* Obtain the character length of an assumed character length
5704 length procedure from the typespec. */
5705 if (fsym->ts.type == BT_CHARACTER
5706 && parmse.string_length == NULL_TREE
5707 && e->ts.type == BT_PROCEDURE
5708 && e->symtree->n.sym->ts.type == BT_CHARACTER
5709 && e->symtree->n.sym->ts.u.cl->length != NULL
5710 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
5712 gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
5713 parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
5717 if (fsym && need_interface_mapping && e)
5718 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
5720 gfc_add_block_to_block (&se->pre, &parmse.pre);
5721 gfc_add_block_to_block (&post, &parmse.post);
5723 /* Allocated allocatable components of derived types must be
5724 deallocated for non-variable scalars, array arguments to elemental
5725 procedures, and array arguments with descriptor to non-elemental
5726 procedures. As bounds information for descriptorless arrays is no
5727 longer available here, they are dealt with in trans-array.c
5728 (gfc_conv_array_parameter). */
5729 if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
5730 && e->ts.u.derived->attr.alloc_comp
5731 && (e->rank == 0 || elemental_proc || !nodesc_arg)
5732 && !expr_may_alias_variables (e, elemental_proc))
5735 /* It is known the e returns a structure type with at least one
5736 allocatable component. When e is a function, ensure that the
5737 function is called once only by using a temporary variable. */
5738 if (!DECL_P (parmse.expr))
5739 parmse.expr = gfc_evaluate_now_loc (input_location,
5740 parmse.expr, &se->pre);
5742 if (fsym && fsym->attr.value)
5745 tmp = build_fold_indirect_ref_loc (input_location,
5748 parm_rank = e->rank;
5756 case (SCALAR_POINTER):
5757 tmp = build_fold_indirect_ref_loc (input_location,
5762 if (e->expr_type == EXPR_OP
5763 && e->value.op.op == INTRINSIC_PARENTHESES
5764 && e->value.op.op1->expr_type == EXPR_VARIABLE)
5767 local_tmp = gfc_evaluate_now (tmp, &se->pre);
5768 local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp,
5770 gfc_add_expr_to_block (&se->post, local_tmp);
5773 if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
5775 /* The derived type is passed to gfc_deallocate_alloc_comp.
5776 Therefore, class actuals can handled correctly but derived
5777 types passed to class formals need the _data component. */
5778 tmp = gfc_class_data_get (tmp);
5779 if (!CLASS_DATA (fsym)->attr.dimension)
5780 tmp = build_fold_indirect_ref_loc (input_location, tmp);
5783 if (!finalized && !e->must_finalize)
5785 if ((e->ts.type == BT_CLASS
5786 && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
5787 || e->ts.type == BT_DERIVED)
5788 tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
5790 else if (e->ts.type == BT_CLASS)
5791 tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
5793 gfc_prepend_expr_to_block (&post, tmp);
5797 /* Add argument checking of passing an unallocated/NULL actual to
5798 a nonallocatable/nonpointer dummy. */
5800 if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
5802 symbol_attribute attr;
5806 if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
5807 attr = gfc_expr_attr (e);
5809 goto end_pointer_check;
5811 /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
5812 allocatable to an optional dummy, cf. 12.5.2.12. */
5813 if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
5814 && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5815 goto end_pointer_check;
5819 /* If the actual argument is an optional pointer/allocatable and
5820 the formal argument takes an nonpointer optional value,
5821 it is invalid to pass a non-present argument on, even
5822 though there is no technical reason for this in gfortran.
5823 See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
5824 tree present, null_ptr, type;
5826 if (attr.allocatable
5827 && (fsym == NULL || !fsym->attr.allocatable))
5828 msg = xasprintf ("Allocatable actual argument '%s' is not "
5829 "allocated or not present",
5830 e->symtree->n.sym->name);
5831 else if (attr.pointer
5832 && (fsym == NULL || !fsym->attr.pointer))
5833 msg = xasprintf ("Pointer actual argument '%s' is not "
5834 "associated or not present",
5835 e->symtree->n.sym->name);
5836 else if (attr.proc_pointer
5837 && (fsym == NULL || !fsym->attr.proc_pointer))
5838 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5839 "associated or not present",
5840 e->symtree->n.sym->name);
5842 goto end_pointer_check;
5844 present = gfc_conv_expr_present (e->symtree->n.sym);
5845 type = TREE_TYPE (present);
5846 present = fold_build2_loc (input_location, EQ_EXPR,
5847 logical_type_node, present,
5849 null_pointer_node));
5850 type = TREE_TYPE (parmse.expr);
5851 null_ptr = fold_build2_loc (input_location, EQ_EXPR,
5852 logical_type_node, parmse.expr,
5854 null_pointer_node));
5855 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
5856 logical_type_node, present, null_ptr);
5860 if (attr.allocatable
5861 && (fsym == NULL || !fsym->attr.allocatable))
5862 msg = xasprintf ("Allocatable actual argument '%s' is not "
5863 "allocated", e->symtree->n.sym->name);
5864 else if (attr.pointer
5865 && (fsym == NULL || !fsym->attr.pointer))
5866 msg = xasprintf ("Pointer actual argument '%s' is not "
5867 "associated", e->symtree->n.sym->name);
5868 else if (attr.proc_pointer
5869 && (fsym == NULL || !fsym->attr.proc_pointer))
5870 msg = xasprintf ("Proc-pointer actual argument '%s' is not "
5871 "associated", e->symtree->n.sym->name);
5873 goto end_pointer_check;
5877 /* If the argument is passed by value, we need to strip the
5879 if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
5880 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
5882 cond = fold_build2_loc (input_location, EQ_EXPR,
5883 logical_type_node, tmp,
5884 fold_convert (TREE_TYPE (tmp),
5885 null_pointer_node));
5888 gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
5894 /* Deferred length dummies pass the character length by reference
5895 so that the value can be returned. */
5896 if (parmse.string_length && fsym && fsym->ts.deferred)
5898 if (INDIRECT_REF_P (parmse.string_length))
5899 /* In chains of functions/procedure calls the string_length already
5900 is a pointer to the variable holding the length. Therefore
5901 remove the deref on call. */
5902 parmse.string_length = TREE_OPERAND (parmse.string_length, 0);
5905 tmp = parmse.string_length;
5906 if (!VAR_P (tmp) && TREE_CODE (tmp) != COMPONENT_REF)
5907 tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
5908 parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
5912 /* Character strings are passed as two parameters, a length and a
5913 pointer - except for Bind(c) which only passes the pointer.
5914 An unlimited polymorphic formal argument likewise does not
5916 if (parmse.string_length != NULL_TREE
5917 && !sym->attr.is_bind_c
5918 && !(fsym && UNLIMITED_POLY (fsym)))
5919 vec_safe_push (stringargs, parmse.string_length);
5921 /* When calling __copy for character expressions to unlimited
5922 polymorphic entities, the dst argument needs a string length. */
5923 if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
5924 && gfc_str_startswith (sym->name, "__vtab_CHARACTER")
5925 && arg->next && arg->next->expr
5926 && (arg->next->expr->ts.type == BT_DERIVED
5927 || arg->next->expr->ts.type == BT_CLASS)
5928 && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
5929 vec_safe_push (stringargs, parmse.string_length);
5931 /* For descriptorless coarrays and assumed-shape coarray dummies, we
5932 pass the token and the offset as additional arguments. */
5933 if (fsym && e == NULL && flag_coarray == GFC_FCOARRAY_LIB
5934 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5935 && !fsym->attr.allocatable)
5936 || (fsym->ts.type == BT_CLASS
5937 && CLASS_DATA (fsym)->attr.codimension
5938 && !CLASS_DATA (fsym)->attr.allocatable)))
5940 /* Token and offset. */
5941 vec_safe_push (stringargs, null_pointer_node);
5942 vec_safe_push (stringargs, build_int_cst (gfc_array_index_type, 0));
5943 gcc_assert (fsym->attr.optional);
5945 else if (fsym && flag_coarray == GFC_FCOARRAY_LIB
5946 && ((fsym->ts.type != BT_CLASS && fsym->attr.codimension
5947 && !fsym->attr.allocatable)
5948 || (fsym->ts.type == BT_CLASS
5949 && CLASS_DATA (fsym)->attr.codimension
5950 && !CLASS_DATA (fsym)->attr.allocatable)))
5952 tree caf_decl, caf_type;
5955 caf_decl = gfc_get_tree_for_caf_expr (e);
5956 caf_type = TREE_TYPE (caf_decl);
5958 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5959 && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE
5960 || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER))
5961 tmp = gfc_conv_descriptor_token (caf_decl);
5962 else if (DECL_LANG_SPECIFIC (caf_decl)
5963 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
5964 tmp = GFC_DECL_TOKEN (caf_decl);
5967 gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
5968 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
5969 tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
5972 vec_safe_push (stringargs, tmp);
5974 if (GFC_DESCRIPTOR_TYPE_P (caf_type)
5975 && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
5976 offset = build_int_cst (gfc_array_index_type, 0);
5977 else if (DECL_LANG_SPECIFIC (caf_decl)
5978 && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
5979 offset = GFC_DECL_CAF_OFFSET (caf_decl);
5980 else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
5981 offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
5983 offset = build_int_cst (gfc_array_index_type, 0);
5985 if (GFC_DESCRIPTOR_TYPE_P (caf_type))
5986 tmp = gfc_conv_descriptor_data_get (caf_decl);
5989 gcc_assert (POINTER_TYPE_P (caf_type));
5993 tmp2 = fsym->ts.type == BT_CLASS
5994 ? gfc_class_data_get (parmse.expr) : parmse.expr;
5995 if ((fsym->ts.type != BT_CLASS
5996 && (fsym->as->type == AS_ASSUMED_SHAPE
5997 || fsym->as->type == AS_ASSUMED_RANK))
5998 || (fsym->ts.type == BT_CLASS
5999 && (CLASS_DATA (fsym)->as->type == AS_ASSUMED_SHAPE
6000 || CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)))
6002 if (fsym->ts.type == BT_CLASS)
6003 gcc_assert (!POINTER_TYPE_P (TREE_TYPE (tmp2)));
6006 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6007 tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
6009 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)));
6010 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6012 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
6013 tmp2 = gfc_conv_descriptor_data_get (tmp2);
6016 gcc_assert (POINTER_TYPE_P (TREE_TYPE (tmp2)));
6019 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6020 gfc_array_index_type,
6021 fold_convert (gfc_array_index_type, tmp2),
6022 fold_convert (gfc_array_index_type, tmp));
6023 offset = fold_build2_loc (input_location, PLUS_EXPR,
6024 gfc_array_index_type, offset, tmp);
6026 vec_safe_push (stringargs, offset);
6029 vec_safe_push (arglist, parmse.expr);
6031 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
6035 else if (sym->ts.type == BT_CLASS)
6036 ts = CLASS_DATA (sym)->ts;
6040 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
6041 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
6042 else if (ts.type == BT_CHARACTER)
6044 if (ts.u.cl->length == NULL)
6046 /* Assumed character length results are not allowed by C418 of the 2003
6047 standard and are trapped in resolve.c; except in the case of SPREAD
6048 (and other intrinsics?) and dummy functions. In the case of SPREAD,
6049 we take the character length of the first argument for the result.
6050 For dummies, we have to look through the formal argument list for
6051 this function and use the character length found there.*/
6053 cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
6054 else if (!sym->attr.dummy)
6055 cl.backend_decl = (*stringargs)[0];
6058 formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
6059 for (; formal; formal = formal->next)
6060 if (strcmp (formal->sym->name, sym->name) == 0)
6061 cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
6063 len = cl.backend_decl;
6069 /* Calculate the length of the returned string. */
6070 gfc_init_se (&parmse, NULL);
6071 if (need_interface_mapping)
6072 gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
6074 gfc_conv_expr (&parmse, ts.u.cl->length);
6075 gfc_add_block_to_block (&se->pre, &parmse.pre);
6076 gfc_add_block_to_block (&se->post, &parmse.post);
6078 /* TODO: It would be better to have the charlens as
6079 gfc_charlen_type_node already when the interface is
6080 created instead of converting it here (see PR 84615). */
6081 tmp = fold_build2_loc (input_location, MAX_EXPR,
6082 gfc_charlen_type_node,
6083 fold_convert (gfc_charlen_type_node, tmp),
6084 build_zero_cst (gfc_charlen_type_node));
6085 cl.backend_decl = tmp;
6088 /* Set up a charlen structure for it. */
6093 len = cl.backend_decl;
6096 byref = (comp && (comp->attr.dimension
6097 || (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
6098 || (!comp && gfc_return_by_reference (sym));
6101 if (se->direct_byref)
6103 /* Sometimes, too much indirection can be applied; e.g. for
6104 function_result = array_valued_recursive_function. */
6105 if (TREE_TYPE (TREE_TYPE (se->expr))
6106 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
6107 && GFC_DESCRIPTOR_TYPE_P
6108 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
6109 se->expr = build_fold_indirect_ref_loc (input_location,
6112 /* If the lhs of an assignment x = f(..) is allocatable and
6113 f2003 is allowed, we must do the automatic reallocation.
6114 TODO - deal with intrinsics, without using a temporary. */
6115 if (flag_realloc_lhs
6116 && se->ss && se->ss->loop_chain
6117 && se->ss->loop_chain->is_alloc_lhs
6118 && !expr->value.function.isym
6119 && sym->result->as != NULL)
6121 /* Evaluate the bounds of the result, if known. */
6122 gfc_set_loop_bounds_from_array_spec (&mapping, se,
6125 /* Perform the automatic reallocation. */
6126 tmp = gfc_alloc_allocatable_for_assignment (se->loop,
6128 gfc_add_expr_to_block (&se->pre, tmp);
6130 /* Pass the temporary as the first argument. */
6131 result = info->descriptor;
6134 result = build_fold_indirect_ref_loc (input_location,
6136 vec_safe_push (retargs, se->expr);
6138 else if (comp && comp->attr.dimension)
6140 gcc_assert (se->loop && info);
6142 /* Set the type of the array. */
6143 tmp = gfc_typenode_for_spec (&comp->ts);
6144 gcc_assert (se->ss->dimen == se->loop->dimen);
6146 /* Evaluate the bounds of the result, if known. */
6147 gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
6149 /* If the lhs of an assignment x = f(..) is allocatable and
6150 f2003 is allowed, we must not generate the function call
6151 here but should just send back the results of the mapping.
6152 This is signalled by the function ss being flagged. */
6153 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6155 gfc_free_interface_mapping (&mapping);
6156 return has_alternate_specifier;
6159 /* Create a temporary to store the result. In case the function
6160 returns a pointer, the temporary will be a shallow copy and
6161 mustn't be deallocated. */
6162 callee_alloc = comp->attr.allocatable || comp->attr.pointer;
6163 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6164 tmp, NULL_TREE, false,
6165 !comp->attr.pointer, callee_alloc,
6166 &se->ss->info->expr->where);
6168 /* Pass the temporary as the first argument. */
6169 result = info->descriptor;
6170 tmp = gfc_build_addr_expr (NULL_TREE, result);
6171 vec_safe_push (retargs, tmp);
6173 else if (!comp && sym->result->attr.dimension)
6175 gcc_assert (se->loop && info);
6177 /* Set the type of the array. */
6178 tmp = gfc_typenode_for_spec (&ts);
6179 gcc_assert (se->ss->dimen == se->loop->dimen);
6181 /* Evaluate the bounds of the result, if known. */
6182 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
6184 /* If the lhs of an assignment x = f(..) is allocatable and
6185 f2003 is allowed, we must not generate the function call
6186 here but should just send back the results of the mapping.
6187 This is signalled by the function ss being flagged. */
6188 if (flag_realloc_lhs && se->ss && se->ss->is_alloc_lhs)
6190 gfc_free_interface_mapping (&mapping);
6191 return has_alternate_specifier;
6194 /* Create a temporary to store the result. In case the function
6195 returns a pointer, the temporary will be a shallow copy and
6196 mustn't be deallocated. */
6197 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
6198 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
6199 tmp, NULL_TREE, false,
6200 !sym->attr.pointer, callee_alloc,
6201 &se->ss->info->expr->where);
6203 /* Pass the temporary as the first argument. */
6204 result = info->descriptor;
6205 tmp = gfc_build_addr_expr (NULL_TREE, result);
6206 vec_safe_push (retargs, tmp);
6208 else if (ts.type == BT_CHARACTER)
6210 /* Pass the string length. */
6211 type = gfc_get_character_type (ts.kind, ts.u.cl);
6212 type = build_pointer_type (type);
6214 /* Emit a DECL_EXPR for the VLA type. */
6215 tmp = TREE_TYPE (type);
6217 && TREE_CODE (TYPE_SIZE (tmp)) != INTEGER_CST)
6219 tmp = build_decl (input_location, TYPE_DECL, NULL_TREE, tmp);
6220 DECL_ARTIFICIAL (tmp) = 1;
6221 DECL_IGNORED_P (tmp) = 1;
6222 tmp = fold_build1_loc (input_location, DECL_EXPR,
6223 TREE_TYPE (tmp), tmp);
6224 gfc_add_expr_to_block (&se->pre, tmp);
6227 /* Return an address to a char[0:len-1]* temporary for
6228 character pointers. */
6229 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6230 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6232 var = gfc_create_var (type, "pstr");
6234 if ((!comp && sym->attr.allocatable)
6235 || (comp && comp->attr.allocatable))
6237 gfc_add_modify (&se->pre, var,
6238 fold_convert (TREE_TYPE (var),
6239 null_pointer_node));
6240 tmp = gfc_call_free (var);
6241 gfc_add_expr_to_block (&se->post, tmp);
6244 /* Provide an address expression for the function arguments. */
6245 var = gfc_build_addr_expr (NULL_TREE, var);
6248 var = gfc_conv_string_tmp (se, type, len);
6250 vec_safe_push (retargs, var);
6254 gcc_assert (flag_f2c && ts.type == BT_COMPLEX);
6256 type = gfc_get_complex_type (ts.kind);
6257 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
6258 vec_safe_push (retargs, var);
6261 /* Add the string length to the argument list. */
6262 if (ts.type == BT_CHARACTER && ts.deferred)
6266 tmp = gfc_evaluate_now (len, &se->pre);
6267 TREE_STATIC (tmp) = 1;
6268 gfc_add_modify (&se->pre, tmp,
6269 build_int_cst (TREE_TYPE (tmp), 0));
6270 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
6271 vec_safe_push (retargs, tmp);
6273 else if (ts.type == BT_CHARACTER)
6274 vec_safe_push (retargs, len);
6276 gfc_free_interface_mapping (&mapping);
6278 /* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
6279 arglen = (vec_safe_length (arglist) + vec_safe_length (optionalargs)
6280 + vec_safe_length (stringargs) + vec_safe_length (append_args));
6281 vec_safe_reserve (retargs, arglen);
6283 /* Add the return arguments. */
6284 vec_safe_splice (retargs, arglist);
6286 /* Add the hidden present status for optional+value to the arguments. */
6287 vec_safe_splice (retargs, optionalargs);
6289 /* Add the hidden string length parameters to the arguments. */
6290 vec_safe_splice (retargs, stringargs);
6292 /* We may want to append extra arguments here. This is used e.g. for
6293 calls to libgfortran_matmul_??, which need extra information. */
6294 vec_safe_splice (retargs, append_args);
6298 /* Generate the actual call. */
6299 if (base_object == NULL_TREE)
6300 conv_function_val (se, sym, expr);
6302 conv_base_obj_fcn_val (se, base_object, expr);
6304 /* If there are alternate return labels, function type should be
6305 integer. Can't modify the type in place though, since it can be shared
6306 with other functions. For dummy arguments, the typing is done to
6307 this result, even if it has to be repeated for each call. */
6308 if (has_alternate_specifier
6309 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
6311 if (!sym->attr.dummy)
6313 TREE_TYPE (sym->backend_decl)
6314 = build_function_type (integer_type_node,
6315 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
6316 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
6319 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
6322 fntype = TREE_TYPE (TREE_TYPE (se->expr));
6323 se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
6325 /* Allocatable scalar function results must be freed and nullified
6326 after use. This necessitates the creation of a temporary to
6327 hold the result to prevent duplicate calls. */
6328 if (!byref && sym->ts.type != BT_CHARACTER
6329 && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
6330 || (comp && comp->attr.allocatable && !comp->attr.dimension)))
6332 tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
6333 gfc_add_modify (&se->pre, tmp, se->expr);
6335 tmp = gfc_call_free (tmp);
6336 gfc_add_expr_to_block (&post, tmp);
6337 gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
6340 /* If we have a pointer function, but we don't want a pointer, e.g.
6343 where f is pointer valued, we have to dereference the result. */
6344 if (!se->want_pointer && !byref
6345 && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6346 || (comp && (comp->attr.pointer || comp->attr.allocatable))))
6347 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
6349 /* f2c calling conventions require a scalar default real function to
6350 return a double precision result. Convert this back to default
6351 real. We only care about the cases that can happen in Fortran 77.
6353 if (flag_f2c && sym->ts.type == BT_REAL
6354 && sym->ts.kind == gfc_default_real_kind
6355 && !sym->attr.always_explicit)
6356 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
6358 /* A pure function may still have side-effects - it may modify its
6360 TREE_SIDE_EFFECTS (se->expr) = 1;
6362 if (!sym->attr.pure)
6363 TREE_SIDE_EFFECTS (se->expr) = 1;
6368 /* Add the function call to the pre chain. There is no expression. */
6369 gfc_add_expr_to_block (&se->pre, se->expr);
6370 se->expr = NULL_TREE;
6372 if (!se->direct_byref)
6374 if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
6376 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
6378 /* Check the data pointer hasn't been modified. This would
6379 happen in a function returning a pointer. */
6380 tmp = gfc_conv_descriptor_data_get (info->descriptor);
6381 tmp = fold_build2_loc (input_location, NE_EXPR,
6384 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
6387 se->expr = info->descriptor;
6388 /* Bundle in the string length. */
6389 se->string_length = len;
6391 else if (ts.type == BT_CHARACTER)
6393 /* Dereference for character pointer results. */
6394 if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
6395 || (comp && (comp->attr.pointer || comp->attr.allocatable)))
6396 se->expr = build_fold_indirect_ref_loc (input_location, var);
6400 se->string_length = len;
6404 gcc_assert (ts.type == BT_COMPLEX && flag_f2c);
6405 se->expr = build_fold_indirect_ref_loc (input_location, var);
6410 /* Associate the rhs class object's meta-data with the result, when the
6411 result is a temporary. */
6412 if (args && args->expr && args->expr->ts.type == BT_CLASS
6413 && sym->ts.type == BT_CLASS && result != NULL_TREE && DECL_P (result)
6414 && !GFC_CLASS_TYPE_P (TREE_TYPE (result)))
6417 gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (args->expr);
6419 gfc_init_se (&parmse, NULL);
6420 parmse.data_not_needed = 1;
6421 gfc_conv_expr (&parmse, class_expr);
6422 if (!DECL_LANG_SPECIFIC (result))
6423 gfc_allocate_lang_decl (result);
6424 GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
6425 gfc_free_expr (class_expr);
6426 gcc_assert (parmse.pre.head == NULL_TREE
6427 && parmse.post.head == NULL_TREE);
6430 /* Follow the function call with the argument post block. */
6433 gfc_add_block_to_block (&se->pre, &post);
6435 /* Transformational functions of derived types with allocatable
6436 components must have the result allocatable components copied when the
6437 argument is actually given. */
6438 arg = expr->value.function.actual;
6439 if (result && arg && expr->rank
6440 && expr->value.function.isym
6441 && expr->value.function.isym->transformational
6443 && arg->expr->ts.type == BT_DERIVED
6444 && arg->expr->ts.u.derived->attr.alloc_comp)
6447 /* Copy the allocatable components. We have to use a
6448 temporary here to prevent source allocatable components
6449 from being corrupted. */
6450 tmp2 = gfc_evaluate_now (result, &se->pre);
6451 tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
6452 result, tmp2, expr->rank, 0);
6453 gfc_add_expr_to_block (&se->pre, tmp);
6454 tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
6456 gfc_add_expr_to_block (&se->pre, tmp);
6458 /* Finally free the temporary's data field. */
6459 tmp = gfc_conv_descriptor_data_get (tmp2);
6460 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
6461 NULL_TREE, NULL_TREE, true,
6462 NULL, GFC_CAF_COARRAY_NOCOARRAY);
6463 gfc_add_expr_to_block (&se->pre, tmp);
6468 /* For a function with a class array result, save the result as
6469 a temporary, set the info fields needed by the scalarizer and
6470 call the finalization function of the temporary. Note that the
6471 nullification of allocatable components needed by the result
6472 is done in gfc_trans_assignment_1. */
6473 if (expr && ((gfc_is_class_array_function (expr)
6474 && se->ss && se->ss->loop)
6475 || gfc_is_alloc_class_scalar_function (expr))
6476 && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
6477 && expr->must_finalize)
6482 if (se->ss && se->ss->loop)
6484 gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
6485 se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
6486 tmp = gfc_class_data_get (se->expr);
6487 info->descriptor = tmp;
6488 info->data = gfc_conv_descriptor_data_get (tmp);
6489 info->offset = gfc_conv_descriptor_offset_get (tmp);
6490 for (n = 0; n < se->ss->loop->dimen; n++)
6492 tree dim = gfc_rank_cst[n];
6493 se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
6494 se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
6499 /* TODO Eliminate the doubling of temporaries. This
6500 one is necessary to ensure no memory leakage. */
6501 se->expr = gfc_evaluate_now (se->expr, &se->pre);
6502 tmp = gfc_class_data_get (se->expr);
6503 tmp = gfc_conv_scalar_to_descriptor (se, tmp,
6504 CLASS_DATA (expr->value.function.esym->result)->attr);
6507 if ((gfc_is_class_array_function (expr)
6508 || gfc_is_alloc_class_scalar_function (expr))
6509 && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
6510 goto no_finalization;
6512 final_fndecl = gfc_class_vtab_final_get (se->expr);
6513 is_final = fold_build2_loc (input_location, NE_EXPR,
6516 fold_convert (TREE_TYPE (final_fndecl),
6517 null_pointer_node));
6518 final_fndecl = build_fold_indirect_ref_loc (input_location,
6520 tmp = build_call_expr_loc (input_location,
6522 gfc_build_addr_expr (NULL, tmp),
6523 gfc_class_vtab_size_get (se->expr),
6524 boolean_false_node);
6525 tmp = fold_build3_loc (input_location, COND_EXPR,
6526 void_type_node, is_final, tmp,
6527 build_empty_stmt (input_location));
6529 if (se->ss && se->ss->loop)
6531 gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
6532 tmp = fold_build2_loc (input_location, NE_EXPR,
6535 fold_convert (TREE_TYPE (info->data),
6536 null_pointer_node));
6537 tmp = fold_build3_loc (input_location, COND_EXPR,
6538 void_type_node, tmp,
6539 gfc_call_free (info->data),
6540 build_empty_stmt (input_location));
6541 gfc_add_expr_to_block (&se->ss->loop->post, tmp);
6546 gfc_prepend_expr_to_block (&se->post, tmp);
6547 classdata = gfc_class_data_get (se->expr);
6548 tmp = fold_build2_loc (input_location, NE_EXPR,
6551 fold_convert (TREE_TYPE (classdata),
6552 null_pointer_node));
6553 tmp = fold_build3_loc (input_location, COND_EXPR,
6554 void_type_node, tmp,
6555 gfc_call_free (classdata),
6556 build_empty_stmt (input_location));
6557 gfc_add_expr_to_block (&se->post, tmp);
6562 gfc_add_block_to_block (&se->post, &post);
6565 return has_alternate_specifier;
6569 /* Fill a character string with spaces. */
6572 fill_with_spaces (tree start, tree type, tree size)
6574 stmtblock_t block, loop;
6575 tree i, el, exit_label, cond, tmp;
6577 /* For a simple char type, we can call memset(). */
6578 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
6579 return build_call_expr_loc (input_location,
6580 builtin_decl_explicit (BUILT_IN_MEMSET),
6582 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
6583 lang_hooks.to_target_charset (' ')),
6584 fold_convert (size_type_node, size));
6586 /* Otherwise, we use a loop:
6587 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
6591 /* Initialize variables. */
6592 gfc_init_block (&block);
6593 i = gfc_create_var (sizetype, "i");
6594 gfc_add_modify (&block, i, fold_convert (sizetype, size));
6595 el = gfc_create_var (build_pointer_type (type), "el");
6596 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
6597 exit_label = gfc_build_label_decl (NULL_TREE);
6598 TREE_USED (exit_label) = 1;
6602 gfc_init_block (&loop);
6604 /* Exit condition. */
6605 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i,
6606 build_zero_cst (sizetype));
6607 tmp = build1_v (GOTO_EXPR, exit_label);
6608 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6609 build_empty_stmt (input_location));
6610 gfc_add_expr_to_block (&loop, tmp);
6613 gfc_add_modify (&loop,
6614 fold_build1_loc (input_location, INDIRECT_REF, type, el),
6615 build_int_cst (type, lang_hooks.to_target_charset (' ')));
6617 /* Increment loop variables. */
6618 gfc_add_modify (&loop, i,
6619 fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
6620 TYPE_SIZE_UNIT (type)));
6621 gfc_add_modify (&loop, el,
6622 fold_build_pointer_plus_loc (input_location,
6623 el, TYPE_SIZE_UNIT (type)));
6625 /* Making the loop... actually loop! */
6626 tmp = gfc_finish_block (&loop);
6627 tmp = build1_v (LOOP_EXPR, tmp);
6628 gfc_add_expr_to_block (&block, tmp);
6630 /* The exit label. */
6631 tmp = build1_v (LABEL_EXPR, exit_label);
6632 gfc_add_expr_to_block (&block, tmp);
6635 return gfc_finish_block (&block);
6639 /* Generate code to copy a string. */
6642 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
6643 int dkind, tree slength, tree src, int skind)
6645 tree tmp, dlen, slen;
6654 stmtblock_t tempblock;
6656 gcc_assert (dkind == skind);
6658 if (slength != NULL_TREE)
6660 slen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, slength), block);
6661 ssc = gfc_string_to_single_character (slen, src, skind);
6665 slen = build_one_cst (gfc_charlen_type_node);
6669 if (dlength != NULL_TREE)
6671 dlen = gfc_evaluate_now (fold_convert (gfc_charlen_type_node, dlength), block);
6672 dsc = gfc_string_to_single_character (dlen, dest, dkind);
6676 dlen = build_one_cst (gfc_charlen_type_node);
6680 /* Assign directly if the types are compatible. */
6681 if (dsc != NULL_TREE && ssc != NULL_TREE
6682 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
6684 gfc_add_modify (block, dsc, ssc);
6688 /* The string copy algorithm below generates code like
6692 if (srclen < destlen)
6694 memmove (dest, src, srclen);
6696 memset (&dest[srclen], ' ', destlen - srclen);
6700 // Truncate if too long.
6701 memmove (dest, src, destlen);
6706 /* Do nothing if the destination length is zero. */
6707 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen,
6708 build_zero_cst (TREE_TYPE (dlen)));
6710 /* For non-default character kinds, we have to multiply the string
6711 length by the base type size. */
6712 chartype = gfc_get_char_type (dkind);
6713 slen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (slen),
6715 fold_convert (TREE_TYPE (slen),
6716 TYPE_SIZE_UNIT (chartype)));
6717 dlen = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (dlen),
6719 fold_convert (TREE_TYPE (dlen),
6720 TYPE_SIZE_UNIT (chartype)));
6722 if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
6723 dest = fold_convert (pvoid_type_node, dest);
6725 dest = gfc_build_addr_expr (pvoid_type_node, dest);
6727 if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
6728 src = fold_convert (pvoid_type_node, src);
6730 src = gfc_build_addr_expr (pvoid_type_node, src);
6732 /* Truncate string if source is too long. */
6733 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen,
6736 /* Copy and pad with spaces. */
6737 tmp3 = build_call_expr_loc (input_location,
6738 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6740 fold_convert (size_type_node, slen));
6742 /* Wstringop-overflow appears at -O3 even though this warning is not
6743 explicitly available in fortran nor can it be switched off. If the
6744 source length is a constant, its negative appears as a very large
6745 postive number and triggers the warning in BUILTIN_MEMSET. Fixing
6746 the result of the MINUS_EXPR suppresses this spurious warning. */
6747 tmp = fold_build2_loc (input_location, MINUS_EXPR,
6748 TREE_TYPE(dlen), dlen, slen);
6749 if (slength && TREE_CONSTANT (slength))
6750 tmp = gfc_evaluate_now (tmp, block);
6752 tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
6753 tmp4 = fill_with_spaces (tmp4, chartype, tmp);
6755 gfc_init_block (&tempblock);
6756 gfc_add_expr_to_block (&tempblock, tmp3);
6757 gfc_add_expr_to_block (&tempblock, tmp4);
6758 tmp3 = gfc_finish_block (&tempblock);
6760 /* The truncated memmove if the slen >= dlen. */
6761 tmp2 = build_call_expr_loc (input_location,
6762 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6764 fold_convert (size_type_node, dlen));
6766 /* The whole copy_string function is there. */
6767 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
6769 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6770 build_empty_stmt (input_location));
6771 gfc_add_expr_to_block (block, tmp);
6775 /* Translate a statement function.
6776 The value of a statement function reference is obtained by evaluating the
6777 expression using the values of the actual arguments for the values of the
6778 corresponding dummy arguments. */
6781 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
6785 gfc_formal_arglist *fargs;
6786 gfc_actual_arglist *args;
6789 gfc_saved_var *saved_vars;
6795 sym = expr->symtree->n.sym;
6796 args = expr->value.function.actual;
6797 gfc_init_se (&lse, NULL);
6798 gfc_init_se (&rse, NULL);
6801 for (fargs = gfc_sym_get_dummy_args (sym); fargs; fargs = fargs->next)
6803 saved_vars = XCNEWVEC (gfc_saved_var, n);
6804 temp_vars = XCNEWVEC (tree, n);
6806 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6807 fargs = fargs->next, n++)
6809 /* Each dummy shall be specified, explicitly or implicitly, to be
6811 gcc_assert (fargs->sym->attr.dimension == 0);
6814 if (fsym->ts.type == BT_CHARACTER)
6816 /* Copy string arguments. */
6819 gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
6820 && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
6822 /* Create a temporary to hold the value. */
6823 if (fsym->ts.u.cl->backend_decl == NULL_TREE)
6824 fsym->ts.u.cl->backend_decl
6825 = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
6827 type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
6828 temp_vars[n] = gfc_create_var (type, fsym->name);
6830 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
6832 gfc_conv_expr (&rse, args->expr);
6833 gfc_conv_string_parameter (&rse);
6834 gfc_add_block_to_block (&se->pre, &lse.pre);
6835 gfc_add_block_to_block (&se->pre, &rse.pre);
6837 gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
6838 rse.string_length, rse.expr, fsym->ts.kind);
6839 gfc_add_block_to_block (&se->pre, &lse.post);
6840 gfc_add_block_to_block (&se->pre, &rse.post);
6844 /* For everything else, just evaluate the expression. */
6846 /* Create a temporary to hold the value. */
6847 type = gfc_typenode_for_spec (&fsym->ts);
6848 temp_vars[n] = gfc_create_var (type, fsym->name);
6850 gfc_conv_expr (&lse, args->expr);
6852 gfc_add_block_to_block (&se->pre, &lse.pre);
6853 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
6854 gfc_add_block_to_block (&se->pre, &lse.post);
6860 /* Use the temporary variables in place of the real ones. */
6861 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6862 fargs = fargs->next, n++)
6863 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
6865 gfc_conv_expr (se, sym->value);
6867 if (sym->ts.type == BT_CHARACTER)
6869 gfc_conv_const_charlen (sym->ts.u.cl);
6871 /* Force the expression to the correct length. */
6872 if (!INTEGER_CST_P (se->string_length)
6873 || tree_int_cst_lt (se->string_length,
6874 sym->ts.u.cl->backend_decl))
6876 type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
6877 tmp = gfc_create_var (type, sym->name);
6878 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
6879 gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
6880 sym->ts.kind, se->string_length, se->expr,
6884 se->string_length = sym->ts.u.cl->backend_decl;
6887 /* Restore the original variables. */
6888 for (fargs = gfc_sym_get_dummy_args (sym), n = 0; fargs;
6889 fargs = fargs->next, n++)
6890 gfc_restore_sym (fargs->sym, &saved_vars[n]);
6896 /* Translate a function expression. */
6899 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
6903 if (expr->value.function.isym)
6905 gfc_conv_intrinsic_function (se, expr);
6909 /* expr.value.function.esym is the resolved (specific) function symbol for
6910 most functions. However this isn't set for dummy procedures. */
6911 sym = expr->value.function.esym;
6913 sym = expr->symtree->n.sym;
6915 /* The IEEE_ARITHMETIC functions are caught here. */
6916 if (sym->from_intmod == INTMOD_IEEE_ARITHMETIC)
6917 if (gfc_conv_ieee_arithmetic_function (se, expr))
6920 /* We distinguish statement functions from general functions to improve
6921 runtime performance. */
6922 if (sym->attr.proc == PROC_ST_FUNCTION)
6924 gfc_conv_statement_function (se, expr);
6928 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
6933 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
6936 is_zero_initializer_p (gfc_expr * expr)
6938 if (expr->expr_type != EXPR_CONSTANT)
6941 /* We ignore constants with prescribed memory representations for now. */
6942 if (expr->representation.string)
6945 switch (expr->ts.type)
6948 return mpz_cmp_si (expr->value.integer, 0) == 0;
6951 return mpfr_zero_p (expr->value.real)
6952 && MPFR_SIGN (expr->value.real) >= 0;
6955 return expr->value.logical == 0;
6958 return mpfr_zero_p (mpc_realref (expr->value.complex))
6959 && MPFR_SIGN (mpc_realref (expr->value.complex)) >= 0
6960 && mpfr_zero_p (mpc_imagref (expr->value.complex))
6961 && MPFR_SIGN (mpc_imagref (expr->value.complex)) >= 0;
6971 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
6976 gcc_assert (ss != NULL && ss != gfc_ss_terminator);
6977 gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
6979 gfc_conv_tmp_array_ref (se);
6983 /* Build a static initializer. EXPR is the expression for the initial value.
6984 The other parameters describe the variable of the component being
6985 initialized. EXPR may be null. */
6988 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
6989 bool array, bool pointer, bool procptr)
6993 if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
6994 && ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
6995 && ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
6996 return build_constructor (type, NULL);
6998 if (!(expr || pointer || procptr))
7001 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
7002 (these are the only two iso_c_binding derived types that can be
7003 used as initialization expressions). If so, we need to modify
7004 the 'expr' to be that for a (void *). */
7005 if (expr != NULL && expr->ts.type == BT_DERIVED
7006 && expr->ts.is_iso_c && expr->ts.u.derived)
7008 gfc_symbol *derived = expr->ts.u.derived;
7010 /* The derived symbol has already been converted to a (void *). Use
7012 if (derived->ts.kind == 0)
7013 derived->ts.kind = gfc_default_integer_kind;
7014 expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
7015 expr->ts.f90_type = derived->ts.f90_type;
7017 gfc_init_se (&se, NULL);
7018 gfc_conv_constant (&se, expr);
7019 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7023 if (array && !procptr)
7026 /* Arrays need special handling. */
7028 ctor = gfc_build_null_descriptor (type);
7029 /* Special case assigning an array to zero. */
7030 else if (is_zero_initializer_p (expr))
7031 ctor = build_constructor (type, NULL);
7033 ctor = gfc_conv_array_initializer (type, expr);
7034 TREE_STATIC (ctor) = 1;
7037 else if (pointer || procptr)
7039 if (ts->type == BT_CLASS && !procptr)
7041 gfc_init_se (&se, NULL);
7042 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7043 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7044 TREE_STATIC (se.expr) = 1;
7047 else if (!expr || expr->expr_type == EXPR_NULL)
7048 return fold_convert (type, null_pointer_node);
7051 gfc_init_se (&se, NULL);
7052 se.want_pointer = 1;
7053 gfc_conv_expr (&se, expr);
7054 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7064 gfc_init_se (&se, NULL);
7065 if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
7066 gfc_conv_structure (&se, gfc_class_initializer (ts, expr), 1);
7068 gfc_conv_structure (&se, expr, 1);
7069 gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
7070 TREE_STATIC (se.expr) = 1;
7075 tree ctor = gfc_conv_string_init (ts->u.cl->backend_decl,expr);
7076 TREE_STATIC (ctor) = 1;
7081 gfc_init_se (&se, NULL);
7082 gfc_conv_constant (&se, expr);
7083 gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
7090 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
7096 gfc_array_info *lss_array;
7103 gfc_start_block (&block);
7105 /* Initialize the scalarizer. */
7106 gfc_init_loopinfo (&loop);
7108 gfc_init_se (&lse, NULL);
7109 gfc_init_se (&rse, NULL);
7112 rss = gfc_walk_expr (expr);
7113 if (rss == gfc_ss_terminator)
7114 /* The rhs is scalar. Add a ss for the expression. */
7115 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
7117 /* Create a SS for the destination. */
7118 lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
7120 lss_array = &lss->info->data.array;
7121 lss_array->shape = gfc_get_shape (cm->as->rank);
7122 lss_array->descriptor = dest;
7123 lss_array->data = gfc_conv_array_data (dest);
7124 lss_array->offset = gfc_conv_array_offset (dest);
7125 for (n = 0; n < cm->as->rank; n++)
7127 lss_array->start[n] = gfc_conv_array_lbound (dest, n);
7128 lss_array->stride[n] = gfc_index_one_node;
7130 mpz_init (lss_array->shape[n]);
7131 mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
7132 cm->as->lower[n]->value.integer);
7133 mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
7136 /* Associate the SS with the loop. */
7137 gfc_add_ss_to_loop (&loop, lss);
7138 gfc_add_ss_to_loop (&loop, rss);
7140 /* Calculate the bounds of the scalarization. */
7141 gfc_conv_ss_startstride (&loop);
7143 /* Setup the scalarizing loops. */
7144 gfc_conv_loop_setup (&loop, &expr->where);
7146 /* Setup the gfc_se structures. */
7147 gfc_copy_loopinfo_to_se (&lse, &loop);
7148 gfc_copy_loopinfo_to_se (&rse, &loop);
7151 gfc_mark_ss_chain_used (rss, 1);
7153 gfc_mark_ss_chain_used (lss, 1);
7155 /* Start the scalarized loop body. */
7156 gfc_start_scalarized_body (&loop, &body);
7158 gfc_conv_tmp_array_ref (&lse);
7159 if (cm->ts.type == BT_CHARACTER)
7160 lse.string_length = cm->ts.u.cl->backend_decl;
7162 gfc_conv_expr (&rse, expr);
7164 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
7165 gfc_add_expr_to_block (&body, tmp);
7167 gcc_assert (rse.ss == gfc_ss_terminator);
7169 /* Generate the copying loops. */
7170 gfc_trans_scalarizing_loops (&loop, &body);
7172 /* Wrap the whole thing up. */
7173 gfc_add_block_to_block (&block, &loop.pre);
7174 gfc_add_block_to_block (&block, &loop.post);
7176 gcc_assert (lss_array->shape != NULL);
7177 gfc_free_shape (&lss_array->shape, cm->as->rank);
7178 gfc_cleanup_loop (&loop);
7180 return gfc_finish_block (&block);
7185 gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
7195 gfc_expr *arg = NULL;
7197 gfc_start_block (&block);
7198 gfc_init_se (&se, NULL);
7200 /* Get the descriptor for the expressions. */
7201 se.want_pointer = 0;
7202 gfc_conv_expr_descriptor (&se, expr);
7203 gfc_add_block_to_block (&block, &se.pre);
7204 gfc_add_modify (&block, dest, se.expr);
7206 /* Deal with arrays of derived types with allocatable components. */
7207 if (gfc_bt_struct (cm->ts.type)
7208 && cm->ts.u.derived->attr.alloc_comp)
7209 // TODO: Fix caf_mode
7210 tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
7213 else if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED
7214 && CLASS_DATA(cm)->attr.allocatable)
7216 if (cm->ts.u.derived->attr.alloc_comp)
7217 // TODO: Fix caf_mode
7218 tmp = gfc_copy_alloc_comp (expr->ts.u.derived,
7223 tmp = TREE_TYPE (dest);
7224 tmp = gfc_duplicate_allocatable (dest, se.expr,
7225 tmp, expr->rank, NULL_TREE);
7229 tmp = gfc_duplicate_allocatable (dest, se.expr,
7230 TREE_TYPE(cm->backend_decl),
7231 cm->as->rank, NULL_TREE);
7233 gfc_add_expr_to_block (&block, tmp);
7234 gfc_add_block_to_block (&block, &se.post);
7236 if (expr->expr_type != EXPR_VARIABLE)
7237 gfc_conv_descriptor_data_set (&block, se.expr,
7240 /* We need to know if the argument of a conversion function is a
7241 variable, so that the correct lower bound can be used. */
7242 if (expr->expr_type == EXPR_FUNCTION
7243 && expr->value.function.isym
7244 && expr->value.function.isym->conversion
7245 && expr->value.function.actual->expr
7246 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
7247 arg = expr->value.function.actual->expr;
7249 /* Obtain the array spec of full array references. */
7251 as = gfc_get_full_arrayspec_from_expr (arg);
7253 as = gfc_get_full_arrayspec_from_expr (expr);
7255 /* Shift the lbound and ubound of temporaries to being unity,
7256 rather than zero, based. Always calculate the offset. */
7257 offset = gfc_conv_descriptor_offset_get (dest);
7258 gfc_add_modify (&block, offset, gfc_index_zero_node);
7259 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
7261 for (n = 0; n < expr->rank; n++)
7266 /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
7267 TODO It looks as if gfc_conv_expr_descriptor should return
7268 the correct bounds and that the following should not be
7269 necessary. This would simplify gfc_conv_intrinsic_bound
7271 if (as && as->lower[n])
7274 gfc_init_se (&lbse, NULL);
7275 gfc_conv_expr (&lbse, as->lower[n]);
7276 gfc_add_block_to_block (&block, &lbse.pre);
7277 lbound = gfc_evaluate_now (lbse.expr, &block);
7281 tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
7282 lbound = gfc_conv_descriptor_lbound_get (tmp,
7286 lbound = gfc_conv_descriptor_lbound_get (dest,
7289 lbound = gfc_index_one_node;
7291 lbound = fold_convert (gfc_array_index_type, lbound);
7293 /* Shift the bounds and set the offset accordingly. */
7294 tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
7295 span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7296 tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
7297 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7299 gfc_conv_descriptor_ubound_set (&block, dest,
7300 gfc_rank_cst[n], tmp);
7301 gfc_conv_descriptor_lbound_set (&block, dest,
7302 gfc_rank_cst[n], lbound);
7304 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7305 gfc_conv_descriptor_lbound_get (dest,
7307 gfc_conv_descriptor_stride_get (dest,
7309 gfc_add_modify (&block, tmp2, tmp);
7310 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7312 gfc_conv_descriptor_offset_set (&block, dest, tmp);
7317 /* If a conversion expression has a null data pointer
7318 argument, nullify the allocatable component. */
7322 if (arg->symtree->n.sym->attr.allocatable
7323 || arg->symtree->n.sym->attr.pointer)
7325 non_null_expr = gfc_finish_block (&block);
7326 gfc_start_block (&block);
7327 gfc_conv_descriptor_data_set (&block, dest,
7329 null_expr = gfc_finish_block (&block);
7330 tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
7331 tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
7332 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7333 return build3_v (COND_EXPR, tmp,
7334 null_expr, non_null_expr);
7338 return gfc_finish_block (&block);
7342 /* Allocate or reallocate scalar component, as necessary. */
7345 alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
7355 tree lhs_cl_size = NULL_TREE;
7360 if (!expr2 || expr2->rank)
7363 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
7365 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7367 char name[GFC_MAX_SYMBOL_LEN+9];
7368 gfc_component *strlen;
7369 /* Use the rhs string length and the lhs element size. */
7370 gcc_assert (expr2->ts.type == BT_CHARACTER);
7371 if (!expr2->ts.u.cl->backend_decl)
7373 gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
7374 gcc_assert (expr2->ts.u.cl->backend_decl);
7377 size = expr2->ts.u.cl->backend_decl;
7379 /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
7381 sprintf (name, "_%s_length", cm->name);
7382 strlen = gfc_find_component (sym, name, true, true, NULL);
7383 lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
7384 gfc_charlen_type_node,
7385 TREE_OPERAND (comp, 0),
7386 strlen->backend_decl, NULL_TREE);
7388 tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
7389 tmp = TYPE_SIZE_UNIT (tmp);
7390 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
7391 TREE_TYPE (tmp), tmp,
7392 fold_convert (TREE_TYPE (tmp), size));
7394 else if (cm->ts.type == BT_CLASS)
7396 gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED);
7397 if (expr2->ts.type == BT_DERIVED)
7399 tmp = gfc_get_symbol_decl (expr2->ts.u.derived);
7400 size = TYPE_SIZE_UNIT (tmp);
7406 e2vtab = gfc_find_and_cut_at_last_class_ref (expr2);
7407 gfc_add_vptr_component (e2vtab);
7408 gfc_add_size_component (e2vtab);
7409 gfc_init_se (&se, NULL);
7410 gfc_conv_expr (&se, e2vtab);
7411 gfc_add_block_to_block (block, &se.pre);
7412 size = fold_convert (size_type_node, se.expr);
7413 gfc_free_expr (e2vtab);
7415 size_in_bytes = size;
7419 /* Otherwise use the length in bytes of the rhs. */
7420 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&cm->ts));
7421 size_in_bytes = size;
7424 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7425 size_in_bytes, size_one_node);
7427 if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp)
7429 tmp = build_call_expr_loc (input_location,
7430 builtin_decl_explicit (BUILT_IN_CALLOC),
7431 2, build_one_cst (size_type_node),
7433 tmp = fold_convert (TREE_TYPE (comp), tmp);
7434 gfc_add_modify (block, comp, tmp);
7438 tmp = build_call_expr_loc (input_location,
7439 builtin_decl_explicit (BUILT_IN_MALLOC),
7441 if (GFC_CLASS_TYPE_P (TREE_TYPE (comp)))
7442 ptr = gfc_class_data_get (comp);
7445 tmp = fold_convert (TREE_TYPE (ptr), tmp);
7446 gfc_add_modify (block, ptr, tmp);
7449 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7450 /* Update the lhs character length. */
7451 gfc_add_modify (block, lhs_cl_size,
7452 fold_convert (TREE_TYPE (lhs_cl_size), size));
7456 /* Assign a single component of a derived type constructor. */
7459 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
7460 gfc_symbol *sym, bool init)
7468 gfc_start_block (&block);
7470 if (cm->attr.pointer || cm->attr.proc_pointer)
7472 /* Only care about pointers here, not about allocatables. */
7473 gfc_init_se (&se, NULL);
7474 /* Pointer component. */
7475 if ((cm->attr.dimension || cm->attr.codimension)
7476 && !cm->attr.proc_pointer)
7478 /* Array pointer. */
7479 if (expr->expr_type == EXPR_NULL)
7480 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7483 se.direct_byref = 1;
7485 gfc_conv_expr_descriptor (&se, expr);
7486 gfc_add_block_to_block (&block, &se.pre);
7487 gfc_add_block_to_block (&block, &se.post);
7492 /* Scalar pointers. */
7493 se.want_pointer = 1;
7494 gfc_conv_expr (&se, expr);
7495 gfc_add_block_to_block (&block, &se.pre);
7497 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7498 && expr->symtree->n.sym->attr.dummy)
7499 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7501 gfc_add_modify (&block, dest,
7502 fold_convert (TREE_TYPE (dest), se.expr));
7503 gfc_add_block_to_block (&block, &se.post);
7506 else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
7508 /* NULL initialization for CLASS components. */
7509 tmp = gfc_trans_structure_assign (dest,
7510 gfc_class_initializer (&cm->ts, expr),
7512 gfc_add_expr_to_block (&block, tmp);
7514 else if ((cm->attr.dimension || cm->attr.codimension)
7515 && !cm->attr.proc_pointer)
7517 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7518 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
7519 else if (cm->attr.allocatable || cm->attr.pdt_array)
7521 tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
7522 gfc_add_expr_to_block (&block, tmp);
7526 tmp = gfc_trans_subarray_assign (dest, cm, expr);
7527 gfc_add_expr_to_block (&block, tmp);
7530 else if (cm->ts.type == BT_CLASS
7531 && CLASS_DATA (cm)->attr.dimension
7532 && CLASS_DATA (cm)->attr.allocatable
7533 && expr->ts.type == BT_DERIVED)
7535 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7536 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7537 tmp = gfc_class_vptr_get (dest);
7538 gfc_add_modify (&block, tmp,
7539 fold_convert (TREE_TYPE (tmp), vtab));
7540 tmp = gfc_class_data_get (dest);
7541 tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
7542 gfc_add_expr_to_block (&block, tmp);
7544 else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
7546 /* NULL initialization for allocatable components. */
7547 gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
7548 null_pointer_node));
7550 else if (init && (cm->attr.allocatable
7551 || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
7552 && expr->ts.type != BT_CLASS)))
7554 /* Take care about non-array allocatable components here. The alloc_*
7555 routine below is motivated by the alloc_scalar_allocatable_for_
7556 assignment() routine, but with the realloc portions removed and
7558 alloc_scalar_allocatable_for_subcomponent_assignment (&block,
7563 /* The remainder of these instructions follow the if (cm->attr.pointer)
7564 if (!cm->attr.dimension) part above. */
7565 gfc_init_se (&se, NULL);
7566 gfc_conv_expr (&se, expr);
7567 gfc_add_block_to_block (&block, &se.pre);
7569 if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
7570 && expr->symtree->n.sym->attr.dummy)
7571 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
7573 if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED)
7575 tmp = gfc_class_data_get (dest);
7576 tmp = build_fold_indirect_ref_loc (input_location, tmp);
7577 vtab = gfc_get_symbol_decl (gfc_find_vtab (&expr->ts));
7578 vtab = gfc_build_addr_expr (NULL_TREE, vtab);
7579 gfc_add_modify (&block, gfc_class_vptr_get (dest),
7580 fold_convert (TREE_TYPE (gfc_class_vptr_get (dest)), vtab));
7583 tmp = build_fold_indirect_ref_loc (input_location, dest);
7585 /* For deferred strings insert a memcpy. */
7586 if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
7589 gcc_assert (se.string_length || expr->ts.u.cl->backend_decl);
7590 size = size_of_string_in_bytes (cm->ts.kind, se.string_length
7592 : expr->ts.u.cl->backend_decl);
7593 tmp = gfc_build_memcpy_call (tmp, se.expr, size);
7594 gfc_add_expr_to_block (&block, tmp);
7597 gfc_add_modify (&block, tmp,
7598 fold_convert (TREE_TYPE (tmp), se.expr));
7599 gfc_add_block_to_block (&block, &se.post);
7601 else if (expr->ts.type == BT_UNION)
7604 gfc_constructor *c = gfc_constructor_first (expr->value.constructor);
7605 /* We mark that the entire union should be initialized with a contrived
7606 EXPR_NULL expression at the beginning. */
7607 if (c != NULL && c->n.component == NULL
7608 && c->expr != NULL && c->expr->expr_type == EXPR_NULL)
7610 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
7611 dest, build_constructor (TREE_TYPE (dest), NULL));
7612 gfc_add_expr_to_block (&block, tmp);
7613 c = gfc_constructor_next (c);
7615 /* The following constructor expression, if any, represents a specific
7616 map intializer, as given by the user. */
7617 if (c != NULL && c->expr != NULL)
7619 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7620 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7621 gfc_add_expr_to_block (&block, tmp);
7624 else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
7626 if (expr->expr_type != EXPR_STRUCTURE)
7628 tree dealloc = NULL_TREE;
7629 gfc_init_se (&se, NULL);
7630 gfc_conv_expr (&se, expr);
7631 gfc_add_block_to_block (&block, &se.pre);
7632 /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the
7633 expression in a temporary variable and deallocate the allocatable
7634 components. Then we can the copy the expression to the result. */
7635 if (cm->ts.u.derived->attr.alloc_comp
7636 && expr->expr_type != EXPR_VARIABLE)
7638 se.expr = gfc_evaluate_now (se.expr, &block);
7639 dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr,
7642 gfc_add_modify (&block, dest,
7643 fold_convert (TREE_TYPE (dest), se.expr));
7644 if (cm->ts.u.derived->attr.alloc_comp
7645 && expr->expr_type != EXPR_NULL)
7647 // TODO: Fix caf_mode
7648 tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
7649 dest, expr->rank, 0);
7650 gfc_add_expr_to_block (&block, tmp);
7651 if (dealloc != NULL_TREE)
7652 gfc_add_expr_to_block (&block, dealloc);
7654 gfc_add_block_to_block (&block, &se.post);
7658 /* Nested constructors. */
7659 tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
7660 gfc_add_expr_to_block (&block, tmp);
7663 else if (gfc_deferred_strlen (cm, &tmp))
7667 gcc_assert (strlen);
7668 strlen = fold_build3_loc (input_location, COMPONENT_REF,
7670 TREE_OPERAND (dest, 0),
7673 if (expr->expr_type == EXPR_NULL)
7675 tmp = build_int_cst (TREE_TYPE (cm->backend_decl), 0);
7676 gfc_add_modify (&block, dest, tmp);
7677 tmp = build_int_cst (TREE_TYPE (strlen), 0);
7678 gfc_add_modify (&block, strlen, tmp);
7683 gfc_init_se (&se, NULL);
7684 gfc_conv_expr (&se, expr);
7685 size = size_of_string_in_bytes (cm->ts.kind, se.string_length);
7686 tmp = build_call_expr_loc (input_location,
7687 builtin_decl_explicit (BUILT_IN_MALLOC),
7689 gfc_add_modify (&block, dest,
7690 fold_convert (TREE_TYPE (dest), tmp));
7691 gfc_add_modify (&block, strlen,
7692 fold_convert (TREE_TYPE (strlen), se.string_length));
7693 tmp = gfc_build_memcpy_call (dest, se.expr, size);
7694 gfc_add_expr_to_block (&block, tmp);
7697 else if (!cm->attr.artificial)
7699 /* Scalar component (excluding deferred parameters). */
7700 gfc_init_se (&se, NULL);
7701 gfc_init_se (&lse, NULL);
7703 gfc_conv_expr (&se, expr);
7704 if (cm->ts.type == BT_CHARACTER)
7705 lse.string_length = cm->ts.u.cl->backend_decl;
7707 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, false, false);
7708 gfc_add_expr_to_block (&block, tmp);
7710 return gfc_finish_block (&block);
7713 /* Assign a derived type constructor to a variable. */
7716 gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
7725 gfc_start_block (&block);
7726 cm = expr->ts.u.derived->components;
7728 if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
7729 && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
7730 || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
7734 gfc_init_se (&se, NULL);
7735 gfc_init_se (&lse, NULL);
7736 gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
7738 gfc_add_modify (&block, lse.expr,
7739 fold_convert (TREE_TYPE (lse.expr), se.expr));
7741 return gfc_finish_block (&block);
7745 gfc_init_se (&se, NULL);
7747 for (c = gfc_constructor_first (expr->value.constructor);
7748 c; c = gfc_constructor_next (c), cm = cm->next)
7750 /* Skip absent members in default initializers. */
7751 if (!c->expr && !cm->attr.allocatable)
7754 /* Register the component with the caf-lib before it is initialized.
7755 Register only allocatable components, that are not coarray'ed
7756 components (%comp[*]). Only register when the constructor is not the
7758 if (coarray && !cm->attr.codimension
7759 && (cm->attr.allocatable || cm->attr.pointer)
7760 && (!c->expr || c->expr->expr_type == EXPR_NULL))
7762 tree token, desc, size;
7763 bool is_array = cm->ts.type == BT_CLASS
7764 ? CLASS_DATA (cm)->attr.dimension : cm->attr.dimension;
7766 field = cm->backend_decl;
7767 field = fold_build3_loc (input_location, COMPONENT_REF,
7768 TREE_TYPE (field), dest, field, NULL_TREE);
7769 if (cm->ts.type == BT_CLASS)
7770 field = gfc_class_data_get (field);
7772 token = is_array ? gfc_conv_descriptor_token (field)
7773 : fold_build3_loc (input_location, COMPONENT_REF,
7774 TREE_TYPE (cm->caf_token), dest,
7775 cm->caf_token, NULL_TREE);
7779 /* The _caf_register routine looks at the rank of the array
7780 descriptor to decide whether the data registered is an array
7782 int rank = cm->ts.type == BT_CLASS ? CLASS_DATA (cm)->as->rank
7784 /* When the rank is not known just set a positive rank, which
7785 suffices to recognize the data as array. */
7788 size = build_zero_cst (size_type_node);
7790 gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
7791 build_int_cst (signed_char_type_node, rank));
7795 desc = gfc_conv_scalar_to_descriptor (&se, field,
7796 cm->ts.type == BT_CLASS
7797 ? CLASS_DATA (cm)->attr
7799 size = TYPE_SIZE_UNIT (TREE_TYPE (field));
7801 gfc_add_block_to_block (&block, &se.pre);
7802 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register,
7803 7, size, build_int_cst (
7805 GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY),
7806 gfc_build_addr_expr (pvoid_type_node,
7808 gfc_build_addr_expr (NULL_TREE, desc),
7809 null_pointer_node, null_pointer_node,
7811 gfc_add_expr_to_block (&block, tmp);
7813 field = cm->backend_decl;
7814 tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
7815 dest, field, NULL_TREE);
7818 gfc_expr *e = gfc_get_null_expr (NULL);
7819 tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
7824 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
7825 expr->ts.u.derived, init);
7826 gfc_add_expr_to_block (&block, tmp);
7828 return gfc_finish_block (&block);
7832 gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v,
7833 gfc_component *un, gfc_expr *init)
7835 gfc_constructor *ctor;
7837 if (un->ts.type != BT_UNION || un == NULL || init == NULL)
7840 ctor = gfc_constructor_first (init->value.constructor);
7842 if (ctor == NULL || ctor->expr == NULL)
7845 gcc_assert (init->expr_type == EXPR_STRUCTURE);
7847 /* If we have an 'initialize all' constructor, do it first. */
7848 if (ctor->expr->expr_type == EXPR_NULL)
7850 tree union_type = TREE_TYPE (un->backend_decl);
7851 tree val = build_constructor (union_type, NULL);
7852 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7853 ctor = gfc_constructor_next (ctor);
7856 /* Add the map initializer on top. */
7857 if (ctor != NULL && ctor->expr != NULL)
7859 gcc_assert (ctor->expr->expr_type == EXPR_STRUCTURE);
7860 tree val = gfc_conv_initializer (ctor->expr, &un->ts,
7861 TREE_TYPE (un->backend_decl),
7862 un->attr.dimension, un->attr.pointer,
7863 un->attr.proc_pointer);
7864 CONSTRUCTOR_APPEND_ELT (v, un->backend_decl, val);
7868 /* Build an expression for a constructor. If init is nonzero then
7869 this is part of a static variable initializer. */
7872 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
7879 vec<constructor_elt, va_gc> *v = NULL;
7881 gcc_assert (se->ss == NULL);
7882 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
7883 type = gfc_typenode_for_spec (&expr->ts);
7887 /* Create a temporary variable and fill it in. */
7888 se->expr = gfc_create_var (type, expr->ts.u.derived->name);
7889 /* The symtree in expr is NULL, if the code to generate is for
7890 initializing the static members only. */
7891 tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
7893 gfc_add_expr_to_block (&se->pre, tmp);
7897 cm = expr->ts.u.derived->components;
7899 for (c = gfc_constructor_first (expr->value.constructor);
7900 c; c = gfc_constructor_next (c), cm = cm->next)
7902 /* Skip absent members in default initializers and allocatable
7903 components. Although the latter have a default initializer
7904 of EXPR_NULL,... by default, the static nullify is not needed
7905 since this is done every time we come into scope. */
7906 if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
7909 if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
7910 && strcmp (cm->name, "_extends") == 0
7911 && cm->initializer->symtree)
7915 vtabs = cm->initializer->symtree->n.sym;
7916 vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
7917 vtab = unshare_expr_without_location (vtab);
7918 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
7920 else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
7922 val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
7923 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7924 fold_convert (TREE_TYPE (cm->backend_decl),
7927 else if (cm->ts.type == BT_INTEGER && strcmp (cm->name, "_len") == 0)
7928 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl,
7929 fold_convert (TREE_TYPE (cm->backend_decl),
7930 integer_zero_node));
7931 else if (cm->ts.type == BT_UNION)
7932 gfc_conv_union_initializer (v, cm, c->expr);
7935 val = gfc_conv_initializer (c->expr, &cm->ts,
7936 TREE_TYPE (cm->backend_decl),
7937 cm->attr.dimension, cm->attr.pointer,
7938 cm->attr.proc_pointer);
7939 val = unshare_expr_without_location (val);
7941 /* Append it to the constructor list. */
7942 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
7946 se->expr = build_constructor (type, v);
7948 TREE_CONSTANT (se->expr) = 1;
7952 /* Translate a substring expression. */
7955 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
7961 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
7963 se->expr = gfc_build_wide_string_const (expr->ts.kind,
7964 expr->value.character.length,
7965 expr->value.character.string);
7967 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
7968 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
7971 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
7975 /* Entry point for expression translation. Evaluates a scalar quantity.
7976 EXPR is the expression to be translated, and SE is the state structure if
7977 called from within the scalarized. */
7980 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
7985 if (ss && ss->info->expr == expr
7986 && (ss->info->type == GFC_SS_SCALAR
7987 || ss->info->type == GFC_SS_REFERENCE))
7989 gfc_ss_info *ss_info;
7992 /* Substitute a scalar expression evaluated outside the scalarization
7994 se->expr = ss_info->data.scalar.value;
7995 if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
7996 se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
7998 se->string_length = ss_info->string_length;
7999 gfc_advance_se_ss_chain (se);
8003 /* We need to convert the expressions for the iso_c_binding derived types.
8004 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
8005 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
8006 typespec for the C_PTR and C_FUNPTR symbols, which has already been
8007 updated to be an integer with a kind equal to the size of a (void *). */
8008 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->ts.f90_type == BT_VOID
8009 && expr->ts.u.derived->attr.is_bind_c)
8011 if (expr->expr_type == EXPR_VARIABLE
8012 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
8013 || expr->symtree->n.sym->intmod_sym_id
8014 == ISOCBINDING_NULL_FUNPTR))
8016 /* Set expr_type to EXPR_NULL, which will result in
8017 null_pointer_node being used below. */
8018 expr->expr_type = EXPR_NULL;
8022 /* Update the type/kind of the expression to be what the new
8023 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
8024 expr->ts.type = BT_INTEGER;
8025 expr->ts.f90_type = BT_VOID;
8026 expr->ts.kind = gfc_index_integer_kind;
8030 gfc_fix_class_refs (expr);
8032 switch (expr->expr_type)
8035 gfc_conv_expr_op (se, expr);
8039 gfc_conv_function_expr (se, expr);
8043 gfc_conv_constant (se, expr);
8047 gfc_conv_variable (se, expr);
8051 se->expr = null_pointer_node;
8054 case EXPR_SUBSTRING:
8055 gfc_conv_substring_expr (se, expr);
8058 case EXPR_STRUCTURE:
8059 gfc_conv_structure (se, expr, 0);
8063 gfc_conv_array_constructor_expr (se, expr);
8072 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
8073 of an assignment. */
8075 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
8077 gfc_conv_expr (se, expr);
8078 /* All numeric lvalues should have empty post chains. If not we need to
8079 figure out a way of rewriting an lvalue so that it has no post chain. */
8080 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
8083 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
8084 numeric expressions. Used for scalar values where inserting cleanup code
8087 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
8091 gcc_assert (expr->ts.type != BT_CHARACTER);
8092 gfc_conv_expr (se, expr);
8095 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
8096 gfc_add_modify (&se->pre, val, se->expr);
8098 gfc_add_block_to_block (&se->pre, &se->post);
8102 /* Helper to translate an expression and convert it to a particular type. */
8104 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
8106 gfc_conv_expr_val (se, expr);
8107 se->expr = convert (type, se->expr);
8111 /* Converts an expression so that it can be passed by reference. Scalar
8115 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
8121 if (ss && ss->info->expr == expr
8122 && ss->info->type == GFC_SS_REFERENCE)
8124 /* Returns a reference to the scalar evaluated outside the loop
8126 gfc_conv_expr (se, expr);
8128 if (expr->ts.type == BT_CHARACTER
8129 && expr->expr_type != EXPR_FUNCTION)
8130 gfc_conv_string_parameter (se);
8132 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
8137 if (expr->ts.type == BT_CHARACTER)
8139 gfc_conv_expr (se, expr);
8140 gfc_conv_string_parameter (se);
8144 if (expr->expr_type == EXPR_VARIABLE)
8146 se->want_pointer = 1;
8147 gfc_conv_expr (se, expr);
8150 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8151 gfc_add_modify (&se->pre, var, se->expr);
8152 gfc_add_block_to_block (&se->pre, &se->post);
8155 else if (add_clobber)
8159 /* FIXME: This fails if var is passed by reference, see PR
8161 var = expr->symtree->n.sym->backend_decl;
8162 clobber = build_clobber (TREE_TYPE (var));
8163 gfc_add_modify (&se->pre, var, clobber);
8168 if (expr->expr_type == EXPR_FUNCTION
8169 && ((expr->value.function.esym
8170 && expr->value.function.esym->result->attr.pointer
8171 && !expr->value.function.esym->result->attr.dimension)
8172 || (!expr->value.function.esym && !expr->ref
8173 && expr->symtree->n.sym->attr.pointer
8174 && !expr->symtree->n.sym->attr.dimension)))
8176 se->want_pointer = 1;
8177 gfc_conv_expr (se, expr);
8178 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8179 gfc_add_modify (&se->pre, var, se->expr);
8184 gfc_conv_expr (se, expr);
8186 /* Create a temporary var to hold the value. */
8187 if (TREE_CONSTANT (se->expr))
8189 tree tmp = se->expr;
8190 STRIP_TYPE_NOPS (tmp);
8191 var = build_decl (input_location,
8192 CONST_DECL, NULL, TREE_TYPE (tmp));
8193 DECL_INITIAL (var) = tmp;
8194 TREE_STATIC (var) = 1;
8199 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
8200 gfc_add_modify (&se->pre, var, se->expr);
8203 if (!expr->must_finalize)
8204 gfc_add_block_to_block (&se->pre, &se->post);
8206 /* Take the address of that value. */
8207 se->expr = gfc_build_addr_expr (NULL_TREE, var);
8211 /* Get the _len component for an unlimited polymorphic expression. */
8214 trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
8217 gfc_ref *ref = expr->ref;
8219 gfc_init_se (&se, NULL);
8220 while (ref && ref->next)
8222 gfc_add_len_component (expr);
8223 gfc_conv_expr (&se, expr);
8224 gfc_add_block_to_block (block, &se.pre);
8225 gcc_assert (se.post.head == NULL_TREE);
8228 gfc_free_ref_list (ref->next);
8233 gfc_free_ref_list (expr->ref);
8240 /* Assign _vptr and _len components as appropriate. BLOCK should be a
8241 statement-list outside of the scalarizer-loop. When code is generated, that
8242 depends on the scalarized expression, it is added to RSE.PRE.
8243 Returns le's _vptr tree and when set the len expressions in to_lenp and
8244 from_lenp to form a le%_vptr%_copy (re, le, [from_lenp, to_lenp])
8248 trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
8249 gfc_expr * re, gfc_se *rse,
8250 tree * to_lenp, tree * from_lenp)
8253 gfc_expr * vptr_expr;
8254 tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
8255 bool set_vptr = false, temp_rhs = false;
8256 stmtblock_t *pre = block;
8258 /* Create a temporary for complicated expressions. */
8259 if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
8260 && rse->expr != NULL_TREE && !DECL_P (rse->expr))
8262 tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
8264 gfc_add_modify (&rse->pre, tmp, rse->expr);
8269 /* Get the _vptr for the left-hand side expression. */
8270 gfc_init_se (&se, NULL);
8271 vptr_expr = gfc_find_and_cut_at_last_class_ref (le);
8272 if (vptr_expr != NULL && gfc_expr_attr (vptr_expr).class_ok)
8274 /* Care about _len for unlimited polymorphic entities. */
8275 if (UNLIMITED_POLY (vptr_expr)
8276 || (vptr_expr->ts.type == BT_DERIVED
8277 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8278 to_len = trans_get_upoly_len (block, vptr_expr);
8279 gfc_add_vptr_component (vptr_expr);
8283 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8284 se.want_pointer = 1;
8285 gfc_conv_expr (&se, vptr_expr);
8286 gfc_free_expr (vptr_expr);
8287 gfc_add_block_to_block (block, &se.pre);
8288 gcc_assert (se.post.head == NULL_TREE);
8290 STRIP_NOPS (lhs_vptr);
8292 /* Set the _vptr only when the left-hand side of the assignment is a
8296 /* Get the vptr from the rhs expression only, when it is variable.
8297 Functions are expected to be assigned to a temporary beforehand. */
8298 vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
8299 ? gfc_find_and_cut_at_last_class_ref (re)
8301 if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
8303 if (to_len != NULL_TREE)
8305 /* Get the _len information from the rhs. */
8306 if (UNLIMITED_POLY (vptr_expr)
8307 || (vptr_expr->ts.type == BT_DERIVED
8308 && vptr_expr->ts.u.derived->attr.unlimited_polymorphic))
8309 from_len = trans_get_upoly_len (block, vptr_expr);
8311 gfc_add_vptr_component (vptr_expr);
8315 if (re->expr_type == EXPR_VARIABLE
8316 && DECL_P (re->symtree->n.sym->backend_decl)
8317 && DECL_LANG_SPECIFIC (re->symtree->n.sym->backend_decl)
8318 && GFC_DECL_SAVED_DESCRIPTOR (re->symtree->n.sym->backend_decl)
8319 && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (
8320 re->symtree->n.sym->backend_decl))))
8323 se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
8324 re->symtree->n.sym->backend_decl));
8326 from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
8327 re->symtree->n.sym->backend_decl));
8329 else if (temp_rhs && re->ts.type == BT_CLASS)
8332 se.expr = gfc_class_vptr_get (rse->expr);
8333 if (UNLIMITED_POLY (re))
8334 from_len = gfc_class_len_get (rse->expr);
8336 else if (re->expr_type != EXPR_NULL)
8337 /* Only when rhs is non-NULL use its declared type for vptr
8339 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts));
8341 /* When the rhs is NULL use the vtab of lhs' declared type. */
8342 vptr_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&le->ts));
8347 gfc_init_se (&se, NULL);
8348 se.want_pointer = 1;
8349 gfc_conv_expr (&se, vptr_expr);
8350 gfc_free_expr (vptr_expr);
8351 gfc_add_block_to_block (block, &se.pre);
8352 gcc_assert (se.post.head == NULL_TREE);
8354 gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
8357 if (to_len != NULL_TREE)
8359 /* The _len component needs to be set. Figure how to get the
8360 value of the right-hand side. */
8361 if (from_len == NULL_TREE)
8363 if (rse->string_length != NULL_TREE)
8364 from_len = rse->string_length;
8365 else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
8367 from_len = gfc_get_expr_charlen (re);
8368 gfc_init_se (&se, NULL);
8369 gfc_conv_expr (&se, re->ts.u.cl->length);
8370 gfc_add_block_to_block (block, &se.pre);
8371 gcc_assert (se.post.head == NULL_TREE);
8372 from_len = gfc_evaluate_now (se.expr, block);
8375 from_len = build_zero_cst (gfc_charlen_type_node);
8377 gfc_add_modify (pre, to_len, fold_convert (TREE_TYPE (to_len),
8382 /* Return the _len trees only, when requested. */
8386 *from_lenp = from_len;
8391 /* Assign tokens for pointer components. */
8394 trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
8397 symbol_attribute lhs_attr, rhs_attr;
8398 tree tmp, lhs_tok, rhs_tok;
8399 /* Flag to indicated component refs on the rhs. */
8402 lhs_attr = gfc_caf_attr (expr1);
8403 if (expr2->expr_type != EXPR_NULL)
8405 rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
8406 if (lhs_attr.codimension && rhs_attr.codimension)
8408 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8409 lhs_tok = build_fold_indirect_ref (lhs_tok);
8412 rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
8416 caf_decl = gfc_get_tree_for_caf_expr (expr2);
8417 gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
8420 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8422 fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
8423 gfc_prepend_expr_to_block (&lse->post, tmp);
8426 else if (lhs_attr.codimension)
8428 lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
8429 lhs_tok = build_fold_indirect_ref (lhs_tok);
8430 tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
8431 lhs_tok, null_pointer_node);
8432 gfc_prepend_expr_to_block (&lse->post, tmp);
8436 /* Indentify class valued proc_pointer assignments. */
8439 pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
8444 while (ref && ref->next)
8447 return ref && ref->type == REF_COMPONENT
8448 && ref->u.c.component->attr.proc_pointer
8449 && expr2->expr_type == EXPR_VARIABLE
8450 && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
8454 /* Do everything that is needed for a CLASS function expr2. */
8457 trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
8458 gfc_expr *expr1, gfc_expr *expr2)
8460 tree expr1_vptr = NULL_TREE;
8463 gfc_conv_function_expr (rse, expr2);
8464 rse->expr = gfc_evaluate_now (rse->expr, &rse->pre);
8466 if (expr1->ts.type != BT_CLASS)
8467 rse->expr = gfc_class_data_get (rse->expr);
8470 expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
8473 gfc_add_block_to_block (block, &rse->pre);
8474 tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
8475 gfc_add_modify (&lse->pre, tmp, rse->expr);
8477 gfc_add_modify (&lse->pre, expr1_vptr,
8478 fold_convert (TREE_TYPE (expr1_vptr),
8479 gfc_class_vptr_get (tmp)));
8480 rse->expr = gfc_class_data_get (tmp);
8488 gfc_trans_pointer_assign (gfc_code * code)
8490 return gfc_trans_pointer_assignment (code->expr1, code->expr2);
8494 /* Generate code for a pointer assignment. */
8497 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
8504 tree expr1_vptr = NULL_TREE;
8505 bool scalar, non_proc_pointer_assign;
8508 gfc_start_block (&block);
8510 gfc_init_se (&lse, NULL);
8512 /* Usually testing whether this is not a proc pointer assignment. */
8513 non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
8515 /* Check whether the expression is a scalar or not; we cannot use
8516 expr1->rank as it can be nonzero for proc pointers. */
8517 ss = gfc_walk_expr (expr1);
8518 scalar = ss == gfc_ss_terminator;
8520 gfc_free_ss_chain (ss);
8522 if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
8523 && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
8525 gfc_add_data_component (expr2);
8526 /* The following is required as gfc_add_data_component doesn't
8527 update ts.type if there is a tailing REF_ARRAY. */
8528 expr2->ts.type = BT_DERIVED;
8533 /* Scalar pointers. */
8534 lse.want_pointer = 1;
8535 gfc_conv_expr (&lse, expr1);
8536 gfc_init_se (&rse, NULL);
8537 rse.want_pointer = 1;
8538 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8539 trans_class_pointer_fcn (&block, &lse, &rse, expr1, expr2);
8541 gfc_conv_expr (&rse, expr2);
8543 if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
8545 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
8547 lse.expr = gfc_class_data_get (lse.expr);
8550 if (expr1->symtree->n.sym->attr.proc_pointer
8551 && expr1->symtree->n.sym->attr.dummy)
8552 lse.expr = build_fold_indirect_ref_loc (input_location,
8555 if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
8556 && expr2->symtree->n.sym->attr.dummy)
8557 rse.expr = build_fold_indirect_ref_loc (input_location,
8560 gfc_add_block_to_block (&block, &lse.pre);
8561 gfc_add_block_to_block (&block, &rse.pre);
8563 /* Check character lengths if character expression. The test is only
8564 really added if -fbounds-check is enabled. Exclude deferred
8565 character length lefthand sides. */
8566 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
8567 && !expr1->ts.deferred
8568 && !expr1->symtree->n.sym->attr.proc_pointer
8569 && !gfc_is_proc_ptr_comp (expr1))
8571 gcc_assert (expr2->ts.type == BT_CHARACTER);
8572 gcc_assert (lse.string_length && rse.string_length);
8573 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8574 lse.string_length, rse.string_length,
8578 /* The assignment to an deferred character length sets the string
8579 length to that of the rhs. */
8580 if (expr1->ts.deferred)
8582 if (expr2->expr_type != EXPR_NULL && lse.string_length != NULL)
8583 gfc_add_modify (&block, lse.string_length,
8584 fold_convert (TREE_TYPE (lse.string_length),
8585 rse.string_length));
8586 else if (lse.string_length != NULL)
8587 gfc_add_modify (&block, lse.string_length,
8588 build_zero_cst (TREE_TYPE (lse.string_length)));
8591 gfc_add_modify (&block, lse.expr,
8592 fold_convert (TREE_TYPE (lse.expr), rse.expr));
8594 /* Also set the tokens for pointer components in derived typed
8596 if (flag_coarray == GFC_FCOARRAY_LIB)
8597 trans_caf_token_assign (&lse, &rse, expr1, expr2);
8599 gfc_add_block_to_block (&block, &rse.post);
8600 gfc_add_block_to_block (&block, &lse.post);
8607 tree strlen_rhs = NULL_TREE;
8609 /* Array pointer. Find the last reference on the LHS and if it is an
8610 array section ref, we're dealing with bounds remapping. In this case,
8611 set it to AR_FULL so that gfc_conv_expr_descriptor does
8612 not see it and process the bounds remapping afterwards explicitly. */
8613 for (remap = expr1->ref; remap; remap = remap->next)
8614 if (!remap->next && remap->type == REF_ARRAY
8615 && remap->u.ar.type == AR_SECTION)
8617 rank_remap = (remap && remap->u.ar.end[0]);
8619 gfc_init_se (&lse, NULL);
8621 lse.descriptor_only = 1;
8622 gfc_conv_expr_descriptor (&lse, expr1);
8623 strlen_lhs = lse.string_length;
8626 if (expr2->expr_type == EXPR_NULL)
8628 /* Just set the data pointer to null. */
8629 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
8631 else if (rank_remap)
8633 /* If we are rank-remapping, just get the RHS's descriptor and
8634 process this later on. */
8635 gfc_init_se (&rse, NULL);
8636 rse.direct_byref = 1;
8637 rse.byref_noassign = 1;
8639 if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8640 expr1_vptr = trans_class_pointer_fcn (&block, &lse, &rse,
8642 else if (expr2->expr_type == EXPR_FUNCTION)
8644 tree bound[GFC_MAX_DIMENSIONS];
8647 for (i = 0; i < expr2->rank; i++)
8648 bound[i] = NULL_TREE;
8649 tmp = gfc_typenode_for_spec (&expr2->ts);
8650 tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
8652 GFC_ARRAY_POINTER_CONT, false);
8653 tmp = gfc_create_var (tmp, "ptrtemp");
8654 rse.descriptor_only = 0;
8656 rse.direct_byref = 1;
8657 gfc_conv_expr_descriptor (&rse, expr2);
8658 strlen_rhs = rse.string_length;
8663 gfc_conv_expr_descriptor (&rse, expr2);
8664 strlen_rhs = rse.string_length;
8665 if (expr1->ts.type == BT_CLASS)
8666 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8671 else if (expr2->expr_type == EXPR_VARIABLE)
8673 /* Assign directly to the LHS's descriptor. */
8674 lse.descriptor_only = 0;
8675 lse.direct_byref = 1;
8676 gfc_conv_expr_descriptor (&lse, expr2);
8677 strlen_rhs = lse.string_length;
8679 if (expr1->ts.type == BT_CLASS)
8681 rse.expr = NULL_TREE;
8682 rse.string_length = NULL_TREE;
8683 trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
8689 /* If the target is not a whole array, use the target array
8690 reference for remap. */
8691 for (remap = expr2->ref; remap; remap = remap->next)
8692 if (remap->type == REF_ARRAY
8693 && remap->u.ar.type == AR_FULL
8698 else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS)
8700 gfc_init_se (&rse, NULL);
8701 rse.want_pointer = 1;
8702 gfc_conv_function_expr (&rse, expr2);
8703 if (expr1->ts.type != BT_CLASS)
8705 rse.expr = gfc_class_data_get (rse.expr);
8706 gfc_add_modify (&lse.pre, desc, rse.expr);
8707 /* Set the lhs span. */
8708 tmp = TREE_TYPE (rse.expr);
8709 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8710 tmp = fold_convert (gfc_array_index_type, tmp);
8711 gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
8715 expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
8718 gfc_add_block_to_block (&block, &rse.pre);
8719 tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
8720 gfc_add_modify (&lse.pre, tmp, rse.expr);
8722 gfc_add_modify (&lse.pre, expr1_vptr,
8723 fold_convert (TREE_TYPE (expr1_vptr),
8724 gfc_class_vptr_get (tmp)));
8725 rse.expr = gfc_class_data_get (tmp);
8726 gfc_add_modify (&lse.pre, desc, rse.expr);
8731 /* Assign to a temporary descriptor and then copy that
8732 temporary to the pointer. */
8733 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
8734 lse.descriptor_only = 0;
8736 lse.direct_byref = 1;
8737 gfc_conv_expr_descriptor (&lse, expr2);
8738 strlen_rhs = lse.string_length;
8739 gfc_add_modify (&lse.pre, desc, tmp);
8742 gfc_add_block_to_block (&block, &lse.pre);
8744 gfc_add_block_to_block (&block, &rse.pre);
8746 /* If we do bounds remapping, update LHS descriptor accordingly. */
8750 gcc_assert (remap->u.ar.dimen == expr1->rank);
8754 /* Do rank remapping. We already have the RHS's descriptor
8755 converted in rse and now have to build the correct LHS
8756 descriptor for it. */
8758 tree dtype, data, span;
8760 tree lbound, ubound;
8763 dtype = gfc_conv_descriptor_dtype (desc);
8764 tmp = gfc_get_dtype (TREE_TYPE (desc));
8765 gfc_add_modify (&block, dtype, tmp);
8767 /* Copy data pointer. */
8768 data = gfc_conv_descriptor_data_get (rse.expr);
8769 gfc_conv_descriptor_data_set (&block, desc, data);
8771 /* Copy the span. */
8772 if (TREE_CODE (rse.expr) == VAR_DECL
8773 && GFC_DECL_PTR_ARRAY_P (rse.expr))
8774 span = gfc_conv_descriptor_span_get (rse.expr);
8777 tmp = TREE_TYPE (rse.expr);
8778 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
8779 span = fold_convert (gfc_array_index_type, tmp);
8781 gfc_conv_descriptor_span_set (&block, desc, span);
8783 /* Copy offset but adjust it such that it would correspond
8784 to a lbound of zero. */
8785 offs = gfc_conv_descriptor_offset_get (rse.expr);
8786 for (dim = 0; dim < expr2->rank; ++dim)
8788 stride = gfc_conv_descriptor_stride_get (rse.expr,
8790 lbound = gfc_conv_descriptor_lbound_get (rse.expr,
8792 tmp = fold_build2_loc (input_location, MULT_EXPR,
8793 gfc_array_index_type, stride, lbound);
8794 offs = fold_build2_loc (input_location, PLUS_EXPR,
8795 gfc_array_index_type, offs, tmp);
8797 gfc_conv_descriptor_offset_set (&block, desc, offs);
8799 /* Set the bounds as declared for the LHS and calculate strides as
8800 well as another offset update accordingly. */
8801 stride = gfc_conv_descriptor_stride_get (rse.expr,
8803 for (dim = 0; dim < expr1->rank; ++dim)
8808 gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
8810 /* Convert declared bounds. */
8811 gfc_init_se (&lower_se, NULL);
8812 gfc_init_se (&upper_se, NULL);
8813 gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
8814 gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
8816 gfc_add_block_to_block (&block, &lower_se.pre);
8817 gfc_add_block_to_block (&block, &upper_se.pre);
8819 lbound = fold_convert (gfc_array_index_type, lower_se.expr);
8820 ubound = fold_convert (gfc_array_index_type, upper_se.expr);
8822 lbound = gfc_evaluate_now (lbound, &block);
8823 ubound = gfc_evaluate_now (ubound, &block);
8825 gfc_add_block_to_block (&block, &lower_se.post);
8826 gfc_add_block_to_block (&block, &upper_se.post);
8828 /* Set bounds in descriptor. */
8829 gfc_conv_descriptor_lbound_set (&block, desc,
8830 gfc_rank_cst[dim], lbound);
8831 gfc_conv_descriptor_ubound_set (&block, desc,
8832 gfc_rank_cst[dim], ubound);
8835 stride = gfc_evaluate_now (stride, &block);
8836 gfc_conv_descriptor_stride_set (&block, desc,
8837 gfc_rank_cst[dim], stride);
8839 /* Update offset. */
8840 offs = gfc_conv_descriptor_offset_get (desc);
8841 tmp = fold_build2_loc (input_location, MULT_EXPR,
8842 gfc_array_index_type, lbound, stride);
8843 offs = fold_build2_loc (input_location, MINUS_EXPR,
8844 gfc_array_index_type, offs, tmp);
8845 offs = gfc_evaluate_now (offs, &block);
8846 gfc_conv_descriptor_offset_set (&block, desc, offs);
8848 /* Update stride. */
8849 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
8850 stride = fold_build2_loc (input_location, MULT_EXPR,
8851 gfc_array_index_type, stride, tmp);
8856 /* Bounds remapping. Just shift the lower bounds. */
8858 gcc_assert (expr1->rank == expr2->rank);
8860 for (dim = 0; dim < remap->u.ar.dimen; ++dim)
8864 gcc_assert (!remap->u.ar.end[dim]);
8865 gfc_init_se (&lbound_se, NULL);
8866 if (remap->u.ar.start[dim])
8868 gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
8869 gfc_add_block_to_block (&block, &lbound_se.pre);
8872 /* This remap arises from a target that is not a whole
8873 array. The start expressions will be NULL but we need
8874 the lbounds to be one. */
8875 lbound_se.expr = gfc_index_one_node;
8876 gfc_conv_shift_descriptor_lbound (&block, desc,
8877 dim, lbound_se.expr);
8878 gfc_add_block_to_block (&block, &lbound_se.post);
8883 /* Check string lengths if applicable. The check is only really added
8884 to the output code if -fbounds-check is enabled. */
8885 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
8887 gcc_assert (expr2->ts.type == BT_CHARACTER);
8888 gcc_assert (strlen_lhs && strlen_rhs);
8889 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
8890 strlen_lhs, strlen_rhs, &block);
8893 /* If rank remapping was done, check with -fcheck=bounds that
8894 the target is at least as large as the pointer. */
8895 if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
8901 lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
8902 rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
8904 lsize = gfc_evaluate_now (lsize, &block);
8905 rsize = gfc_evaluate_now (rsize, &block);
8906 fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
8909 msg = _("Target of rank remapping is too small (%ld < %ld)");
8910 gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
8914 if (expr1->ts.type == BT_CHARACTER
8915 && expr1->symtree->n.sym->ts.deferred
8916 && expr1->symtree->n.sym->ts.u.cl->backend_decl
8917 && VAR_P (expr1->symtree->n.sym->ts.u.cl->backend_decl))
8919 tmp = expr1->symtree->n.sym->ts.u.cl->backend_decl;
8920 if (expr2->expr_type != EXPR_NULL)
8921 gfc_add_modify (&block, tmp,
8922 fold_convert (TREE_TYPE (tmp), strlen_rhs));
8924 gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
8927 gfc_add_block_to_block (&block, &lse.post);
8929 gfc_add_block_to_block (&block, &rse.post);
8932 return gfc_finish_block (&block);
8936 /* Makes sure se is suitable for passing as a function string parameter. */
8937 /* TODO: Need to check all callers of this function. It may be abused. */
8940 gfc_conv_string_parameter (gfc_se * se)
8944 if (TREE_CODE (se->expr) == STRING_CST)
8946 type = TREE_TYPE (TREE_TYPE (se->expr));
8947 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8951 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
8953 if (TREE_CODE (se->expr) != INDIRECT_REF)
8955 type = TREE_TYPE (se->expr);
8956 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
8960 type = gfc_get_character_type_len (gfc_default_character_kind,
8962 type = build_pointer_type (type);
8963 se->expr = gfc_build_addr_expr (type, se->expr);
8967 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
8971 /* Generate code for assignment of scalar variables. Includes character
8972 strings and derived types with allocatable components.
8973 If you know that the LHS has no allocations, set dealloc to false.
8975 DEEP_COPY has no effect if the typespec TS is not a derived type with
8976 allocatable components. Otherwise, if it is set, an explicit copy of each
8977 allocatable component is made. This is necessary as a simple copy of the
8978 whole object would copy array descriptors as is, so that the lhs's
8979 allocatable components would point to the rhs's after the assignment.
8980 Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not
8981 necessary if the rhs is a non-pointer function, as the allocatable components
8982 are not accessible by other means than the function's result after the
8983 function has returned. It is even more subtle when temporaries are involved,
8984 as the two following examples show:
8985 1. When we evaluate an array constructor, a temporary is created. Thus
8986 there is theoretically no alias possible. However, no deep copy is
8987 made for this temporary, so that if the constructor is made of one or
8988 more variable with allocatable components, those components still point
8989 to the variable's: DEEP_COPY should be set for the assignment from the
8990 temporary to the lhs in that case.
8991 2. When assigning a scalar to an array, we evaluate the scalar value out
8992 of the loop, store it into a temporary variable, and assign from that.
8993 In that case, deep copying when assigning to the temporary would be a
8994 waste of resources; however deep copies should happen when assigning from
8995 the temporary to each array element: again DEEP_COPY should be set for
8996 the assignment from the temporary to the lhs. */
8999 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
9000 bool deep_copy, bool dealloc, bool in_coarray)
9006 gfc_init_block (&block);
9008 if (ts.type == BT_CHARACTER)
9013 if (lse->string_length != NULL_TREE)
9015 gfc_conv_string_parameter (lse);
9016 gfc_add_block_to_block (&block, &lse->pre);
9017 llen = lse->string_length;
9020 if (rse->string_length != NULL_TREE)
9022 gfc_conv_string_parameter (rse);
9023 gfc_add_block_to_block (&block, &rse->pre);
9024 rlen = rse->string_length;
9027 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
9028 rse->expr, ts.kind);
9030 else if (gfc_bt_struct (ts.type)
9031 && (ts.u.derived->attr.alloc_comp
9032 || (deep_copy && ts.u.derived->attr.pdt_type)))
9034 tree tmp_var = NULL_TREE;
9037 /* Are the rhs and the lhs the same? */
9040 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9041 gfc_build_addr_expr (NULL_TREE, lse->expr),
9042 gfc_build_addr_expr (NULL_TREE, rse->expr));
9043 cond = gfc_evaluate_now (cond, &lse->pre);
9046 /* Deallocate the lhs allocated components as long as it is not
9047 the same as the rhs. This must be done following the assignment
9048 to prevent deallocating data that could be used in the rhs
9052 tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
9053 tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
9055 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9057 gfc_add_expr_to_block (&lse->post, tmp);
9060 gfc_add_block_to_block (&block, &rse->pre);
9061 gfc_add_block_to_block (&block, &lse->pre);
9063 gfc_add_modify (&block, lse->expr,
9064 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9066 /* Restore pointer address of coarray components. */
9067 if (ts.u.derived->attr.coarray_comp && deep_copy && tmp_var != NULL_TREE)
9069 tmp = gfc_reassign_alloc_comp_caf (ts.u.derived, tmp_var, lse->expr);
9070 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9072 gfc_add_expr_to_block (&block, tmp);
9075 /* Do a deep copy if the rhs is a variable, if it is not the
9079 int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
9080 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0;
9081 tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0,
9083 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
9085 gfc_add_expr_to_block (&block, tmp);
9088 else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
9090 gfc_add_block_to_block (&block, &lse->pre);
9091 gfc_add_block_to_block (&block, &rse->pre);
9092 tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
9093 TREE_TYPE (lse->expr), rse->expr);
9094 gfc_add_modify (&block, lse->expr, tmp);
9098 gfc_add_block_to_block (&block, &lse->pre);
9099 gfc_add_block_to_block (&block, &rse->pre);
9101 gfc_add_modify (&block, lse->expr,
9102 fold_convert (TREE_TYPE (lse->expr), rse->expr));
9105 gfc_add_block_to_block (&block, &lse->post);
9106 gfc_add_block_to_block (&block, &rse->post);
9108 return gfc_finish_block (&block);
9112 /* There are quite a lot of restrictions on the optimisation in using an
9113 array function assign without a temporary. */
9116 arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
9119 bool seen_array_ref;
9121 gfc_symbol *sym = expr1->symtree->n.sym;
9123 /* Play it safe with class functions assigned to a derived type. */
9124 if (gfc_is_class_array_function (expr2)
9125 && expr1->ts.type == BT_DERIVED)
9128 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
9129 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
9132 /* Elemental functions are scalarized so that they don't need a
9133 temporary in gfc_trans_assignment_1, so return a true. Otherwise,
9134 they would need special treatment in gfc_trans_arrayfunc_assign. */
9135 if (expr2->value.function.esym != NULL
9136 && expr2->value.function.esym->attr.elemental)
9139 /* Need a temporary if rhs is not FULL or a contiguous section. */
9140 if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
9143 /* Need a temporary if EXPR1 can't be expressed as a descriptor. */
9144 if (gfc_ref_needs_temporary_p (expr1->ref))
9147 /* Functions returning pointers or allocatables need temporaries. */
9148 c = expr2->value.function.esym
9149 ? (expr2->value.function.esym->attr.pointer
9150 || expr2->value.function.esym->attr.allocatable)
9151 : (expr2->symtree->n.sym->attr.pointer
9152 || expr2->symtree->n.sym->attr.allocatable);
9156 /* Character array functions need temporaries unless the
9157 character lengths are the same. */
9158 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
9160 if (expr1->ts.u.cl->length == NULL
9161 || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9164 if (expr2->ts.u.cl->length == NULL
9165 || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
9168 if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
9169 expr2->ts.u.cl->length->value.integer) != 0)
9173 /* Check that no LHS component references appear during an array
9174 reference. This is needed because we do not have the means to
9175 span any arbitrary stride with an array descriptor. This check
9176 is not needed for the rhs because the function result has to be
9178 seen_array_ref = false;
9179 for (ref = expr1->ref; ref; ref = ref->next)
9181 if (ref->type == REF_ARRAY)
9182 seen_array_ref= true;
9183 else if (ref->type == REF_COMPONENT && seen_array_ref)
9187 /* Check for a dependency. */
9188 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
9189 expr2->value.function.esym,
9190 expr2->value.function.actual,
9194 /* If we have reached here with an intrinsic function, we do not
9195 need a temporary except in the particular case that reallocation
9196 on assignment is active and the lhs is allocatable and a target. */
9197 if (expr2->value.function.isym)
9198 return (flag_realloc_lhs && sym->attr.allocatable && sym->attr.target);
9200 /* If the LHS is a dummy, we need a temporary if it is not
9202 if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
9205 /* If the lhs has been host_associated, is in common, a pointer or is
9206 a target and the function is not using a RESULT variable, aliasing
9207 can occur and a temporary is needed. */
9208 if ((sym->attr.host_assoc
9209 || sym->attr.in_common
9210 || sym->attr.pointer
9211 || sym->attr.cray_pointee
9212 || sym->attr.target)
9213 && expr2->symtree != NULL
9214 && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
9217 /* A PURE function can unconditionally be called without a temporary. */
9218 if (expr2->value.function.esym != NULL
9219 && expr2->value.function.esym->attr.pure)
9222 /* Implicit_pure functions are those which could legally be declared
9224 if (expr2->value.function.esym != NULL
9225 && expr2->value.function.esym->attr.implicit_pure)
9228 if (!sym->attr.use_assoc
9229 && !sym->attr.in_common
9230 && !sym->attr.pointer
9231 && !sym->attr.target
9232 && !sym->attr.cray_pointee
9233 && expr2->value.function.esym)
9235 /* A temporary is not needed if the function is not contained and
9236 the variable is local or host associated and not a pointer or
9238 if (!expr2->value.function.esym->attr.contained)
9241 /* A temporary is not needed if the lhs has never been host
9242 associated and the procedure is contained. */
9243 else if (!sym->attr.host_assoc)
9246 /* A temporary is not needed if the variable is local and not
9247 a pointer, a target or a result. */
9249 && expr2->value.function.esym->ns == sym->ns->parent)
9253 /* Default to temporary use. */
9258 /* Provide the loop info so that the lhs descriptor can be built for
9259 reallocatable assignments from extrinsic function calls. */
9262 realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
9265 /* Signal that the function call should not be made by
9266 gfc_conv_loop_setup. */
9267 se->ss->is_alloc_lhs = 1;
9268 gfc_init_loopinfo (loop);
9269 gfc_add_ss_to_loop (loop, *ss);
9270 gfc_add_ss_to_loop (loop, se->ss);
9271 gfc_conv_ss_startstride (loop);
9272 gfc_conv_loop_setup (loop, where);
9273 gfc_copy_loopinfo_to_se (se, loop);
9274 gfc_add_block_to_block (&se->pre, &loop->pre);
9275 gfc_add_block_to_block (&se->pre, &loop->post);
9276 se->ss->is_alloc_lhs = 0;
9280 /* For assignment to a reallocatable lhs from intrinsic functions,
9281 replace the se.expr (ie. the result) with a temporary descriptor.
9282 Null the data field so that the library allocates space for the
9283 result. Free the data of the original descriptor after the function,
9284 in case it appears in an argument expression and transfer the
9285 result to the original descriptor. */
9288 fcncall_realloc_result (gfc_se *se, int rank)
9297 /* Use the allocation done by the library. Substitute the lhs
9298 descriptor with a copy, whose data field is nulled.*/
9299 desc = build_fold_indirect_ref_loc (input_location, se->expr);
9300 if (POINTER_TYPE_P (TREE_TYPE (desc)))
9301 desc = build_fold_indirect_ref_loc (input_location, desc);
9303 /* Unallocated, the descriptor does not have a dtype. */
9304 tmp = gfc_conv_descriptor_dtype (desc);
9305 gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
9307 res_desc = gfc_evaluate_now (desc, &se->pre);
9308 gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
9309 se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
9311 /* Free the lhs after the function call and copy the result data to
9312 the lhs descriptor. */
9313 tmp = gfc_conv_descriptor_data_get (desc);
9314 zero_cond = fold_build2_loc (input_location, EQ_EXPR,
9315 logical_type_node, tmp,
9316 build_int_cst (TREE_TYPE (tmp), 0));
9317 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9318 tmp = gfc_call_free (tmp);
9319 gfc_add_expr_to_block (&se->post, tmp);
9321 tmp = gfc_conv_descriptor_data_get (res_desc);
9322 gfc_conv_descriptor_data_set (&se->post, desc, tmp);
9324 /* Check that the shapes are the same between lhs and expression. */
9325 for (n = 0 ; n < rank; n++)
9328 tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9329 tmp1 = gfc_conv_descriptor_lbound_get (res_desc, gfc_rank_cst[n]);
9330 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9331 gfc_array_index_type, tmp, tmp1);
9332 tmp1 = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
9333 tmp = fold_build2_loc (input_location, MINUS_EXPR,
9334 gfc_array_index_type, tmp, tmp1);
9335 tmp1 = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9336 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9337 gfc_array_index_type, tmp, tmp1);
9338 tmp = fold_build2_loc (input_location, NE_EXPR,
9339 logical_type_node, tmp,
9340 gfc_index_zero_node);
9341 tmp = gfc_evaluate_now (tmp, &se->post);
9342 zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
9343 logical_type_node, tmp,
9347 /* 'zero_cond' being true is equal to lhs not being allocated or the
9348 shapes being different. */
9349 zero_cond = gfc_evaluate_now (zero_cond, &se->post);
9351 /* Now reset the bounds returned from the function call to bounds based
9352 on the lhs lbounds, except where the lhs is not allocated or the shapes
9353 of 'variable and 'expr' are different. Set the offset accordingly. */
9354 offset = gfc_index_zero_node;
9355 for (n = 0 ; n < rank; n++)
9359 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
9360 lbound = fold_build3_loc (input_location, COND_EXPR,
9361 gfc_array_index_type, zero_cond,
9362 gfc_index_one_node, lbound);
9363 lbound = gfc_evaluate_now (lbound, &se->post);
9365 tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
9366 tmp = fold_build2_loc (input_location, PLUS_EXPR,
9367 gfc_array_index_type, tmp, lbound);
9368 gfc_conv_descriptor_lbound_set (&se->post, desc,
9369 gfc_rank_cst[n], lbound);
9370 gfc_conv_descriptor_ubound_set (&se->post, desc,
9371 gfc_rank_cst[n], tmp);
9373 /* Set stride and accumulate the offset. */
9374 tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
9375 gfc_conv_descriptor_stride_set (&se->post, desc,
9376 gfc_rank_cst[n], tmp);
9377 tmp = fold_build2_loc (input_location, MULT_EXPR,
9378 gfc_array_index_type, lbound, tmp);
9379 offset = fold_build2_loc (input_location, MINUS_EXPR,
9380 gfc_array_index_type, offset, tmp);
9381 offset = gfc_evaluate_now (offset, &se->post);
9384 gfc_conv_descriptor_offset_set (&se->post, desc, offset);
9389 /* Try to translate array(:) = func (...), where func is a transformational
9390 array function, without using a temporary. Returns NULL if this isn't the
9394 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
9398 gfc_component *comp = NULL;
9401 if (arrayfunc_assign_needs_temporary (expr1, expr2))
9404 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
9406 comp = gfc_get_proc_ptr_comp (expr2);
9408 if (!(expr2->value.function.isym
9409 || (comp && comp->attr.dimension)
9410 || (!comp && gfc_return_by_reference (expr2->value.function.esym)
9411 && expr2->value.function.esym->result->attr.dimension)))
9414 gfc_init_se (&se, NULL);
9415 gfc_start_block (&se.pre);
9416 se.want_pointer = 1;
9418 gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL);
9420 if (expr1->ts.type == BT_DERIVED
9421 && expr1->ts.u.derived->attr.alloc_comp)
9424 tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, se.expr,
9426 gfc_add_expr_to_block (&se.pre, tmp);
9429 se.direct_byref = 1;
9430 se.ss = gfc_walk_expr (expr2);
9431 gcc_assert (se.ss != gfc_ss_terminator);
9433 /* Reallocate on assignment needs the loopinfo for extrinsic functions.
9434 This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
9435 Clearly, this cannot be done for an allocatable function result, since
9436 the shape of the result is unknown and, in any case, the function must
9437 correctly take care of the reallocation internally. For intrinsic
9438 calls, the array data is freed and the library takes care of allocation.
9439 TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
9441 if (flag_realloc_lhs
9442 && gfc_is_reallocatable_lhs (expr1)
9443 && !gfc_expr_attr (expr1).codimension
9444 && !gfc_is_coindexed (expr1)
9445 && !(expr2->value.function.esym
9446 && expr2->value.function.esym->result->attr.allocatable))
9448 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
9450 if (!expr2->value.function.isym)
9452 ss = gfc_walk_expr (expr1);
9453 gcc_assert (ss != gfc_ss_terminator);
9455 realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
9456 ss->is_alloc_lhs = 1;
9459 fcncall_realloc_result (&se, expr1->rank);
9462 gfc_conv_function_expr (&se, expr2);
9463 gfc_add_block_to_block (&se.pre, &se.post);
9466 gfc_cleanup_loop (&loop);
9468 gfc_free_ss_chain (se.ss);
9470 return gfc_finish_block (&se.pre);
9474 /* Try to efficiently translate array(:) = 0. Return NULL if this
9478 gfc_trans_zero_assign (gfc_expr * expr)
9480 tree dest, len, type;
9484 sym = expr->symtree->n.sym;
9485 dest = gfc_get_symbol_decl (sym);
9487 type = TREE_TYPE (dest);
9488 if (POINTER_TYPE_P (type))
9489 type = TREE_TYPE (type);
9490 if (!GFC_ARRAY_TYPE_P (type))
9493 /* Determine the length of the array. */
9494 len = GFC_TYPE_ARRAY_SIZE (type);
9495 if (!len || TREE_CODE (len) != INTEGER_CST)
9498 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
9499 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9500 fold_convert (gfc_array_index_type, tmp));
9502 /* If we are zeroing a local array avoid taking its address by emitting
9504 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
9505 return build2_loc (input_location, MODIFY_EXPR, void_type_node,
9506 dest, build_constructor (TREE_TYPE (dest),
9509 /* Convert arguments to the correct types. */
9510 dest = fold_convert (pvoid_type_node, dest);
9511 len = fold_convert (size_type_node, len);
9513 /* Construct call to __builtin_memset. */
9514 tmp = build_call_expr_loc (input_location,
9515 builtin_decl_explicit (BUILT_IN_MEMSET),
9516 3, dest, integer_zero_node, len);
9517 return fold_convert (void_type_node, tmp);
9521 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
9522 that constructs the call to __builtin_memcpy. */
9525 gfc_build_memcpy_call (tree dst, tree src, tree len)
9529 /* Convert arguments to the correct types. */
9530 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
9531 dst = gfc_build_addr_expr (pvoid_type_node, dst);
9533 dst = fold_convert (pvoid_type_node, dst);
9535 if (!POINTER_TYPE_P (TREE_TYPE (src)))
9536 src = gfc_build_addr_expr (pvoid_type_node, src);
9538 src = fold_convert (pvoid_type_node, src);
9540 len = fold_convert (size_type_node, len);
9542 /* Construct call to __builtin_memcpy. */
9543 tmp = build_call_expr_loc (input_location,
9544 builtin_decl_explicit (BUILT_IN_MEMCPY),
9546 return fold_convert (void_type_node, tmp);
9550 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
9551 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
9552 source/rhs, both are gfc_full_array_ref_p which have been checked for
9556 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
9558 tree dst, dlen, dtype;
9559 tree src, slen, stype;
9562 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9563 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
9565 dtype = TREE_TYPE (dst);
9566 if (POINTER_TYPE_P (dtype))
9567 dtype = TREE_TYPE (dtype);
9568 stype = TREE_TYPE (src);
9569 if (POINTER_TYPE_P (stype))
9570 stype = TREE_TYPE (stype);
9572 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
9575 /* Determine the lengths of the arrays. */
9576 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
9577 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
9579 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9580 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9581 dlen, fold_convert (gfc_array_index_type, tmp));
9583 slen = GFC_TYPE_ARRAY_SIZE (stype);
9584 if (!slen || TREE_CODE (slen) != INTEGER_CST)
9586 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
9587 slen = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
9588 slen, fold_convert (gfc_array_index_type, tmp));
9590 /* Sanity check that they are the same. This should always be
9591 the case, as we should already have checked for conformance. */
9592 if (!tree_int_cst_equal (slen, dlen))
9595 return gfc_build_memcpy_call (dst, src, dlen);
9599 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
9600 this can't be done. EXPR1 is the destination/lhs for which
9601 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
9604 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
9606 unsigned HOST_WIDE_INT nelem;
9612 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
9616 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
9617 dtype = TREE_TYPE (dst);
9618 if (POINTER_TYPE_P (dtype))
9619 dtype = TREE_TYPE (dtype);
9620 if (!GFC_ARRAY_TYPE_P (dtype))
9623 /* Determine the lengths of the array. */
9624 len = GFC_TYPE_ARRAY_SIZE (dtype);
9625 if (!len || TREE_CODE (len) != INTEGER_CST)
9628 /* Confirm that the constructor is the same size. */
9629 if (compare_tree_int (len, nelem) != 0)
9632 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
9633 len = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, len,
9634 fold_convert (gfc_array_index_type, tmp));
9636 stype = gfc_typenode_for_spec (&expr2->ts);
9637 src = gfc_build_constant_array_constructor (expr2, stype);
9639 stype = TREE_TYPE (src);
9640 if (POINTER_TYPE_P (stype))
9641 stype = TREE_TYPE (stype);
9643 return gfc_build_memcpy_call (dst, src, len);
9647 /* Tells whether the expression is to be treated as a variable reference. */
9650 gfc_expr_is_variable (gfc_expr *expr)
9653 gfc_component *comp;
9654 gfc_symbol *func_ifc;
9656 if (expr->expr_type == EXPR_VARIABLE)
9659 arg = gfc_get_noncopying_intrinsic_argument (expr);
9662 gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
9663 return gfc_expr_is_variable (arg);
9666 /* A data-pointer-returning function should be considered as a variable
9668 if (expr->expr_type == EXPR_FUNCTION
9669 && expr->ref == NULL)
9671 if (expr->value.function.isym != NULL)
9674 if (expr->value.function.esym != NULL)
9676 func_ifc = expr->value.function.esym;
9681 gcc_assert (expr->symtree);
9682 func_ifc = expr->symtree->n.sym;
9689 comp = gfc_get_proc_ptr_comp (expr);
9690 if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION)
9693 func_ifc = comp->ts.interface;
9697 if (expr->expr_type == EXPR_COMPCALL)
9699 gcc_assert (!expr->value.compcall.tbp->is_generic);
9700 func_ifc = expr->value.compcall.tbp->u.specific->n.sym;
9707 gcc_assert (func_ifc->attr.function
9708 && func_ifc->result != NULL);
9709 return func_ifc->result->attr.pointer;
9713 /* Is the lhs OK for automatic reallocation? */
9716 is_scalar_reallocatable_lhs (gfc_expr *expr)
9720 /* An allocatable variable with no reference. */
9721 if (expr->symtree->n.sym->attr.allocatable
9725 /* All that can be left are allocatable components. However, we do
9726 not check for allocatable components here because the expression
9727 could be an allocatable component of a pointer component. */
9728 if (expr->symtree->n.sym->ts.type != BT_DERIVED
9729 && expr->symtree->n.sym->ts.type != BT_CLASS)
9732 /* Find an allocatable component ref last. */
9733 for (ref = expr->ref; ref; ref = ref->next)
9734 if (ref->type == REF_COMPONENT
9736 && ref->u.c.component->attr.allocatable)
9743 /* Allocate or reallocate scalar lhs, as necessary. */
9746 alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
9761 if (!expr1 || expr1->rank)
9764 if (!expr2 || expr2->rank)
9767 for (ref = expr1->ref; ref; ref = ref->next)
9768 if (ref->type == REF_SUBSTRING)
9771 realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
9773 /* Since this is a scalar lhs, we can afford to do this. That is,
9774 there is no risk of side effects being repeated. */
9775 gfc_init_se (&lse, NULL);
9776 lse.want_pointer = 1;
9777 gfc_conv_expr (&lse, expr1);
9779 jump_label1 = gfc_build_label_decl (NULL_TREE);
9780 jump_label2 = gfc_build_label_decl (NULL_TREE);
9782 /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
9783 tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
9784 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
9786 tmp = build3_v (COND_EXPR, cond,
9787 build1_v (GOTO_EXPR, jump_label1),
9788 build_empty_stmt (input_location));
9789 gfc_add_expr_to_block (block, tmp);
9791 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9793 /* Use the rhs string length and the lhs element size. */
9794 size = string_length;
9795 tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
9796 tmp = TYPE_SIZE_UNIT (tmp);
9797 size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
9798 TREE_TYPE (tmp), tmp,
9799 fold_convert (TREE_TYPE (tmp), size));
9803 /* Otherwise use the length in bytes of the rhs. */
9804 size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
9805 size_in_bytes = size;
9808 size_in_bytes = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
9809 size_in_bytes, size_one_node);
9811 if (gfc_caf_attr (expr1).codimension && flag_coarray == GFC_FCOARRAY_LIB)
9813 tree caf_decl, token;
9815 symbol_attribute attr;
9817 gfc_clear_attr (&attr);
9818 gfc_init_se (&caf_se, NULL);
9820 caf_decl = gfc_get_tree_for_caf_expr (expr1);
9821 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, NULL_TREE,
9823 gfc_add_block_to_block (block, &caf_se.pre);
9824 gfc_allocate_allocatable (block, lse.expr, size_in_bytes,
9825 gfc_build_addr_expr (NULL_TREE, token),
9826 NULL_TREE, NULL_TREE, NULL_TREE, jump_label1,
9829 else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp)
9831 tmp = build_call_expr_loc (input_location,
9832 builtin_decl_explicit (BUILT_IN_CALLOC),
9833 2, build_one_cst (size_type_node),
9835 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9836 gfc_add_modify (block, lse.expr, tmp);
9840 tmp = build_call_expr_loc (input_location,
9841 builtin_decl_explicit (BUILT_IN_MALLOC),
9843 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9844 gfc_add_modify (block, lse.expr, tmp);
9847 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9849 /* Deferred characters need checking for lhs and rhs string
9850 length. Other deferred parameter variables will have to
9852 tmp = build1_v (GOTO_EXPR, jump_label2);
9853 gfc_add_expr_to_block (block, tmp);
9855 tmp = build1_v (LABEL_EXPR, jump_label1);
9856 gfc_add_expr_to_block (block, tmp);
9858 /* For a deferred length character, reallocate if lengths of lhs and
9859 rhs are different. */
9860 if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
9862 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
9864 fold_convert (TREE_TYPE (lse.string_length),
9866 /* Jump past the realloc if the lengths are the same. */
9867 tmp = build3_v (COND_EXPR, cond,
9868 build1_v (GOTO_EXPR, jump_label2),
9869 build_empty_stmt (input_location));
9870 gfc_add_expr_to_block (block, tmp);
9871 tmp = build_call_expr_loc (input_location,
9872 builtin_decl_explicit (BUILT_IN_REALLOC),
9873 2, fold_convert (pvoid_type_node, lse.expr),
9875 tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
9876 gfc_add_modify (block, lse.expr, tmp);
9877 tmp = build1_v (LABEL_EXPR, jump_label2);
9878 gfc_add_expr_to_block (block, tmp);
9880 /* Update the lhs character length. */
9881 size = string_length;
9882 gfc_add_modify (block, lse.string_length,
9883 fold_convert (TREE_TYPE (lse.string_length), size));
9887 /* Check for assignments of the type
9891 to make sure we do not check for reallocation unneccessarily. */
9895 is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
9897 gfc_actual_arglist *a;
9900 switch (expr2->expr_type)
9903 return gfc_dep_compare_expr (expr1, expr2) == 0;
9906 if (expr2->value.function.esym
9907 && expr2->value.function.esym->attr.elemental)
9909 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9912 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9917 else if (expr2->value.function.isym
9918 && expr2->value.function.isym->elemental)
9920 for (a = expr2->value.function.actual; a != NULL; a = a->next)
9923 if (e1 && e1->rank > 0 && !is_runtime_conformable (expr1, e1))
9932 switch (expr2->value.op.op)
9935 case INTRINSIC_UPLUS:
9936 case INTRINSIC_UMINUS:
9937 case INTRINSIC_PARENTHESES:
9938 return is_runtime_conformable (expr1, expr2->value.op.op1);
9940 case INTRINSIC_PLUS:
9941 case INTRINSIC_MINUS:
9942 case INTRINSIC_TIMES:
9943 case INTRINSIC_DIVIDE:
9944 case INTRINSIC_POWER:
9948 case INTRINSIC_NEQV:
9955 case INTRINSIC_EQ_OS:
9956 case INTRINSIC_NE_OS:
9957 case INTRINSIC_GT_OS:
9958 case INTRINSIC_GE_OS:
9959 case INTRINSIC_LT_OS:
9960 case INTRINSIC_LE_OS:
9962 e1 = expr2->value.op.op1;
9963 e2 = expr2->value.op.op2;
9965 if (e1->rank == 0 && e2->rank > 0)
9966 return is_runtime_conformable (expr1, e2);
9967 else if (e1->rank > 0 && e2->rank == 0)
9968 return is_runtime_conformable (expr1, e1);
9969 else if (e1->rank > 0 && e2->rank > 0)
9970 return is_runtime_conformable (expr1, e1)
9971 && is_runtime_conformable (expr1, e2);
9989 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
9990 gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
9993 tree tmp, fcn, stdcopy, to_len, from_len, vptr;
9994 vec<tree, va_gc> *args = NULL;
9996 vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
9999 /* Generate allocation of the lhs. */
10005 tmp = gfc_vptr_size_get (vptr);
10006 class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10007 ? gfc_class_data_get (lse->expr) : lse->expr;
10008 gfc_init_block (&alloc);
10009 gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
10010 tmp = fold_build2_loc (input_location, EQ_EXPR,
10011 logical_type_node, class_han,
10012 build_int_cst (prvoid_type_node, 0));
10013 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
10015 PRED_FORTRAN_FAIL_ALLOC),
10016 gfc_finish_block (&alloc),
10017 build_empty_stmt (input_location));
10018 gfc_add_expr_to_block (&lse->pre, tmp);
10021 fcn = gfc_vptr_copy_get (vptr);
10023 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
10024 ? gfc_class_data_get (rse->expr) : rse->expr;
10027 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10028 || INDIRECT_REF_P (tmp)
10029 || (rhs->ts.type == BT_DERIVED
10030 && rhs->ts.u.derived->attr.unlimited_polymorphic
10031 && !rhs->ts.u.derived->attr.pointer
10032 && !rhs->ts.u.derived->attr.allocatable)
10033 || (UNLIMITED_POLY (rhs)
10034 && !CLASS_DATA (rhs)->attr.pointer
10035 && !CLASS_DATA (rhs)->attr.allocatable))
10036 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10038 vec_safe_push (args, tmp);
10039 tmp = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10040 ? gfc_class_data_get (lse->expr) : lse->expr;
10041 if (!POINTER_TYPE_P (TREE_TYPE (tmp))
10042 || INDIRECT_REF_P (tmp)
10043 || (lhs->ts.type == BT_DERIVED
10044 && lhs->ts.u.derived->attr.unlimited_polymorphic
10045 && !lhs->ts.u.derived->attr.pointer
10046 && !lhs->ts.u.derived->attr.allocatable)
10047 || (UNLIMITED_POLY (lhs)
10048 && !CLASS_DATA (lhs)->attr.pointer
10049 && !CLASS_DATA (lhs)->attr.allocatable))
10050 vec_safe_push (args, gfc_build_addr_expr (NULL_TREE, tmp));
10052 vec_safe_push (args, tmp);
10054 stdcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10056 if (to_len != NULL_TREE && !integer_zerop (from_len))
10059 vec_safe_push (args, from_len);
10060 vec_safe_push (args, to_len);
10061 extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args);
10063 tmp = fold_build2_loc (input_location, GT_EXPR,
10064 logical_type_node, from_len,
10065 build_zero_cst (TREE_TYPE (from_len)));
10066 return fold_build3_loc (input_location, COND_EXPR,
10067 void_type_node, tmp,
10075 tree rhst = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
10076 ? gfc_class_data_get (lse->expr) : lse->expr;
10077 stmtblock_t tblock;
10078 gfc_init_block (&tblock);
10079 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
10080 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10081 if (!POINTER_TYPE_P (TREE_TYPE (rhst)))
10082 rhst = gfc_build_addr_expr (NULL_TREE, rhst);
10083 /* When coming from a ptr_copy lhs and rhs are swapped. */
10084 gfc_add_modify_loc (input_location, &tblock, rhst,
10085 fold_convert (TREE_TYPE (rhst), tmp));
10086 return gfc_finish_block (&tblock);
10090 /* Subroutine of gfc_trans_assignment that actually scalarizes the
10091 assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
10092 init_flag indicates initialization expressions and dealloc that no
10093 deallocate prior assignment is needed (if in doubt, set true).
10094 When PTR_COPY is set and expr1 is a class type, then use the _vptr-copy
10095 routine instead of a pointer assignment. Alias resolution is only done,
10096 when MAY_ALIAS is set (the default). This flag is used by ALLOCATE()
10097 where it is known, that newly allocated memory on the lhs can never be
10098 an alias of the rhs. */
10101 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10102 bool dealloc, bool use_vptr_copy, bool may_alias)
10107 gfc_ss *lss_section;
10114 bool scalar_to_array;
10115 tree string_length;
10117 bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
10118 symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
10119 bool is_poly_assign;
10121 /* Assignment of the form lhs = rhs. */
10122 gfc_start_block (&block);
10124 gfc_init_se (&lse, NULL);
10125 gfc_init_se (&rse, NULL);
10127 /* Walk the lhs. */
10128 lss = gfc_walk_expr (expr1);
10129 if (gfc_is_reallocatable_lhs (expr1))
10131 lss->no_bounds_check = 1;
10132 if (!(expr2->expr_type == EXPR_FUNCTION
10133 && expr2->value.function.isym != NULL
10134 && !(expr2->value.function.isym->elemental
10135 || expr2->value.function.isym->conversion)))
10136 lss->is_alloc_lhs = 1;
10139 lss->no_bounds_check = expr1->no_bounds_check;
10143 if ((expr1->ts.type == BT_DERIVED)
10144 && (gfc_is_class_array_function (expr2)
10145 || gfc_is_alloc_class_scalar_function (expr2)))
10146 expr2->must_finalize = 1;
10148 /* Checking whether a class assignment is desired is quite complicated and
10149 needed at two locations, so do it once only before the information is
10151 lhs_attr = gfc_expr_attr (expr1);
10152 is_poly_assign = (use_vptr_copy || lhs_attr.pointer
10153 || (lhs_attr.allocatable && !lhs_attr.dimension))
10154 && (expr1->ts.type == BT_CLASS
10155 || gfc_is_class_array_ref (expr1, NULL)
10156 || gfc_is_class_scalar_expr (expr1)
10157 || gfc_is_class_array_ref (expr2, NULL)
10158 || gfc_is_class_scalar_expr (expr2));
10161 /* Only analyze the expressions for coarray properties, when in coarray-lib
10163 if (flag_coarray == GFC_FCOARRAY_LIB)
10165 lhs_caf_attr = gfc_caf_attr (expr1, false, &lhs_refs_comp);
10166 rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
10169 if (lss != gfc_ss_terminator)
10171 /* The assignment needs scalarization. */
10174 /* Find a non-scalar SS from the lhs. */
10175 while (lss_section != gfc_ss_terminator
10176 && lss_section->info->type != GFC_SS_SECTION)
10177 lss_section = lss_section->next;
10179 gcc_assert (lss_section != gfc_ss_terminator);
10181 /* Initialize the scalarizer. */
10182 gfc_init_loopinfo (&loop);
10184 /* Walk the rhs. */
10185 rss = gfc_walk_expr (expr2);
10186 if (rss == gfc_ss_terminator)
10187 /* The rhs is scalar. Add a ss for the expression. */
10188 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
10189 /* When doing a class assign, then the handle to the rhs needs to be a
10190 pointer to allow for polymorphism. */
10191 if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
10192 rss->info->type = GFC_SS_REFERENCE;
10194 rss->no_bounds_check = expr2->no_bounds_check;
10195 /* Associate the SS with the loop. */
10196 gfc_add_ss_to_loop (&loop, lss);
10197 gfc_add_ss_to_loop (&loop, rss);
10199 /* Calculate the bounds of the scalarization. */
10200 gfc_conv_ss_startstride (&loop);
10201 /* Enable loop reversal. */
10202 for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
10203 loop.reverse[n] = GFC_ENABLE_REVERSE;
10204 /* Resolve any data dependencies in the statement. */
10206 gfc_conv_resolve_dependencies (&loop, lss, rss);
10207 /* Setup the scalarizing loops. */
10208 gfc_conv_loop_setup (&loop, &expr2->where);
10210 /* Setup the gfc_se structures. */
10211 gfc_copy_loopinfo_to_se (&lse, &loop);
10212 gfc_copy_loopinfo_to_se (&rse, &loop);
10215 gfc_mark_ss_chain_used (rss, 1);
10216 if (loop.temp_ss == NULL)
10219 gfc_mark_ss_chain_used (lss, 1);
10223 lse.ss = loop.temp_ss;
10224 gfc_mark_ss_chain_used (lss, 3);
10225 gfc_mark_ss_chain_used (loop.temp_ss, 3);
10228 /* Allow the scalarizer to workshare array assignments. */
10229 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
10230 == OMPWS_WORKSHARE_FLAG
10231 && loop.temp_ss == NULL)
10233 maybe_workshare = true;
10234 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
10237 /* Start the scalarized loop body. */
10238 gfc_start_scalarized_body (&loop, &body);
10241 gfc_init_block (&body);
10243 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
10245 /* Translate the expression. */
10246 rse.want_coarray = flag_coarray == GFC_FCOARRAY_LIB && init_flag
10247 && lhs_caf_attr.codimension;
10248 gfc_conv_expr (&rse, expr2);
10250 /* Deal with the case of a scalar class function assigned to a derived type. */
10251 if (gfc_is_alloc_class_scalar_function (expr2)
10252 && expr1->ts.type == BT_DERIVED)
10254 rse.expr = gfc_class_data_get (rse.expr);
10255 rse.expr = build_fold_indirect_ref_loc (input_location, rse.expr);
10258 /* Stabilize a string length for temporaries. */
10259 if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
10260 && !(VAR_P (rse.string_length)
10261 || TREE_CODE (rse.string_length) == PARM_DECL
10262 || TREE_CODE (rse.string_length) == INDIRECT_REF))
10263 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10264 else if (expr2->ts.type == BT_CHARACTER)
10266 if (expr1->ts.deferred && gfc_check_dependency (expr1, expr2, true))
10267 rse.string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
10268 string_length = rse.string_length;
10271 string_length = NULL_TREE;
10275 gfc_conv_tmp_array_ref (&lse);
10276 if (expr2->ts.type == BT_CHARACTER)
10277 lse.string_length = string_length;
10281 gfc_conv_expr (&lse, expr1);
10282 if (gfc_option.rtcheck & GFC_RTCHECK_MEM
10284 && gfc_expr_attr (expr1).allocatable
10291 tmp = INDIRECT_REF_P (lse.expr)
10292 ? gfc_build_addr_expr (NULL_TREE, lse.expr) : lse.expr;
10294 /* We should only get array references here. */
10295 gcc_assert (TREE_CODE (tmp) == POINTER_PLUS_EXPR
10296 || TREE_CODE (tmp) == ARRAY_REF);
10298 /* 'tmp' is either the pointer to the array(POINTER_PLUS_EXPR)
10299 or the array itself(ARRAY_REF). */
10300 tmp = TREE_OPERAND (tmp, 0);
10302 /* Provide the address of the array. */
10303 if (TREE_CODE (lse.expr) == ARRAY_REF)
10304 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
10306 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
10307 tmp, build_int_cst (TREE_TYPE (tmp), 0));
10308 msg = _("Assignment of scalar to unallocated array");
10309 gfc_trans_runtime_check (true, false, cond, &loop.pre,
10310 &expr1->where, msg);
10313 /* Deallocate the lhs parameterized components if required. */
10314 if (dealloc && expr2->expr_type == EXPR_FUNCTION
10315 && !expr1->symtree->n.sym->attr.associate_var)
10317 if (expr1->ts.type == BT_DERIVED
10318 && expr1->ts.u.derived
10319 && expr1->ts.u.derived->attr.pdt_type)
10321 tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
10323 gfc_add_expr_to_block (&lse.pre, tmp);
10325 else if (expr1->ts.type == BT_CLASS
10326 && CLASS_DATA (expr1)->ts.u.derived
10327 && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
10329 tmp = gfc_class_data_get (lse.expr);
10330 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
10332 gfc_add_expr_to_block (&lse.pre, tmp);
10337 /* Assignments of scalar derived types with allocatable components
10338 to arrays must be done with a deep copy and the rhs temporary
10339 must have its components deallocated afterwards. */
10340 scalar_to_array = (expr2->ts.type == BT_DERIVED
10341 && expr2->ts.u.derived->attr.alloc_comp
10342 && !gfc_expr_is_variable (expr2)
10343 && expr1->rank && !expr2->rank);
10344 scalar_to_array |= (expr1->ts.type == BT_DERIVED
10346 && expr1->ts.u.derived->attr.alloc_comp
10347 && gfc_is_alloc_class_scalar_function (expr2));
10348 if (scalar_to_array && dealloc)
10350 tmp = gfc_deallocate_alloc_comp_no_caf (expr2->ts.u.derived, rse.expr, 0);
10351 gfc_prepend_expr_to_block (&loop.post, tmp);
10354 /* When assigning a character function result to a deferred-length variable,
10355 the function call must happen before the (re)allocation of the lhs -
10356 otherwise the character length of the result is not known.
10357 NOTE 1: This relies on having the exact dependence of the length type
10358 parameter available to the caller; gfortran saves it in the .mod files.
10359 NOTE 2: Vector array references generate an index temporary that must
10360 not go outside the loop. Otherwise, variables should not generate
10362 NOTE 3: The concatenation operation generates a temporary pointer,
10363 whose allocation must go to the innermost loop.
10364 NOTE 4: Elemental functions may generate a temporary, too. */
10365 if (flag_realloc_lhs
10366 && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
10367 && !(lss != gfc_ss_terminator
10368 && rss != gfc_ss_terminator
10369 && ((expr2->expr_type == EXPR_VARIABLE && expr2->rank)
10370 || (expr2->expr_type == EXPR_FUNCTION
10371 && expr2->value.function.esym != NULL
10372 && expr2->value.function.esym->attr.elemental)
10373 || (expr2->expr_type == EXPR_FUNCTION
10374 && expr2->value.function.isym != NULL
10375 && expr2->value.function.isym->elemental)
10376 || (expr2->expr_type == EXPR_OP
10377 && expr2->value.op.op == INTRINSIC_CONCAT))))
10378 gfc_add_block_to_block (&block, &rse.pre);
10380 /* Nullify the allocatable components corresponding to those of the lhs
10381 derived type, so that the finalization of the function result does not
10382 affect the lhs of the assignment. Prepend is used to ensure that the
10383 nullification occurs before the call to the finalizer. In the case of
10384 a scalar to array assignment, this is done in gfc_trans_scalar_assign
10385 as part of the deep copy. */
10386 if (!scalar_to_array && expr1->ts.type == BT_DERIVED
10387 && (gfc_is_class_array_function (expr2)
10388 || gfc_is_alloc_class_scalar_function (expr2)))
10391 tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
10392 gfc_prepend_expr_to_block (&rse.post, tmp);
10393 if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
10394 gfc_add_block_to_block (&loop.post, &rse.post);
10399 if (is_poly_assign)
10400 tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
10401 use_vptr_copy || (lhs_attr.allocatable
10402 && !lhs_attr.dimension),
10403 flag_realloc_lhs && !lhs_attr.pointer);
10404 else if (flag_coarray == GFC_FCOARRAY_LIB
10405 && lhs_caf_attr.codimension && rhs_caf_attr.codimension
10406 && ((lhs_caf_attr.allocatable && lhs_refs_comp)
10407 || (rhs_caf_attr.allocatable && rhs_refs_comp)))
10409 /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
10410 allocatable component, because those need to be accessed via the
10411 caf-runtime. No need to check for coindexes here, because resolve
10412 has rewritten those already. */
10414 gfc_actual_arglist a1, a2;
10415 /* Clear the structures to prevent accessing garbage. */
10416 memset (&code, '\0', sizeof (gfc_code));
10417 memset (&a1, '\0', sizeof (gfc_actual_arglist));
10418 memset (&a2, '\0', sizeof (gfc_actual_arglist));
10423 code.ext.actual = &a1;
10424 code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
10425 tmp = gfc_conv_intrinsic_subroutine (&code);
10427 else if (!is_poly_assign && expr2->must_finalize
10428 && expr1->ts.type == BT_CLASS
10429 && expr2->ts.type == BT_CLASS)
10431 /* This case comes about when the scalarizer provides array element
10432 references. Use the vptr copy function, since this does a deep
10433 copy of allocatable components, without which the finalizer call */
10434 tmp = gfc_get_vptr_from_expr (rse.expr);
10435 if (tmp != NULL_TREE)
10437 tree fcn = gfc_vptr_copy_get (tmp);
10438 if (POINTER_TYPE_P (TREE_TYPE (fcn)))
10439 fcn = build_fold_indirect_ref_loc (input_location, fcn);
10440 tmp = build_call_expr_loc (input_location,
10442 gfc_build_addr_expr (NULL, rse.expr),
10443 gfc_build_addr_expr (NULL, lse.expr));
10447 /* If nothing else works, do it the old fashioned way! */
10448 if (tmp == NULL_TREE)
10449 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10450 gfc_expr_is_variable (expr2)
10452 || expr2->expr_type == EXPR_ARRAY,
10453 !(l_is_temp || init_flag) && dealloc,
10454 expr1->symtree->n.sym->attr.codimension);
10456 /* Add the pre blocks to the body. */
10457 gfc_add_block_to_block (&body, &rse.pre);
10458 gfc_add_block_to_block (&body, &lse.pre);
10459 gfc_add_expr_to_block (&body, tmp);
10460 /* Add the post blocks to the body. */
10461 gfc_add_block_to_block (&body, &rse.post);
10462 gfc_add_block_to_block (&body, &lse.post);
10464 if (lss == gfc_ss_terminator)
10466 /* F2003: Add the code for reallocation on assignment. */
10467 if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
10468 && !is_poly_assign)
10469 alloc_scalar_allocatable_for_assignment (&block, string_length,
10472 /* Use the scalar assignment as is. */
10473 gfc_add_block_to_block (&block, &body);
10477 gcc_assert (lse.ss == gfc_ss_terminator
10478 && rse.ss == gfc_ss_terminator);
10482 gfc_trans_scalarized_loop_boundary (&loop, &body);
10484 /* We need to copy the temporary to the actual lhs. */
10485 gfc_init_se (&lse, NULL);
10486 gfc_init_se (&rse, NULL);
10487 gfc_copy_loopinfo_to_se (&lse, &loop);
10488 gfc_copy_loopinfo_to_se (&rse, &loop);
10490 rse.ss = loop.temp_ss;
10493 gfc_conv_tmp_array_ref (&rse);
10494 gfc_conv_expr (&lse, expr1);
10496 gcc_assert (lse.ss == gfc_ss_terminator
10497 && rse.ss == gfc_ss_terminator);
10499 if (expr2->ts.type == BT_CHARACTER)
10500 rse.string_length = string_length;
10502 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
10504 gfc_add_expr_to_block (&body, tmp);
10507 /* F2003: Allocate or reallocate lhs of allocatable array. */
10508 if (flag_realloc_lhs
10509 && gfc_is_reallocatable_lhs (expr1)
10511 && !is_runtime_conformable (expr1, expr2))
10513 realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
10514 ompws_flags &= ~OMPWS_SCALARIZER_WS;
10515 tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
10516 if (tmp != NULL_TREE)
10517 gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
10520 if (maybe_workshare)
10521 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
10523 /* Generate the copying loops. */
10524 gfc_trans_scalarizing_loops (&loop, &body);
10526 /* Wrap the whole thing up. */
10527 gfc_add_block_to_block (&block, &loop.pre);
10528 gfc_add_block_to_block (&block, &loop.post);
10530 gfc_cleanup_loop (&loop);
10533 return gfc_finish_block (&block);
10537 /* Check whether EXPR is a copyable array. */
10540 copyable_array_p (gfc_expr * expr)
10542 if (expr->expr_type != EXPR_VARIABLE)
10545 /* First check it's an array. */
10546 if (expr->rank < 1 || !expr->ref || expr->ref->next)
10549 if (!gfc_full_array_ref_p (expr->ref, NULL))
10552 /* Next check that it's of a simple enough type. */
10553 switch (expr->ts.type)
10565 return !expr->ts.u.derived->attr.alloc_comp;
10574 /* Translate an assignment. */
10577 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
10578 bool dealloc, bool use_vptr_copy, bool may_alias)
10582 /* Special case a single function returning an array. */
10583 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
10585 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
10590 /* Special case assigning an array to zero. */
10591 if (copyable_array_p (expr1)
10592 && is_zero_initializer_p (expr2))
10594 tmp = gfc_trans_zero_assign (expr1);
10599 /* Special case copying one array to another. */
10600 if (copyable_array_p (expr1)
10601 && copyable_array_p (expr2)
10602 && gfc_compare_types (&expr1->ts, &expr2->ts)
10603 && !gfc_check_dependency (expr1, expr2, 0))
10605 tmp = gfc_trans_array_copy (expr1, expr2);
10610 /* Special case initializing an array from a constant array constructor. */
10611 if (copyable_array_p (expr1)
10612 && expr2->expr_type == EXPR_ARRAY
10613 && gfc_compare_types (&expr1->ts, &expr2->ts))
10615 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
10620 if (UNLIMITED_POLY (expr1) && expr1->rank
10621 && expr2->ts.type != BT_CLASS)
10622 use_vptr_copy = true;
10624 /* Fallback to the scalarizer to generate explicit loops. */
10625 return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc,
10626 use_vptr_copy, may_alias);
10630 gfc_trans_init_assign (gfc_code * code)
10632 return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
10636 gfc_trans_assign (gfc_code * code)
10638 return gfc_trans_assignment (code->expr1, code->expr2, false, true);